01-08-2026, 07:43 PM (This post was last modified: 01-08-2026, 08:37 PM by ahenry3068.)
(01-08-2026, 07:32 PM)bplus Wrote: Works fine! I am seeing: blinkers, floaters, "rocks" 2x2's looks like normal life.
Here is my most recent version modified rules for 3D sim:
Code: (Select All)
_Title "3D per Parallelism test Game of Life - hold enter to reset" ' started Parallelism b+ 2024-02-20
' "parallelism suggests a connection of meaning through an echo of form"
' 2024-02-21 Pyramid 2 screw around with pyramid numbers fix projection formula
' 2024-02-21 now test cubes with DrawCube sub
' 2024-02-21 return to Pyramid 2 and fix that according to how this Project sub works.
' 2024-02-22 test Game of Life code from thisversion of DrawCube
' Ah! apply some tips I learned with 3D Rendering of Game of Life
Dim Shared As Long SW, SH: SW = 720: SH = 720
Screen _NewImage(SW, SH, 32)
_ScreenMove 280, 0
Randomize Timer
Type XYZ
As Single x, y, z
End Type
Type XY
As Single x, y
End Type
Dim Shared PC: PC = .35 ' or something PC = Parallel Constant
Window (-15, 35)-(35, -15) ' setup for 3D
' setup for Game of Life
Dim As Integer xmin, xmax, ymin, ymax, zmin, zmax
xmin = 1: xmax = 30: ymin = 1: ymax = 30: zmin = 1: zmax = 30
Dim As Integer x, y, z, r, g, b, mm, xx, yy, zz, rr, gg, bb, gen
Color &HFFDDDDFF, &HFF000000
ResetStart:
gen = 0
ReDim As Integer U(xmin To xmax, ymin To ymax, zmin To zmax), U2(xmin To xmax, ymin To ymax, zmin To zmax)
'For z = zmin + 10 To zmax - 10
' For x = xmin + 10 To xmax - 10
' For y = ymin + 10 To ymax - 10
' If Rnd > .9 Then U(x, y, z) = 1
'Next y, x, z
Do
Cls
_PrintString (10, 10), "Generation:" + Str$(gen) + " press any for next, escape to quit... "
r = rr: g = gg: b = bb
For z = zmin + 1 To zmax - 1
r = r * 1.04: g = g * 1.04: b = b * 1.04
For x = xmin + 1 To xmax - 1
For y = ymin + 1 To ymax - 1
If U(x, y, z) = 1 Then
drawCube x, y, z, .9, _RGB32(r, g, b)
End If
Next y, x
_Display
_Limit 30
Next z
_Display
Sleep
If _KeyDown(13) Then Cls: _Delay .5: GoTo ResetStart
For z = zmin + 1 To zmax - 1
For x = xmin + 1 To xmax - 1
For y = ymin + 1 To ymax - 1
mm = 0
For xx = x - 1 To x + 1
For yy = y - 1 To y + 1
For zz = z - 1 To z + 1
If x = xx And y = yy And z = zz Then
Else
If U(xx, yy, zz) = 1 Then mm = mm + 1
End If
Next zz, yy, xx
If (mm > 1) And (mm < 4) Then ' neighbors for birth
U2(x, y, z) = 1
ElseIf U(x, y, z) = 1 And mm = 3 Then ' neighbors to survive
U2(x, y, z) = 1
Else
U2(x, y, z) = 0
End If
Next y, x
Next z
For z = zmin + 1 To zmax - 1
For x = xmin + 1 To xmax - 1
For y = ymin + 1 To ymax - 1
U(x, y, z) = U2(x, y, z)
Next y, x, z
gen = gen + 1
Loop Until _KeyDown(27)
Sub drawCube (cx, cy, cz, side, colr~&) 'draw a cube on screen from an xyz() 3D array
Dim As Integer i, r, g, b
Dim sd2, lx, rx, ty, by, fz, bz
Dim c2 As _Unsigned Long
r = _Red32(colr~&): g = _Green32(colr~&): b = _Blue32(colr~&)
ReDim corners(0 To 7) As XYZ
sd2 = side / 2
rx = cx + sd2: lx = cx - sd2
ty = cy + sd2: by = cy - sd2
fz = cz + sd2: bz = cz - sd2
'bck face
corners(0).x = lx: corners(0).y = ty: corners(0).z = bz
corners(1).x = rx: corners(1).y = ty: corners(1).z = bz
corners(2).x = rx: corners(2).y = by: corners(2).z = bz
corners(3).x = lx: corners(3).y = by: corners(3).z = bz
'frt face
corners(4).x = lx: corners(4).y = ty: corners(4).z = fz
corners(5).x = rx: corners(5).y = ty: corners(5).z = fz
corners(6).x = rx: corners(6).y = by: corners(6).z = fz
corners(7).x = lx: corners(7).y = by: corners(7).z = fz
ReDim xy(0 To 7) As XY
For i = 0 To 7
Project corners(i), xy(i) ' take a corner x,y,z and convert to screen coordinates x,y
Next
' steves latest version to check out, seems to be working OK
Sub FillTriangle (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
$Checking:Off
Static a&, m As _MEM
If a& = 0 Then a& = _NewImage(1, 1, 32): m = _MemImage(a&)
_MemPut m, m.OFFSET, K
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
$Checking:On
End Sub
' here I am working with a Window so Screen obeys right hand rule so as z increases
' the image x, y plane is closer to the eye/camera so is bigger
' but should be distance squared
' thankyou vince '2024-02 the bigger the Z the closer it is to the eye the greater the image
Sub Project (pIN As XYZ, pOut As XY) 'M2SPP = Model (3D) 2 Screen Per Parallelism
pOut.x = pIN.x - PC * pIN.z
pOut.y = pIN.y - PC * pIN.z
End Sub
Starts as 1x1x3 "blinker" in 2D Life
I can't copy and paste this code. It's full of garbage formatting characters when I cut/paste it !!!!!
CANCEL THAT ABOVE STATEMENT. I GOT IT !
It looks very interesting !
I did get mine right ! The first iteration had a couple of stupid errors.
Right click to delete blocks and as for speed, change the _LIMIT
Man! all 3 of us must have posted nearly same time. When I left, my post was right after Henry's, when I come back yours is sandwiched in-between! Weird.
I missed right-click edit, nice!
Guess I will review again to see what the ghosting thingy... is doing. I might like it
_Title "Conways GAME OF LIFE "
_Blink Off
Locate 2, 1
Color 10
Print " F1 ";
Color 12
Print "- ";
Color 15
Print "Init Random Live Cells"
Print
Color 10
Print " F2 ";
Color 12
Print "- ";
Color 15
Print "User Cell Selection"
Color 4
Print " (";
Color 2
Print "ENTER";
Color 7
Print " When done";
Color 4
Print ")"
Print
Color 10
Print " ESC ";
Color 12
Print "- ";
Color 15
Print "Exit CONWAY's Game of Life"
Print
Do
c = _KeyHit
Loop Until c = _KEY_F1 Or c = _KEY_F2 Or c = _KEY_ESC
Select Case c
Case _KEY_F1
InitGridRandom
Case _KEY_F2
MouseTick = _FreeTimer
On Timer(MouseTick, .05) CheckMouseStuff
Timer(MouseTick) On
_Title "Conways GAME OF LIFE - SET CELLS"
InitGridUser
Timer(MouseTick) Off
_Title "Conways GAME OF LIFE "
Case _KEY_ESC
System
End Select
Do
UpdateGeneration TheCells1(), TheCells2()
DRAWGRID TheCells2()
_Delay .1
UpdateGeneration TheCells2(), TheCells1()
DRAWGRID TheCells1()
_Delay .1
Loop Until InKey$ = Chr$(27)
Screen 0
_FreeImage MyScreen
_AutoDisplay
Do
Loop Until _KeyHit = 0 And InKey$ = ""
GoTo startup
' $Include: './BUTTONS.BM'
Sub UpdateGeneration (InCells() As CellType, OutCells() As CellType)
Dim i As Long
Dim CellPointer As Long
Dim RowAbove As Long
Dim RowBelow As Long
Dim ColLeft As Long
Dim ColRight As Long
Dim NRow As Long
Dim NCol As Long
Dim Neighbors(0 To 7) As CellType
CellPointer = 0
For i = 0 To UBound(InCells)
If InCells(i).Row = 0 Then
RowAbove = InCells(i).Parent.HEI - 1
Else
RowAbove = InCells(i).Row - 1
End If
If InCells(i).Row = InCells(i).Parent.HEI - 1 Then
RowBelow = 0
Else
RowBelow = InCells(i).Row + 1
End If
If InCells(i).Col = 0 Then
ColLeft = InCells(i).Parent.WID - 1
Else
ColLeft = InCells(i).Col - 1
End If
If InCells(i).Col = InCells(i).Parent.WID - 1 Then
ColRight = 0
Else
ColRight = InCells(i).Col + 1
End If
Neighbors(5) = InCells((RowBelow * MYGRID.WID) + ColLeft)
Neighbors(6) = InCells((RowBelow * MYGRID.WID) + InCells(i).Col)
Neighbors(7) = InCells((RowBelow * MYGRID.WID) + ColRight)
OutCells(i).IsAlive = IsAlive(InCells(i), Neighbors())
Next
Generation = Generation + 1
_Title "Conways GAME OF LIFE Gen: " + _Trim$(Str$(Generation))
End Sub
Function IsAlive (CellIn As CellType, CellNeighbors() As CellType)
Dim LifeCount As Integer
Dim i As Long
LifeCount = 0
For i = 0 To 7
If CellNeighbors(i).IsAlive Then
LifeCount = LifeCount + 1
End If
Next
If CellIn.IsAlive And (LifeCount > 1 And LifeCount < 4) Then
IsAlive = _TRUE
Exit Function
End If
If CellIn.IsAlive And (LifeCount > 3) Then
IsAlive = _FALSE
Exit Function
End If
If Not (CellIn.IsAlive) And (LifeCount = 3) Then
IsAlive = _TRUE
Exit Function
End If
IsAlive = _FALSE
End Function
Sub InitGridRandom
Dim I As Long
Dim GRow As Long
Dim GCol As Long
Dim CellPointer As Long
Randomize Timer
CellPointer = 0
NumberOfCells = MYGRID.WID * MYGRID.HEI
ReDim TheCells1(0 To NumberOfCells - 1) As CellType
ReDim TheCells2(0 To NumberOfCells - 1) As CellType
For GRow = 0 To MYGRID.HEI - 1
For GCol = 0 To MYGRID.WID - 1
TheCells1(CellPointer).Row = GRow
TheCells1(CellPointer).Col = GCol
TheCells2(CellPointer).Row = GRow
TheCells2(CellPointer).Col = GCol
TheCells1(CellPointer).Parent = MYGRID
TheCells2(CellPointer).Parent = MYGRID
If (Int(Rnd * 100) + 1) < 25 Then
TheCells1(CellPointer).IsAlive = _TRUE
Else
TheCells1(CellPointer).IsAlive = _FALSE
End If
CellPointer = CellPointer + 1
Next
Next
MyScreen = _NewImage(MYGRID.WID * MYGRID.CellWidth, MYGRID.HEI * MYGRID.CellHeight, 32)
Screen MyScreen
For I = 0 To NumberOfCells - 1
DrawCell TheCells1(I)
Next
End Sub
Sub InitGridUser
Dim I As Long
Dim GRow As Long
Dim GCol As Long
Dim CellPointer As Long
Dim X As Long
Dim Y As Long
Randomize Timer
CellPointer = 0
NumberOfCells = MYGRID.WID * MYGRID.HEI
ReDim TheCells1(0 To NumberOfCells - 1) As CellType
ReDim TheCells2(0 To NumberOfCells - 1) As CellType
Dim Boxes(0 To NumberOfCells - 1) As MouseBox
Do
If Click Then
For I = 0 To NumberOfCells - 1
If IN_BOX(Boxes(I), Mx, My) Then
If TheCells1(I).IsAlive Then
TheCells1(I).IsAlive = _FALSE
Else
TheCells1(I).IsAlive = _TRUE
End If
DrawCell TheCells1(I)
_Display
Exit For
End If
Next
End If
_Limit 60
Loop Until InKey$ = Chr$(13)
Timer(MouseTick) Off
End Sub
Sub DRAWGRID (Cells() As CellType)
Dim i As Long
For i = 0 To UBound(Cells)
DrawCell Cells(i)
Next
_Display
End Sub
Function getcellLiveColor&&
Static Lr As Integer
Static Lg As Integer
Static Lb As Integer
Static TheColor As _Unsigned Long
Static FadeIncrement As Integer
Static LastGeneration As _Integer64
Static FadeComponent As Integer
If FadeIncrement = 0 Then
Lg = 100
Lr = 0
Lb = 0
FadeIncrement = 10
FadeComponent = 1
Randomize Timer
End If
If Generation = LastGeneration GoTo SkipAll
doFade:
Select Case FadeComponent
Case 1
Lr = Lr + FadeIncrement
If Lr <= 0 Or Lr >= 255 Then
GoSub SwapDirections
If Lr < 0 Then Lr = 0
If Lr > 255 Then Lr = 255
End If
Case 2
Lg = Lg + FadeIncrement
If Lg <= 0 Or Lg >= 255 Then
GoSub SwapDirections
If Lg < 0 Then Lg = 0
If Lg > 255 Then Lg = 255
End If
Case 3
Lb = Lb + FadeIncrement
If Lb <= 0 Or Lb >= 255 Then
GoSub SwapDirections
If Lb < 0 Then Lb = 0
If Lb > 255 Then Lb = 255
End If
End Select
TheColor = _RGB32(Lr, Lg, Lb, 255)
SkipAll:
LastGeneration = Generation
getcellLiveColor = TheColor
Exit Function
SwapDirections:
FadeComponent = Int(Rnd * 3) + 1
FadeIncrement = Int(Rnd * 20) + 1
Select Case FadeComponent
Case 1
If Lr > 200 Then FadeIncrement = FadeIncrement * -1
Case 2
If Lg > 200 Then FadeIncrement = FadeIncrement * -1
Case 3
If Lb > 200 Then FadeIncrement = FadeIncrement * -1
End Select
Return
End Function
Sub DrawCell (Cell As CellType)
Dim CellColor As _Unsigned Long
Dim X As Long
Dim Y As Long
Dim X2 As Long
Dim Y2 As Long
If Cell.IsAlive Then
' CellColor = _RGB32(200, 0, 0, 255)
CellColor = getcellLiveColor
Else
CellColor = (getcellLiveColor Xor &HFFFFFFFF) Or (_RGB32(0, 0, 0, 255))
End If
X = (Cell.Col * Cell.Parent.CellWidth)
Y = (Cell.Row * Cell.Parent.CellHeight)
X2 = X + Cell.Parent.CellWidth
Y2 = Y + Cell.Parent.CellHeight
Line (X, Y)-(X2, Y2), _RGB32(0, 0, 0, 255), BF
Line (X + 1, Y + 1)-(X2 - 1, Y2 - 1), CellColor, BF
End Sub
01-09-2026, 01:14 AM (This post was last modified: 01-09-2026, 01:19 AM by bplus.)
Colorful!
You might like this, Hex Life 2:
Code: (Select All)
Option _Explicit 'Bplus started 2019-09-23 from Hex Minesweeper Custom Field
'2019-09-25 post with original Life Rules
'2019-09-27 OK let's try some more color!
'2019-09-28 fix hexagon fills by not using PAINT
'2019-09-30 add Generation as suggested by Ken
Const cellR = 10 ' which makes the following constant
Const xSpacing = 2 * cellR * Cos(_D2R(30))
Const ySpacing = cellR * (1 + Sin(_D2R(30)))
Type cell
x As Integer
y As Integer
L As Integer
End Type
Dim Shared k(6) As _Unsigned Long
k(0) = &HFF000000: k(1) = &HFFFFFF88: k(2) = &HFFDDDDFF: k(3) = &HFF550033: k(4) = &HFF005500: k(5) = &HFF000044: k(6) = &HFFFF0000
Dim Shared xmax As Integer, ymax As Integer, Xarrd As Integer, Yarrd As Integer 'set all this in customField sub
' note: To preserve symmetry when cells hit boundries with a symmetric seed started in middle:
' y should be odd for 1 center row
' x should be equal to or less than y
' If int(x/2 + .5) is even then the right one of two center cells is marked else the one center cell is marked
'
Xarrd = 41 ' the top left cell has been hacked to duplicate the top right cell, to preserve symmetric seeds through a run
Yarrd = 41 'y should always be odd top preserve symmetry of center symmetric seed
Screen _NewImage(xmax, ymax, 32)
_ScreenMove (1280 - xmax) / 2 + 60, (760 - ymax) / 2
Randomize Timer
Dim Shared b(0 To Xarrd + 1, 0 To Yarrd + 1) As cell, ng(0 To Xarrd + 1, 0 To Yarrd + 1) As Integer 'oversize the board to make it easy to count
Dim x As Integer, y As Integer, xoffset, xStop As Integer, nc As Integer, c As Integer, r As Integer, mb As Integer, kh&, gen As Integer
Do
_Title "Hexagon Life: Left Click to Toggle Cells On/Off, Right Click to Start Run, Escape to Quit"
' set x, y for cells and mark ceter cell(s)
For y = 1 To Yarrd
If y Mod 2 = 0 Then
xoffset = .5 * xSpacing: xStop = Xarrd - 1
Else
xoffset = 0: xStop = Xarrd
End If
For x = 1 To xStop
b(x, y).x = x * xSpacing + xoffset + .5 * xSpacing
b(x, y).y = y * ySpacing + .5 * ySpacing
If x = Int(Xarrd / 2 + .5) And y = Int(Yarrd / 2 + .5) Then b(x, y).L = 1 Else b(x, y).L = 0 'mark middle cell
showCell x, y, 7
Next
Next
_Display
'setup seed by toggling cells on and off
While mb <> 2
kh& = _KeyHit
If kh& = 27 Then Exit Do
mb = 0: c = 0: r = 0
getCell c, r, mb
If mb = 1 Then
b(c, r).L = 1 - b(c, r).L
showCell c, r, 7
End If
_Display
_Limit 60
Wend
mb = 0
_Title "Hexagon Life: Spacebar to Restart/Reseed, Escape to Quit"
While kh& <> 32 And kh& <> 27
kh& = _KeyHit
'count the neighbors
For y = 1 To Yarrd
If y Mod 2 = 0 Then
xoffset = .5 * xSpacing: xStop = Xarrd - 1
Else
xoffset = 0: xStop = Xarrd
End If
For x = 1 To xStop
'2 sets of neighbors depending if x offset or not
If xoffset > .05 Then
nc = b(x, y - 1).L + b(x + 1, y - 1).L + b(x - 1, y).L
nc = nc + b(x + 1, y).L + b(x, y + 1).L + b(x + 1, y + 1).L
Else
nc = b(x - 1, y - 1).L + b(x, y - 1).L + b(x - 1, y).L
nc = nc + b(x + 1, y).L + b(x - 1, y + 1).L + b(x, y + 1).L
End If
'originally tested and posted( 9/25/2019) here only 2 neighbors for birth in Classic Life it takes 3
'IF (nc = 3 AND b(x, y).L = 1) OR nc = 2 THEN ng(x, y) = 1 ELSE ng(x, y) = 0
'TempodiBasic suggested this survival if 1 survival or surviaval and birth for 2 neighbors
If (nc = 1 And b(x, y).L = 1) Or nc = 2 Then ng(x, y) = 1 Else ng(x, y) = 0
' my first test for TempodiBasic, I mistakenly ran this which is good too!
'IF (nc = 3 AND b(x, y).L = 1) OR nc = 1 THEN ng(x, y) = 1 ELSE ng(x, y) = 0
showCell x, y, nc
If x = Xarrd And y = 1 Then showCell 1, 1, nc
Next
Next
'redraw all cells so no CLS
For y = 1 To Yarrd 'transfer data from ng to b().l and show cell
If y Mod 2 = 0 Then
xStop = Xarrd - 1
Else
xStop = Xarrd
End If
For x = 1 To xStop
b(x, y).L = ng(x, y)
'showCell x, y
Next
'fix symmetry for top left corner, match x at other end for bi-lat symmetry
b(1, 1).L = b(Xarrd, 1).L
'showCell 1, 1
Next
gen = gen + 1
Locate 1, 1: Print Space$(50)
Locate 1, 1: Print "Generation:"; gen
_Display
_Limit 1
Wend
If kh& = 27 Then Exit Do
kh& = 0
Loop
Sub showCell (c As Integer, r As Integer, kNum As Integer)
Dim clr As _Unsigned Long
If r Mod 2 = 0 Then
If c < 1 Or c > Xarrd - 1 Then Exit Sub
Else
If c < 1 Or c > Xarrd Then Exit Sub
End If
If r < 1 Or r > Yarrd Then Exit Sub
If kNum = 7 Then
If b(c, r).L = 1 Then clr = &HFFFFFFFF Else clr = &HFF000000
Else
clr = k(kNum)
End If
If kNum < 7 Then
fHexH b(c, r).x, b(c, r).y, cellR, clr
hexH b(c, r).x, b(c, r).y, cellR, &HFF000000
Else
fHexH b(c, r).x, b(c, r).y, cellR, clr
hexH b(c, r).x, b(c, r).y, cellR, &HFF440044
End If
End Sub
Sub getCell (returnCol As Integer, returnRow As Integer, mbNum As Integer)
Dim m, mx, my, mb1, mb2, r As Integer, c As Integer
While _MouseInput: Wend
mb1 = _MouseButton(1): mb2 = _MouseButton(2)
If mb1 Then mbNum = 1
If mb2 Then mbNum = 2
If mb1 Or mb2 Then ' get last place mouse button was down
While mb1 Or mb2 ' wait for mouse button release as a "click"
m = _MouseInput: mb1 = _MouseButton(1): mb2 = _MouseButton(2)
mx = _MouseX: my = _MouseY
'LOCATE 1, 1: PRINT SPACE$(50)
'LOCATE 1, 1: PRINT mx, my, .5 * xSpacing
_Display
Wend
For r = 1 To Yarrd
For c = 1 To Xarrd
If ((mx - b(c, r).x) ^ 2 + (my - b(c, r).y) ^ 2) ^ .5 < .5 * xSpacing Then
'LOCATE 1, 1: PRINT SPACE$(50)
'LOCATE 1, 1: PRINT c, r
returnCol = c: returnRow = r: Exit Sub
End If
Next
Next
mbNum = 0 'still here then clicked wrong
End If
End Sub
'draw Hexagon Outline that can be packed Horizontally, flat edge to flat edge
Sub hexH (xOrigin As Single, yOrigin As Single, radius As Single, c As _Unsigned Long)
Dim polyAngle As Single, aOff As Single, x1 As Single, y1 As Single, i As Integer, x2 As Single, y2 As Single
polyAngle = _Pi(2) / 6: aOff = _Pi / 2
x1 = xOrigin + radius * Cos(polyAngle + aOff)
y1 = yOrigin + radius * Sin(polyAngle + aOff)
For i = 2 To 7
x2 = xOrigin + radius * Cos(i * polyAngle + aOff)
y2 = yOrigin + radius * Sin(i * polyAngle + aOff)
Line (x1, y1)-(x2, y2), c
x1 = x2: y1 = y2
Next
End Sub
'draw filled Hexagon that can be packed Horizontally, flat edge to flat edge
'uses SUB fTri
Sub fHexH (xOrigin As Single, yOrigin As Single, radius As Single, c As _Unsigned Long)
Dim polyAngle As Single, aOff As Single, x1 As Single, y1 As Single, i As Integer, x2 As Single, y2 As Single
polyAngle = _Pi(2) / 6: aOff = _Pi / 2
x1 = xOrigin + radius * Cos(polyAngle + aOff)
y1 = yOrigin + radius * Sin(polyAngle + aOff)
For i = 2 To 7
x2 = xOrigin + radius * Cos(i * polyAngle + aOff)
y2 = yOrigin + radius * Sin(i * polyAngle + aOff)
fTri xOrigin, yOrigin, x1, y1, x2, y2, c
x1 = x2: y1 = y2
Next
End Sub
Sub fTri (x1 As Single, y1 As Single, x2 As Single, y2 As Single, x3 As Single, y3 As Single, K As _Unsigned Long)
Dim a&
a& = _NewImage(1, 1, 32)
_Dest a&
PSet (0, 0), K
_Dest 0
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
_FreeImage a& '<<< this is important!
End Sub
Here is an ascii life in an interesting life cycle!
Code: (Select All)
' Life from jb uses mod for border crossing and this example is best string seed
Screen _NewImage(240, 480, 32)
DefLng A-Z
Dim g(29, 29)
For y = 14 To 14 'seed g()
For x = 10 To 19
g(x, y) = 1
Locate y, x: Print "*"
Next
Next
restart:
ReDim ng(29, 29)
For y = 0 To 29
For x = 0 To 29
nc = g(mod1(x-1, 30), mod1(y-1, 30)) + g(mod1(x, 30), mod1(y-1, 30)) + g(mod1(x+1, 30), mod1(y-1, 30)) +_
g(mod1(x-1, 30), mod1(y, 30)) + g(mod1(x+1, 30), mod1(y, 30)) +_
g(mod1(x-1, 30), mod1(y+1, 30)) + g(mod1(x, 30), mod1(y+1, 30))+ g(mod1(x+1, 30), mod1(y+1, 30))
If g(x, y) Then
Locate y + 1, x + 1: Print "*";
If nc = 2 Or nc = 3 Then ng(x, y) = 1
Else
Locate y + 1, x + 1: Print " ";
If nc = 3 Then ng(x, y) = 1
End If
Next
Next
For y = 0 To 29 'transfer ng to g and erase
For x = 0 To 29
g(x, y) = ng(x, y)
Next
Next
ReDim ng(29, 29)
_Limit 2
GoTo restart
Function mod1 (a, md)
If a < 0 Then mod1 = (a + md) Mod md Else mod1 = a Mod md
End Function
01-09-2026, 01:27 AM (This post was last modified: 01-09-2026, 01:56 AM by bplus.)
Oh turns out I did fade version also, press f while thing is running:
Code: (Select All)
Option _Explicit ' by bplus 2019-09-20
DefInt A-Z ' strip Quick Life down to bare essentials
_Title "Core Life: f for fade look, t for traditioanal look, press spacebar when stabilized, esc to quit"
Const xmax = 700, ymax = 700, n = 140, s = 5
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 360, 20
Dim g, x, y, r, nc, Fade 'nc is neighbor count
Dim a(0 To n + 1, 0 To n + 1), ng(0 To n + 1, 0 To n + 1) 'a() is Life array, ng() is next generation
Color &HFFFFFF00, &HFF080021: r = 35
Do 'seed for Conway's Life Classic
Cls
g = 0: r = r - 1: If r = 1 Then r = 68
For y = 0 To n + 1
For x = 0 To n + 1 'for symmetric line blocks
If y = n / 2 And x > r And x < (n + 1 - r) Then a(x, y) = 1 Else a(x, y) = 0
Next
Next
While InKey$ <> " " And _KeyDown(27) = 0 'run life until spacebar detected
For x = 1 To n
For y = 1 To n
nc = a(x - 1, y - 1) + a(x - 1, y) + a(x - 1, y + 1) + a(x, y - 1) + a(x, y + 1) + a(x + 1, y - 1) + a(x + 1, y) + a(x + 1, y + 1)
If a(x, y) Then ' a is alive Classic Conway's Life Rules for survival
If nc = 2 Or nc = 3 Then ng(x, y) = 1 Else ng(x, y) = 0
Else 'birth?
If nc = 3 Then ng(x, y) = 1 Else ng(x, y) = 0
End If
Next
Next
If _KeyDown(Asc("t")) Then Fade = 0
If _KeyDown(Asc("f")) Then Fade = -1
If Fade Then Line (0, 0)-Step(xmax, ymax), &H30080021, BF Else Line (0, 0)-Step(xmax, ymax), &HFF080021, BF
For y = 1 To n
For x = 1 To n
If a(x, y) Then 'this separates into individual cells for Classic look
Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s - 2, s - 2), &HFFFFFFFF, BF
End If
Next
Next
Locate 1, 1: Print "Seed:"; r; " Gen:"; g
_Display
For y = 1 To n
For x = 1 To n
a(x, y) = ng(x, y) 'load a() with next generation data
Next
Next
g = g + 1
_Display
_Limit 10
Wend
Loop Until _KeyDown(27)
Cls: End
Sub LngArrCopy (A&(), copyB&())
ReDim copyB&(LBound(A&) To UBound(A&)) 'container for _memget is ready
Dim m As _MEM
m = _Mem(A&())
_MemGet m, m.OFFSET, copyB&()
_MemFree m '<<<<<<<<<<<<<<<<<<<<<<<<<< like freeimage very important
End Sub
(01-09-2026, 01:27 AM)bplus Wrote: Oh turns out I did fade version also, press f while thing is running:
Code: (Select All)
Option _Explicit ' by bplus 2019-09-20
DefInt A-Z ' strip Quick Life down to bare essentials
_Title "Core Life: f for fade look, t for traditioanal look, press spacebar when stabilized, esc to quit"
Const xmax = 700, ymax = 700, n = 140, s = 5
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 360, 20
Dim g, x, y, r, nc, Fade 'nc is neighbor count
Dim a(0 To n + 1, 0 To n + 1), ng(0 To n + 1, 0 To n + 1) 'a() is Life array, ng() is next generation
Color &HFFFFFF00, &HFF080021: r = 35
Do 'seed for Conway's Life Classic
Cls
g = 0: r = r - 1: If r = 1 Then r = 68
For y = 0 To n + 1
For x = 0 To n + 1 'for symmetric line blocks
If y = n / 2 And x > r And x < (n + 1 - r) Then a(x, y) = 1 Else a(x, y) = 0
Next
Next
While InKey$ <> " " And _KeyDown(27) = 0 'run life until spacebar detected
For x = 1 To n
For y = 1 To n
nc = a(x - 1, y - 1) + a(x - 1, y) + a(x - 1, y + 1) + a(x, y - 1) + a(x, y + 1) + a(x + 1, y - 1) + a(x + 1, y) + a(x + 1, y + 1)
If a(x, y) Then ' a is alive Classic Conway's Life Rules for survival
If nc = 2 Or nc = 3 Then ng(x, y) = 1 Else ng(x, y) = 0
Else 'birth?
If nc = 3 Then ng(x, y) = 1 Else ng(x, y) = 0
End If
Next
Next
If _KeyDown(Asc("t")) Then Fade = 0
If _KeyDown(Asc("f")) Then Fade = -1
If Fade Then Line (0, 0)-Step(xmax, ymax), &H30080021, BF Else Line (0, 0)-Step(xmax, ymax), &HFF080021, BF
For y = 1 To n
For x = 1 To n
If a(x, y) Then 'this separates into individual cells for Classic look
Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s - 2, s - 2), &HFFFFFFFF, BF
End If
Next
Next
Locate 1, 1: Print "Seed:"; r; " Gen:"; g
_Display
For y = 1 To n
For x = 1 To n
a(x, y) = ng(x, y) 'load a() with next generation data
Next
Next
g = g + 1
_Display
_Limit 10
Wend
Loop Until _KeyDown(27)
Cls: End
Sub LngArrCopy (A&(), copyB&())
ReDim copyB&(LBound(A&) To UBound(A&)) 'container for _memget is ready
Dim m As _MEM
m = _Mem(A&())
_MemGet m, m.OFFSET, copyB&()
_MemFree m '<<<<<<<<<<<<<<<<<<<<<<<<<< like freeimage very important
End Sub
