Greedy Worm build 2020-06-16

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
UEZ
Posts: 610
Joined: May 05, 2017 19:59
Location: Germany

Greedy Worm build 2020-06-16

Postby UEZ » Jun 16, 2020 9:15

Image

Greedy Worm.bas

Code: Select all

'Ported to FB by UEZ build 2020-06-16
'Original code by EliK -> https://www.openprocessing.org/sketch/875675
'Thanks to dodicat for the Regulate function

#Include "fbgfx.bi"
Using FB

Const iW = 1000, iH = 600, maxLength = 128

Sub DrawCircleAA(xm As Short, ym As Short, r As Short, col As Ulong) 'Alois Zingl -> https://github.com/w8r/bresenham-zingl
   Dim As Long x = -r, y = 0, x2, e2, ierr = 2 - 2 * r, a, a1, a2, c
   Dim As Ulong iCol
   
   r = 1 - ierr
   While x < 0
      c = 255 * Abs(ierr - 2 * (x + y) - 2) / r
      a1 = c / 255 : a2 = (1 - a1) * 255
      iCol = (255 - c) Shl 24 Or (col And &hFFFFFF)
      Pset(xm + x, ym - y), icol
      Pset(xm + y, ym + x), icol
      Pset(xm - x, ym + y), icol
      Pset(xm - y, ym - x), icol
      e2  = ierr
      x2 = x
      If (ierr + y > 0) Then
         c = 255 * (ierr - 2 * x - 1) / r
         If c < 256 Then
            a1 = c / 255 : a2 = (1 - a1) * 255
            iCol = (255 - c) Shl 24 Or (col And &hFFFFFF)
            Pset(xm + x,     ym - y - 1), icol         
            Pset(xm + y + 1, ym + x      ), icol
            Pset(xm - x,     ym + y + 1), icol
            Pset(xm - y - 1, ym - x      ), icol
         End If
         x += 1
         ierr += x * 2 + 1
      End If
      If e2 + x2 <= 0 Then
         c = 255 * (2 * y + 3 - e2) / r
         If c < 256 Then
            a1 = c / 255 : a2 = (1 - a1) * 255
            iCol = (255 - c) Shl 24 Or (col And &hFFFFFF)
            Pset(xm + x2 + 1, ym - y ), icol
            Pset(xm + y      , ym + x2 + 1), icol
            Pset(xm - x2 - 1, ym + y ), icol
            Pset(xm - y      , ym - x2 - 1), icol
         End If
         y += 1
         ierr += y * 2 + 1
      End If
   Wend
End Sub

Function Regulate(TargetFPS As Long, Byref fps As Long) As Long 'by dodicat
   Static As Double timervalue, _lastsleeptime, t3, frames
   Var t = Timer
   frames += 1
   If (t - t3) >= 1 Then t3 = t : fps = frames : frames = 0
   Var sleeptime =_lastsleeptime + ((1 / TargetFPS) - t + timervalue) * 1000
   If sleeptime < 1 Then sleeptime = 1
   _lastsleeptime = sleeptime
   timervalue = t
   Return sleeptime
End Function

Type Worm
   Public:
      Declare Constructor()
      Declare Destructor()
      Declare Sub Init()
      Declare Sub Draw()
   Private:
      As Ushort up, up2, c, wormSize, dist, speed
      As Single x2, y2, tx, ty, t, WormSlices(Any, Any)
End Type

Constructor Worm()
   Redim WormSlices(maxLength, 1)
   Init()
End Constructor

Destructor Worm()
   Redim WormSlices(0, 0)
End Destructor

Sub Worm.Init()
   Randomize Timer, 5
   x2 = 500 :tx = 510 :y2 = -600 : ty = 0 : t = 0 : up = 0 : up2 = 0 : c = 0 : wormSize = 25 : dist = 60 : speed = 17.5
End Sub

Sub Worm.Draw()
   Static As Ulong FPS
   Dim As Single tt
   'Cls
   Line (0, 0)-(iW, iH), &hF0FFFFFF, BF
   t += 1
   If t < 5 Then
      up = Iif(Rnd() > 0.5, 1, 0)
      up2 = Iif(Rnd() > 0.5, 1, 0)
   End If
   tt = t / speed
   If up = 0 Then tx -= tt
   If up = 1 Then tx += tt
   If up2 = 0 Then ty -= tt
   If up2 = 1 Then ty += tt
   If t > dist Then t = 0
   If tx > x2 Then x2 += (tx - x2) / dist
   If tx < x2 Then x2 -= (x2 - tx) / dist
   If ty > y2 Then y2 += (ty - y2) / dist
   If ty < y2 Then y2 -= (y2 - ty) / dist
   
   If c < maxLength + 1 Then 'fill up array first
      WormSlices(c, 0) = x2
      WormSlices(c, 1) = y2
      c += 1
   Else
      'simulation of the JavaScript slice array function
      For i As Ushort = 0 To maxLength - 1 'shift array values from top to down
         WormSlices(i, 0) = WormSlices(i + 1, 0)
         WormSlices(i, 1) = WormSlices(i + 1, 1)
      Next
      'add new element to top
      WormSlices(maxLength, 0) = x2
      WormSlices(maxLength, 1) = y2
   End If
   
   Dim as UShort s
   Static as Single k = 0
   Dim As Single h, p
   Static As Single e1 = 0
   'draw
   For i As Ushort = 0 To c - 1
      If WormSlices(i, 0) > iW Then up = 0
      If WormSlices(i, 1) > iH Then up2 = 0
      If WormSlices(i, 0) < 0 Then up = 1
      If WormSlices(i, 1) < 0 Then up2 = 1
      s = IIf(i > c - 12, wormSize - 12 + (c - i), iif(i < 17.5, wormSize - 17.5 + i, wormSize))
      h = Sin(k / 2500 - (i shl 1)) * 8
      If i = c - 1 Then
         Circle(WormSlices(i, 0), WormSlices(i, 1)), s, &hF0B07A69, , , , F ''draw head
         DrawCircleAA(WormSlices(i, 0), WormSlices(i, 1), s + 0.5, &h6E5326)
         Circle(WormSlices(i, 0), WormSlices(i, 1)), Abs((s * 0.25) * Sin(e1)), &h60000000, , , , F 'mouth
         e1 += 0.05
      Else
         p = s + h
         Circle(WormSlices(i, 0), WormSlices(i, 1)), p, &h58FA8D1B, , , , F
         DrawCircleAA(WormSlices(i, 0), WormSlices(i, 1), p + 0.5, &h6E5326)         
      end if
      k += 1
   Next
   Dim As Ushort o = wormSize Shr 1
   'draw food
   Circle(tx, ty), o, &hE0FF0000, , , , F
   DrawCircleAA(tx, ty, o, &hFFFF0000)
   .Draw String (tx + o + 10, ty), "Yumyum", &hFF20B020
   .Draw String (4, 4), Str(FPS) + " fps", &hFF000000
   'Screensync
   Flip
   Sleep(Regulate(60, FPS), 1)
End Sub

'ScreenControl SET_DRIVER_NAME, "GDI"
Screenres iW, iH, 32, 2, GFX_WINDOWED Or GFX_NO_SWITCH Or GFX_ALWAYS_ON_TOP Or GFX_ALPHA_PRIMITIVES Or GFX_HIGH_PRIORITY
ScreenSet 1, 0
Windowtitle("Greedy Worm")   

Color , &hFFFFFFFF
Cls

Dim As Worm Worms

Worms.Init

Do
   Worms.Draw
Loop Until Len(Inkey())
dodicat
Posts: 6634
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Greedy Worm build 2020-06-16

Postby dodicat » Jun 17, 2020 17:06

Thanks UEZ, a real slug.
It reminds me of a creature I put in squares many years ago.
Going from eggs to adult to caterpillar, which I know now, after looking up a biology for beginners book, was the wrong way round.

Code: Select all

Type ball
  As Single x,y,r
  As Ulong c
  As Single dx,dy
  As Single kx,ky
End Type
'macro bundle
#define floatrange(f,l) (Rnd*((l+1)-(f))+(f))
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
#define lngth(x1,y1,x2,y2) sqr((x1-x2)*(x1-x2)+(y1-y2)*(y1-y2))
#define Rd( c ) (( c ) Shr 16 And 255 )
#define Gr( c ) (( c ) Shr  8 And 255 )
#define Bl( c ) (( c )And 255 )
#define redball Rgb(240,0,0)
#define yellowball Rgb(190,190,0)
#define whiteball Rgb(250,250,250)
#define blackball Rgb(50,50,50)
#define Intrange(f,l) int(Rnd*((l+1)-(f))+(f))
#define ub b(ubound(b))
#macro incircle(cx,cy,r,mx,my,a,result)
If a<=1 Then
  result=a*(cx-mx)*a*(cx-mx) +1*(cy-my)*1*(cy-my)<= r*r*a*a
Else
  result=a*(cx-mx)*a*(cx-mx) +1*(cy-my)*1*(cy-my)<= (r)*(r)
End If
#endmacro
#macro arraydelete(a,position)
Scope
  Dim As Long index=position
  If index>=Lbound(a) And index<=Ubound(a) Then
    For x As Long=index To Ubound(a)-1
      a(x)=a(x+1)
    Next x
    Redim Preserve a(Lbound(a) To Ubound(a)-1)
  End If
End Scope
#endmacro
#macro ppset(_x,_y,colour)
pixel=row+pitch*(_y)+4*(_x)
*pixel=(colour)
#endmacro

#macro onscreen(x,y)
x>0 And x<1023 And y>0 And y<767
#endmacro
'==================================================   
Dim As Single ratio=1

Screenres 1024,768,32,,64

Dim Shared As Any Pointer row
row=Screenptr
Dim Shared As Ulong Pointer pixel
Dim Shared As Integer pitch
Screeninfo ,,,,pitch

Sub ORB(cx As Long,cy As Long,r As Long,col As Long,a As Single,i As Any Ptr=0)
  Dim As Long result
  Dim As Single dist,p
  For x As Long=cx-r-1 To cx+r+1
    For y As Long=cy-r-1 To cy+r+1
      incircle(cx,cy,r,x,y,a,result)
      If result Then
        dist=lngth(cx,cy,x,y)
        p=map(0,r,dist,1,.3)
        If onscreen(x,y) Then
          ppset(x,y,Rgb(rd(col)*p,gr(col)*p,bl(col)*p))
        End If
      End If
    Next y
  Next x
  Circle(cx,cy),r,Rgb(rd(col)*p,gr(col)*p,bl(col)*p),,,a
End Sub

Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long
  Static As Double timervalue,lastsleeptime,t3,frames
  frames+=1
  If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
  Var sleeptime=lastsleeptime+((1/myfps)-Timer+timervalue)*1000
  If sleeptime<1 Then sleeptime=1
  lastsleeptime=sleeptime
  timervalue=Timer
  Return sleeptime
End Function

Dim As Ulong colour
Dim As Long result,cx=1024/2,cy=768/2
Dim As String ik
Redim As ball b(0)
Paint(0,0),Rgb(0,80,0)
Do
  ik=Inkey
  Screenlock
  Var xpos=floatrange(20,1000)
  Var ypos=floatrange(20,740)
  Var rad=floatrange(5,15)
  Dim As Long i=intrange(1,8)
  Select Case i
  Case 1 To 3:colour=redball
  Case 4 To 6:colour=yellowball
  Case 7:colour=blackball
  Case 8:colour=whiteball
  End Select
 
  incircle(512,384,200,xpos,ypos,ratio,result)
 
  If result=0 Then
    Var d=lngth(xpos,ypos,cx,cy)
    Var dx=(2/d)*(cx-xpos)
    Var dy=(2/d)*(cy-ypos)
    Redim Preserve b(1 To Ubound(b)+1)
    b(Ubound(b))=Type<ball>(xpos,ypos,rad,colour,dx,dy)
    ORB(xpos,ypos,rad,colour,ratio)
  End If
 
  Screenunlock
  Sleep 1,1
Loop Until Ubound(b)>3000 Or (Len(ik) And ik<>Chr(27))
Color,Rgb(0,80,0)
Dim As Long n
Do
  ik=Inkey
  n=0
  Screenlock
  Cls
  Circle(cx,cy),20,Rgba(0,0,0,25),,,,f
  Do
    n+=1
    If n>=Ubound(b) Then Exit Do
    b(n).x+=b(n).dx:b(n).y+=b(n).dy
    incircle(cx,cy,20,b(n).x,b(n).y,ratio,result)
    If result Then
      arraydelete(b,n)
    End If
    b(n).r=.995*b(n).r
    orb(b(n).x,b(n).y,b(n).r,b(n).c,ratio)
  Loop
  Screenunlock
  Sleep 1,1
Loop Until ik=Chr(27) Or n=1


Dim As Long sx=400,sy=300,fps
Dim As Single kx=.1,ky=.1
Redim As ball b(0)
Var rad=5.0
Do
  sx+=10*kx
  sy+=10*ky
  If sx>1024 Or sx<0 Then kx=-kx
  If sy>768 Or sy<0 Then ky=-ky
  rad=rad+.25
  Dim As Long i=intrange(1,8)
  Select Case i
  Case 1 To 3:colour=redball
  Case 4 To 6:colour=yellowball
  Case 7:colour=blackball
  Case 8:colour=whiteball
  End Select
  Redim Preserve b(1 To Ubound(b)+1)
  b(Ubound(b))=Type<ball>(sx,sy,rad,colour,0,0,1,1)
Loop Until Ubound(b)>89

Color,Rgb(0,80,0)
kx=3:ky=3

Do
  ik=Inkey
  Screenlock
  Cls
  Draw String(50,50),"FPS = " & fps
  ub.x+=kx
  ub.y+=ky
  If ub.x<0 Or ub.x>1024  Then kx=-kx
  If ub.y<0  Or ub.y>768 Then ky=-ky
  If ub.x>50 And ub.x<975  Then
    If ub.y>50  And ub.y<718 Then
      If Instr(Str(Timer),"123") Then kx=-kx
      If Instr(Str(Timer),"456") Then ky=-ky
    End If
  End If
 
  For n As Long=1 To Ubound(b)-1
    b(n).dx=(b(n+1).x-b(n).x)
    b(n).dy=(b(n+1).y-b(n).y)
    b(n).x+=b(n).kx*b(n).dx/(2*Abs(kx)):b(n).y+=b(n).ky*b(n).dy/(2*Abs(kx))
    orb(b(n).x,b(n).y,b(n).r,b(n).c,ratio)
  Next n
  'eyes
  orb(ub.x+8,ub.y-8,10,Rgb(255,255,255),ratio/2)
  orb(ub.x-8,ub.y-8,10,Rgb(255,255,255),ratio/2)
  orb(ub.x+8,ub.y-8,2,Rgb(0,0,0),ratio)
  orb(ub.x-8,ub.y-8,2,Rgb(0,0,0),ratio)
  Screenunlock
  Sleep regulate(60,fps),1
Loop Until ik=Chr(27)



Draw String(1024/2-16,768/2), "DONE"
Sleep


 
Tourist Trap
Posts: 2901
Joined: Jun 02, 2015 16:24

Re: Greedy Worm build 2020-06-16

Postby Tourist Trap » Jun 17, 2020 17:25

:-)
Really impressive both of those programs. You guys are artists.
UEZ
Posts: 610
Joined: May 05, 2017 19:59
Location: Germany

Re: Greedy Worm build 2020-06-16

Postby UEZ » Jun 18, 2020 9:37

Thanks for your feedback.

@dodicat: nice work, especially the eyes - looks really cool. :-)

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 2 guests