Screen Savers

[bplus]

Sierpinski in Space

Code: (Select All)

_Title "Sierpinski in Space" ' b+ trans 2022-05-19 from
'Sierpinski in Space.bas  SmallBASIC 0.12.6 [B+=MGA] 2016-05-28
'From  screen saver number 1.bas 2016-02-11 SmallBASIC 0.12.0 [B+=MGA]
'this version replaces solid triangle with Sierpinski line traingles.

Randomize Timer
Type triangle
    As Single x1, x2, x3, y1, y2, y3, dx1, dx2, dx3, dy1, dy2, dy3
    As _Unsigned Long c
End Type
xmax = _DesktopWidth: ymax = _DesktopHeight
xtop = xmax + 100: ytop = ymax + 100

Screen _NewImage(xmax, ymax, 32)
_FullScreen

restart:
If _KeyDown(27) Then System
ntri = rand(1, 5)
ReDim t(ntri) As triangle 'setup new set of triangles
For i = 1 To ntri
    t(i).x1 = rand(-100, xtop): t(i).x2 = rand(-100, xtop): t(i).x3 = rand(-100, xtop)
    t(i).y1 = rand(-100, ytop): t(i).y2 = rand(-100, ytop): t(i).y3 = rand(-100, ytop)
    t(i).dx1 = rand(0, 10) * rdir: t(i).dx2 = rand(0, 10) * rdir: t(i).dx2 = rand(0, 10) * rdir
    t(i).dy1 = rand(0, 10) * rdir: t(i).dy2 = rand(0, 10) * rdir: t(i).dy2 = rand(0, 10) * rdir
    t(i).c = _RGB32(rand(55, 255) * rand(0, 1), rand(55, 255) * rand(0, 1), rand(55, 255) * rand(0, 1))
    If t(i).c = 0 Then t(i).c = _RGB32(rand(60, 255), rand(60, 255), rand(60, 255))
Next

While _KeyDown(27) = 0
    If Len(InKey$) Then GoTo restart
    Cls
    For i = 1 To ntri
        Color t(i).c
        SierLineTri t(i).x1, t(i).y1, t(i).x2, t(i).y2, t(i).x3, t(i).y3, 0
        t(i).x1 = t(i).x1 + t(i).dx1
        If t(i).x1 < -100 Then t(i).dx1 = t(i).dx1 * -1
        If t(i).x1 > xtop Then t(i).dx1 = t(i).dx1 * -1
        t(i).x2 = t(i).x2 + t(i).dx2
        If t(i).x2 < -100 Then t(i).dx2 = t(i).dx2 * -1
        If t(i).x2 > xtop Then t(i).dx2 = t(i).dx2 * -1
        t(i).x3 = t(i).x3 + t(i).dx3
        If t(i).x3 < -100 Then t(i).dx3 = t(i).dx3 * -1
        If t(i).x3 > xtop Then t(i).dx3 = t(i).dx3 * -1
        t(i).y1 = t(i).y1 + t(i).dy1
        If t(i).y1 < -100 Then t(i).dy1 = t(i).dy1 * -1
        If t(i).y1 > ytop Then t(i).dy1 = t(i).dy1 * -1
        t(i).y2 = t(i).y2 + t(i).dy2
        If t(i).y2 < -100 Then t(i).dy2 = t(i).dy2 * -1
        If t(i).y2 > ytop Then t(i).dy2 = t(i).dy2 * -1
        t(i).y3 = t(i).y3 + t(i).dy3
        If t(i).y3 < -100 Then t(i).dy3 = t(i).dy3 * -1
        If t(i).y3 > ytop Then t(i).dy3 = t(i).dy3 * -1
    Next
    _Display
    _Limit 20
Wend
GoTo restart

'Given 3 points of a triangle draw the Sierpinsky traiangle
'within from the midpoints of each line forming the outer
'triangle. This is the basic Sierpinski Unit that is repeated
'at greater depths.
Sub SierLineTri (x1, y1, x2, y2, x3, y3, depth)
    'local mx1, mx2, mx3, my1, my2, my3

    If depth = 0 Then 'draw out triangle if level 0
        Line (x1, y1)-(x2, y2)
        Line (x2, y2)-(x3, y3)
        Line (x1, y1)-(x3, y3)
    End If

    'find midpoints
    If x2 < x1 Then mx1 = (x1 - x2) / 2 + x2 Else mx1 = (x2 - x1) / 2 + x1
    If y2 < y1 Then my1 = (y1 - y2) / 2 + y2 Else my1 = (y2 - y1) / 2 + y1
    If x3 < x2 Then mx2 = (x2 - x3) / 2 + x3 Else mx2 = (x3 - x2) / 2 + x2
    If y3 < y2 Then my2 = (y2 - y3) / 2 + y3 Else my2 = (y3 - y2) / 2 + y2
    If x3 < x1 Then mx3 = (x1 - x3) / 2 + x3 Else mx3 = (x3 - x1) / 2 + x1
    If y3 < y1 Then my3 = (y1 - y3) / 2 + y3 Else my3 = (y3 - y1) / 2 + y1

    Line (mx1, my1)-(mx2, my2) '  'draw all inner triangles
    Line (mx2, my2)-(mx3, my3)
    Line (mx1, my1)-(mx3, my3)

    If depth < 5 Then 'not done so call me again
        SierLineTri x1, y1, mx1, my1, mx3, my3, depth + 1
        SierLineTri x2, y2, mx1, my1, mx2, my2, depth + 1
        SierLineTri x3, y3, mx3, my3, mx2, my2, depth + 1
    End If
End Sub

Function rdir
    If Rnd < .5 Then rdir = -1 Else rdir = 1
End Function

Function rand (lo, hi)
    rand = (Rnd * (hi - lo + 1)) \ 1 + lo
End Function

   

[bplus]

Lava Flow

Code: (Select All)

_Title "Lava Flow" 'bplus 2019-12-12 based on Lava 3.bas SmallBASIC 2015-04-25

'================================================================================
'                  Press Spacebar for slightly differnt lava effect
'================================================================================

Const xmax = 1200, ymax = 720, n = 800, bg = &HFF000000 '<< try different colors
Dim Shared x(1 To n), y(1 To n), xr(1 To n), yr(1 To n), c(1 To n) As _Unsigned Long
Screen _NewImage(xmax, ymax, 32)
_FullScreen
Randomize Timer
For i = 1 To n: new i, -1: Next 'init lava
Line (0, 0)-(xmax, ymax), bg, BF 'black'n screen
Do
    If InKey$ = " " Then toggle = 1 - toggle
    For i = 1 To n
        If toggle Then Color c(i) Else Color lavaColor~&
        fEllipse x(i), y(i), xr(i), yr(i)
        x(i) = x(i) + xr(i)
        y(i) = y(i) + (Int(Rnd * 3) - 1) * yr(i) + .1
        If x(i) > xmax Then new i, 0
        If y(i) < -5 Or y(i) > ymax + 5 Then new i, 0
    Next
    xp = Int(Rnd * (xmax - 5)) + 1
    yp = Int(Rnd * (ymax - 5)) + 1
    Paint (xp, yp), fire~&, bg
    If xp Mod 100 = 50 Or xp Mod 100 = 55 Then Paint (xp, yp), bg, bg
    _Limit 30
Loop Until _KeyDown(27)
System

Sub fEllipse (CX As Long, CY As Long, xRadius As Long, yRadius As Long)
    Dim scale As Single, x As Long, y As Long
    scale = yRadius / xRadius
    Line (CX, CY - yRadius)-(CX, CY + yRadius), , BF
    For x = 1 To xRadius
        y = scale * Sqr(xRadius * xRadius - x * x)
        Line (CX + x, CY - y)-(CX + x, CY + y), , BF
        Line (CX - x, CY - y)-(CX - x, CY + y), , BF
    Next
End Sub

Sub new (i, rndxTF)
    If rndxTF Then x(i) = Int(Rnd * (xmax - 10)) + 5 Else x(i) = Rnd * 10
    y(i) = Int(Rnd * (ymax - 10)) + 5
    xr(i) = Int(Rnd * 4) + 3
    yr(i) = Rnd * xr(i) * .5
    c(i) = lavaColor~&
End Sub

Function fire~&
    If Rnd < .25 Then fire~& = &HFF000000 Else fire~& = _RGB32(255, Rnd * 128 + 127, 0)
End Function

Function lavaColor~&
    r = Int(Rnd * 31)
    If r Mod 4 = 0 Then lavaColor = bg Else lavaColor~& = _RGB32(r / 30 * 128 + 127, Rnd * r / 45 * 255, 0)
End Function

[Pete]

I lava good screen saver!

Pete

[bplus]

Lavish praise!

[Pete]

Erupts in laughter!

[bplus]

Arachnid Spirals 2 Screen

A prefect demo app for showing a running program from another program, eg Very Simple GUI - Get Filename and Run it or Kill it! see Code and Stuff > Works In Progress > Very Simple Gui https://qb64phoenix.com/forum/showthread...29#pid3329
Reply #30

This is a gag graphics that takes a screen shot of your desktop and draws a spider spinning a web over it!

Code: (Select All)

Option _Explicit
_Title "Draw Spinner and Web" 'B+ started 2019-06-15
' Draw Spinner and web mod 2019-09-17
Randomize Timer
Dim sc&, sx, sy, sh 'spider stuff
Dim a, tn, ta, tcx, tcy, tr, tx, ty, tdx, tdy, oldx, oldy 'web stuff

sc& = _ScreenImage
_Delay .1

Dim Shared xmax As Integer, ymax As Integer
xmax = _DesktopWidth
ymax = _DesktopHeight

Screen _NewImage(xmax, ymax, 32)

_FullScreen

_Dest sc&
tn = 13: ta = _Pi(2 / 13): tcx = .75 * xmax: tcy = .33 * ymax
For a = 1 To tn
    Line (tcx + xmax * Cos(a * ta), tcy + xmax * Sin(a * ta))-(tcx + xmax * Cos(a * ta + _Pi), tcy + xmax * Sin(a * ta + _Pi)), &H88000000
Next
_Dest 0

tx = tcx: ty = tcy: tdx = 5: tdy = 0
sx = tcx: sy = tcy
a = a + ta: tr = tr + ta
tx = tcx + tr * Cos(a): ty = tcy + tr * Sin(a)
sh = _Atan2(ty - sy, tx - sx)
tdx = 1 * Cos(sh): tdy = 1 * Sin(sh)
While InKey$ <> Chr$(27)
    'update web
    If ((sx - tx) ^ 2 + (sy - ty) ^ 2) ^ .5 < 5 Then 'setup next target x, y nad new spider heading
        oldx = sx: oldy = sy
        sx = tx: sy = ty
        _Dest sc&
        Line (oldx, oldy)-(sx, sy), &H66000000
        _Dest 0
        a = a + ta: tr = tr + 3 * ta
        tx = tcx + tr * Cos(a): ty = tcy + tr * Sin(a)
        sh = _Atan2(ty - sy, tx - sx)
        tdx = 1 * Cos(sh): tdy = 1 * Sin(sh)
    Else
        'save image wo spider
        oldx = sx: oldy = sy
        sx = sx + tdx: sy = sy + tdy
        _Dest sc&
        Line (oldx, oldy)-(sx, sy), &H66000000
        _Dest 0
    End If
    _PutImage , sc&
    '_PRINTSTRING (500, 200), STR$(tx) + STR$(ty) + STR$(tdx) + STR$(tdy) + STR$(sh)
    'place spider
    drawSpinner sx, sy, 1, sh, &H88221100
    _Display
    _Limit 30
Wend
System

Sub drawSpinner (x As Integer, y As Integer, scale As Single, heading As Single, c As _Unsigned Long)
    Dim x1, x2, x3, x4, y1, y2, y3, y4, r, a, a1, a2, lg, d, rd, red, blue, green
    Static switch As Integer
    switch = switch + 2
    switch = switch Mod 16 + 1
    red = _Red32(c): green = _Green32(c): blue = _Blue32(c)
    r = 10 * scale
    x1 = x + r * Cos(heading): y1 = y + r * Sin(heading)
    r = 2 * r 'lg lengths
    For lg = 1 To 8
        If lg < 5 Then
            a = heading + .9 * lg * _Pi(1 / 5) + (lg = switch) * _Pi(1 / 10)
        Else
            a = heading - .9 * (lg - 4) * _Pi(1 / 5) - (lg = switch) * _Pi(1 / 10)
        End If
        x2 = x1 + r * Cos(a): y2 = y1 + r * Sin(a)
        drawLink x1, y1, 3 * scale, x2, y2, 2 * scale, _RGB32(red + 20, green + 10, blue + 5)
        If lg = 1 Or lg = 2 Or lg = 7 Or lg = 8 Then d = -1 Else d = 1
        a1 = a + d * _Pi(1 / 12)
        x3 = x2 + r * 1.5 * Cos(a1): y3 = y2 + r * 1.5 * Sin(a1)
        drawLink x2, y2, 2 * scale, x3, y3, scale, _RGB32(red + 35, green + 17, blue + 8)
        rd = Int(Rnd * 8) + 1
        a2 = a1 + d * _Pi(1 / 8) * rd / 8
        x4 = x3 + r * 1.5 * Cos(a2): y4 = y3 + r * 1.5 * Sin(a2)
        drawLink x3, y3, scale, x4, y4, scale, _RGB32(red + 50, green + 25, blue + 12)
    Next
    r = r * .5
    fcirc x1, y1, r, _RGB32(red - 20, green - 10, blue - 5)
    x2 = x1 + (r + 1) * Cos(heading - _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading - _Pi(1 / 12))
    fcirc x2, y2, r * .2, &HFF000000
    x2 = x1 + (r + 1) * Cos(heading + _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading + _Pi(1 / 12))
    fcirc x2, y2, r * .2, &HFF000000
    r = r * 2
    x1 = x + r * .9 * Cos(heading + _Pi): y1 = y + r * .9 * Sin(heading + _Pi)
    TiltedEllipseFill 0, x1, y1, r, .7 * r, heading + _Pi, _RGB32(red, green, blue)
End Sub

Sub drawLink (x1, y1, r1, x2, y2, r2, c As _Unsigned Long)
    Dim a, a1, a2, x3, x4, x5, x6, y3, y4, y5, y6
    a = _Atan2(y2 - y1, x2 - x1)
    a1 = a + _Pi(1 / 2)
    a2 = a - _Pi(1 / 2)
    x3 = x1 + r1 * Cos(a1): y3 = y1 + r1 * Sin(a1)
    x4 = x1 + r1 * Cos(a2): y4 = y1 + r1 * Sin(a2)
    x5 = x2 + r2 * Cos(a1): y5 = y2 + r2 * Sin(a1)
    x6 = x2 + r2 * Cos(a2): y6 = y2 + r2 * Sin(a2)
    fquad x3, y3, x4, y4, x5, y5, x6, y6, c
    fcirc x1, y1, r1, c
    fcirc x2, y2, r2, c
End Sub

'need 4 non linear points (not all on 1 line) list them clockwise so x2, y2 is opposite of x4, y4
Sub fquad (x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, x3 As Integer, y3 As Integer, x4 As Integer, y4 As Integer, c As _Unsigned Long)
    ftri x1, y1, x2, y2, x4, y4, c
    ftri x3, y3, x4, y4, x1, y1, c
End Sub

Sub ftri (x1, y1, x2, y2, x3, y3, 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

Sub fcirc (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
    Dim Radius As Integer, RadiusError As Integer
    Dim X As Integer, Y As Integer
    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

Sub TiltedEllipseFill (destHandle&, x0, y0, a, b, ang, c As _Unsigned Long)
    Dim max As Integer, mx2 As Integer, i As Integer, j As Integer, k As Single, lasti As Single, lastj As Single
    Dim prc As _Unsigned Long, tef As Long
    prc = _RGB32(255, 255, 255, 255)
    If a > b Then max = a + 1 Else max = b + 1
    mx2 = max + max
    tef = _NewImage(mx2, mx2)
    _Dest tef
    _Source tef 'point wont read without this!
    For k = 0 To 6.2832 + .05 Step .1
        i = max + a * Cos(k) * Cos(ang) + b * Sin(k) * Sin(ang)
        j = max + a * Cos(k) * Sin(ang) - b * Sin(k) * Cos(ang)
        If k <> 0 Then
            Line (lasti, lastj)-(i, j), prc
        Else
            PSet (i, j), prc
        End If
        lasti = i: lastj = j
    Next
    Dim xleft(mx2) As Integer, xright(mx2) As Integer, x As Integer, y As Integer
    For y = 0 To mx2
        x = 0
        While Point(x, y) <> prc And x < mx2
            x = x + 1
        Wend
        xleft(y) = x
        While Point(x, y) = prc And x < mx2
            x = x + 1
        Wend
        While Point(x, y) <> prc And x < mx2
            x = x + 1
        Wend
        If x = mx2 Then xright(y) = xleft(y) Else xright(y) = x
    Next
    _Dest destHandle&
    For y = 0 To mx2
        If xleft(y) <> mx2 Then Line (xleft(y) + x0 - max, y + y0 - max)-(xright(y) + x0 - max, y + y0 - max), c, BF
    Next
    _FreeImage tef
End Sub

Here is a shot of running the program from QB64 IDE with Task Manager on Top of it (to show spider better):
   

This might not make a good screen saver as an arachnophobe is likely to take a fly swatter and smash the screen trying to be rid of the creepy crawling thing!

[johnno56]

I am curious, and please correct me if I am in error, but were not screen savers designed to help reduce the "burning" of the coating on the inside of a Cathode Ray Tubes? As most PC's (laptops, tablets etc) now use some form of "flat panel", would that then relegate screen savers useless except for the purpose of, what is the phrase?  ... eye candy?

My favourite was, "Mystify"

[bplus]

Screen Savers serve same purpose as hanging paintings on the wall, only they are much more dynamic, so maybe more like a window only not to outside but some other place.

[Kernelpanic]

I am curious, and please correct me if I am in error, but were not screen savers designed to help reduce the "burning" of the coating on the inside of a Cathode Ray Tubes? 

That's right! That used to be a problem. For private users from about 1984 until the end of the cathode tube. My first screensaver simply turned the screen black.

My favorite was and is always "Mystify" on Windows. In SuSE Linux there was also interesting screensavers.

[bplus]

My favourite was, "Mystify"

My favorite was and is always "Mystify" on Windows.

I agree! https://qb64phoenix.com/forum/showthread...898#pid898

Wow 3 Basic programmers with the same opinion on something!
And I think Pete and The Bob are here in same boat: https://qb64phoenix.com/forum/showthread...779#pid779

I found this, slightly better than my version that starts this thread: https://www.youtube.com/watch?v=yE3BTTtPKB4
It appears to be doing shapely curves. Can anyone, duplicate or even better that!?