Greedy Worm build 2020-06-16

[UEZ]

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]

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]

:-)
Really impressive both of those programs. You guys are artists.

[UEZ]

Thanks for your feedback.

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