PureBasic Forums - English

http://www.purebasic.com
https://www.purebasic.fr/english/

Canvas flocking cellular automaton

https://www.purebasic.fr/english/viewtopic.php?t=54380

Page 1 of 1

Canvas flocking cellular automaton

Posted: Wed Apr 17, 2013 10:02 pm
by fiver
This is code for a flocking cellular automaton ported to PB from html5 canvas/javascript code posted on rectangleworld:
http://rectangleworld.com/blog/archives/587
Lot's of other cool stuff there :wink:
It is based on bird flocking behaviour and cellular automata and particularly boid's algorithm which models flocks of birds using the behavioural principles separation, alignment and cohesion.

It looks fairly blocky in the screen-shot below but there are lots of tweaks you can make, it looks really good with a 1px x 1px grid but don't go too big on the window size or your CPU will melt :twisted: Interestingly, a fairly naive analysis (Task manger :D ) indicates that PB's canvas runs about 3 times faster than the one in firefox size for size.

Image

It should work on Mac but only tested on xubuntu 12.10 and Windows Vista.

Code: Select all

;-- separation: if a cell’s color is too close to that of one of its neighbors, move away from that color.
;-- alignment: adjust the rate of change of a cell’s color towards the average rate of change of its neighbors.
;-- cohesion: move the color of a cell towards the average color of its neighbors.

;-- 1000mS / 25 = 40mS
#mSRedraw = 40
#minDist = 8
#minDistSquare = #minDist * #minDist
#sepNormMag = 4
#Easing = 0.67

;-- Smaller cells and a bigger canvas will eat your CPU!
CanvWidth.w = 600
CanvHeight.w = 400
Cellwidth.w= CanvWidth / 20
CellHeight.w = CanvHeight / 30

ArrayX = CanvWidth/Cellwidth
ArrayY = CanvHeight/CellHeight

Structure CELL
  X.w
  Y.w
  ;-- Colours
  R.f
  G.f
  B.f
  bufferR.f
  bufferG.f
  bufferB.f
  ;-- Velocities
  RVel.f
  GVel.f
  BVel.f
  bufferRVel.f
  bufferGVel.f
  bufferBVel.f
  List *neighbours()
  neighbourCnt.w
EndStructure

Dim Cells.CELL(ArrayX, ArrayY)


Procedure InitialiseCells(Canvas)
  Shared Cells(), ArrayX, ArrayY, CellWidth, CellHeight

  If StartDrawing(CanvasOutput(Canvas))

    For i = 0 To ArrayX
      For j = 0 To ArrayY
        Cells(i,j)\X = i * Cellwidth
        Cells(i,j)\Y = j * CellHeight

        Cells(i,j)\bufferRVel = 0
        Cells(i,j)\bufferGVel = 0
        Cells(i,j)\bufferBVel = 0

        Cells(i,j)\RVel = 0
        Cells(i,j)\GVel = 0
        Cells(i,j)\BVel = 0

        Cells(i,j)\R = Random(255)
        Cells(i,j)\G = Random(255)
        Cells(i,j)\B = Random(255)

        Cells(i,j)\bufferR = Cells(i,j)\R
        Cells(i,j)\bufferG = Cells(i,j)\G
        Cells(i,j)\bufferB = Cells(i,j)\B

        Box(Cells(i,j)\X, Cells(i,j)\Y, Cellwidth, CellHeight, RGB(Cells(i,j)\R, Cells(i,j)\G, Cells(i,j)\B))
      Next
    Next
    StopDrawing()
  EndIf
EndProcedure


Procedure InitialiseNeighbours()
  Shared Cells(), ArrayX, ArrayY

  For i = 0 To ArrayX
    For j = 0 To ArrayY

      If i > 0
        AddElement(Cells(i, j)\neighbours())
        Cells(i, j)\neighbours() = @Cells(i - 1, j)
        AddElement(Cells(i - 1, j)\neighbours())
        Cells(i - 1, j)\neighbours() = @Cells(i, j)
      EndIf

      If j > 0
        AddElement(Cells(i, j)\neighbours())
        Cells(i, j)\neighbours() = @Cells(i, j - 1)
        AddElement(Cells(i, j - 1)\neighbours())
        Cells(i, j - 1)\neighbours() = @Cells(i, j)
      EndIf
      neighbourCnt = ListSize(Cells(i,j)\neighbours())
    Next
  Next
  ;-- Go through again and get the number of neighbours
  For i = 0 To ArrayX
    For j = 0 To ArrayY
      Cells(i,j)\neighbourCnt = ListSize(Cells(i,j)\neighbours())
    Next
  Next
EndProcedure


Procedure UpdateCells(Canvas)
  Shared Cells(), ArrayX, ArrayY, CellWidth, CellHeight
  If StartDrawing(CanvasOutput(Canvas))

    For i = 0 To ArrayX
      For j = 0 To ArrayY
        rAve = 0
        gAve = 0
        bAve = 0
        rVelAve = 0
        gVelAve = 0
        bVelAve = 0
        rSep = 0
        gSep = 0
        bSep = 0

        ForEach Cells(i,j)\neighbours()
          *neighbour.CELL = Cells(i, j)\neighbours()

          rAve + *neighbour\R
          gAve + *neighbour\G
          bAve + *neighbour\B

          rVelAve + *neighbour\RVel
          gVelAve + *neighbour\GVel
          bVelAve + *neighbour\BVel

          dr = Cells(i,j)\R - *neighbour\R
          dg = Cells(i,j)\G - *neighbour\G
          db = Cells(i,j)\B - *neighbour\B

          If dr*dr + dg*dg + db*db < #minDistSquare
            rSep + dr
            gSep + dg
            bSep + db
          EndIf

        Next

        f.f = 1 / Cells(i,j)\neighbourCnt
        rAve = rAve * f
        gAve = gAve * f
        bAve = bAve * f
        rVelAve = rVelAve * f
        gVelAve = gVelAve * f
        bVelAve = bVelAve * f

        ;-- normalize separation vector
        If (rSep <> 0) Or (gSep <> 0) Or (bSep <> 0)
          sepMagRecip = #sepNormMag / Sqr(rSep * rSep + gSep * gSep + bSep * bSep)
          rSep = rSep * sepMagRecip
          gSep = gSep * sepMagRecip
          bSep = bSep * sepMagRecip
        EndIf

        ;-- Update velocity by combining separation, alignment and cohesion effects.
        ;-- Change velocity only by Easing ratio.
        Cells(i,j)\bufferRVel + #Easing * (rSep + rVelAve + rAve - Cells(i,j)\R - Cells(i,j)\bufferRVel)
        Cells(i,j)\bufferGVel + #Easing * (gSep + gVelAve + gAve - Cells(i,j)\G - Cells(i,j)\bufferGVel)
        Cells(i,j)\bufferBVel + #Easing * (bSep + bVelAve + bAve - Cells(i,j)\B - Cells(i,j)\bufferBVel)

        ;-- update colors according to color velocities
        Cells(i,j)\bufferR + Cells(i,j)\bufferRVel
        Cells(i,j)\bufferG + Cells(i,j)\bufferGVel
        Cells(i,j)\bufferB + Cells(i,j)\bufferBVel

        ;-- bounce colors off of color cube boundaries
        If Cells(i,j)\bufferR < 0
          Cells(i,j)\bufferR = 0
          Cells(i,j)\bufferRVel = Cells(i,j)\bufferRVel * -1
        ElseIf Cells(i,j)\bufferR > 255
          Cells(i,j)\bufferR = 255
          Cells(i,j)\bufferRVel = Cells(i,j)\bufferRVel * -1
        EndIf

        If Cells(i,j)\bufferG < 0
          Cells(i,j)\bufferG = 0
          Cells(i,j)\bufferGVel = Cells(i,j)\bufferGVel * -1
        ElseIf Cells(i,j)\bufferG > 255
          Cells(i,j)\bufferG = 255
          Cells(i,j)\bufferGVel = Cells(i,j)\bufferGVel * -1
        EndIf

        If Cells(i,j)\bufferB < 0
          Cells(i,j)\bufferB = 0
          Cells(i,j)\bufferBVel = Cells(i,j)\bufferBVel * -1
        ElseIf Cells(i,j)\bufferB > 255
          Cells(i,j)\bufferB = 255
          Cells(i,j)\bufferBVel = Cells(i,j)\bufferBVel * -1
        EndIf

      Next
    Next
    ;-- now loop through again, copy buffer values and draw
    For i = 0 To ArrayX
      For j = 0 To ArrayY
        Cells(i,j)\R = Cells(i,j)\bufferR
        Cells(i,j)\G = Cells(i,j)\bufferG
        Cells(i,j)\B = Cells(i,j)\bufferB

        Cells(i,j)\RVel = Cells(i,j)\bufferRVel
        Cells(i,j)\GVel = Cells(i,j)\bufferGVel
        Cells(i,j)\BVel = Cells(i,j)\bufferBVel

        Box(Cells(i,j)\X, Cells(i,j)\Y, Cellwidth, CellHeight, RGB(Cells(i,j)\R, Cells(i,j)\G, Cells(i,j)\B))
      Next
    Next

    StopDrawing()
  EndIf
EndProcedure

Procedure MaxWindow()
  Shared Cells(), Canvas, CanvWidth, CanvHeight, ArrayX, ArrayY, CellWidth, CellHeight
  ExamineDesktops()
  CanvWidth = DesktopWidth(0)
  CanvHeight = DesktopHeight(0)
  Cellwidth= CanvWidth / 20
  CellHeight = CanvHeight / 30
  ArrayX = CanvWidth/Cellwidth
  ArrayY = CanvHeight/CellHeight
  Dim Cells.CELL(ArrayX, ArrayY)
  InitialiseCells(Canvas)
  InitialiseNeighbours()
  ResizeGadget(Canvas, #PB_Ignore, #PB_Ignore, CanvWidth, CanvHeight)
  CompilerIf #PB_Compiler_OS = #PB_OS_Linux
  gtk_window_fullscreen_(WindowID(0))
  CompilerEndIf
EndProcedure

Procedure MinWindow()
  Shared Cells(), Canvas, CanvWidth, CanvHeight, ArrayX, ArrayY, CellWidth, CellHeight
  CanvWidth = WindowWidth(0)
  Debug CanvWidth
  CanvHeight = WindowHeight(0)
  Cellwidth= CanvWidth / 20
  CellHeight = CanvHeight / 30
  ArrayX = CanvWidth/Cellwidth
  ArrayY = CanvHeight/CellHeight
  Dim Cells.CELL(ArrayX, ArrayY)
  InitialiseCells(Canvas)
  InitialiseNeighbours()
  ResizeGadget(Canvas, #PB_Ignore, #PB_Ignore, CanvWidth, CanvHeight)
EndProcedure

If OpenWindow(0, 0, 0, CanvWidth, CanvHeight, "Flocking Cellular Automaton", #PB_Window_BorderLess | #PB_Window_MaximizeGadget | #PB_Window_ScreenCentered)
  AddWindowTimer(0, 666, #mSRedraw)
  AddKeyboardShortcut(0, #PB_Shortcut_Escape, 1)
  AddKeyboardShortcut(0, #PB_Shortcut_Tab, 2)
  Canvas = CanvasGadget(#PB_Any, 0, 0, CanvWidth, CanvHeight)
  GadgetToolTip(Canvas, "Flocking Cellular Automaton" + #CRLF$ + "Left click to reset" + #CRLF$ + "Tab toggles fullscreen" + #CRLF$ + "Esc to exit")
  InitialiseCells(Canvas)
  InitialiseNeighbours()
  Repeat
    Event = WaitWindowEvent(5)
    Type = EventType()
    If Event = #PB_Event_MaximizeWindow
      MaxWindow()
    ElseIf Event = #PB_Event_RestoreWindow
      MinWindow()
    ElseIf Event = #PB_Event_SizeWindow
      MinWindow()
    ElseIf Event = #PB_Event_Timer And EventTimer() = 666
      UpdateCells(Canvas)
    ElseIf Event = #PB_Event_Gadget
      If Type = #PB_EventType_LeftClick
        InitialiseCells(Canvas)
        UpdateCells(Canvas)
      EndIf
    ElseIf Event = #PB_Event_Menu
      Menu = EventMenu()
      If Menu = 1
        Break
      ElseIf Menu = 2
        State ! 1
        If State = 1
          SetWindowState(0, #PB_Window_Maximize)
        Else
          CompilerIf #PB_Compiler_OS = #PB_OS_Linux
          gtk_window_unfullscreen_(WindowID(0))
          CompilerEndIf
          SetWindowState(0, #PB_Window_Normal)
        EndIf
      EndIf
    EndIf

  Until Event = #PB_Event_CloseWindow
EndIf

Re: Canvas flocking cellular automaton

Posted: Wed Apr 17, 2013 10:31 pm
by luis
Nice :P

I've put

Cellwidth.w= 3
CellHeight.w = 3

and looks similar to a colorful plasma effect but smoothly evolving forever

Thanks!

Re: Canvas flocking cellular automaton

Posted: Wed Apr 17, 2013 10:44 pm
by davido
Thanks very much looks nice.

Tried suggestion by luis - looks even better!

Re: Canvas flocking cellular automaton

Posted: Wed Apr 17, 2013 11:06 pm
by Mindphazer
Works fine on OSX, except : TAB key does not toggle to fullscreen

Re: Canvas flocking cellular automaton

Posted: Wed Apr 17, 2013 11:42 pm
by idle
very nice

Re: Canvas flocking cellular automaton

Posted: Thu Apr 18, 2013 12:53 pm
by kernadec
thank you fiver

very beautiful and without smoking

good day

Re: Canvas flocking cellular automaton

Posted: Thu Apr 18, 2013 2:38 pm
by Fred
yep, very good
All times are UTC+01:00
Page 1 of 1

Powered by phpBB® Forum Software © phpBB Limited