Code archives/Algorithms/"Life" on infinite field

;J. H. Conway's Game of Life on nearly infinite field by Matt Merkulov

; The index and simultaneously a cell
Type ptr
 Field nxt.ptr[3]; following indexes in hierarchy
 Field prev.ptr; the previous index in hierarchy
 Field prevpos; an arrangement of the previous index
 Field neig.ptr[7]; addresses of neighbours(for a cell(cage))
 Field x, y, nq; coordinates and quantity(amount) of neighbours
End Type

; Indexes on cells for which change of a condition is possible(probable)
Type chang
 Field p.ptr
End Type

Const loadorg$="locomot.png"
; Const loadorg$="virus.png"
Const xres=800, yres=600

Global cellq, scrx, scry, ib

; Breakdown of a file of indexes on 3 lists
Dim pmark.ptr(3)
For n=0 To 3
 pmark(n)=New ptr
Next

Graphics xres, yres
SetFont LoadFont(" Arial cyr ", 14)

Dim change(24)
For n=0 To 1
 Read m$
 For nn=0 To 8
 change(n*16+nn)=Sgn(Instr(m$, nn))
 Next
Next
Data "3", "0145678"

i=CreateImage(xres, yres)
ib=ImageBuffer(i)

i2=LoadImage(loadorg$)
ib2=ImageBuffer(i2)
xsiz=ImageWidth(i2)
ysiz=ImageHeight(i2)
For x=0 To xsiz-1
 For y=0 To ysiz-1
 If ReadPixel(x, y, ib2) And 255 Then
  ; The first met cell - a starting point for creation of the others
  If cellq=0 Then
  cell.ptr=New ptr
  ptrq=ptrq+1
  cell\x=400
  cell\y=300
  xx=x
  yy=y
  End If
  newborn findcell(cell, x-xx, y-yy)
 End If
 Next
Next
FreeImage i2

Repeat
 
 DrawBlock i, 0,0

 gen=gen+1
 ; The cursor of the mouse moves to the center of the screen(to not cling to edges(territories))
 MoveMouse xres Sar 1, yres Sar 1

 If cellq=0 Then Exit

 ; All the cells subject to changes, pereeshchayutsya in the list ¹2
 For ch.chang=Each chang
 If change(ch\p\nq) Then Insert ch\p After pmark(2)
 Next
 Delete Each chang

 ; We change a condition of all cells(cages) from the list ¹2
 cell=pmark(2)
 Repeat
 cell=After cell
 If cell=pmark(3) Then Exit
 If cell\nq <16 Then
  newborn cell
 Else
  ; For all neighbours - reduction of their counter of neighbours
  For n=0 To 7
  cell2.ptr=cell\neig[n]
  cell2\nq=cell2\nq-1
  ; Entering the neighbour in the list of cells which, probably, will change the condition
  If change(cell2\nq) Then ch.chang=New chang: ch\p=cell2
  Next
  ; Deenergizing a bat zapolnennosti
  cell\nq=cell\nq And 15
  WritePixel scrx+cell\x, scry+cell\y, 0, ib
  cellq=cellq-1
  ; Entering the processed cell in the list of potentially changing cells
  If change(cell\nq) Then ch.chang=New chang: ch\p=cell
 End If
 Forever

 ; Cells from the list ¹2 pass all in the list ¹1(are stabilized)
 Insert pmark(2) Before pmark(3)

 ; Displacement of the cursor of the mouse is defined(determined)
 dx=MouseX()-xres Sar 1
 dy=MouseY()-yres Sar 1
 ; If the cursor was displaced, there is a copying of cells(cages)(all 1-st list)
 If dx <> 0 Or dy <> 0 Then
 scrx=scrx+dx
 scry=scry+dy

 SetBuffer ib
 Cls
 SetBuffer FrontBuffer()

 cell=pmark(1)
 Repeat
  cell=After cell
  If cell=pmark(2) Then Exit
  If cell\nq And 16 Then WritePixel scrx+cell\x, scry+cell\y,-1, ib
 Forever

 End If

 SetBuffer ib
 Color 0,0,0
 Rect 0,0,100,36
 Color 255,255,255
 Text 0,0, "FPS: "+1000.0 /(MilliSecs()-fps)
 Text 0,12, "Cells(Cages): "+cellq
 Text 0,24, "Generation: "+gen
 fps=MilliSecs()
 SetBuffer FrontBuffer()
 
Until KeyHit(1)
End

; Function of search of a cell in hierarchy on a starting point and displacement
; If the cell does not exist, it(she) is created together with a chain of indexes
Function findcell.ptr(cell.ptr, x, y)
; If displacement zero, result - a starting point
If x=0 And y=0 Then Return cell
; We remember coordinates of a required cell(in case it(she) should be created)
xx=x+cell\x
yy=y+cell\y
pmax=1; the Counter of a level in hierarchy
; The first stage - rise upwards
Repeat
 ; Addition of the new index from above if the top of hierarchy is reached(achieved)
 If cell\prev=Null Then
 p.ptr=New ptr
 Insert p After pmark(0)
 ; The position is defined(determined) by position of a required cell
 pos=(x <0)+(y <0) Shl 1
 p\nxt[pos]=cell
 cell\prev=p
 cell\prevpos=pos
 Else
 ; Differently - transition to higher level in hierarchy
 pos=cell\prevpos
 p.ptr=cell\prev
 End If
 ; Change of coordinates according to moving
 If pos And 1 Then x=x+pmax
 If pos And 2 Then y=y+pmax
 ; Increase of a level
 pmax=pmax Shl 1
 cell=p
 ; An output(exit) if the point is reached(achieved), whence it is possible to go down up to required
Until x>=0 And y>=0 And x <pmax And y <pmax

; The second stage - descent(release)
Repeat
 ; Downturn of a level
 pmax=pmax Shr 1
 ; Definition of a direction
 pos=((x And pmax)=pmax)+((y And pmax)=pmax) Shl 1

 ; Creation of the new index if the branch is absent
 If cell\nxt[pos]=Null Then
 p.ptr=New ptr
 Insert p After pmark(0)
 cell\nxt[pos]=p
 p\prev=cell
 p\prevpos=pos
 ; If we create a cell(cage)(the index of 1-st level) it is moved it(her) to the list ¹1 and
 ; We appropriate(give) the remembered coordinates
 If pmax=1 Then
  Insert p After pmark(1)
  p\x=xx
  p\y=yy
 End If
 End If
 cell=cell\nxt[pos]
 ; If will reach(achieve) a bottom of hierarchy(a level of cells(cages)) - an output(exit)
Until pmax=1
Return cell
End Function

; Function of a birth of a new cell(cage)
Function newborn(cell.ptr)
; Search, storing of neighbours and increase in their counter of quantity(amount) of neighbours
For xx=-1 To 1
 For yy=-1 To 1
 If xx Or yy Then
  cell2.ptr=findcell(cell, xx, yy)
  cell2\nq=cell2\nq+1
  ; Entering the neighbour in the list of cells which, probably, will change the condition
  If change(cell2\nq) Then ch.chang=New chang: ch\p=cell2
  cell\neig[n]=cell2
  n=n+1
 End If
 Next
Next
; Inclusion a bat zapolnennosti
cell\nq=cell\nq Or 16
; Entering the processed cell in the list of potentially changing cells
If change(cell\nq) Then ch.chang=New chang: ch\p=cell
WritePixel cell\x+scrx, cell\y+scry,-1, ib
cellq=cellq+1
End Function