+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Programs (https://qb64phoenix.com/forum/forumdisplay.php?fid=7)
+---- Thread: Life Experiments (/showthread.php?tid=779)
Life Experiments - bplus - 08-17-2022
Well @James D Jarvis you did it now, you rekindled my interest in Conway's Life.
For starters add that mem copy method to old code for testing different Line Lengths for Seeds, maybe call it "Life in the Fast Lane!" but it was speedy enough before that I had to use limit the loops!
Anyway different line lengths for seed on a 140 x 140 array. It stays symmetric until we hit top or bottom before the other side does, right and left seem to always be symmetric.
Code: (Select All)
Option _Explicit ' by bplus 2019-09-20 mod to Life Line Seed Experiment 2022-08-17
_Title "Life Line Seed Experiment"
DefLng A-Z
Const xmax = 700, ymax = 700, n = 140, s = 5
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 360, 0
Dim g, x, y, r, nc, wait$ '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
' Using lines of different lengths if line is odd symmetric results, even maybe not top and bottom differ << nope it depends !
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
If a(x, y) = 1 Then
Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s - 2, s - 2), &HFFFFFFFF, BF
Else
Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s - 2, s - 2), &HFF000000, BF
End If
Next
Next
' Sleep refuses to cooperate with _KeyClear! So a full stop Input statement.
Locate 1, 1: Input "This is the line seed. Press enter to continue..."; wait$
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
' Run through the generations use any key to stop run and reseed with new line length.
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
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
Line (0, 0)-Step(xmax, ymax), &H11080021, 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
LngArrCopy ng(), a() ' good! looks like mem copy works
g = g + 1
_Display
_Limit 30
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 SubRE: Life Experiments - bplus - 08-17-2022
Life with Square/TTT grid seeds, something new happens @ #69 seed, 4 symmetric areas stay alive!
Code: (Select All)
Option _Explicit ' by bplus 2019-09-20 mod to Life Line Seed Experiment 2022-08-17
_Title "Life Square Seed Experiment"
DefLng A-Z
Const xmax = 700, ymax = 700, n = 140, s = 5
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 360, 0
Dim g, x, y, r, nc, wait$ '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 = 30
Do 'seed for Conway's Life Classic
' Using lines of different lengths if line is odd symmetric results, even maybe not top and bottom differ
Cls
g = 0: r = r + 1: If r = 70 Then r = 0
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
If y = 1 + r Or y = n - r Or x = 1 + r Or x = n - r Then a(x, y) = 1 Else a(x, y) = 0
If a(x, y) = 1 Then
Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s - 2, s - 2), &HFFFFFFFF, BF
Else
Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s - 2, s - 2), &HFF000000, BF
End If
Next
Next
' Sleep refuses to cooperate with _KeyClear! So a full stop Input statement.
Locate 1, 1: Input "This is the line seed. Press enter to continue..."; wait$
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
' Run through the generations use any key to stop run and reseed with new line length.
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
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
Line (0, 0)-Step(xmax, ymax), &H11080021, 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
LngArrCopy ng(), a() ' good! looks like mem copy works
g = g + 1
_Display
_Limit 30
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 SubRE: Life Experiments - bplus - 08-18-2022
Here is a 3 X 8 Block that cycles through 15 patterns and Persists!
Code: (Select All)
Option _Explicit ' by bplus 2019-09-20 mod to Life Line Seed Experiment 2022-08-17
_Title "Life Persist Seed Experiment"
DefLng A-Z
Const xmax = 700, ymax = 700, n = 140, s = 5
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 360, 0
Dim g, x, y, r, nc, wait$ '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 = 68
'Do 'seed for Conway's Life Classic
' Using lines of different lengths if line is odd symmetric results, even maybe not top and bottom differ
Cls
g = 0: r = r + 1: If r = 70 Then r = 0
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
If y >= n / 2 - 1 And y <= n / 2 + 1 Then
If x >= n / 2 - 4 And x <= n / 2 + 3 Then
a(x, y) = 1
End If
End If
If a(x, y) = 1 Then
Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s - 2, s - 2), &HFFFFFFFF, BF
Else
Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s - 2, s - 2), &HFF000000, BF
End If
Next
Next
' Sleep refuses to cooperate with _KeyClear! So a full stop Input statement.
Locate 1, 1: Input "This is the line seed. Press enter to continue..."; wait$
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
' Run through the generations use any key to stop run and reseed with new line length.
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
While _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
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
LngArrCopy ng(), a() ' good! looks like mem copy works
g = g + 1
If g Mod 15 = 0 Then _PrintString (334, 390), Str$(15) Else _PrintString (334, 390), Str$(g Mod 15)
_Display
Sleep
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 SubRE: Life Experiments - James D Jarvis - 08-18-2022
Neato. Fun to inspire others, even when I was just polishing a mistake (or two).