+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://staging.qb64phoenix.com/forumdisplay.php?fid=26)
+---- Forum: bplus (https://staging.qb64phoenix.com/forumdisplay.php?fid=36)
+---- Thread: Life Experiments (/showthread.php?tid=783)
Life Experiments - bplus - 08-18-2022
I suspect I am on a private quest with Conway's "Game" of Life so I will continue updates here in this little corner of forum from here:
https://staging.qb64phoenix.com/showthread.php?tid=779&pid=5509#pid5509
I sort of accomplished something already finding the 3X8 block seed that cycles through 15 patterns, immortal life if undisturbed like blinkers and gliders (if they don't run into borders out on the edge of the universe or anything else). I suspect if 2 gliders collide just the right way they will create instead of cancel each other out. I might have found the 3X8 block seed quicker trying triple line lengths so that is probably next experiment then 4 and 5 line stacks maybe.
I have updated all previous code with a Fade (f) or Traditional Black and White Off/On (t) screen toggles. I like fade because the old alive cells fade away and blinkers look almost like stationary plusses ie you can easily tell the run is done with stationary debris or nothing left in the screen.
Here is single line experiments increasing line length to 70 width of screen in cells, now with f/t toggles:
Code: (Select All)
Option _Explicit ' by bplus 2019-09-20 mod to Life Line Seed Experiment 2022-08-17
_Title "Life Line Seed Experiment: f for fade look, t for traditioanal look, press spacebar when stabilized, esc to quit"
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$, 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
' 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 = 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
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
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 SubDouble line, which starts small and really short runs but gets more interesting as lines get longer:
Code: (Select All)
Option _Explicit ' by bplus 2019-09-20 mod to Life Line Seed Experiment 2022-08-17
_Title "Life Double Line Seed Experiment: f for fade look, t for traditioanal look, press spacebar when stabilized, esc to quit"
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$, 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 = 70
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 = 1 Then r = 70
For y = 0 To n + 1
For x = 0 To n + 1 'for symmetric line blocks
If (y = n / 2 Or y = (n / 2 + 1)) 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
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
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 SubI call it a Square Seed but it is more like a TicTacToe Grid that shrinks the central square down to a Double Line. My first try towards Grids that I suspect might be really interesting seed.
Code: (Select All)
Option _Explicit ' by bplus 2019-09-20 mod to Life Line Seed Experiment 2022-08-17
_Title "Life Square Seed: f for fade look, t for traditioanal look, press spacebar when stabilized, esc to quit"
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$, 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 = 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 = 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
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
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 SubThe above is the one where I discovered the 3x8 seed that Persists by cycling through 15 patterns (I have it set to show that in first run of code) and here "Persist" isolated from above. I like this pattern because it looks like an alien space ship!
Code: (Select All)
Option _Explicit ' by bplus 2019-09-20 mod to Life Line Seed Experiment 2022-08-17
_Title "Life Persist Seed: f for fade look, t for traditioanal look, press spacebar for next state, esc to quit"
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$, 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 = 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
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
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 SubPut it in Fade mode and hold down the spacebar!
RE: Life Experiments - vince - 08-18-2022
Nice mods, B+. This is a new kind of science: https://en.wikipedia.org/wiki/A_New_Kind_of_Science
RE: Life Experiments - bplus - 08-18-2022
Yeah I remember seeing that book at library back when I didn't have a computer. I wonder if they still have it? That sucker was huge!
Wolfram has gone onto a PL and much more at the website.
RE: Life Experiments - vince - 08-18-2022
yeah it's freely available on his website https://www.wolframscience.com/nks/
RE: Life Experiments - bplus - 08-19-2022
Did not know (or forgot) Sierpinski Triangle can be made with Celluar Automata on lines only ie neighbor counts of 3 cells above the cell in question!
Code: (Select All)
_Title "Cellular 1 or 2 of 3 Rule"
Screen _NewImage(1300, 700, 32)
_ScreenMove 40, 0
DefLng A-Z
s = 2
n = 1300 / s - 2
Dim a(0 To n + 1), ng(0 To n + 1)
a(n / 2) = 1
y = 0
While y < 700
For i = 1 To n
sum = a(i - 1) + a(i) + a(i + 1)
If sum = 0 Or sum = 3 Then
ng(i) = 0
Line (i * s, y)-Step(s, s), &HFF000000, BF
ElseIf sum = 1 Or sum = 2 Then
ng(i) = 1
Line (i * s, y)-Step(s, s), , BF
End If
Next
y = y + s
For i = 1 To n
a(i) = ng(i)
Next
Wend
SleepRE: Life Experiments - bplus - 08-19-2022
Almost same thing with 5 cells above looking at sums 1,2 or3 opposed to 0, 4 or 5
Code: (Select All)
_Title "Cellular first 3 of 5 Rule"
Screen _NewImage(1300, 700, 32)
_ScreenMove 40, 0
DefLng A-Z
s = 2
n = 1300 / s - 2
Dim a(0 To n + 1), ng(0 To n + 1)
a(n / 2) = 1
y = 0
While y < 700
For i = 2 To n - 2
sum = a(i - 2) + a(i - 1) + a(i) + a(i + 1) + a(i + 2)
If sum = 0 Or sum = 4 Or sum = 5 Then
ng(i) = 0
Line (i * s, y)-Step(s, s), &HFF000000, BF
ElseIf sum = 1 Or sum = 2 Or sum = 3 Then
ng(i) = 1
Line (i * s, y)-Step(s, s), , BF
End If
Next
y = y + s
For i = 1 To n
a(i) = ng(i)
Next
Wend
Sleep