Life Experiments

[bplus]

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://qb64phoenix.com/forum/showthread...09#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 Sub

Double 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 Sub

I 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 Sub

The 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 Sub

Put it in Fade mode and hold down the spacebar!

[vince]

Nice mods, B+.  This is a new kind of science:  https://en.wikipedia.org/wiki/A_New_Kind_of_Science

[bplus]

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.

[vince]

yeah it's freely available on his website https://www.wolframscience.com/nks/

[bplus]

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
Sleep

   

[bplus]

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