Life Experiments

[bplus]

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 Sub