+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://qb64phoenix.com/forum/forumdisplay.php?fid=26)
+---- Forum: bplus (https://qb64phoenix.com/forum/forumdisplay.php?fid=36)
+---- Thread: Screen Savers (/showthread.php?tid=219)
RE: Screen Savers - bplus - 05-19-2022
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 FunctionRE: Screen Savers - bplus - 05-21-2022
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 FunctionRE: Screen Savers - Pete - 05-21-2022
I lava good screen saver!
Pete
RE: Screen Savers - bplus - 05-21-2022
Lavish praise!
RE: Screen Savers - Pete - 05-22-2022
Erupts in laughter!
RE: Screen Savers - bplus - 06-17-2022
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.php?tid=552&pid=3329#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!
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 SubHere 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!
RE: Screen Savers - johnno56 - 06-18-2022
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"
RE: Screen Savers - bplus - 06-18-2022
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.
RE: Screen Savers - Kernelpanic - 06-18-2022
(06-18-2022, 12:23 AM)johnno56 Wrote: 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.
RE: Screen Savers - bplus - 06-18-2022
Quote: My favourite was, "Mystify"
Quote: My favorite was and is always "Mystify" on Windows.I agree! https://qb64phoenix.com/forum/showthread.php?tid=219&pid=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.php?tid=197&pid=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!?