Pixel life - Printable Version

'pixel_life ' an attmept to repilicate Conway's game of life without arrays by using 2 images 'not sure if I got it working right just yet 'feel free to fiddle with it, press <esc> to exit the program at any time 'there are multiple start states you can change by editing the comments Dim Shared xmax, ymax xmax = 400: ymax = 400 'change these as you wish , high numbers may be slow on older machines Dim Shared s0 As Long Dim Shared s1 As Long Dim Shared klr As _Unsigned Long s0 = _NewImage(xmax, ymax, 32) s1 = _NewImage(xmax, ymax, 32) Screen s0 _Title "Pixel Life <esc> to exit" '_FullScreen Randomize Timer klr = _RGB32(30, 200, 0) 'use comments to change starting population of dots 'rand_gen0 test_genA 'test_genB 'test_mousepop t = 0 rr = 0: gg = 80: bb = 0 Do _Limit 6 'I want to be able to see the changes as the generations go on gg = gg + 2 t = t + 1 _PutImage (0, 0), s1, s0 update_gen Loop Until InKey$ = Chr$(27) _Dest s0 Print t, " generations" End Sub test_genA _Dest s1 Cls , _RGB32(0, 0, 0) PSet (xmax \ 2, ymax \ 2 - 2), klr PSet (xmax \ 2, ymax \ 2 - 1), klr PSet (xmax \ 2, ymax \ 2), klr PSet (xmax \ 2, ymax \ 2 + 1), klr PSet (xmax \ 2, ymax \ 2 + 2), klr PSet (xmax \ 2 + 1, ymax \ 2), klr PSet (xmax \ 2 - 1, ymax \ 2), klr End Sub Sub test_genB _Dest s1 Cls , _RGB32(0, 0, 0) PSet (xmax \ 2, ymax \ 2), klr PSet (xmax \ 2 + 1, ymax \ 2), klr PSet (xmax \ 2 + 2, ymax \ 2 + 1), klr PSet (xmax \ 2, ymax \ 2 + 2), klr PSet (xmax \ 2 + 1, ymax \ 2 + 2), klr PSet (xmax \ 2 + 2, ymax \ 2 + 2), klr PSet (xmax \ 2 + 3, ymax \ 2 + 2), klr End Sub Sub test_mousepop _Dest s1 Screen s1 Cls , _RGB32(0, 0, 0) Do ' press space when done drawing Do While _MouseInput mx = _MouseX my = _MouseY If mx > 0 And mx < xmax And my > 0 And my < ymax Then If _MouseButton(2) Then PSet (mx, my), klr End If End If Loop Loop Until InKey$ = Chr$(32) Screen s0 _Dest s0 End Sub Sub rand_gen0 _Dest s1 Cls , _RGB32(0, 0, 0) For y = 0 To ymax - 1 For x = 0 To xmax - 1 If Rnd * 30 < 2 Then PSet (x, y), klr Next Next _Dest s0 End Sub Sub update_gen 'change each generation _Dest s1 Cls , _RGB32(0, 0, 0) _Dest s0 For y = 0 To ymax - 1 For x = 0 To xmax - 1 update_cell x, y Next Next End Sub Sub update_cell (sx, sy) 'check each cell for neighbors and update life _Source s0 _Dest s1 ds = -1 'set to -1 because we are going to count the cell itself and ignore it this way If sx > 1 Then x0 = sx - 1 Else x0 = 0 If sy > 1 Then y0 = sy - 1 Else y0 = 0 If sx < xmax - 1 Then x1 = sx + 1 Else x1 = xmax - 1 If sy < ymax - 1 Then y1 = sy + 1 Else y1 = ymax - 1 For y = y0 To y1 For x = x0 To x1 If Point(x, y) <> _RGB32(0, 0, 0) Then ds = ds + 1 Next Next Select Case ds Case 0, 1 PSet (sx, sy), _RGB32(0, 0, 0) Case 2,3 PSet (sx, sy), klr ' Case 3 'yeah this was strange... keeping it here as comments for reasons ' If Point(sx, sy) = _RGB32(0, 0, 0) Then PSet (sx, sy), klr Else PSet (sx, sy), klr Case Is > 3 PSet (sx, sy), _RGB32(0, 0, 0) End Select End Sub

Code: (Select All)

'pixel_life

' an attmept to repilicate Conway's game of life without arrays by using 2 images

'not sure if I got it working right just yet

'feel free to fiddle with it, press <esc> to exit the program at any time

'there are multiple start states you can change by editing the comments

Dim Shared xmax, ymax

xmax = 401: ymax = 401 'change these as you wish , high numbers may be slow on older machines

Dim Shared s0 As Long

Dim Shared s1 As Long

Dim Shared klr As _Unsigned Long

s0 = _NewImage(xmax, ymax, 32)

s1 = _NewImage(xmax, ymax, 32)

Screen s0

_Title "Pixel Life      <esc> to exit"

'_FullScreen

Randomize Timer

klr = _RGB32(30, 200, 0)

'use comments to change starting population of dots

'rand_gen0

test_genA

'test_genB

'test_mousepop

t = 0

rr = 0: gg = 80: bb = 0

Do

    _Limit 2 'I want to be able to see the changes as the generations go on

    gg = gg + 2

    t = t + 1

    _PutImage (0, 0), s1, s0

    update_gen

Loop Until InKey$ = Chr$(27)

_Dest s0

Print t, " generations"

End



Sub test_genA

    _Dest s1

    Cls , _RGB32(0, 0, 0)

    PSet (xmax \ 2, ymax \ 2 - 2), klr

    PSet (xmax \ 2, ymax \ 2 - 1), klr

    PSet (xmax \ 2, ymax \ 2), klr

    PSet (xmax \ 2, ymax \ 2 + 1), klr

    PSet (xmax \ 2, ymax \ 2 + 2), klr

    PSet (xmax \ 2 + 1, ymax \ 2), klr

    PSet (xmax \ 2 - 1, ymax \ 2), klr

End Sub

Sub test_genB

    _Dest s1

    Cls , _RGB32(0, 0, 0)

    PSet (xmax \ 2, ymax \ 2), klr

    PSet (xmax \ 2 + 1, ymax \ 2), klr

    PSet (xmax \ 2 + 2, ymax \ 2 + 1), klr

    PSet (xmax \ 2, ymax \ 2 + 2), klr

    PSet (xmax \ 2 + 1, ymax \ 2 + 2), klr

    PSet (xmax \ 2 + 2, ymax \ 2 + 2), klr

    PSet (xmax \ 2 + 3, ymax \ 2 + 2), klr

End Sub

Sub test_mousepop

    _Dest s1

    Screen s1

    Cls , _RGB32(0, 0, 0)

    Do

        ' press space when done drawing

        Do While _MouseInput

            mx = _MouseX

            my = _MouseY

            If mx > 0 And mx < xmax And my > 0 And my < ymax Then

                If _MouseButton(2) Then

                    PSet (mx, my), klr

                End If

            End If

        Loop

    Loop Until InKey$ = Chr$(32)

    Screen s0

    _Dest s0

End Sub

Sub rand_gen0

    _Dest s1

    Cls , _RGB32(0, 0, 0)

    For y = 0 To ymax - 1

        For x = 0 To xmax - 1

            If Rnd * 30 < 2 Then PSet (x, y), klr

        Next

    Next

    _Dest s0

End Sub

Sub update_gen

    'change each generation

    _Dest s1

    Cls , _RGB32(0, 0, 0)

    _Dest s0

    For y = 0 To ymax - 1

        For x = 0 To xmax - 1

            update_cell x, y

        Next

    Next

End Sub

Sub update_cell (sx, sy)

    'check each cell for neighbors and update life

    _Source s0

    _Dest s1

    ds = -1 'set to -1 because we are going to count the cell itself and ignore it this way

    If sx > 1 Then x0 = sx - 1 Else x0 = 0

    If sy > 1 Then y0 = sy - 1 Else y0 = 0

    If sx < xmax - 1 Then x1 = sx + 1 Else x1 = xmax - 1

    If sy < ymax - 1 Then y1 = sy + 1 Else y1 = ymax - 1

    For y = y0 To y1

        For x = x0 To x1

            If Point(x, y) <> _RGB32(0, 0, 0) Then ds = ds + 1

        Next

    Next

    Select Case ds

        Case 0, 1

            PSet (sx, sy), _RGB32(0, 0, 0)

        Case 2, 3

            PSet (sx, sy), klr

            ' Case 3     'yeah this was strange... keeping it here as comments for reasons

            '    If Point(sx, sy) = _RGB32(0, 0, 0) Then PSet (sx, sy), klr Else PSet (sx, sy), klr

        Case Is > 3

            PSet (sx, sy), _RGB32(0, 0, 0)

    End Select

End Sub

mutation = Int(Rnd * 100) Select Case mutation Case Is < 10 PSet (xmax \ 2, ymax \ 2), klr Case 10, 11 Circle (xmax \ 2, ymax \ 2), Int(2 + Rnd * 10), klr Case 12 dx = (1 + Rnd * 12) Line (xmax \ 2 - dx, ymax \ 2 - dx)-(xmax \ 2 + dx, ymax \ 2 + dx), klr, B End Select

Code: (Select All)

Option _Explicit

_Title "pixel Life 2" ' b+ 2023-10-15

' inspired by James Jarvis Pixel Life



Dim As Long XPixels, YPixels

XPixels = 401 ' so we can do perfect symmetry

YPixels = 401 ' ditto



Screen _NewImage(XPixels, YPixels, 12) ' the 12 only allows 16 colors

_ScreenMove 400, 150



Dim As Long s2, x, y, xx, yy, nc, gen

s2 = _NewImage(XPixels, YPixels, 12)



Do

    _Dest 0

    _PutImage , s2, 0

    _Display



    ' update s2

    _Source 0

    _Dest s2

    Line (0, 0)-(XPixels - 1, YPixels - 1), 9, B ' draw eternal white border seed and sun!

    Line (1, 1)-(XPixels - 2, YPixels - 2), 0, BF ' clear inside

    For y = 1 To YPixels - 2

        For x = 1 To XPixels - 2

            nc = 0

            For yy = -1 To 1

                For xx = -1 To 1

                    If Point(x + xx, y + yy) Then nc = nc + 1

                Next

            Next

            If Point(x, y) Then nc = nc - 1

            If nc = 2 Then

                PSet (x, y), 9

            ElseIf nc = 3 Then

                PSet (x, y), 10

            End If

        Next

    Next

    gen = gen + 1

    _Title "Gen:" + Str$(gen)

    If gen < 300 Then _Limit 100 Else _Limit 1

Loop Until _KeyDown(27)