Proggies

[bplus]

Mandala Life Eternal Border

Code: (Select All)

Option _Explicit
_Title "Mandala Life trans from sb" 'b+ 2023-01-15
'Mandala life.bas SmallBASIC (not MS) B+ for Bpf 2015-03-25
Screen _NewImage(600, 600, 12)
Dim As Long an, s, bigblock, g, x, y, pc, lc, cl
an = 60: s = 10: bigblock = 600: g = 0
Dim As Long a(1 To an, 1 To an), ng(1 To an, 1 To an), ls(1 To an, 1 To an)
Dim r$

While _KeyDown(27) = 0
    'If g Mod 2 = 0 Then ' keep a pulsing border
    For x = 1 To an
        a(x, 1) = 1: a(x, an) = 1: a(1, x) = 1: a(an, x) = 1
    Next
    'End If
    For x = 2 To an - 1
        For y = 2 To an - 1
            pc = 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)
            ls(x, y) = pc: r$ = _Trim$(Str$(pc))
            If a(x, y) Then
                If InStr("2346", r$) Then ng(x, y) = 1 Else ng(x, y) = 0
            Else 'birth?
                If InStr("34", r$) Then ng(x, y) = 1 Else ng(x, y) = 0
            End If
        Next
    Next
    Line (1, 1)-(bigblock, bigblock), 15, BF
    For y = 1 To an
        For x = 1 To an
            If a(x, y) Then
                Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s, s), 0, BF
            Else
                lc = ls(x, y)
                Select Case lc
                    Case 0: cl = 15 'br white
                    Case 1: cl = 11 'cyan
                    Case 2: cl = 7 'low white, br gray
                    Case 3: cl = 10 'light green
                    Case 4: cl = 9 'blue
                    Case 5: cl = 13 'violet
                    Case 6: cl = 12 'br red
                    Case 7: cl = 4 'dark red
                    Case 8: cl = 1 'indigo
                End Select
                Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s, s), cl, BF
            End If
        Next
    Next
    For y = 1 To an
        For x = 1 To an
            a(x, y) = ng(x, y)
        Next
    Next
    g = g + 1
    If g > 60 Then _Delay .25

Wend

   

[bplus]

Quick Life

Code: (Select All)

_Title "Quick Conway Life" ' b+ 2023-1-15
Screen _NewImage(710, 710, 32)
Randomize Timer

DefLng A-Z
Dim g(69, 69)

For y = 1 To 68 'seed g()
    For x = 1 To 68
        If Rnd < .33 Then g(x, y) = 1
    Next
Next

While _KeyDown(27) = 0
    ReDim ng(69, 69)
    Cls
    gen = gen + 1
    Print "Gen"; gen
    For y = 1 To 68
        For x = 1 To 68
            nc = g(x - 1, y - 1) + g(x, y - 1) + g(x + 1, y - 1) + g(x - 1, y) + g(x + 1, y) + g(x - 1, y + 1) + g(x, y + 1) + g(x + 1, y + 1)
            If g(x, y) Then
                Line (x * 10, y * 10)-Step(10, 10), &HFFFFFFFF, BF
                Line (x * 10, y * 10)-Step(10, 10), &HFF000000, B
                If nc = 2 Or nc = 3 Then ng(x, y) = 1
            Else
                If nc = 3 Then ng(x, y) = 1
            End If
        Next
    Next
    For y = 1 To 68 'transfer ng to g and erase
        For x = 1 To 68
            g(x, y) = ng(x, y)
        Next
    Next
    ReDim ng(69, 69)
    _Limit 10
Wend

   

[bplus]

Recurring Squares

Code: (Select All)

_Title "recurring squares 2017-10-26 by bplus"
' Now with Alpha coloring!
'reoccuring squares SmallBASIC translation from
Rem reoccuring squares NaaLaa started 2015-05-14 MGA/B+

Const xmax = 700
Const ymax = 700

Screen _NewImage(xmax, ymax, 32)
_ScreenMove 360, 30 'adjust as needed _MIDDLE needs a delay .5 or more for me
Common Shared dimmer
sq = 700: dir = 1
While 1
    Cls
    white& = _RGB32(255, 255, 255)
    fRecStep 0, 0, sq, sq, white&
    sqPlus sq / 2, sq / 2, sq / 2
    _Display
    _Limit 30
    dimmer = dimmer + dir
    If dimmer > 255 Then dimmer = 255: dir = dir * -1: _Delay .5
    If dimmer < 0 Then dimmer = 0: dir = dir * -1: _Delay .5
Wend

Sub fRecStep (x1, y1, x2, y2, c&)
    Line (x1, y1)-Step(x2, y2), c&, BF
End Sub

Sub sqPlus (x, y, side)
    cx = x - side / 2: cy = y - side / 2
    fRecStep cx, cy, side, side, _RGBA32(0, 0, 0, dimmer)
    If side < 10 Then Exit Sub
    ns = side / 2: nc = colorNumber - 35
    sqPlus cx, cy, ns
    sqPlus cx + side, cy, ns
    sqPlus cx, cy + side, ns
    sqPlus cx + side, cy + side, ns
End Sub

   

[bplus]

Mandala Life Perpetual Random Border

This is better version with a border that can be reseeded randomly with a Spacebar key press:

Code: (Select All)

Option _Explicit
_Title "Mandala Life Perpetual Random Border" 'b+ 2023-01-17 from no pulse
Randomize Timer
Dim Shared As Long CellsPerSide, pixPerSide, Block
CellsPerSide = 60: pixPerSide = 10: Block = 600
Dim Shared Seed(1 To CellsPerSide)
Dim As Long a(1 To CellsPerSide, 1 To CellsPerSide), ng(1 To CellsPerSide, 1 To CellsPerSide), ls(1 To CellsPerSide, 1 To CellsPerSide)
Dim r$
Dim As Long g, x, y, pc, lc, cl
Screen _NewImage(Block, Block, 12)
_Title "Press Spacebar to Reseed Perpetual Border..."
makeSeed
While _KeyDown(27) = 0
    If _KeyHit = 32 Then makeSeed
    For x = 1 To CellsPerSide 'redraw random seed around border
        a(x, 1) = Seed(x)
        a(x, CellsPerSide) = Seed(x)
        a(1, x) = Seed(x)
        a(CellsPerSide, x) = Seed(x)
    Next
    For x = 2 To CellsPerSide - 1
        For y = 2 To CellsPerSide - 1
            pc = 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)
            ls(x, y) = pc: r$ = _Trim$(Str$(pc))
            If a(x, y) Then
                If InStr("2346", r$) Then ng(x, y) = 1 Else ng(x, y) = 0
            Else 'birth?
                If InStr("34", r$) Then ng(x, y) = 1 Else ng(x, y) = 0
            End If
        Next
    Next
    Line (1, 1)-(Block, Block), 15, BF
    For y = 1 To CellsPerSide
        For x = 1 To CellsPerSide
            If a(x, y) Then
                Line ((x - 1) * pixPerSide + 1, (y - 1) * pixPerSide + 1)-Step(pixPerSide, pixPerSide), 0, BF
            Else
                lc = ls(x, y)
                Select Case lc
                    Case 0: cl = 15 'br white
                    Case 1: cl = 11 'cyan
                    Case 2: cl = 7 'low white, br gray
                    Case 3: cl = 10 'light green
                    Case 4: cl = 9 'blue
                    Case 5: cl = 13 'violet
                    Case 6: cl = 12 'br red
                    Case 7: cl = 4 'dark red
                    Case 8: cl = 1 'indigo
                End Select
                Line ((x - 1) * pixPerSide + 1, (y - 1) * pixPerSide + 1)-Step(pixPerSide, pixPerSide), cl, BF
            End If
        Next
    Next
    _Display
    _Limit 2
    For y = 1 To CellsPerSide
        For x = 1 To CellsPerSide
            a(x, y) = ng(x, y)
        Next
    Next
Wend
Sub makeSeed
    Dim As Long i, r
    Dim d
    d = Rnd
    For i = 1 To Int(CellsPerSide / 2 + .5)
        If Rnd < d Then r = 1 Else r = 0
        Seed(i) = r: Seed(CellsPerSide - i + 1) = r
    Next
End Sub

See it in action, thanks dbox!
https://qbjs.org/index.html?code=J09wdGl...QDP5QIBdWI=

[dbox]

Update: This runs in QBJS but it is slow compared to QB64pe straight up, also modified to work in QBJS

With as often as I see this filled circle routine used, perhaps I should just add a native, optimized filled circle method to QBJS.

[bplus]

Maybe Charlie saw this somewhere?

Code: (Select All)

_Title "Cardioid and Beyond" 'B+ 2019-02-17
Const xmax = 700
Const ymax = 700
Const npoints = 200
Screen _NewImage(xmax, ymax, 32)
Dim Shared pR, pG, pB, cN
CX = xmax / 2
CY = ymax / 2
DA = _Pi(2 / npoints)
R = CX - 10

For Mult = 0 To 100 Step .01
    Cls
    Color &HFFFFFFFF
    Print "Multiple: ";
    Print Using "###.##"; Mult
    If Mult = Int(Mult) Then resetPlasma
    Circle (CX, CY), R, _RGB32(0, 128, 0)
    For i = 1 To 200
        x1 = CX + R * Cos(i * DA)
        y1 = CY + R * Sin(i * DA)
        x2 = CX + R * Cos(Mult * i * DA)
        y2 = CY + R * Sin(Mult * i * DA)
        changePlasma
        Line (x1, y1)-(x2, y2)
    Next
    _Display
    _Limit 30
Next

Sub changePlasma ()
    cN = cN + 1
    Color _RGB(127 + 127 * Sin(pR * cN), 127 + 127 * Sin(pG * cN), 127 + 127 * Sin(pB * cN))
End Sub

Sub resetPlasma ()
    pR = Rnd ^ 2: pG = Rnd ^ 2: pB = Rnd ^ 2
End Sub

   

[bplus]

Plasma Digital Clock

Code: (Select All)

_Title "Digital Plasmatic Clock   press spacebar for new coloring set" ' b+ 2020-01-20 translated and modified from SmallBASIC
'Plasma Magnifico - updated 2015-11-26 for Android
'This program creates a plasma surface, which looks oily or silky.

Const xmax = 850, ymax = 200, sq = 25
Const dat = "1110111000001101111100011111100101110111011101101001001111111111011011"

Type xy
    x As Single
    y As Single
    dx As Single
    dy As Single
End Type
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 300, 40

Dim c(360) As _Unsigned Long, p(6) As xy, f(6)
restart:
r = Rnd: g = Rnd: b = Rnd: i = 0
For n = 1 To 5
    r1 = r: g1 = g: b1 = b
    Do: r = Rnd: Loop Until Abs(r - r1) > .2
    Do: g = Rnd: Loop Until Abs(g - g1) > .2
    Do: b = Rnd: Loop Until Abs(g - g1) > .2
    For m = 0 To 17: m1 = 17 - m
        f1 = (m * r) / 18: f2 = (m * g) / 18: f3 = (m * b) / 18: c(i) = rgbf(f1, f2, f3): i = i + 1
    Next
    For m = 0 To 17: m1 = 17 - m
        f1 = (m + m1 * r) / 18: f2 = (m + m1 * g) / 18: f3 = (m + m1 * b) / 18: c(i) = rgbf(f1, f2, f3): i = i + 1
    Next
    For m = 0 To 17: m1 = 17 - m
        f1 = (m1 + m * r) / 18: f2 = (m1 + m * g) / 18: f3 = (m1 + m * b) / 18: c(i) = rgbf(f1, f2, f3): i = i + 1
    Next
    For m = 0 To 17: m1 = 17 - m
        f1 = (m1 * r) / 18: f2 = (m1 * g) / 18: f3 = (m1 * b) / 18: c(i) = rgbf(f1, f2, f3): i = i + 1
    Next
Next

For n = 0 To 5
    p(n).x = Rnd * xmax: p(n).y = Rnd * ymax: p(n).dx = Rnd * 2 - 1: p(n).dy = Rnd * 2 - 1
    f(n) = Rnd * .1
Next

While _KeyDown(27) = 0
    If InKey$ = " " Then GoTo restart
    For i = 0 To 5
        p(i).x = p(i).x + p(i).dx
        If p(i).x > xmax Or p(i).x < 0 Then p(i).dx = -p(i).dx
        p(i).y = p(i).y + p(i).dy
        If p(i).y > ymax Or p(i).y < 0 Then p(i).dy = -p(i).dy
    Next
    For y = 0 To ymax - 1 Step 2
        For x = 0 To xmax - 1 Step 2
            d = 0
            For n = 0 To 5
                dx = x - p(n).x: dy = y - p(n).y
                k = Sqr(dx * dx + dy * dy)
                d = d + (Sin(k * f(n)) + 1) / 2
            Next n: d = d * 60
            Line (x, y)-Step(2, 2), c(d), BF
        Next
    Next
    For j = 1 To 3
        If j = 1 Then
            c~& = &HFFFFFFFF: offset = -2
        ElseIf j = 2 Then
            c~& = &HFF555555: offset = 2
        Else
            c~& = &HFFAAAAAA: offset = 0
        End If
        For n = 1 To 8 'clock digits over background
            If Mid$(Time$, n, 1) = ":" Then
                Line ((n - 1) * 4 * sq + 2 * sq + offset, sq + sq + offset)-Step(sq, sq), c~&, BF
                Line ((n - 1) * 4 * sq + 2 * sq + offset, sq + 4 * sq + offset)-Step(sq, sq), c~&, BF
            Else
                drawC (n - 1) * 4 * sq + sq + offset, sq + offset, Mid$(dat$, Val(Mid$(Time$, n, 1)) * 7 + 1, 7), c~&
            End If
        Next
    Next
    _Display
Wend

Function rgbf~& (n1, n2, n3)
    rgbf~& = _RGB32(n1 * 255, n2 * 255, n3 * 255)
End Function

Sub drawC (x, y, c$, c As _Unsigned Long)
    For m = 1 To 7
        If Val(Mid$(c$, m, 1)) Then
            Select Case m
                Case 1: Line (x, y)-Step(sq, 3 * sq), c, BF
                Case 2: Line (x, y + 2 * sq)-Step(sq, 4 * sq), c, BF
                Case 3: Line (x, y)-Step(3 * sq, sq), c, BF
                Case 4: Line (x, y + 2 * sq)-Step(3 * sq, sq), c, BF
                Case 5: Line (x, y + 5 * sq)-Step(3 * sq, sq), c, BF
                Case 6: Line (x + 2 * sq, y)-Step(sq, 3 * sq), c, BF
                Case 7: Line (x + 2 * sq, y + 2 * sq)-Step(sq, 4 * sq), c, BF
            End Select
        End If
    Next
End Sub

   

[vince]

wow that's a serious mod, bplus

[bplus]

I think it was Richard Frost who showed me digit making code and I added Plasma way back at Org or maybe even Net!

Someone was asking about digit making code and I was reminded of this and hoping Charlie will see and pass on to that someone.

That's Basic sharing!

[mnrvovrfc]

Cannot look at that "plasma", still not recovered from the effects from that big impressive program part of the QB64 samples, which was able to run on QuickBASIC with a particular CPU "cheat" from the late 1990's. Which "concluded" with the impressive three-dimensional room simulation. It also had the three-dimensional cow "plotter", rotated it ridiculously to show off... I think the programmer was Greek but don't remember the name of it. The name of the program had "saks" in it or something. (scratch head)