Life Experiments

[bplus]

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 Sub