Proggies - Printable Version

This is something to behold while running! less than 100 LOC

Code: (Select All)
_Title "Alien Trees Reflection - Plasma Mod 2, spacebar for new set" 'b+ 2022-05-07

Randomize Timer

Const xmax = 1024, ymax = 600

Screen _NewImage(xmax, ymax, 32)

_ScreenMove 200, 80 ' clear sides

Dim Shared As _Unsigned Long star: star = _RGB32(0, 255, 255)

Dim Shared As Long seed(1 To 3), start, cN

Dim Shared As Single rd(1 To 3), gn(1 To 3), bl(1 To 3)

ref& = _NewImage(xmax, ymax * .2, 32)

bk& = _NewImage(xmax, ymax, 32)

restart:

Randomize Timer

seed(1) = Rnd * 1000

seed(2) = Rnd * 1000

seed(3) = Rnd * 1000

For i = 1 To 3

    rd(i) = Rnd * Rnd

    gn(i) = Rnd * Rnd

    bl(i) = Rnd * Rnd

Next

For i = 0 To ymax

    Line (0, i)-(xmax, i), _RGB32(70, 60, i / ymax * 160)

Next

stars = xmax * ymax * 10 ^ -4

horizon = .67 * ymax

For i = 1 To stars 'stars in sky

    PSet (Rnd * xmax, Rnd * horizon), star

Next

stars = stars / 2

For i = 1 To stars

    fcirc Rnd * xmax, Rnd * horizon, 1, star

Next

stars = stars / 2

For i = 1 To stars

    fcirc Rnd * xmax, Rnd * horizon, 2, star

Next

For i = .67 * ymax To .8 * ymax

    gc = 100 - (i - .67 * ymax) * .5

    Line (0, i)-(xmax, i), _RGB32(gc, gc, gc)

Next

Do

    start = start + 1

    cN = start

    Randomize Using seed(1)

    branch xmax * .6 + Rnd * .3 * xmax, ymax * .75 - .07 * ymax, 6, 90, xmax / 20, 0, 1

    cN = start

    Randomize Using seed(2)

    branch Rnd * .3 * xmax, ymax * .75 - .05 * ymax, 7, 90, xmax / 18, 0, 2

    cN = start

    Randomize Using seed(3)

    branch xmax / 2, ymax * .77, 8, 90, xmax / 16, 0, 3

    If _KeyDown(32) Then GoTo restart

    _PutImage , 0, ref&, (0, 0)-(xmax, .8 * ymax)

    _PutImage (0, .8 * ymax)-(xmax, ymax), ref&, 0, (0, _Height(ref&))-(xmax, 0)

    _Display

    _Limit 30

Loop Until _KeyDown(27)

Sub branch (x, y, startr, angD, lngth, lev, tree)

    x2 = x + Cos(_D2R(angD)) * lngth

    y2 = y - Sin(_D2R(angD)) * lngth

    dx = (x2 - x) / lngth

    dy = (y2 - y) / lngth

    For i = 0 To lngth

        fcirc x + dx * i, y + dy * i, startr, changePlasma~&(tree)

    Next

    If startr - 1 < 0 Or lev > 11 Or lngth < 5 Then Exit Sub

    lev2 = lev + 1

    branch x2, y2, startr - 1, angD + 10 + 30 * Rnd, .8 * lngth + .2 * Rnd * lngth, lev2, tree

    branch x2, y2, startr - 1, angD - 10 - 30 * Rnd, .8 * lngth + .2 * Rnd * lngth, lev2, tree

End Sub

Sub fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)

    Dim Radius As Long, RadiusError As Long

    Dim X As Long, Y As Long

    Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0

    If Radius = 0 Then PSet (CX, CY), C: Exit Sub

    Line (CX - X, CY)-(CX + X, CY), C, BF

    While X > Y

        RadiusError = RadiusError + Y * 2 + 1

        If RadiusError >= 0 Then

            If X <> Y + 1 Then

                Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF

                Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF

            End If

            X = X - 1

            RadiusError = RadiusError - X * 2

        End If

        Y = Y + 1

        Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF

        Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF

    Wend

End Sub

Function changePlasma~& (n)

    cN = cN - 1 'dim shared cN as _Integer64, pR as long, pG as long, pB as long

    changePlasma~& = _RGB32(127 + 127 * Sin(rd(n) * cN), 127 + 127 * Sin(gn(n) * cN), 127 + 127 * Sin(bl(n) * cN))

End Function

Code: (Select All)

_Title "Test Rainbow" ' b+ 2022-05-15

Const w = 1024, h = 600, wd2 = 512, hd2 = 300

Screen _NewImage(w, h, 32)

_ScreenMove 180, 60

Do

    Cls

    dt = 100

    While dt > .002 Or dt < .00095

        dt = Rnd * .0015

    Wend

    rpick = Int(Rnd * 6) + 1

    For x = 0 To w

        For y = 0 To h

            r = Sin(1.1 * t) * hd2 - y + hd2

            Select Case rpick

                Case 1: Line (x, y)-Step(1, 1), _RGB(r, r - y, -r), BF ' yellow top,  red middle, blue bottom

                Case 2: Line (x, y)-Step(1, 1), _RGB(r, -r, r - y), BF ' purple , red , green

                Case 3: Line (x, y)-Step(1, 1), _RGB(-r, r, r - y), BF ' cyan , yellow green, red

                Case 4: Line (x, y)-Step(1, 1), _RGB(-r, r - y, r), BF ' white , blue,  red

                Case 5: Line (x, y)-Step(1, 1), _RGB(r - y, -r, r), BF ' purple, blue ,green

                Case 6: Line (x, y)-Step(1, 1), _RGB(r - y, r, -r), BF ' yellow green blue

            End Select

        Next

        t = t + dt ' <<<<<<<<<<<< put this back in so the background is shaped

    Next

    Print dt

    Sleep

Loop

Code: (Select All)

_Title "Test Rainbow 2 add image" ' b+ 2022-05-15

w = _DesktopWidth: h = _DesktopHeight: hd2 = h / 2

Screen _NewImage(w, h, 32)

_FullScreen

img& = _LoadImage("Phoenix A.png")

_ClearColor &HFFFFFFFF, img&

Do

    Cls

    dt = 100

    While dt > .002 Or dt < .00095

        dt = Rnd * .0015

    Wend

    rpick = Int(Rnd * 6) + 1

    For x = 0 To w

        For y = 0 To h

            r = Sin(1.1 * t) * hd2 - y + hd2

            Select Case rpick

                Case 1: Line (x, y)-Step(1, 1), _RGB(r, r - y, -r), BF ' yellow top,  red middle, blue bottom

                Case 2: Line (x, y)-Step(1, 1), _RGB(r, -r, r - y), BF ' purple , red , green

                Case 3: Line (x, y)-Step(1, 1), _RGB(-r, r, r - y), BF ' cyan , yellow green, red

                Case 4: Line (x, y)-Step(1, 1), _RGB(-r, r - y, r), BF ' white , blue,  red

                Case 5: Line (x, y)-Step(1, 1), _RGB(r - y, -r, r), BF ' purple, blue ,green

                Case 6: Line (x, y)-Step(1, 1), _RGB(r - y, r, -r), BF ' yellow green blue

            End Select

        Next

        t = t + dt ' <<<<<<<<<<<< put this back in so the background is shaped

    Next

    _PutImage ((_Width - _Width(img&)) / 2, (_Height - _Height(img&)))-Step(_Width(img&), _Height(img&)), img&, 0

    Sleep

Loop Until _KeyDown(27)