Game of life

[bplus]

Colorful!

You might like this, Hex Life 2:

Code: (Select All)

Option _Explicit 'Bplus started 2019-09-23 from Hex Minesweeper Custom Field
'2019-09-25 post with original Life Rules
'2019-09-27 OK let's try some more color!
'2019-09-28 fix hexagon fills by not using PAINT
'2019-09-30 add Generation as suggested by Ken

Const cellR = 10 ' which makes the following constant
Const xSpacing = 2 * cellR * Cos(_D2R(30))
Const ySpacing = cellR * (1 + Sin(_D2R(30)))

Type cell
    x As Integer
    y As Integer
    L As Integer
End Type
Dim Shared k(6) As _Unsigned Long
k(0) = &HFF000000: k(1) = &HFFFFFF88: k(2) = &HFFDDDDFF: k(3) = &HFF550033: k(4) = &HFF005500: k(5) = &HFF000044: k(6) = &HFFFF0000
Dim Shared xmax As Integer, ymax As Integer, Xarrd As Integer, Yarrd As Integer 'set all this in customField sub


'      note: To preserve symmetry when cells hit boundries with a symmetric seed started in middle:
'            y should be odd for 1 center row
'            x should be equal to or less than y
'            If int(x/2 + .5) is even then the right one of two center cells is marked else the one center cell is marked
'

Xarrd = 41 ' the top left cell has been hacked to duplicate the top right cell, to preserve symmetric seeds through a run

Yarrd = 41 'y should always be odd top preserve symmetry of center symmetric seed

xmax = (Xarrd + 2) * xSpacing: ymax = (Yarrd + 2) * ySpacing

Screen _NewImage(xmax, ymax, 32)
_ScreenMove (1280 - xmax) / 2 + 60, (760 - ymax) / 2
Randomize Timer
Dim Shared b(0 To Xarrd + 1, 0 To Yarrd + 1) As cell, ng(0 To Xarrd + 1, 0 To Yarrd + 1) As Integer 'oversize the board to make it easy to count

Dim x As Integer, y As Integer, xoffset, xStop As Integer, nc As Integer, c As Integer, r As Integer, mb As Integer, kh&, gen As Integer

Do
    _Title "Hexagon Life: Left Click to Toggle Cells On/Off, Right Click to Start Run, Escape to Quit"
    ' set x, y for cells and mark ceter cell(s)
    For y = 1 To Yarrd
        If y Mod 2 = 0 Then
            xoffset = .5 * xSpacing: xStop = Xarrd - 1
        Else
            xoffset = 0: xStop = Xarrd
        End If
        For x = 1 To xStop
            b(x, y).x = x * xSpacing + xoffset + .5 * xSpacing
            b(x, y).y = y * ySpacing + .5 * ySpacing
            If x = Int(Xarrd / 2 + .5) And y = Int(Yarrd / 2 + .5) Then b(x, y).L = 1 Else b(x, y).L = 0 'mark middle cell
            showCell x, y, 7
        Next
    Next
    _Display

    'setup seed by toggling cells on and off
    While mb <> 2
        kh& = _KeyHit
        If kh& = 27 Then Exit Do
        mb = 0: c = 0: r = 0
        getCell c, r, mb
        If mb = 1 Then
            b(c, r).L = 1 - b(c, r).L
            showCell c, r, 7
        End If
        _Display
        _Limit 60
    Wend
    mb = 0
    _Title "Hexagon Life: Spacebar to Restart/Reseed, Escape to Quit"
    While kh& <> 32 And kh& <> 27
        kh& = _KeyHit
        'count the neighbors
        For y = 1 To Yarrd
            If y Mod 2 = 0 Then
                xoffset = .5 * xSpacing: xStop = Xarrd - 1
            Else
                xoffset = 0: xStop = Xarrd
            End If
            For x = 1 To xStop
                '2 sets of neighbors depending if x offset or not
                If xoffset > .05 Then
                    nc = b(x, y - 1).L + b(x + 1, y - 1).L + b(x - 1, y).L
                    nc = nc + b(x + 1, y).L + b(x, y + 1).L + b(x + 1, y + 1).L
                Else
                    nc = b(x - 1, y - 1).L + b(x, y - 1).L + b(x - 1, y).L
                    nc = nc + b(x + 1, y).L + b(x - 1, y + 1).L + b(x, y + 1).L
                End If
                'originally tested and posted( 9/25/2019) here only 2 neighbors for birth in Classic Life it takes 3
                'IF (nc = 3 AND b(x, y).L = 1) OR nc = 2 THEN ng(x, y) = 1 ELSE ng(x, y) = 0

                'TempodiBasic suggested this survival if 1 survival or surviaval and birth for 2 neighbors
                If (nc = 1 And b(x, y).L = 1) Or nc = 2 Then ng(x, y) = 1 Else ng(x, y) = 0

                ' my first test for TempodiBasic, I mistakenly ran this which is good too!
                'IF (nc = 3 AND b(x, y).L = 1) OR nc = 1 THEN ng(x, y) = 1 ELSE ng(x, y) = 0

                showCell x, y, nc
                If x = Xarrd And y = 1 Then showCell 1, 1, nc
            Next
        Next

        'redraw all cells so no CLS
        For y = 1 To Yarrd 'transfer data from ng to b().l and show cell
            If y Mod 2 = 0 Then
                xStop = Xarrd - 1
            Else
                xStop = Xarrd
            End If
            For x = 1 To xStop
                b(x, y).L = ng(x, y)
                'showCell x, y
            Next
            'fix symmetry for top left corner, match x at other end for bi-lat symmetry
            b(1, 1).L = b(Xarrd, 1).L
            'showCell 1, 1
        Next
        gen = gen + 1
        Locate 1, 1: Print Space$(50)
        Locate 1, 1: Print "Generation:"; gen
        _Display
        _Limit 1
    Wend
    If kh& = 27 Then Exit Do
    kh& = 0
Loop

Sub showCell (c As Integer, r As Integer, kNum As Integer)
    Dim clr As _Unsigned Long
    If r Mod 2 = 0 Then
        If c < 1 Or c > Xarrd - 1 Then Exit Sub
    Else
        If c < 1 Or c > Xarrd Then Exit Sub
    End If
    If r < 1 Or r > Yarrd Then Exit Sub
    If kNum = 7 Then
        If b(c, r).L = 1 Then clr = &HFFFFFFFF Else clr = &HFF000000
    Else
        clr = k(kNum)
    End If
    If kNum < 7 Then
        fHexH b(c, r).x, b(c, r).y, cellR, clr
        hexH b(c, r).x, b(c, r).y, cellR, &HFF000000
    Else
        fHexH b(c, r).x, b(c, r).y, cellR, clr
        hexH b(c, r).x, b(c, r).y, cellR, &HFF440044
    End If
End Sub

Sub getCell (returnCol As Integer, returnRow As Integer, mbNum As Integer)
    Dim m, mx, my, mb1, mb2, r As Integer, c As Integer
    While _MouseInput: Wend
    mb1 = _MouseButton(1): mb2 = _MouseButton(2)
    If mb1 Then mbNum = 1
    If mb2 Then mbNum = 2
    If mb1 Or mb2 Then '                      get last place mouse button was down
        While mb1 Or mb2 '                    wait for mouse button release as a "click"
            m = _MouseInput: mb1 = _MouseButton(1): mb2 = _MouseButton(2)
            mx = _MouseX: my = _MouseY
            'LOCATE 1, 1: PRINT SPACE$(50)
            'LOCATE 1, 1: PRINT mx, my, .5 * xSpacing
            _Display
        Wend
        For r = 1 To Yarrd
            For c = 1 To Xarrd
                If ((mx - b(c, r).x) ^ 2 + (my - b(c, r).y) ^ 2) ^ .5 < .5 * xSpacing Then
                    'LOCATE 1, 1: PRINT SPACE$(50)
                    'LOCATE 1, 1: PRINT c, r
                    returnCol = c: returnRow = r: Exit Sub
                End If
            Next
        Next
        mbNum = 0 'still here then clicked wrong
    End If
End Sub

'draw Hexagon Outline that can be packed Horizontally, flat edge to flat edge
Sub hexH (xOrigin As Single, yOrigin As Single, radius As Single, c As _Unsigned Long)
    Dim polyAngle As Single, aOff As Single, x1 As Single, y1 As Single, i As Integer, x2 As Single, y2 As Single
    polyAngle = _Pi(2) / 6: aOff = _Pi / 2
    x1 = xOrigin + radius * Cos(polyAngle + aOff)
    y1 = yOrigin + radius * Sin(polyAngle + aOff)
    For i = 2 To 7
        x2 = xOrigin + radius * Cos(i * polyAngle + aOff)
        y2 = yOrigin + radius * Sin(i * polyAngle + aOff)
        Line (x1, y1)-(x2, y2), c
        x1 = x2: y1 = y2
    Next
End Sub

'draw filled Hexagon that can be packed Horizontally, flat edge to flat edge
'uses SUB fTri
Sub fHexH (xOrigin As Single, yOrigin As Single, radius As Single, c As _Unsigned Long)
    Dim polyAngle As Single, aOff As Single, x1 As Single, y1 As Single, i As Integer, x2 As Single, y2 As Single
    polyAngle = _Pi(2) / 6: aOff = _Pi / 2
    x1 = xOrigin + radius * Cos(polyAngle + aOff)
    y1 = yOrigin + radius * Sin(polyAngle + aOff)
    For i = 2 To 7
        x2 = xOrigin + radius * Cos(i * polyAngle + aOff)
        y2 = yOrigin + radius * Sin(i * polyAngle + aOff)
        fTri xOrigin, yOrigin, x1, y1, x2, y2, c
        x1 = x2: y1 = y2
    Next
End Sub

Sub fTri (x1 As Single, y1 As Single, x2 As Single, y2 As Single, x3 As Single, y3 As Single, K As _Unsigned Long)
    Dim a&
    a& = _NewImage(1, 1, 32)
    _Dest a&
    PSet (0, 0), K
    _Dest 0
    _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
    _FreeImage a& '<<< this is important!
End Sub

   
   

---

Here is an ascii life in an interesting life cycle!

Code: (Select All)

' Life from jb uses mod for border crossing and this example is best string seed
Screen _NewImage(240, 480, 32)
DefLng A-Z
Dim g(29, 29)

For y = 14 To 14 'seed g()
    For x = 10 To 19
        g(x, y) = 1
        Locate y, x: Print "*"
    Next
Next

restart:
ReDim ng(29, 29)
For y = 0 To 29
    For x = 0 To 29
nc = g(mod1(x-1, 30), mod1(y-1, 30)) + g(mod1(x, 30), mod1(y-1, 30)) + g(mod1(x+1, 30), mod1(y-1, 30)) +_
g(mod1(x-1, 30), mod1(y, 30)) + g(mod1(x+1, 30), mod1(y, 30)) +_
g(mod1(x-1, 30), mod1(y+1, 30)) + g(mod1(x, 30), mod1(y+1, 30))+ g(mod1(x+1, 30), mod1(y+1, 30))
        If g(x, y) Then
            Locate y + 1, x + 1: Print "*";
            If nc = 2 Or nc = 3 Then ng(x, y) = 1
        Else
            Locate y + 1, x + 1: Print " ";
            If nc = 3 Then ng(x, y) = 1
        End If
    Next
Next
For y = 0 To 29 'transfer ng to g and erase
    For x = 0 To 29
        g(x, y) = ng(x, y)
    Next
Next
ReDim ng(29, 29)
_Limit 2
GoTo restart

Function mod1 (a, md)
    If a < 0 Then mod1 = (a + md) Mod md Else mod1 = a Mod md
End Function