+- 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 - 07-19-2022
Another Golden Oldie from bplus collection:
Morph Curve
Code: (Select All)
_Title "Morph Curve" 'b+ 2022-07-19 trans from
' Morph Curve on Plasma.bas SmallBASIC 0.12.8 [B+=MGA] 2017-04-11
'from SpecBAS version Paul Dunn Dec 2, 2015
'https://www.youtube.com/watch?v=j2rmBRLEVms
' mods draw lines segments with drawpoly, add plasma, play with numbers
Option _Explicit
Const xmax = 1200, ymax = 700, pts = 500, interps = 30, pi = _Pi
Dim Shared plasmaR, plasmaG, plasmaB, plasmaN
Randomize Timer
Screen _NewImage(xmax, ymax, 32)
_FullScreen
Dim p(pts + 1, 1), q(pts + 1, 1), s(pts + 1, 1), i(interps)
Dim As Long L, c, j
Dim As Single cx, cy, sc, st, n, m, t, lastx, lasty
L = 0: cx = xmax / 2: cy = ymax / 2: sc = cy * .5: st = 2 * pi / pts
For n = 1 To interps
i(n) = Sin(n / interps * (pi / 2))
Next
While _KeyDown(27) = 0
resetPlasma
n = Int(Rnd * 75) + 2: m = Int(Rnd * 500) - 250: c = 0
For t = 0 To 2 * pi Step st
If _KeyDown(27) Then System
q(c, 0) = cx + sc * (Cos(t) + Cos(n * t) / 2 + Sin(m * t) / 3)
q(c, 1) = cy + sc * (Sin(t) + Sin(n * t) / 2 + Cos(m * t) / 3)
setPlasma
If t > 0 Then pline lastx, lasty, q(c, 0), q(c, 1), 10
lastx = q(c, 0): lasty = q(c, 1)
c = c + 1
Next
q(c, 0) = q(0, 0): q(c, 1) = q(0, 1)
If L = 0 Then
L = L + 1
_Display
_Limit 30
Else
For t = 1 To interps
Cls
For n = 0 To pts
If _KeyDown(27) Then System
s(n, 0) = q(n, 0) * i(t) + p(n, 0) * (1 - i(t))
s(n, 1) = q(n, 1) * i(t) + p(n, 1) * (1 - i(t))
setPlasma
If n > 0 Then pline lastx, lasty, s(n, 0), s(n, 1), 10
lastx = s(n, 0): lasty = s(n, 1)
Next
s(n, 0) = s(0, 0)
s(n, 1) = s(0, 1)
_Display
_Limit 30
Next
End If
For j = 0 To pts + 1 'copy q into p
If _KeyDown(27) Then System
p(j, 0) = q(j, 0)
p(j, 1) = q(j, 1)
Next
_Display
_Delay 4
Wend
'fast thick line!!!
Sub pline (x1, y1, x2, y2, thick) 'this draws a little rectangle
Dim r, dx, dy, perpA1, perpA2, x3, y3, x4, y4, x5, y5, x6, y6
r = thick / 2
dx = x2 - x1
dy = y2 - y1
perpA1 = _Atan2(dy, dx) + pi / 2
perpA2 = perpA1 - pi
x3 = x1 + r * Cos(perpA1) 'corner 1
y3 = y1 + r * Sin(perpA1)
x4 = x2 + r * Cos(perpA1) 'corner 2
y4 = y2 + r * Sin(perpA1)
x5 = x2 + r * Cos(perpA2) 'corner 3
y5 = y2 + r * Sin(perpA2)
x6 = x1 + r * Cos(perpA2) 'corner 4
y6 = y1 + r * Sin(perpA2)
Line (x3, y3)-(x4, y4)
Line (x4, y4)-(x5, y5)
Line (x5, y5)-(x6, y6)
Line (x6, y6)-(x3, y3)
End Sub
Sub resetPlasma () 'all globals
plasmaR = Rnd ^ 2: plasmaG = Rnd ^ 2: plasmaB = Rnd ^ 2: plasmaN = 0
End Sub
Sub setPlasma () 'all globals
plasmaN = plasmaN + .37
Color _RGB32(120 + 84 * Sin(plasmaR * plasmaN), 120 + 84 * Sin(plasmaG * plasmaN), 120 + 84 * Sin(plasmaB * plasmaN))
End SubQBJS Share: https://qbjs.org/?code=X1RpdGxlICJNb3JwaCBDdXJ2ZSIgJ2IrIDIwMjItMDctMTkgdHJhbnMgZnJvbQonIMspIG9uIFBsYXNtYS5iYXMgIFNtYWxsQkFTSUMgMC4xMi44IFtCKz1NR0FdIDIwMTctMDQtMTEKJ8RJIFNwZWNCQVMgdmVyc2nESGF1bCBEdW5uIERlYyAyLMQyNQonaHR0cHM6Ly93d3cueW91dHViZS5jb20vd2F0Y2g/dj1qMnJtQlJMRVZtcwonIG1vZHMgZHJhdyBsaW5lcyBzZWdtZW50cyB3aXRoxRlwb2x5LCBhZGQgcOUAuSzECHnGIG51bWJlcnMKCk9wdOQAk19FeHBsaWNpdApDb25zdCB4bWF4ID0gMTIwMCwgecYNN8QMcHRzID0gNcQLaW50ZXJwxA8zxBlpID0gX1BpCkRpbSBTaGFyZch4UsV5c21hR8gJQsgJTgpSYW5kb21pemUgVGltZXIKU2NyZWVuIF9OZXdJbWFnZSjkAIrmAIMsIDMyKQpfRnVsbMYmCsVscCjkAJQrIDEsIDEpLCBxzg9zzg9pKOcAtinFPEFzIExvbmcgTCwgYywgasgUU2luZ2xlIGN4LCBjeSwgc2MsIHN0LCBuLCBtLCB0LCBsYXN0eMYHeQpMID0gMDogY+QBI+UBNy8gMjogY3kgPeYBOcUPc2MgPcQUKiAuNTogc3QgPSAyICrkATUv5AFTCkZvciBu5AFxIFRv6AFZCiAgICBpKG4pID3kAJIobiAvyBsgKiAoxTwyKSkKTmV4dApXaGlsZSBfS2V5RG93bigyN8Q2MMVDcmVzZXTmArzFEMRoSW50KFJuZCAqIDc1KSAr5ACjbc0XNTAwKSAtIDI15ADbyUvkAKfkALww5ACn5wDBU3RlcCBzdMUgxAFJZu4Ah1RoZW4gU3lzdGVtySRxKGMsIDDkAKNjeCAr5AEeKiAoQ29zKHTkAI3ECW4gKiB0KeQA4iAr5QD+bcgRMynORzHFR3nJR8QtxUfECc1HxFjUR+4BH+cAxHQgPuQA5+QAvXDkA2LtAfXkAmflAMLHCeQCWzHmASPEAcUrID3IJTrGNcgRMcp65QIW5AKexRLlAcnuAR9xKDDGQsc6yBPHRElmIOUCf+UAqMlWxBNMyVbEAV9EaXPkA/3KEUxpbWl0IDPmALRFbHNlyRvoAeTxAovIAUNszhDoArzlAhXkAs3MHecApv8CEsoBcyhu6QD7xgoqIGnmAdBwyREoMSAtxRbqAUrNQOcBKMYKzkDFEdxA8QIMyAFJZiBu/gIUxXzkAhTFCe8CFMgB6AIcxy3qAhzHNc0x6QISyAHHNsUv5QIa0h7lAP3FHs9N8QIFxRXtAgnNdEVuZCBJZukD+GrrAePkAl0gJ2NvcHkgceQCJG8gcP8EAO4B7nAoaukB5sUKzhrnAcDFCu4DGu0AxF9EZeQG0TQKV2VuZAoKJ2Zhc3QgdGhpY2vlBxQhISEKU3Vi5wGrKHgxLCB5MSwgeDIsIHkyLMYpKSAndGhp5gdJcyBhIGxpdOQII3JlY3Rh5AYExWjkBhZyLCBkeCwgZHksIHBlcnBBMccIMiwgeDMsIHkzLCB4NCwgeTQsIHg1LCB5NSwgeDYsIHk2CsVDciA9xnHkBIvFEmTlBjAyIC0geOYDqGTlBjLEEXnGEcZo5AdWQXRhbjIoxHxkeOUCyuUF+8olMiA9yC4tIHBpxRl4M8RgMSArIHIgKuUE+8YiKeQBuHJuZXLnBB95xCh5yCjkBTTHKMZGNMRG5AU92EbmAId5xCh5yCjRRjXVRjLKRjPGRsQo0kYyx0Y29QDSy0Y0xkbEKPIA0sdGTOYCDeUBtCktKOYBtc0bxhItKOYByM0bxhItKOYB280bxhItyFoK5AM+U3ViCuUCg+sHgyAoKSAnYWxsIGdsb2Jh5wVL5wkpID0g5Ad+XuQHj8YTR9ITQtITTuUHoc1y33DJN8gKKyAuMzfFHENvbG9yIF9SR0IzMigxMjAgKyA4NOgBScUuUuQH+cY45ATk1CNH3yPlAMjKI+kBLw==
Some of these actually look better in QBJS, lines are so skinny.
RE: Screen Savers - bplus - 08-28-2022
Rain Drain
Code: (Select All)
'Rain Drain.bas started 2017-09-13
'translated from
'Rain Drain.bas SmallBASIC 0.12.9 [B+=MGA] 2017-04-26
' 2020-08-29 Rain Drain 2: What if we move one side of every line up and down?
_Define A-Z As SINGLE
Randomize Timer
Const xmax = 1100
Const ymax = 700
Screen _NewImage(xmax, ymax, 32)
_FullScreen
_Title "Rain Drain 2: spacebar for new arrangement, esc to quit"
Type ball
x As Single
y As Single
speed As Single
r As Single
c As Long
End Type
Type bLine
x1 As Single
y1 As Single
x2 As Single
y2 As Single
a As Double
End Type
While _KeyDown(27) = 0
balls = 1500
ReDim b(balls) As ball
For i = 1 To balls
b(i).x = Rnd * xmax
b(i).y = Rnd * ymax
b(i).speed = 9.85
b(i).r = 6
b(i).c = _RGB(0, rand%(200, 255), rand%(200, 255))
Next
m = 10
nbl = 12
ReDim bl(nbl) As bLine
For i = 1 To nbl
d = rand%(50, 200)
bl(i).x1 = rand%(m, xmax - d - m)
bl(i).y1 = i * ymax / nbl - 10
bl(i).a = Rnd * _Pi(1 / 4) - _Pi(1 / 8)
bl(i).x2 = bl(i).x1 + d * Cos(bl(i).a)
bl(i).y2 = bl(i).y1 + d * Sin(bl(i).a)
Next
dir = .5: lp = 0
While 1
Cls
If 32 = _KeyHit Then
Exit While
ElseIf 27 = _KeyHit Then
End
End If
lp = lp + dir
If lp > 50 Then dir = -dir
If lp < -50 Then dir = -dir
For j = 1 To balls
If b(j).y - b(j).r > ymax Or b(j).x + b(j).r < 0 Or b(j).x - b(j).r > xmax Then
b(j).x = rand%(0, xmax): b(j).y = 0
End If
fcirc b(j).x, b(j).y, b(j).r, b(j).c
testx = b(j).x + b(j).speed * Cos(_Pi(.5))
testy = b(j).y + b(j).speed * Sin(_Pi(.5))
cFlag = 0
For i = 1 To nbl
Color _RGB(255, 0, 0)
If j = 1 Then bl(i).y1 = bl(i).y1 + dir
Line (bl(i).x1, bl(i).y1)-(bl(i).x2, bl(i).y2)
If cFlag = 0 Then
If hitLine(testx, testy, b(j).r, bl(i).x1, bl(i).y1, bl(i).x2, bl(i).y2) Then
bx1 = b(j).x + b(j).speed * Cos(bl(i).a)
bx2 = b(j).x + b(j).speed * Cos(_Pi(1) - bl(i).a)
by1 = yy(bx1, bl(i).x1, bl(i).y1, bl(i).x2, bl(i).y2) - b(j).r - 1
by2 = yy(bx2, bl(i).x1, bl(i).y1, bl(i).x2, bl(i).y2) - b(j).r - 1
If by1 = (-9999 - b(j).r - 1) Or by2 = (-9999 - b(j).r - 1) Then
cFlag = 0: Exit For
End If
If by1 >= by2 Then b(j).y = by1: b(j).x = bx1 Else b(j).y = by2: b(j).x = bx2
cFlag = 1
End If
End If
Next
If cFlag = 0 Then b(j).x = testx: b(j).y = testy
Next
_Limit 20
_Display
Wend
Wend
Function hitLine (x, y, r, xx1, yy1, xx2, yy2)
x1 = xx1: y1 = yy1: x2 = xx2: y2 = yy2
If x1 > x2 Then Swap x1, x2: Swap y1, y2
If x < x1 Or x > x2 Then hitLine = 0: Exit Function
If ((y2 - y1) / (x2 - x1)) * (x - x1) + y1 - r < y And y < ((y2 - y1) / (x2 - x1)) * (x - x1) + y1 + r Then
hitLine = 1
Else
hitLine = 0
End If
End Function
Function yy (x, xx1, yy1, xx2, yy2) 'this puts drop on line
'copy parameters that are changed
x1 = xx1: y1 = yy1: x2 = xx2: y2 = yy2
If x1 > x2 Then Swap x1, x2: Swap y1, y2
If x1 <= x And x <= x2 Then
yy = ((y2 - y1) / (x2 - x1)) * (x - x1) + y1
Else
yy = -9999
End If
End Function
Function rand% (lo%, hi%)
rand% = (Rnd * (hi% - lo% + 1)) \ 1 + lo%
End Function
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 SubRE: Screen Savers - TempodiBasic - 08-29-2022
Hi boys,
@ thanks for sharing your interesting and beautyful demos
moreover I thank you for letting me meet QBJS that I didn't know
Happy coding
RE: Screen Savers - bplus - 09-06-2022
Alien Trees Mod 3
Code: (Select All)
_Title "Alien Trees Mod 3: Leaves" 'b+ 2022-09-05
Randomize Timer
DefDbl A-Z
Const xmax = 1024, ymax = 600
Type ship
As Double x, y, dx, dy, scale, tilt
End Type
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 170, 40 ' clear sides
_FullScreen
Randomize Timer
Dim Shared As Long bk ' background image
bk = _NewImage(xmax, ymax, 32) 'container for drawings
Dim Shared As Long seed(1 To 3), start, cN ' Randomize seeds for trees and plasma starters
Dim Shared As Single rd(1 To 3), gn(1 To 3), bl(1 To 3) ' plasma colors for trees
Dim Shared leaf ' indexing ends of branches
ref& = _NewImage(xmax, ymax * .2, 32) 'container for reflection image
Dim Shared ships(448) As ship ' ships / leaves
Dim Shared leaves(448) As Long ' ship images
makeShips ' just do this once for images and travel rates
restart:
makeBackground
seed(1) = Rnd * 1000 ' get new trees setup including the Plasma generators
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
leaf = 0
start = 0
cN = start
Randomize Using seed(1)
branch xmax * .6 + Rnd * .3 * xmax, ymax * .8 - 30, 6, 90, xmax / 20, 0, 1, 1
cN = start
Randomize Using seed(2)
branch Rnd * .3 * xmax, ymax * .8 - 15, 7, 90, xmax / 18, 0, 2, 1
cN = start
Randomize Using seed(3)
branch xmax / 2, ymax * .8 - 8, 8, 90, xmax / 16, 0, 3, 1
start = 0: d = 1300: ds = 5 ' start the show! press spacebar to start a different setting
Do
_PutImage , bk, 0
start = start + 1
cN = start
Randomize Using seed(1)
branch xmax * .6 + Rnd * .3 * xmax, ymax * .8 - 30, 6, 90, xmax / 20, 0, 1, 0
cN = start
Randomize Using seed(2)
branch Rnd * .3 * xmax, ymax * .8 - 15, 7, 90, xmax / 18, 0, 2, 0
cN = start
Randomize Using seed(3)
branch xmax / 2, ymax * .8 - 8, 8, 90, xmax / 16, 0, 3, 0
For i = 448 To 1 Step -1
RotoZoom ships(i).x + d * ships(i).dx, ships(i).y + d * ships(i).dy, leaves(i), ships(i).scale, 0
Next
d = d + ds
If d > 1300 Then ds = -3: d = 1300
If d < 0 Then ds = 7: d = 0: _Delay 2
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 makeShips
cN = 0
rd(1) = Rnd
gn(1) = Rnd
bl(1) = Rnd
For i = 0 To 448
leaves(i) = _NewImage(61, 31, 32) ' ship is 60 x 30 drawn in top left hand corner
' need black backgrounf for ship
Color , &HFF000000 '= balck background
Cls
drawShip 30, 15, changePlasma(1)
_PutImage , 0, leaves(i), (0, 0)-(61, 31) ' <<<< upper left corner of screen!!!
' make the background black of ship transparent
_ClearColor &HFF000000, leaves(i)
a = _Pi(2) * Rnd
ships(i).dx = Cos(a)
ships(i).dy = Sin(a)
Next
End Sub
Sub makeBackground
_Dest bk
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), _RGB32(175 + Rnd * 80, 175 + Rnd * 80, 175 + Rnd * 80)
Next
stars = stars / 2
For i = 1 To stars
fcirc Rnd * xmax, Rnd * horizon, 1, _RGB32(175 + Rnd * 80, 175 + Rnd * 80, 175 + Rnd * 80)
Next
stars = stars / 2
For i = 1 To stars
fcirc Rnd * xmax, Rnd * horizon, 2, _RGB32(175 + Rnd * 80, 175 + Rnd * 80, 175 + Rnd * 80)
Next
DrawTerrain 405, 25, &HFF002255
DrawTerrain 420, 15, &HFF224444
DrawTerrain 435, 6, &HFF448855
DrawTerrain 450, 5, &HFF88FF66
_Dest 0
End Sub
Sub branch (x, y, startr, angD, lngth, lev, tree, leafTF)
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 <= 0 Or lev > 11 Or lngth < 5 Then
If leafTF Then
'fcirc x + dx * i, y + dy * i, 5, &HFF008800
leaf = leaf + 1
ships(leaf).x = x + dx * i
ships(leaf).y = y + dy * i
ships(leaf).scale = .5 - (4 - tree) * .075
End If
Exit Sub
Else
lev2 = lev + 1
branch x2, y2, startr - 1, angD + 10 + 30 * Rnd, .8 * lngth + .2 * Rnd * lngth, lev2, tree, leafTF
branch x2, y2, startr - 1, angD - 10 - 30 * Rnd, .8 * lngth + .2 * Rnd * lngth, lev2, tree, leafTF
End If
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
Sub drawShip (x, y, colr As _Unsigned Long) 'shipType collisions same as circle x, y radius = 30
Static ls
Dim light As Long, r As Long, g As Long, b As Long
r = _Red32(colr): g = _Green32(colr): b = _Blue32(colr)
fellipse x, y, 6, 15, _RGB32(r, g - 120, b - 100)
fellipse x, y, 18, 11, _RGB32(r, g - 60, b - 50)
fellipse x, y, 30, 7, _RGB32(r, g, b)
For light = 0 To 5
fcirc x - 30 + 11 * light + ls, y, 1, _RGB32(ls * 50, ls * 50, ls * 50)
Next
ls = ls + 1
If ls > 5 Then ls = 0
End Sub
' ======== helper subs for drawShip that you can use for other things specially fcirc = fill_circle x, y, radius, color
Sub fellipse (CX As Long, CY As Long, xr As Long, yr As Long, C As _Unsigned Long)
If xr = 0 Or yr = 0 Then Exit Sub
Dim h2 As _Integer64, w2 As _Integer64, h2w2 As _Integer64
Dim x As Long, y As Long
w2 = xr * xr: h2 = yr * yr: h2w2 = h2 * w2
Line (CX - xr, CY)-(CX + xr, CY), C, BF
Do While y < yr
y = y + 1
x = Sqr((h2w2 - y * y * w2) \ h2)
Line (CX - x, CY + y)-(CX + x, CY + y), C, BF
Line (CX - x, CY - y)-(CX + x, CY - y), C, BF
Loop
End Sub
Sub DrawTerrain (h, modN, c As _Unsigned Long) ' modN for ruggedness the higher the less smooth
For x = 0 To _Width
If x Mod modN = 0 Then ' adjust mod number for ruggedness the higher the number the more jagged
If h < 600 - modN And h > 50 + modN Then
dy = Rnd * 20 - 10
ElseIf h >= 600 - modN Then
dy = Rnd * -10
ElseIf h <= 50 + modN Then
dy = Rnd * 10
End If
End If
h = h + .1 * dy
Line (x, _Height)-(x, h), c
Next
End Sub
Sub RotoZoom (X As Long, Y As Long, Image As Long, Scale As Double, degreesRotation As Double)
Dim px(3) As Single, py(3) As Single, W&, H&, sinr!, cosr!, i&, x2&, y2&
W& = _Width(Image&): H& = _Height(Image&)
px(0) = -W& / 2: py(0) = -H& / 2: px(1) = -W& / 2: py(1) = H& / 2
px(2) = W& / 2: py(2) = H& / 2: px(3) = W& / 2: py(3) = -H& / 2
sinr! = Sin(-degreesRotation / 57.2957795131): cosr! = Cos(-degreesRotation / 57.2957795131)
For i& = 0 To 3
x2& = (px(i&) * cosr! + sinr! * py(i&)) * Scale + X: y2& = (py(i&) * cosr! - px(i&) * sinr!) * Scale + Y
px(i&) = x2&: py(i&) = y2&
Next
_MapTriangle (0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
_MapTriangle (0, 0)-(W& - 1, 0)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
End SubRE: Screen Savers - SierraKen - 09-08-2022
LOL B+ this is the best! I like how the saucers come down to the trees like a swarm of birds. There is one thing I noticed, half-way to the trees everything stops for about 1/2 a second and then starts again. It could just be my computer. Pretty amazing!
RE: Screen Savers - bplus - 09-09-2022
Thanks Ken and TempodiBasic upstairs there
I never noticed a pause when developing the code. There is a purposeful delay once all the ships are roosted in the "trees".
There have been reports of time shifts happening when large numbers of ships occupy a small space, 448 is enough I guess.
RE: Screen Savers - SpriggsySpriggs - 09-15-2022
These are very pretty, bplus. Thanks for sharing!
RE: Screen Savers - bplus - 09-15-2022
Thanks Spriggsy!
I think I will throw this in before it gets buried, I think it is cool and looking to try this effect on something else:
Xor 2 Fans
Code: (Select All)
_Title "Xor 2 fans" 'b+ 2022-09-10 just saw at JB
' hmm... how to do this in QB64?
Screen _NewImage(800, 600, 32)
_FullScreen
f1& = _NewImage(800, 600, 32)
f2& = _NewImage(800, 600, 32)
Color , &HFF990000
Do
Cls
ao1 = ao1 + .012: ao2 = ao2 - .012
_Dest f1&
Line (0, 0)-(799, 599), _RGB32(0, 0, 0), BF
drawFan 300, 300, 295, 32, &HFFFFFFFF, ao1
_Dest f2&
Line (0, 0)-(799, 599), _RGB32(0, 0, 0), BF
drawFan 500, 300, 295, 32, &HFFFFFFFF, ao2
_Dest 0
For y = 0 To 599
For x = 0 To 799
_Source f1&
If Point(x, y) = _RGB32(0, 0, 0) Then p1 = 0 Else p1 = -1
_Source f2&
If Point(x, y) = _RGB32(0, 0, 0) Then p2 = 0 Else p2 = -1
If p1 Xor p2 Then PSet (x, y), &HFFAAAAAA ' tone it down a bit
Next
Next
_Display
_Limit 60 'Draw as fast as you can!
Loop While _KeyDown(27) = 0
Sub drawFan (x, y, r, nBlades, colr As _Unsigned Long, ao)
angle = _Pi(1 / nBlades)
For i = 0 To 2 * nBlades - 1 Step 2
x1 = x + r * Cos(i * angle + ao)
y1 = y + r * Sin(i * angle + ao)
x2 = x + r * Cos((i + 1) * angle + ao)
y2 = y + r * Sin((i + 1) * angle + ao)
ftri x, y, x1, y1, x2, y2, colr
Next
End Sub
Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim D As Long
Static a&
D = _Dest
If a& = 0 Then a& = _NewImage(1, 1, 32)
_Dest a&
_DontBlend a& ' '<<<< new 2019-12-16 fix
PSet (0, 0), K
_Blend a& '<<<< new 2019-12-16 fix
_Dest D
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
End SubRE: Screen Savers - bplus - 01-31-2023
Using PixelCollision code I've perfected my
Creepy Screen Saver
Code: (Select All)
Option _Explicit
_Title "Spiders with Box and Pixel Collisions Experiment 2" 'b+ 2023-01-30/31
' 2023-01-30 Another experiment in handling Spider collisions,
' At collision, no reversal nor turn, jump ahead alittle!
' Tweaked number of spiders, speeds, colors and sizes and sound if collide
' !!!!!!!!!!!!!!!!!!! Escape to Quit !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
' !!! Speaker volume around 20 maybe! !!!
Randomize Timer
Dim Shared xmax As Integer, ymax As Integer
xmax = _DesktopWidth
ymax = _DesktopHeight
Const nSpinners = 40
Type SpinnerType
As Single x, y, dx, dy, sz
c As _Unsigned Long
End Type
Dim Shared s(1 To nSpinners) As SpinnerType
Type boxType ' for PixelCollison&
As Long img, x, y, w, h
c As _Unsigned Long
End Type
Dim As Long i, j, iImg, jImg, lc, i2, sc, intx, inty
Dim As boxType sIo, sJo
sc = _ScreenImage
Screen _NewImage(xmax, ymax, 32)
'_ScreenMove 0, 0
_FullScreen
For i = 1 To nSpinners
newSpinner i
Next
i2 = 1
While InKey$ <> Chr$(27)
'_Title Str$(i2) + " spiders" ' when testing spider speeds
_PutImage , sc, 0
lc = lc + 1
If lc Mod 50 = 49 Then
lc = 0
If i2 < nSpinners Then i2 = i2 + 1
End If
For i = 1 To i2
'ready for collision check
' max sz = .75 which needs 140 x 140 image square +++++++++++++++++++++++++
iImg = _NewImage(140, 140, 32)
_Dest iImg
drawSpinner iImg, 70, 70, s(i).sz, _Atan2(s(i).dy, s(i).dx), s(i).c
_Dest 0
sIo.x = s(i).x - 70
sIo.y = s(i).y - 70
sIo.w = 140
sIo.h = 140 ' this meets requirements for collision obj1
sIo.img = iImg ' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
For j = i + 1 To i2
' max sz = .75 which needs 140 x 140 image square +++++++++++++++++++++
jImg = _NewImage(140, 140, 32)
_Dest jImg
drawSpinner jImg, 70, 70, s(j).sz, _Atan2(s(j).dy, s(j).dx), s(j).c
_Dest 0
sJo.x = s(j).x - 70
sJo.y = s(j).y - 70
sJo.w = 140
sJo.h = 140 ' this meets requirements for collision obj1
sJo.img = jImg
If PixelCollision&(sIo, sJo, intx, inty) Then '+++++++++++++++++++++++++++++++++++++++
If Rnd < .1 Then Sound Rnd * 7000 + 4000, .05
s(i).x = s(i).x + s(i).dx + rndCW(0, 3.5)
s(i).y = s(i).y + s(i).dy + rndCW(0, 3.5)
s(j).x = s(j).x + s(j).dx + rndCW(0, 3.5)
s(j).y = s(j).y + s(j).dy + rndCW(0, 3.5)
Exit For
End If
_FreeImage jImg
Next
s(i).x = s(i).x + s(i).dx + rndCW(0, 3.5)
s(i).y = s(i).y + s(i).dy + rndCW(0, 3.5)
If s(i).x < -100 Or s(i).x > xmax + 100 Or s(i).y < -100 Or s(i).y > ymax + 100 Then newSpinner i
_PutImage (s(i).x - 70, s(i).y - 70), iImg, 0
_FreeImage iImg
Next
_Display
_Limit 30
Wend
Sub newSpinner (i As Integer) 'set Spinners dimensions start angles, color?
Dim r
s(i).sz = rndCW(.5, .25) ' * .55 + .2
If Rnd < .5 Then r = -1 Else r = 1
s(i).dx = (s(i).sz * Rnd * 8 + 1) * r * 2: s(i).dy = (s(i).sz * Rnd * 8 + 1) * r * 2
r = Int(Rnd * 4)
Select Case r
Case 0: s(i).x = Rnd * (xmax - 120) + 60: s(i).y = 0: If s(i).dy < 0 Then s(i).dy = -s(i).dy
Case 1: s(i).x = Rnd * (xmax - 120) + 60: s(i).y = ymax: If s(i).dy > 0 Then s(i).dy = -s(i).dy
Case 2: s(i).x = 0: s(i).y = Rnd * (ymax - 120) + 60: If s(i).dx < 0 Then s(i).dx = -s(i).dx
Case 3: s(i).x = xmax: s(i).y = Rnd * (ymax - 120) + 60: If s(i).dx > 0 Then s(i).dx = -s(i).dx
End Select
r = Rnd * 80 + 40
s(i).c = _RGB32(r, 20 + rndCW(.5 * r, 15), 10 + rndCW(.25 * r, 10))
End Sub
Sub drawSpinner (idest&, 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 idest&, 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 idest&, 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 idest&, 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 idest&, x1, y1, r, .7 * r, heading + _Pi, _RGB32(red, green, blue)
End Sub
Sub drawLink (idest&, 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 idest&, 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 (idest&, 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 idest&, x1, y1, x2, y2, x4, y4, c
ftri idest&, x3, y3, x4, y4, x1, y1, c
End Sub
Sub ftri (idest&, x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim a&
a& = _NewImage(1, 1, 32)
_Dest a&
PSet (0, 0), K
_Dest idest&
_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 TEmax 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 TEmax = a + 1 Else TEmax = b + 1
mx2 = TEmax + TEmax
tef = _NewImage(mx2, mx2)
_Dest tef
_Source tef 'point wont read without this!
For k = 0 To 6.2832 + .05 Step .1
i = TEmax + a * Cos(k) * Cos(ang) + b * Sin(k) * Sin(ang)
j = TEmax + 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 - TEmax, y + y0 - TEmax)-(xright(y) + x0 - TEmax, y + y0 - TEmax), c, BF
Next
_FreeImage tef
End Sub
Function BoxCollision% (b1x, b1y, b1w, b1h, b2x, b2y, b2w, b2h)
' x, y represent the box left most x and top most y
' w, h represent the box width and height which is the usual way sprites / tiles / images are described
' such that boxbottom = by + bh
' and boxright = bx + bw
If (b1y + b1h < b2y) Or (b1y > b2y + b2h) Or (b1x > b2x + b2w) Or (b1x + b1w < b2x) Then
BoxCollision% = 0
Else
BoxCollision% = -1
End If
End Function
' this needs max, min functions as well as BoxCollision%
Sub Intersect2Boxes (b1x, b1y, b1w, b1h, b2x, b2y, b2w, b2h, bix As Long, biy As Long, biw As Long, bih As Long)
If b2x >= b1x And b2x <= b1x + b1w And b2y >= b1y And b2y <= b1y + b1h Then 'top left corner in 2nd box
bix = b2x: biy = b2y
If b2x + b2w <= b1x + b1w Then biw = b2w Else biw = b1x + b1w - b2x
If b2y + b2h <= b1y + b1h Then bih = b2h Else bih = b1y + b1h - b2y
ElseIf b2x >= b1x And b2x <= b1x + b1w And b2y + b2h >= b1y And b2y + b2h <= b1y + b1h Then 'bottom left corner of 2nd box in first
bix = b2x
If b2x + b2w <= b1x + b1w Then biw = b2w Else biw = b1x + b1w - b2x
If b2y <= b1y Then biy = b1y: bih = b2y + b2h - b1y Else biy = b2y: bih = b2h
ElseIf b2x + b2w >= b1x And b2x + b2w <= b1x + b1w And b2y >= b1y And b2y <= b1y + b1h Then 'right top corner 2nd box in first
If b2x >= b1x Then bix = b2x: biw = b2w Else bix = b1x: biw = b2x + b2w - b1x
biy = b2y
If b2y + b2h <= b1y + b1h Then bih = b2h Else bih = b1y + b1h - b2y
ElseIf b2x + b2w >= b1x And b2x + b2w <= b1x + b1w And b2y + b2h >= b1y And b2y + b2h <= b1y + b1h Then 'left bottom corners in first box
If b2x >= b1x Then bix = b2x: biw = b2w Else bix = b1x: biw = b2x + b2w - b1x
If b2y >= b1y Then biy = b2y: bih = b2h Else biy = b1y: bih = b2y + b2h - b1y
ElseIf BoxCollision%(b1x, b1y, b1w, b1h, b2x, b2y, b2w, b2h) Then
bix = max(b1x, b2x): biy = max(b1y, b2y)
biw = min(b1x + b1w, b2x + b2w) - bix: bih = min(b1y + b1h, b2y + b2h) - biy
Else 'no intersect
bix = -1: biy = -1: biw = 0: bih = 0
End If
End Sub
Function max (a, b)
If a > b Then max = a Else max = b
End Function
Function min (a, b)
If a < b Then min = a Else min = b
End Function
' this sub needs Intersect2Boxes which uses max, min, and BoxCollision Functions
Function PixelCollision& (img1 As boxType, img2 As boxType, intx As Long, inty As Long)
' boxType here needs at least an x, y, w, h and img
Dim As Long x, y, ix, iy, iw, ih
Dim As _Unsigned Long p1, p2
intx = -1: inty = -1 ' no collision set
Intersect2Boxes img1.x, img1.y, img1.w, img1.h, img2.x, img2.y, img2.w, img2.h, ix, iy, iw, ih
If ix <> -1 Then ' the boxes intersect
y = iy: x = ix
Do
_Source img1.img
p1 = Point(x - img1.x, y - img1.y) ' point minus img x, y location = location in image I hope
_Source img2.img
p2 = Point(x - img2.x, y - img2.y)
If (p1 <> 0) And (p2 <> 0) Then
PixelCollision& = -1: intx = x: inty = y: Exit Function
End If
If (x + 1) > (ix + iw - 1) Then ' get rid of 2 slow For Loops
x = ix: y = y + 1
If y >= (iy + ih - 1) Then
_Source 0: Exit Function
Else
y = y + 1
End If
Else
x = x + 1
End If
Loop
End If
End Function
Function rndCW (C As Single, range As Single) 'center +/-range weights to center
rndCW = C + Rnd * range - Rnd * range
End FunctionRE: Screen Savers - vince - 02-01-2023
looks like JB is 3rd after smallbasic and qb64pe but still good that's in the top 3