RE: Proggies - bplus - 05-25-2022
Kaleidoscope
Code: (Select All) _Title "Kaleidoscope" 'b+ 2022-05-24
' it so obvious to use maptriangle!
Randomize Timer
Dim Shared sH, sW, sHd2, sWd2
sH = 700: sW = 700: sHd2 = sH / 2: sWd2 = sW / 2
Screen _NewImage(700, 700, 32)
_ScreenMove 290, 0
Do Until _KeyDown(27)
If Rnd > .05 Then Line (0, 0)-(sW - 1, sH - 1), _RGB32(0, 0, 0, 10), BF Else Cls
n = (n + 1) Mod 66 + 4
If n Mod 2 Then n = n + 1
ReDim px(0 To n - 1), py(0 To n - 1)
circleDivN = _Pi(2 / n)
For i = 0 To n - 1
px(i) = sWd2 + sHd2 * Cos(i * circleDivN)
py(i) = sHd2 + sHd2 * Sin(i * circleDivN)
Next
For i = 1 To 700
Line (Rnd * sW, Rnd * sH)-Step(Rnd * 5, Rnd * 5), _RGB32(Rnd * 255, Rnd * 255, Rnd * 255), BF
Circle (Rnd * sW, Rnd * sH), Rnd * 8 + 2, _RGB32(Rnd * 255, Rnd * 255, Rnd * 255)
Next
For i = 1 To 30
w = Rnd * 700
Line (sWd2 - w / 2, Rnd * sH)-Step(w, Rnd * 5), _RGB32(Rnd * 255, Rnd * 255, Rnd * 255), BF
Next
For s = 0 To n - 1
For i = 0 To n - 1
_MapTriangle (sWd2, sHd2)-(px((i + s) Mod n), py((i + s) Mod n))-(px((i + 1 + s) Mod n), py((i + 1 + s) Mod n)), 0 To(sWd2, sHd2)-(px((i + 2 + s) Mod n), py((i + 2 + s) Mod n))-(px((i + 1 + s) Mod n), py((i + 1 + s) Mod n))
Next
Next
_Display
_Limit 2
Loop
RE: Proggies - vince - 05-25-2022
(05-17-2022, 11:16 PM)bplus Wrote: 2000th post here at Phoenix:
Code: (Select All) Title "Flower Wheel" ' b+ 2022-04?
Nice fractal, bplus. This also looks like a JB original
RE: Proggies - bplus - 05-29-2022
Networking (no not that kind) Color Domination Theory
Code: (Select All) _Title "Networking 1 translation" 'by B+ started 2018-11-13 mod 2022-05-29
Randomize Timer
Const xmax = 800, ymax = 600, nP = 500, rD = 35
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 200, 60
Dim x(nP), y(nP), dx(nP), dy(nP), c(nP) As _Unsigned Long
'initialize points
For i = 0 To nP
x(i) = Rnd * xmax: y(i) = Rnd * ymax
If Rnd < .5 Then dx(i) = -3 * Rnd - .5 Else dx(i) = 3 * Rnd + .5
If Rnd < .5 Then dy(i) = -3 * Rnd - .5 Else dy(i) = 3 * Rnd + .5
c(i) = _RGB32(Rnd * 200 + 55, Rnd * 200 + 55, Rnd * 200 + 55)
Next
While _KeyDown(27) = 0
Cls
For i = 0 To nP 'big show of points and triangle
Color c(i)
Line (x(i), y(i))-Step(1, 1), c(i), BF
For j = i + 1 To nP 'search for triangle points within 100 pixels
If distance(x(i), y(i), x(j), y(j)) < rD Then
For k = j + 1 To nP
If distance(x(k), y(k), x(j), y(j)) < rD Then
If distance(x(k), y(k), x(i), y(i)) < rD Then
'draw 3 lines of triangle
Line (x(i), y(i))-(x(j), y(j)), c(i)
Line (x(k), y(k))-(x(j), y(j)), c(i)
Line (x(i), y(i))-(x(k), y(k)), c(i)
c(j) = c(i): c(k) = c(i)
End If
End If
Next
End If
Next
'update points
x(i) = x(i) + dx(i)
y(i) = y(i) + dy(i)
If x(i) < 0 Then x(i) = xmax + x(i)
If x(i) > xmax Then x(i) = x(i) - xmax
If y(i) < 0 Then y(i) = 0: dy(i) = dy(i) * -1
If y(i) > ymax Then y(i) = ymax: dy(i) = dy(i) * -1
Next
_Display
_Limit 200
Wend
Function distance (x1, y1, x2, y2)
distance = ((x1 - x2) ^ 2 + (y1 - y2) ^ 2) ^ .5
End Function
Quiz: Why did I call it Color Domination Theory?
Update: Now see it in action on QBJS!
https://qbjs.org/index.html?code=T3B0aW9uIF9FeHBsaWNpdApfVGl0bGUgIk5ldHdvcmtpbmcgMSB0cmFuc2xhxCsiICdieSBCKyBzdGFydGVkIDIwMTgtMTEtMTMgbW/EDzIyLTA1LTI5ClJhbmRvbWl6ZSBUaW1lcgpDb25zdCB4bWF4ID0gODAwLCB5xgw2xAxuUCA9IDXECnJEID0gMzUKU2NyZWVuIF9OZXdJbWFnZSjEO8Y1LCAzMikKX8YiTW92ZSAyxDo2MApEaW0geChuUCksIHnGB2THD2THEGPEByBBcyBfVW5zaWduZWQgTG9uZ8U6QXPFDCBpLCBqLCBrCidpbml0aWFs5ADFcG9pbnRzCkZvciBpID0gMCBUbyBuUAogICAgeChpKSA9IFJuZCAq5QDhOiB5zBPkALPFKUlmxRI8IC41IFRoZW7kAJ3FKC0zICrFGy3EG0Vsc2XJG8gaKyAuNddFx23URccb0UVjxhhfUkdCMzIoxBsq5AFEICsgNTUsxSvaECkKTmV4dApXaGlsZSBfS2V5RG93bigyN8RRMMVeQ2xzxQjvAS0gJ2JpZyBzaG93IG9m5wFRIGFuZCB0cmlhbmdsZcU1xUFvbG9y5QClyRNMaW5lICjkARXkAdtpKSktU3RlcCgxLCAx5QHWxBhCRskvxHtqID0gaSArIDHIf3NlYXJjaCBmb3LJc+gAh3dpdGhpbiAxMDAgcGl4ZecAwcgBSWYgZGlzdGFuY2XrAIMsIHgoasUMaikpIDzkArrkAZHNOugAjGsgPSBq6gCM0STSZmvFWsQG32bfRspG6QE730bIASdkcmF3IDMgbGluZXPkAbPxAajUAfIBqSjrAMHmAavfQcZB6AC730HaQe0AgslO30HEAWMoauQCzcQoOiBjKGvIDdk1RW5kIElm1R/XG+UDQ9sozSAndXBkYXTpBITIF+cEIsUHK+YEMckc5wP5xQcr5gQIyRxJZsY0POQDmeQEQshJ5AWQK8UO0Sw+xh7NL8QHLcUYzC/Fc8lbxQ49IDA66QSMxggqIC0x0TY+5gYTzDnEEdk86QElX0Rpc3BsYXnGDUxpbWl05ASvCldlbmQKCkZ1bmPlBujoAxggKHgxLCB5MSwgeDIsIHky5gDvyR49ICgoeDHkANsyKSBeIDIgKyAoecQQecYQxAUuNQrkAbLIWwo=
If you wait awhile, sometimes a long while, you will see a color take over.
RE: Proggies - bplus - 05-30-2022
For Memorial Day
Code: (Select All) _Title "For Memorial Day mod x3" 'trans 2019-05-29 B+ from wave mod2x
'For Memorial Day.txt for Just Basic v1.01 [B+=MGA] 2016-05-29
' plus ad lib
' notes: American Flag close to proportion standards
'
' verticals:
' Hoist Flag = 1.0 vertical height use 650 pixels because divided by 13 = 50 each stripe
'Hoist Union = 7/13 = 350
' stripe = 1/13 = 50
' star space = .054 = 350/(10 spaces) = 35 pixels 35/650 ~ .5385
'
' horizontals:
' Fly Flag length = 1.9 = 650 * 1.9 = 1235
' Fly Union length = .76 = 650 * .76 = 494
' star space = .063 494/(12 spaces) ~ 41.167 using 41 * 12 = 492 add 1 pixel before and after stars
'star outer diameter = .0616 * 650 ~ 40 (40.04) so outer radius is 20
' and inner (20 / 2.5) = 8 < does not look right try 7
Const xMaxScreen = 1280
Const yMaxScreen = 780
Const xMaxFlag = 1235 '<=== actual drawing space needed
Const yMaxFlag = 650 '<=== actual drawing space needed
Const PI = _Pi
Const DEG = 180 / PI
Const RAD = PI / 180
Const White = &HFFFFFFFF
'https://www.google.com/search?client=opera&q=US+flag+blue+spec&sourceid=opera&ie=UTF-8&oe=UTF-8
Const OldGloryRed = &HFFBF0A30
Const OldGloryBlue = &HFF002868
Const Sky& = &H2F40A0FF
Dim Shared Flag As Long, p
Screen _NewImage(xMaxScreen, yMaxScreen, 32)
Flag = _NewImage(xMaxFlag, yMaxFlag, 32)
_ScreenMove 70, 0
_Dest Flag
Line (0, 0)-(xMaxFlag, yMaxFlag), OldGloryRed, BF
For row = 1 To 12 Step 2
Line (0, row * 50)-(xMaxFlag - 1, (row + 1) * 50 - 1), White, BF
Next
'the "Union"
Line (0, 0)-(494, 350), OldGloryBlue, BF
For row = 1 To 9
ystar = 35 * row
If row Mod 2 = 1 Then
For col = 0 To 5
xstar = 42 + col * 2 * 41
star xstar, ystar, 7.5, 19.5, 5, 18, White
Next
Else
For col = 0 To 4
xstar = 83 + col * 2 * 41
star xstar, ystar, 7.5, 19.5, 5, 18, White
Next
End If
Next
_Dest 0
_Source Flag
Color Sky, Sky
_SetAlpha 150, &H00000000 To &HFFFFFFFF, Flag
Do
Line (0, 0)-(xMaxScreen, yMaxScreen), Sky, BF
sc = Rnd * yMaxFlag * .5 + 10
rw = sc * 1.9
rh = sc
_PutImage (Rnd * xMaxScreen - .5 * rw, Rnd * (yMaxScreen) - .5 * rh)-Step(rw, rh), Flag, 0
_Display
_Limit 2
Loop
Sub star (x, y, rInner, rOuter, nPoints, angleOffset, K As _Unsigned Long)
' x, y are same as for circle,
' rInner is center circle radius
' rOuter is the outer most point of star
' nPoints is the number of points,
' angleOffset = angle offset IN DEGREES, it will be converted to radians in sub
' this is to allow us to spin the polygon of n sides
pAngle = RAD * (360 / nPoints): radAngleOffset = RAD * angleOffset
x1 = x + rInner * Cos(radAngleOffset)
y1 = y + rInner * Sin(radAngleOffset)
For i = 0 To nPoints - 1
x2 = x + rOuter * Cos(i * pAngle + radAngleOffset + .5 * pAngle)
y2 = y + rOuter * Sin(i * pAngle + radAngleOffset + .5 * pAngle)
x3 = x + rInner * Cos((i + 1) * pAngle + radAngleOffset)
y3 = y + rInner * Sin((i + 1) * pAngle + radAngleOffset)
ftri x1, y1, x2, y2, x3, y3, K
'triangles leaked
Line (x1, y1)-(x2, y2), White
Line (x2, y2)-(x3, y3), White
Line (x3, y3)-(x1, y1), White
x1 = x3: y1 = y3
Next
Paint (x, y), White, White
End Sub
Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
a& = _NewImage(1, 1, 32)
predest = _Dest
_Dest a&
PSet (0, 0), K
_Dest predest
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
_FreeImage a& '<<< this is important!
End Sub
RE: Proggies - bplus - 06-04-2022
Goldwave
Here is a Golden Oldie that Aurel dragged out at his forum:
Code: (Select All) _Title "Gold Wave bplus 2018-03-13"
'translated from SmallBASIC: Goldwave by johnno copied and mod by bplus 2018-01-28
'QB64 version 2017 1106/82 (the day before they switched to version 1.2)
Const xmax = 600
Const ymax = 480
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 360, 60
Dim ccc As _Unsigned Long
' compare fill triangle subs: one uses very simple _MAPTRIANGLE opt = 1
' 2nd uses primative line graphic0s opt <> 1
opt = 0 ' << opt 1 uses _MAPTRIANGLE to fill triangles, any other uses line filled triangles
While 1
For t = 1 To 60 Step .1 '< changed
Cls 'changed
For y1 = 0 To 24
For x1 = 0 To 24
x = (12 * (24 - x1)) + (12 * y1)
y = (-6 * (24 - x1)) + (6 * y1) + 300
d = ((10 - x1) ^ 2 + (10 - y1) ^ 2) ^ .5
h = 60 * Sin(x1 / 4 + t) + 65
If t > 10 And t < 20 Then h = 60 * Sin(y1 / 4 + t) + 65
If t > 20 And t < 30 Then h = 60 * Sin((x1 - y1) / 4 + t) + 65
If t > 30 And t < 40 Then h = 30 * Sin(x1 / 2 + t) + 30 * Sin(y1 / 2 + t) + 65
If t > 40 And t < 50 Then h = 60 * Sin((x1 + y1) / 4 + t) + 65
If t > 50 And t < 60 Then h = 60 * Sin(d * .3 + t) + 65
If opt = 1 Then
'TOP
ccc = _RGB32(242 + .1 * h, 242 + .1 * h, h)
filltri x, y - h, x + 10, y + 5 - h, x + 20, y - h, ccc
filltri x, y - h, x + 10, y - 5 - h, x + 20, y - h, ccc
'FRONT-LEFT
ccc = _RGB(255, 80, 0)
filltri x, y - h, x + 10, y + 5 - h, x + 10, y, ccc
filltri x, y - h, x, y - 5, x + 10, y, ccc
'FRONT-RIGHT
ccc = _RGB32(255, 150, 0)
filltri x + 10, y + 5 - h, x + 10, y, x + 20, y - 5, ccc
filltri x + 10, y + 5 - h, x + 20, y - h, x + 20, y - 5, ccc
Else
Color _RGB32(242 + .1 * h, 242 + .1 * h, h)
filltri2 x, y - h, x + 10, y + 5 - h, x + 20, y - h
filltri2 x, y - h, x + 10, y - 5 - h, x + 20, y - h
'FRONT-LEFT
Color _RGB32(255, 80, 0)
filltri2 x, y - h, x + 10, y + 5 - h, x + 10, y
filltri2 x, y - h, x, y - 5, x + 10, y
Color _RGB32(255, 150, 0)
filltri2 x + 10, y + 5 - h, x + 10, y, x + 20, y - 5
filltri2 x + 10, y + 5 - h, x + 20, y - h, x + 20, y - 5
End If
If InKey$ = Chr$(27) Then End
Next
Next
_Display
_Limit 200
Next
Wend
'Andy Amaya's modified FillTriangle
Sub filltri2 (xx1, yy1, xx2, yy2, xx3, yy3)
'make copies before swapping
x1 = xx1: y1 = yy1: x2 = xx2: y2 = yy2: x3 = xx3: y3 = yy3
'thanks Andy Amaya!
'triangle coordinates must be ordered: where x1 < x2 < x3
If x2 < x1 Then Swap x1, x2: Swap y1, y2
If x3 < x1 Then Swap x1, x3: Swap y1, y3
If x3 < x2 Then Swap x2, x3: Swap y2, y3
If x1 <> x3 Then slope1 = (y3 - y1) / (x3 - x1)
'draw the first half of the triangle
length = x2 - x1
If length <> 0 Then
slope2 = (y2 - y1) / (x2 - x1)
For x = 0 To length
Line (Int(x + x1), Int(x * slope1 + y1))-(Int(x + x1), Int(x * slope2 + y1))
'lastx2% = lastx%
lastx% = Int(x + x1)
Next
End If
'draw the second half of the triangle
y = length * slope1 + y1: length = x3 - x2
If length <> 0 Then
slope3 = (y3 - y2) / (x3 - x2)
For x = 0 To length
'IF INT(x + x2) <> lastx% AND INT(x + x2) <> lastx2% THEN 'works! but need 2nd? check
If Int(x + x2) <> lastx% Then
Line (Int(x + x2), Int(x * slope1 + y))-(Int(x + x2), Int(x * slope3 + y2))
End If
Next
End If
End Sub
' found at QB64.net: http://www.qb64.net/forum/index.php?topic=14425.0
Sub filltri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
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
RE: Proggies - triggered - 06-05-2022
This reminds me of Mennonite's sinecube
RE: Proggies - bplus - 06-05-2022
That's a great proggie see Sample Misc Sinecube.bas.
I remember he showed us it at old SmallBASIC forum or BP.org before I knew about QB64!
RE: Proggies - bplus - 06-06-2022
Celtic Knot Puzzle
Click tiles in top left figure to make a 6 x 6 tile Celtic Knot much like my Avatar ;-))
Press escape and the image will be copied and rotated 45 degrees and be drawn in bottom right corner, to compare to my Avatar. Hint: I needed a solution image to use when building, it's not easy!
Code: (Select All) _Title "A Celtic Knot Puzzle - click the piece build a knot!" ' b+ 2022-06-06
Screen _NewImage(1200, 700, 32)
_ScreenMove 130, 20
d& = _LoadImage("D tile.png")
d2& = _LoadImage("D2 tile.png")
_PutImage (0, 1), d&, 0
Bg~& = Point(3, 3)
iw = _Width(d&): ih = _Height(d&)
_PrintString (10, 280), Str$(iw) + Str$(ih)
For i = 0 To 6
Line (0, i * 44)-(iw, i * 44), &HFFFFFF00
Next
For i = 0 To 16
Line (i * 44, 0)-(i * 44, ih), &HFFFFFF00
Next
iw2 = _Width(d2&): ih2 = _Height(d2&)
iw2 = 16 * 44: ih2 = 8 * 44
_PutImage (1, 300), d2&, 0
For i = 0 To 8
Line (0, i * 44 + 300)-(iw2, i * 44 + 300), &HFFFFFF00
Next
For i = 0 To 16
Line (i * 44, 0 + 300)-(i * 44, ih2 + 300), &HFFFFFF00
Next
_PrintString (10, 660), Str$(iw2) + Str$(ih2)
For i = 0 To 8
Line (0 + 800, i * 44)-(ih2 + 800, i * 44), &HFFFFFF00
Next
For i = 0 To 8
Line (i * 44 + 800, 0)-(i * 44 + 800, ih2), &HFFFFFF00
Next
Do
While _MouseInput: Wend
mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
If mx < 800 Then
cellx = Int(mx / 44)
If my >= 300 Then
celly = Int((my - 300) / 44): fig = 2
Else
celly = Int(my / 44): fig = 1
End If
Else
fig = 3
cellx = Int((mx - 800) / 44)
celly = Int(my / 44)
End If
If mb Then
_PrintString (800, 400), Space$(50)
_PrintString (800, 400), "Fig:" + Str$(fig) + " cell:" + Str$(cellx) + Str$(celly)
If fig = 1 Then
If cellx >= 0 And cellx <= 15 And celly >= 0 And celly <= 5 Then
_PutImage (850, 450)-Step(44, 44), 0, 0, (cellx * 44, celly * 44)-Step(44, 44)
End If
ElseIf fig = 2 Then
If cellx >= 0 And cellx <= 15 And celly >= 0 And celly <= 7 Then
_PutImage (850, 450)-Step(44, 44), 0, 0, (cellx * 44, celly * 44 + 300)-Step(44, 44)
End If
ElseIf fig = 3 Then
If cellx >= 0 And cellx <= 7 And celly >= 0 And celly <= 7 Then
_PutImage (cellx * 44 + 800, celly * 44)-Step(44, 44), 0, 0, (850, 450)-Step(44, 44)
End If
End If
_Delay .2
End If
' 800, 450 step 44, 44 ' will be transfer spot from fig 1 or 2 to fig 3
Loop Until _KeyDown(27)
_PrintString (800, 400), Space$(50) ' erase note
Line (850, 450)-Step(45, 45), &HFF000000, BF ' cover last puzzle piece
' grab image and twist 45 degrees!
trans& = _NewImage(264, 264, 32) 'container to hold image
_PutImage , 0, trans&, (800, 0)-Step(264, 264)
RotoZoom _Width - 190, _Height - 190, trans&, 1, 45
Sleep
Sub RotoZoom (X As Long, Y As Long, Image As Long, Scale As Single, degreesRotation As Single)
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 Sub
Here is the Puzzle with Solution:
Here is the zip with source, exe and 3 images 2 images are used for tiles but never used bottom left and you will want to use solution image to help tile solution.
RE: Proggies - bplus - 06-07-2022
The Hypotrochoid Show
Code: (Select All) _Title "The Hypotrochoid Show" 'for QB64 B+ 2019-07-18
Const xmax = 700, ymax = 700
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 100, 20
c2~& = &HFFBB0000
xc = xmax / 2: yc = ymax / 2: r = yc * .5: st = 1 / (2 * _Pi * r)
n = 0: m = 3
While _KeyDown(27) = 0
m = m + 1
For n = 5 To 30 Step .05
Cls
For a = 0 To 2 * _Pi Step st
xReturn = xc + r * (Cos(a) + Cos(n * a) / 3 + Sin(m * a) / 2)
yReturn = yc + r * (Sin(a) + Sin(n * a) / 3 + Cos(m * a) / 2)
fcirc xReturn, yReturn, 10, _RGB32(0, 200, 0, n)
fcirc xReturn, yReturn, 4, c2~&
Next
Print "m = "; m; " n = "; n
_Display
Next
_Delay 1
Wend
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
Update: This runs in QBJS but it is slow compared to QB64pe straight up, also modified to work in QBJS
https://qbjs.org/index.html?code=J09wdGlvbiBfRXhwbGljaXQKX1RpdGxlICJUaGUgSHlwb3Ryb2Nob2lkIFNob3ciICdmb3IgUUI2NCBCKyAyMDE5LTA3LTE4CkNvbnN0IHhtYXggPSA3MDAsIHnJDApTY3JlZW4gX05ld0ltYWdlKMQoxiIsIDMyKQonX8YjTW92ZSAxxD4yMApEaW0gQXMgX1Vuc2lnbmVkIExvbmcgYzLFGXhjLCB5Yywgciwgc3QsIG4sIG0sIGEsIHhSZXR1cm4sIHlyxQkKYzJ+JiA9ICZIRkZCQjAwMDAKeGMgPeYAqi8gMjogecQP5QCtxQ9yxA5jICogLjU6IHN0ID0gMSAvICgyICogX1BpICogcikKbiA9IDA6IG0gPSAzCldoaWxlIF9LZXlEb3duKDI3KcQeCiAgIMUhbSArIDHFDkZvciDEOjUgVG8gMzAgU3RlcCAuMDXFHcQBQ2xzyQzELWHEScQtyH3FMnN0ySXEAecA8eQA02MgKyByICogKENvcyhhKSArIMQJbiAqIGEpIC8gMyArIFNpbihtyBEyKc1K5wEy5gEAx0rEMMVKxAnNSsRb2EpmY2lyY/EBiywgMTAsIF9SR0IzMijlAeMwLCAwLCBu3z3HCTQsIOQBzMksTmV46gEKUHJpbnQgIuQBcSI7IG07ICIg5QFsIjsgbsklX0Rpc3BsYXnKEWxpbWl05AJxxRPFUldlbmQKClN1YucAiShDWOQChuQCfCwgQ1nKDFLLF/ICqOYA1OQCqlJhZGl1c8s4xRBFcnJvcsgVySzLa8lqxR3HRT0gQWJzKFIpOs1GPSAtxg86IFggPccbOiBZ6QKISWbKQTAgVGhlbiBQU2V05ADc5ADUKSwgQzogRXhpdCBTdWLFMkxpbmXEHyAtIMYjLcQNK8cNLCBDxSbmAvtYID4gWekBVO4AmcwOKyBZICogMukDEO0AmsYjPugAoMkhxyVYIDw+IFnEO9If7wCwWeUBpy0gWOgAtMoR6AC43Tor0DrEEdA6RW5kIElmzRPkAXvERuoA3cQB+gEPLSBY5AEPyS7PU+QBvsR8yk/wAZTkALLtAZjFEewAqtEyK9AyxBHIMuUC+uQAhuQCBQ==
RE: Proggies - bplus - 06-07-2022
Boing
Code: (Select All) _Title "Mouse down, drag ball, release... Boing" 'B+ 2019-01-08 from
'boing.bas for SmallBASIC 2015-07-25 MGA/B+
'coloring mods
Const xmax = 1200
Const ymax = 700
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 80, 20
Dim s(1 To 4, 1 To 2)
s(1, 1) = 0: s(1, 2) = 50
s(2, 1) = 0: s(2, 2) = ymax - 50
s(3, 1) = xmax + 30: s(3, 2) = 50
s(4, 1) = xmax + 30: s(4, 2) = ymax - 50
oldtx = 0: oldtyty = 0: da = .03
boingx = 0: boingy = 0
While 1
While _MouseInput: Wend
mb = _MouseButton(1)
If mb Then
tx = _MouseX + 20
ty = _MouseY
Else
tx = xmax / 2
ty = ymax / 2
If tx <> oldtx Or ty <> oldty Then
boingx = 3 * (tx - oldtx) / 4
boingy = 3 * (ty - oldty) / 4
Else
boingx = -3 * boingx / 4
boingy = -3 * boingy / 4
End If
tx = tx + boingx
ty = ty + boingy
End If
a = 0
oldtx = tx
oldty = ty
Cls
For corner = 1 To 4
s1x = s(corner, 1)
s1y = s(corner, 2)
dx = (tx - s1x) / 2000
dy = (ty - s1y) / 2000
x = tx - 20
y = ty
For i = 1 To 2000
sx = 20 * Cos(a) + x
sy = 20 * Sin(a) + y
Line (sx, sy + 5)-(sx + 4, sy + 5), _RGB32(118, 118, 118), BF
Line (sx, sy + 4)-(sx + 4, sy + 4), _RGB32(148, 148, 148), BF
Line (sx, sy + 3)-(sx + 4, sy + 3), _RGB32(238, 238, 238), BF
Line (sx, sy + 2)-(sx + 4, sy + 3), _RGB32(208, 208, 208), BF
Line (sx, sy + 1)-(sx + 4, sy + 1), _RGB32(168, 168, 168), BF
Line (sx, sy)-(sx + 4, sy), _RGB32(108, 108, 108), BF
Line (sx, sy - 1)-(sx + 4, sy - 1), _RGB32(68, 68, 68), BF
x = x - dx: y = y - dy
a = a + da
Next
Next
For r = 50 To 1 Step -1
g = (50 - r) * 5 + 5
Color _RGB32(g, g, g)
fcirc tx - 20, ty, r
Next
_Display
_Limit 15
Wend
'Steve McNeil's copied from his forum note: Radius is too common a name
Sub fcirc (CX As Long, CY As Long, R As Long)
Dim subRadius As Long, RadiusError As Long
Dim X As Long, Y As Long
subRadius = Abs(R)
RadiusError = -subRadius
X = subRadius
Y = 0
If subRadius = 0 Then PSet (CX, CY): Exit Sub
' Draw the middle span here so we don't draw it twice in the main loop,
' which would be a problem with blending turned on.
Line (CX - X, CY)-(CX + X, CY), , 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), , BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), , BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), , BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), , BF
Wend
End Sub
|