Posts: 1,616
Threads: 157
Joined: Apr 2022
Reputation:
77
Speaking of clockwise... you should consider making this into a clock. Remember all those clock submissions?
Does everybody know what time it is? It's trig time! (I miss Home Improvement.)
Pete
Posts: 2,700
Threads: 124
Joined: Apr 2022
Reputation:
134
Did I forget to save my post?
Again, For clocks I subtract Pi/2 from angle so 0 radians / 12 o'clock is straight up.
Here is 49+ clocks in 38 LOC:
Code: (Select All) _Title "49+ Analog Clocks in 38 Lines of Code for QB64 B+ 2018-10-02"
Screen _NewImage(720, 720, 32)
_ScreenMove 300, 10
While 1
Cls
For i = 0 To 11
clock 360 + 258 * Cos(_Pi(2 * i / 12)), 360 + 258 * Sin(_Pi(2 * i / 12)), 65
clock 360 + 149 * Cos(_Pi(2 * i / 12)), 360 + 149 * Sin(_Pi(2 * i / 12)), 37
clock 360 + 86 * Cos(_Pi(2 * i / 12)), 360 + 86 * Sin(_Pi(2 * i / 12)), 20
clock 360 + 50 * Cos(_Pi(2 * i / 12)), 360 + 50 * Sin(_Pi(2 * i / 12)), 12
Next
clock 360, 360, 340
clock 700, 700, 865
_Display
_Limit 2
Wend
Sub clock (x, y, r)
For a = 0 To 359 Step 6
If a Mod 30 = 0 Then r1 = 1 / 30 * r Else r1 = 1 / 75 * r
Circle (x + r * Cos(_D2R(a)), y + r * Sin(_D2R(a))), r1
Paint (x + r * Cos(_D2R(a)), y + r * Sin(_D2R(a))), _RGB32(100, 100, 100), _RGB32(255, 255, 255)
Next
If Val(Left$(Time$, 2)) + (Val(Mid$(Time$, 4, 2)) / 60) >= 12 Then hrs = Val(Left$(Time$, 2)) + (Val(Mid$(Time$, 4, 2)) / 60) - 12 Else hrs = Val(Left$(Time$, 2)) + (Val(Mid$(Time$, 4, 2)) / 60)
ftri x + 1 / 15 * r * Cos(Val(Mid$(Time$, 4, 2)) * _Pi(1 / 30) - _Pi(1 / 2) + _Pi(1 / 2)), y + 1 / 15 * r * Sin(Val(Mid$(Time$, 4, 2)) * _Pi(1 / 30) - _Pi(1 / 2) + _Pi(1 / 2)), x + 1 / 15 * r * Cos(Val(Mid$(Time$, 4, 2)) * _Pi(1 / 30) - _Pi(1 / 2) - _Pi(1 / 2)), y + 1 / 15 * r * Sin(Val(Mid$(Time$, 4, 2)) * _Pi(1 / 30) - _Pi(1 / 2) - _Pi(1 / 2)), x + r * Cos(Val(Mid$(Time$, 4, 2)) * _Pi(1 / 30) - _Pi(1 / 2)), y + r * Sin(Val(Mid$(Time$, 4, 2)) * _Pi(1 / 30) - _Pi(1 / 2)), _RGB32(255, 0, 0)
ftri x + 1 / 10 * r * Cos(hrs * _Pi(1 / 6) - _Pi(1 / 2) + _Pi(1 / 2)), y + 1 / 10 * r * Sin(hrs * _Pi(1 / 6) - _Pi(1 / 2) + _Pi(1 / 2)), x + 1 / 10 * r * Cos(hrs * _Pi(1 / 6) - _Pi(1 / 2) - _Pi(1 / 2)), y + 1 / 10 * r * Sin(hrs * _Pi(1 / 6) - _Pi(1 / 2) - _Pi(1 / 2)), x + 2 / 3 * r * Cos(hrs * _Pi(1 / 6) - _Pi(1 / 2)), y + 2 / 3 * r * Sin(hrs * _Pi(1 / 6) - _Pi(1 / 2)), _RGB32(0, 0, 255)
Line (x, y)-(x + r * Cos(Val(Right$(Time$, 2)) * _Pi(1 / 30) - _Pi(1 / 2)), y + r * Sin(Val(Right$(Time$, 2)) * _Pi(1 / 30) - _Pi(1 / 2))), _RGB32(255, 255, 0)
Circle (x, y), 1 / 10 * r, _RGB32(255, 255, 255)
Paint (x + 1 / 75 * r, y + 1 / 75 * r), _RGB32(100, 100, 100), _RGB32(255, 255, 255)
Circle (x, y), 1 / 30 * r, _RGB32(0, 0, 0)
End Sub
Sub ftri (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
b = b + ...
Posts: 1,616
Threads: 157
Joined: Apr 2022
Reputation:
77
Thanks for posting that here. You could also post it on TikTok.
Pete
- Runs for the hills.
If eggs are brain food, Biden takes his scrambled.
Posts: 224
Threads: 7
Joined: Apr 2022
Reputation:
14
wow pretty cool bplus, it's almost exactly like that clock thing Bill did with triple pendulii or something
Posts: 40
Threads: 2
Joined: May 2022
Ah yes, vince must be talking about the parametric clock:
Code: (Select All) Option _Explicit
Do Until _ScreenExists: Loop
_Title "Parametric Clock"
Dim Shared MainScreen As Long
Dim Shared BackScreen As Long
MainScreen = _NewImage(600, 600, 32)
BackScreen = _NewImage(600, 600, 32)
Screen MainScreen
Randomize Timer
Dim Shared pi As Double
Dim Shared phi As Double
pi = 4 * Atn(1)
phi = (1 + Sqr(5)) / 2
Type TimeValue
Hour As Integer
Minute As Integer
Second As Double
TenthSecond As Double
End Type
Type Vector
x As Double
y As Double
End Type
Type ClockHand
Center As Vector
HandPosition As Vector
Length As Double
Angle As Double
Shade As _Unsigned Long
End Type
Dim Shared TheTime As TimeValue
Dim Shared HourHand As ClockHand
Dim Shared MinuteHand As ClockHand
Dim Shared SecondHand As ClockHand
Dim Shared TenthSecondHand As ClockHand
Dim Shared Mode As Integer
Dim Shared ModeList(12) As Integer
Dim Shared TimeShift As Double
TimeShift = 0
HourHand.Center.x = 0
HourHand.Center.y = 0
HourHand.Length = 150
MinuteHand.Length = HourHand.Length / (phi)
SecondHand.Length = HourHand.Length / (phi ^ 2)
TenthSecondHand.Length = HourHand.Length / (phi ^ 3)
HourHand.Shade = _RGB32(200, 50, 50, 255)
MinuteHand.Shade = _RGB32(65, 105, 225, 255)
SecondHand.Shade = _RGB32(255, 165, 0, 255)
TenthSecondHand.Shade = _RGB32(138, 43, 226, 255)
Call InitializeModes
Mode = 12
Call PrepareClockface(1)
Do
Call KeyProcess
Call UpdateTime(Timer + TimeShift)
Call UpdateClock
Call DrawEverything
_KeyClear
_Limit 60
Loop
System
Sub InitializeModes
Dim k As Integer
For k = 1 To 12
ModeList(k) = k
Next
End Sub
Sub PrepareClockface (metric As Integer)
Dim p As Double
Dim q As Long
_Dest BackScreen
Cls
Call ccircle(0, 0, HourHand.Length, HourHand.Shade)
p = Rnd
For q = 0 To ((Mode * 3600) - (metric)) Step (metric)
Call UpdateTime(q)
Call UpdateClock
Call lineSmooth(SecondHand.Center.x, SecondHand.Center.y, SecondHand.HandPosition.x, SecondHand.HandPosition.y, _RGB32(255 * p, 255 * Rnd * 155, 255 * (1 - p), 30))
Next
For q = 0 To ((Mode * 3600) - (3600)) Step (3600)
Call UpdateTime(q)
Call UpdateClock
Call ccircle(HourHand.HandPosition.x, HourHand.HandPosition.y, 6, HourHand.Shade)
Call ccirclefill(HourHand.HandPosition.x, HourHand.HandPosition.y, 5, _RGB32(0, 0, 0, 255))
Next
_Dest MainScreen
End Sub
Sub KeyProcess
If (_KeyDown(32) = -1) Then ' Space
TimeShift = -Timer
End If
If ((_KeyDown(114) = -1) Or (_KeyDown(84) = -1)) Then ' r or R
TimeShift = 0
End If
If (_KeyDown(19200) = -1) Then ' Leftarrow
Call DecreaseMode
Call PrepareClockface(1)
_Delay .1
End If
If (_KeyDown(19712) = -1) Then ' Rightarrow
Call IncreaseMode
Call PrepareClockface(1)
_Delay .1
End If
If (_KeyDown(18432) = -1) Then
TimeShift = TimeShift + 60 ' Uparrow
End If
If (_KeyDown(20480) = -1) Then ' Downarrow
TimeShift = TimeShift - 60
End If
End Sub
Sub UpdateTime (z As Double)
Dim t As Double
t = z
TheTime.Hour = Int(t / 3600)
t = t - TheTime.Hour * 3600
TheTime.Hour = TheTime.Hour Mod Mode
If (TheTime.Hour = 0) Then TheTime.Hour = Mode
TheTime.Minute = Int(t / 60)
t = t - TheTime.Minute * 60
TheTime.Second = t
TheTime.TenthSecond = (TheTime.Second - Int(TheTime.Second))
End Sub
Sub UpdateClock
HourHand.Angle = -((TheTime.Hour + (TheTime.Minute / 60) + (TheTime.Second / 3600)) / Mode) * 2 * pi + (pi / 2)
MinuteHand.Angle = -((TheTime.Minute / 60) + (TheTime.Second / 3600)) * 2 * pi + (pi / 2)
SecondHand.Angle = -(TheTime.Second / 60) * 2 * pi + (pi / 2)
'TenthSecondHand.Angle = -(TheTime.TenthSecond) * 2 * pi + (pi / 2)
HourHand.HandPosition.x = HourHand.Center.x + HourHand.Length * Cos(HourHand.Angle)
HourHand.HandPosition.y = HourHand.Center.y + HourHand.Length * Sin(HourHand.Angle)
MinuteHand.Center.x = HourHand.HandPosition.x
MinuteHand.Center.y = HourHand.HandPosition.y
MinuteHand.HandPosition.x = MinuteHand.Center.x + MinuteHand.Length * Cos(MinuteHand.Angle)
MinuteHand.HandPosition.y = MinuteHand.Center.y + MinuteHand.Length * Sin(MinuteHand.Angle)
SecondHand.Center.x = MinuteHand.HandPosition.x
SecondHand.Center.y = MinuteHand.HandPosition.y
SecondHand.HandPosition.x = SecondHand.Center.x + SecondHand.Length * Cos(SecondHand.Angle)
SecondHand.HandPosition.y = SecondHand.Center.y + SecondHand.Length * Sin(SecondHand.Angle)
'TenthSecondHand.Center.x = SecondHand.HandPosition.x
'TenthSecondHand.Center.y = SecondHand.HandPosition.y
'TenthSecondHand.HandPosition.x = TenthSecondHand.Center.x + TenthSecondHand.Length * Cos(TenthSecondHand.Angle)
'TenthSecondHand.HandPosition.y = TenthSecondHand.Center.y + TenthSecondHand.Length * Sin(TenthSecondHand.Angle)
End Sub
Sub DrawEverything
Cls
_PutImage (0, 0)-(_Width, _Height), BackScreen, MainScreen, (0, 0)-(_Width, _Height)
Call DrawModeList
Call DrawHUD
Call DrawClockHands
Call DrawDigitalClock
_Display
End Sub
Sub DrawModeList
Dim k As Integer
For k = 1 To UBound(ModeList)
If (Mode = k) Then
Color _RGB32(255, 255, 0, 255), _RGB32(0, 0, 255, 255)
Else
Color _RGB32(100, 100, 100, 255), _RGB32(0, 0, 0, 0)
End If
_PrintString ((4 + 5 * k) * 8, _Height - (1) * 16), LTrim$(RTrim$(Str$(ModeList(k))))
Next
Color _RGB32(200, 200, 0, 255), _RGB32(0, 0, 0, 0)
_PrintString ((4 + 1) * 8, _Height - (1) * 16), ">"
_PrintString ((4 + 5 * (UBound(ModeList) + 1)) * 8, _Height - (1) * 16), "<"
End Sub
Sub IncreaseMode
If (Mode < 12) Then
Mode = Mode + 1
Else
Mode = 1
End If
End Sub
Sub DecreaseMode
If (Mode = 1) Then
Mode = 12
Else
Mode = Mode - 1
End If
End Sub
Sub DrawClockHands
Dim k As Double
Dim ctmp As _Unsigned Long
Dim SeedLength As Double
SeedLength = 12
For k = 0 To 1 Step .01
ctmp = ColorMix(_RGB32(0, 0, 255, 255), HourHand.Shade, k)
ctmp = _RGB32(_Red32(ctmp), _Green32(ctmp), _Blue32(ctmp), k * _Alpha32(ctmp))
Call ccirclefill(HourHand.Center.x + (k * HourHand.Length) * Cos(HourHand.Angle), HourHand.Center.y + (k * HourHand.Length) * Sin(HourHand.Angle), k * SeedLength, ctmp)
Next
For k = 0 To 1 Step .01
ctmp = ColorMix(HourHand.Shade, MinuteHand.Shade, k)
ctmp = _RGB32(_Red32(ctmp), _Green32(ctmp), _Blue32(ctmp), _Alpha32(ctmp))
Call ccirclefill(MinuteHand.Center.x + (k * MinuteHand.Length) * Cos(MinuteHand.Angle), MinuteHand.Center.y + (k * MinuteHand.Length) * Sin(MinuteHand.Angle), SeedLength * (1 - k / phi), ctmp)
Next
For k = 0 To 1 Step .005
ctmp = ColorMix(MinuteHand.Shade, SecondHand.Shade, k)
ctmp = _RGB32(_Red32(ctmp), _Green32(ctmp), _Blue32(ctmp), _Alpha32(ctmp))
Call ccirclefill(SecondHand.Center.x + (k * SecondHand.Length) * Cos(SecondHand.Angle), SecondHand.Center.y + (k * SecondHand.Length) * Sin(SecondHand.Angle), (SeedLength * (1 - 1 / phi)) * (1 - k), ctmp)
Next
'FOR k = 0 TO 1 STEP .005
'ctmp = ColorMix(SecondHand.Shade, TenthSecondHand.Shade, k)
'ctmp = _RGB32(_RED32(ctmp), _GREEN32(ctmp), _BLUE32(ctmp), _ALPHA32(ctmp))
'CALL ccirclefill(TenthSecondHand.Center.x + (k * TenthSecondHand.Length) * COS(TenthSecondHand.Angle), TenthSecondHand.Center.y + (k * TenthSecondHand.Length) * SIN(TenthSecondHand.Angle), (SeedLength * (1 - 1 / phi)) * (1 - k), ctmp)
'NEXT
Call DrawPulley(HourHand.Center.x, HourHand.Center.x, 0, HourHand.HandPosition.x, HourHand.HandPosition.y, SeedLength + 2, _RGB32(255, 255, 255, 255))
Call DrawPulley(HourHand.HandPosition.x, HourHand.HandPosition.y, SeedLength + 2, MinuteHand.HandPosition.x, MinuteHand.HandPosition.y, (SeedLength * (1 - 1 / phi)) + 1, _RGB32(255, 255, 255, 255))
Call DrawPulley(MinuteHand.HandPosition.x, MinuteHand.HandPosition.y, (SeedLength * (1 - 1 / phi)) + 1, SecondHand.HandPosition.x, SecondHand.HandPosition.y, 0, _RGB32(255, 255, 255, 255))
'CALL DrawPulley(SecondHand.HandPosition.x, SecondHand.HandPosition.y, (SeedLength * (1 - 1 / phi)) + 1, TenthSecondHand.HandPosition.x, TenthSecondHand.HandPosition.y, 0, _RGB32(255, 255, 255, 255))
End Sub
Sub DrawDigitalClock
Dim t As String
Color _RGB32(200, 200, 0, 255), _RGB32(0, 0, 0, 0)
Dim h As String
Dim m As String
Dim s As String
Dim n As String
h = LTrim$(RTrim$(Str$(TheTime.Hour)))
If Len(h) = 1 Then h = "0" + h
m = LTrim$(RTrim$(Str$(TheTime.Minute)))
If Len(m) = 1 Then m = "0" + m
s = LTrim$(RTrim$(Str$(Int(TheTime.Second))))
If Len(s) = 1 Then s = "0" + s
n = LTrim$(RTrim$(Str$((Int(10 * TheTime.TenthSecond)))))
t = h + ":" + m + ":" + s ' + ":" + n
Locate 1, (_Width / 8) / 2 - Len(t) / 2
Print t
End Sub
Sub DrawHUD
Color _RGB32(0, 200, 200, 255), _RGB32(0, 0, 0, 0)
Locate 1, 2: Print "SPACE = Stopwatch"
Locate 2, 2: Print " R = Reset"
Locate 1, 59: Print "UpArrow = Time +"
Locate 2, 59: Print "DnArrow = Time -"
End Sub
Function ColorMix~& (Shade1 As _Unsigned Long, Shade2 As _Unsigned Long, param As Double)
ColorMix~& = _RGB32((1 - param) * _Red32(Shade1) + param * _Red32(Shade2), (1 - param) * _Green32(Shade1) + param * _Green32(Shade2), (1 - param) * _Blue32(Shade1) + param * _Blue32(Shade2))
End Function
Sub cpset (x1, y1, col As _Unsigned Long)
PSet (_Width / 2 + x1, -y1 + _Height / 2), col
End Sub
Sub cline (x1 As Double, y1 As Double, x2 As Double, y2 As Double, col As _Unsigned Long)
Line (_Width / 2 + x1, -y1 + _Height / 2)-(_Width / 2 + x2, -y2 + _Height / 2), col
End Sub
Sub ccircle (x1 As Double, y1 As Double, rad As Double, col As _Unsigned Long)
Circle (_Width / 2 + x1, -y1 + _Height / 2), rad, col
End Sub
Sub ccirclefill (x1 As Double, y1 As Double, rad As Double, col As _Unsigned Long)
Call CircleFill(_Width / 2 + x1, -y1 + _Height / 2, rad, col)
End Sub
Sub CircleFill (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
' CX = center x coordinate
' CY = center y coordinate
' R = radius
' C = fill color
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 DrawPulley (x1 As Double, y1 As Double, rad1 As Double, x2 As Double, y2 As Double, rad2 As Double, col As _Unsigned Long)
Dim ang As Double
ang = _Atan2(y2 - y1, x2 - x1) + pi / 2
Call lineSmooth(x1 + rad1 * Cos(ang), y1 + rad1 * Sin(ang), x2 + rad2 * Cos(ang), y2 + rad2 * Sin(ang), col)
Call lineSmooth(x1 - rad1 * Cos(ang), y1 - rad1 * Sin(ang), x2 - rad2 * Cos(ang), y2 - rad2 * Sin(ang), col)
Call ccircle(x1, y1, rad1, col)
Call ccircle(x2, y2, rad2, col)
End Sub
Sub lineSmooth (x0, y0, x1, y1, c As _Unsigned Long)
'Inspiration credit: {(FellippeHeitor)(qb64.org)(2020)}
' {https://en.wikipedia.org/w/index.php?title=Xiaolin_Wu%27s_line_algorithm&oldid=852445548}
'Edit: {(STxAxTIC)(2020-11-20)(Correction to alpha channel.)}
Dim plX As Integer, plY As Integer, plI
Dim steep As _Byte
steep = Abs(y1 - y0) > Abs(x1 - x0)
If steep Then
Swap x0, y0
Swap x1, y1
End If
If x0 > x1 Then
Swap x0, x1
Swap y0, y1
End If
Dim dx, dy, gradient
dx = x1 - x0
dy = y1 - y0
gradient = dy / dx
If dx = 0 Then
gradient = 1
End If
'handle first endpoint
Dim xend, yend, xgap, xpxl1, ypxl1
xend = _Round(x0)
yend = y0 + gradient * (xend - x0)
xgap = (1 - ((x0 + .5) - Int(x0 + .5)))
xpxl1 = xend 'this will be used in the main loop
ypxl1 = Int(yend)
If steep Then
plX = ypxl1
plY = xpxl1
plI = (1 - (yend - Int(yend))) * xgap
Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
plX = ypxl1 + 1
plY = xpxl1
plI = (yend - Int(yend)) * xgap
Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
Else
plX = xpxl1
plY = ypxl1
plI = (1 - (yend - Int(yend))) * xgap
Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
plX = xpxl1
plY = ypxl1 + 1
plI = (yend - Int(yend)) * xgap
Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
End If
Dim intery
intery = yend + gradient 'first y-intersection for the main loop
'handle second endpoint
Dim xpxl2, ypxl2
xend = _Round(x1)
yend = y1 + gradient * (xend - x1)
xgap = ((x1 + .5) - Int(x1 + .5))
xpxl2 = xend 'this will be used in the main loop
ypxl2 = Int(yend)
If steep Then
plX = ypxl2
plY = xpxl2
plI = (1 - (yend - Int(yend))) * xgap
Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
plX = ypxl2 + 1
plY = xpxl2
plI = (yend - Int(yend)) * xgap
Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
Else
plX = xpxl2
plY = ypxl2
plI = (1 - (yend - Int(yend))) * xgap
Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
plX = xpxl2
plY = ypxl2 + 1
plI = (yend - Int(yend)) * xgap
Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
End If
'main loop
Dim x
If steep Then
For x = xpxl1 + 1 To xpxl2 - 1
plX = Int(intery)
plY = x
plI = (1 - (intery - Int(intery)))
Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
plX = Int(intery) + 1
plY = x
plI = (intery - Int(intery))
Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
intery = intery + gradient
Next
Else
For x = xpxl1 + 1 To xpxl2 - 1
plX = x
plY = Int(intery)
plI = (1 - (intery - Int(intery)))
Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
plX = x
plY = Int(intery) + 1
plI = (intery - Int(intery))
Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
intery = intery + gradient
Next
End If
Exit Sub
'plot:
' Change to regular PSET for standard coordinate orientation.
'Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
'Return
End Sub
Posts: 2,700
Threads: 124
Joined: Apr 2022
Reputation:
134
10-06-2022, 12:42 PM
(This post was last modified: 10-06-2022, 12:47 PM by bplus.)
I have 6 mods of that thing STx started:
Code: (Select All) Option _Explicit
_Title "Jointed 4 arms clock #6: Any changes color, digits change hours: 0 = 12 or click mouse at 1, 2, 3... o'clock" 'b+ started 2020-11-22
' inspsired by STx Parametric clock specially the faces https://www.qb64.org/forum/index.php?topic=3277.msg125579#msg125579
' I wish to see what a large circle joint at center would look like, first can I get similar face? yes sorta
' 2020-11-23 More work on clock face, less LOC for drawPully, add modes and color changes
' 2020-11-24 add stuff to make different arms
' 2020-11-25 OK 4 armed clocks
Randomize Timer
Const xmax = 710, ymax = 710, CX = xmax / 2, CY = ymax / 2, hhr0 = 20, hhr1 = 10, mhr1 = 5, shr1 = 3, thr = 0, hh = 180, mh = 110, sh = 36, th = 12
Dim Shared face As Long, mode As Long, colr As _Unsigned Long, hourHand&, minHand&, secHand&, tenthsHand&
Screen _NewImage(xmax, ymax, 32)
_Delay .25
_ScreenMove _Middle
Dim k$, a, t As Double, h, m, s, tenths, hha, mha, sha, tha, hhx, hhy, mhx, mhy, shx, shy, thx, thy
face = _NewImage(_Width, _Height, 32)
makeAFace
Do
k$ = InKey$
If Len(k$) Then
If InStr("0123456789", k$) Then mode = Val(k$)
makeAFace
End If
While _MouseInput: Wend
If _MouseButton(1) Then
a = _R2D(_Atan2(_MouseY - CY, _MouseX - CX)) + 90 + 15
If a < 0 Then a = a + 360
If a > 360 Then a = a - 360
a = Int(a / 30)
If a >= 0 And a <= 12 Then mode = a: makeAFace
End If
_PutImage , face&, 0
t = Timer(.001)
h = t / 3600 ' fix this for mode
If h > 12 Then h = h - 12
m = (h - Int(h)) * 60
s = t Mod 60
tenths = Int((t - Int(t)) * 10)
hha = h / mode * _Pi(2) - _Pi(.5)
mha = m / 60 * _Pi(2) - _Pi(.5)
sha = s / 60 * _Pi(2) - _Pi(.5)
tha = tenths / 10 * _Pi(2) - _Pi(.5)
hhx = CX + hh * Cos(hha): hhy = CY + hh * Sin(hha)
mhx = hhx + mh * Cos(mha): mhy = hhy + mh * Sin(mha)
shx = mhx + sh * Cos(sha): shy = mhy + sh * Sin(sha)
thx = shx + .35 * th * Cos(tha): thy = shy + .35 * th * Sin(tha) ' why so far away? move in .4 ???
RotoZoom3 CX, CY, hourHand&, 1, 1, hha
RotoZoom3 hhx, hhy, minHand&, 1, 1, mha
RotoZoom3 mhx, mhy, secHand&, 1, 1, sha
RotoZoom3 thx, thy, tenthsHand&, 1, 1, tha
_Display
_Limit 30
Loop Until _KeyDown(27)
Sub drawPully (x1, y1, r1, x2, y2, r2, c As _Unsigned Long)
Dim a
a = _Atan2(y2 - y1, x2 - x1) + _Pi(.5)
Line (x1 + r1 * Cos(a), y1 + r1 * Sin(a))-(x2 + r2 * Cos(a), y2 + r2 * Sin(a)), c
Line (x1 + r1 * Cos(a - _Pi), y1 + r1 * Sin(a - _Pi))-(x2 + r2 * Cos(a - _Pi), y2 + r2 * Sin(a - _Pi)), c
Circle (x1, y1), r1, c
Circle (x2, y2), r2, c
End Sub
Sub makeAFace
Dim cColr As _Unsigned Long, r, g, b, a, vi, h, hha, mha, sha, hhx, hhy, mhx, mhy, shx, shy, t, tha, thx, thy
colr = _RGB32((Rnd < .5) * -1 * (Rnd * 128 + 127), Rnd * 128 + 127, (Rnd < .5) * -1 * (Rnd * 128 + 127), &H23)
cAnalysis colr, r, g, b, a
cColr = _RGB32(255 - r, 255 - g, 255 - b, 2)
If mode = 0 Then mode = 12
Cls
For vi = 1 To mode * 3600
h = vi / 3600
hha = h / mode * _Pi(2) - _Pi(.5)
mha = (h - Int(h)) * _Pi(2) - _Pi(.5)
sha = (vi Mod 60) / 60 * _Pi(2) - _Pi(.5)
hhx = CX + hh * Cos(hha): hhy = CY + hh * Sin(hha)
mhx = hhx + mh * Cos(mha): mhy = hhy + mh * Sin(mha)
shx = mhx + sh * Cos(sha): shy = mhy + sh * Sin(sha)
drawPully mhx, mhy, mhr1, shx, shy, shr1, colr
For t = 0 To 9
tha = t / 10 * _Pi(2) - _Pi(.5)
thx = shx + th * Cos(tha): thy = shy + th * Sin(tha)
drawPully shx, shy, shr1, thx, thy, thr, cColr
Next
Next
_PutImage , 0, face
'arms look better with the draw color for the face on the edges, it hides raggity border edges.
' otherwise we could just draw these once at the beginning of program.
makeArmImage hourHand&, hh, hhr0, hhr1, &HFFFFFFFF, &H88000000
makeArmImage minHand&, mh, hhr1, mhr1, &HFFFFFFFF, &H88000000
makeArmImage secHand&, sh, mhr1, shr1, &HFFFFFFFF, &H88000000
makeArmImage tenthsHand&, th, shr1, thr, &HFFFFFFFF, &H88000000
End Sub
Sub makeArmImage (hdl&, length, r1, r2, c1 As _Unsigned Long, c2 As _Unsigned Long)
' intend to use this with rotozoom so have to make image rotate-able in middle
' arm image starts big in middle and points right to smaller radius r2
' hdl& image handle to use
' length run of origins of half circles
' c1 is color on left in middle = bigger joint , c2 is color on right
Dim width, height, wd2, hd2, x1, y1, x2, y2, a
width = 2 * (r2 + length) + 2: height = 2 * r1 + 2: wd2 = width / 2: hd2 = height / 2
hdl& = _NewImage(width + 2, height + 2, 32)
_Dest hdl&
_Source hdl&
x1 = wd2: y1 = hd2: x2 = wd2 + length: y2 = hd2: a = _Pi(.5)
Line (x1 + r1 * Cos(a), y1 + r1 * Sin(a))-(x2 + r2 * Cos(a), y2 + r2 * Sin(a)), colr
Line (x1 + r1 * Cos(a - _Pi), y1 + r1 * Sin(a - _Pi))-(x2 + r2 * Cos(a - _Pi), y2 + r2 * Sin(a - _Pi)), colr
arc x1, y1, r1, _Pi(.5), _Pi(1.5), colr
arc x2, y2, r2, _Pi(1.5), _Pi(.5), colr
paint4 x1, y1, c1, c2
_Dest 0
_Source 0
End Sub
'use radians
Sub arc (x, y, r, raBegin, raEnd, c As _Unsigned Long) ' updated 2020-11-24
' raStart is first angle clockwise from due East = 0 degrees
' arc will start drawing there and clockwise until raStop angle reached
'x, y origin, r = radius, c = color
Dim raStart, raStop, dStart, dStop, al, a, lastx, lasty
' Last time I tried to use this SUB it hung the program, possible causes:
' Make sure raStart and raStop are between 0 and 2pi.
' This sub does not have to be recursive, use GOSUB to do drawing to execute arc in one call.
'make copies before changing
raStart = raBegin: raStop = raEnd
While raStart < 0: raStart = raStart + _Pi(2): Wend
While raStart >= _Pi(2): raStart = raStart - _Pi(2): Wend
While raStop < 0: raStop = raStop + _Pi(2): Wend
While raStop >= _Pi(2): raStop = raStop - _Pi(2): Wend
If raStop < raStart Then
dStart = raStart: dStop = _Pi(2) - .00001
GoSub drawArc
dStart = 0: dStop = raStop
GoSub drawArc
Else
dStart = raStart: dStop = raStop
GoSub drawArc
End If
Exit Sub
drawArc: ' I am going back to lines instead of pset
al = 2 * _Pi * r * (dStop - dStart) / _Pi(2)
For a = dStart To dStop Step 1 / al
If a > dStart Then Line (lastx, lasty)-(x + r * Cos(a), y + r * Sin(a)), c
lastx = x + r * Cos(a): lasty = y + r * Sin(a)
Next
Return
End Sub
Sub cAnalysis (c As _Unsigned Long, outRed, outGrn, outBlu, outAlp)
outRed = _Red32(c): outGrn = _Green32(c): outBlu = _Blue32(c): outAlp = _Alpha32(c)
End Sub
Function Ink~& (c1 As _Unsigned Long, c2 As _Unsigned Long, fr##)
Dim R1, G1, B1, A1, R2, G2, B2, A2
cAnalysis c1, R1, G1, B1, A1
cAnalysis c2, R2, G2, B2, A2
Ink~& = _RGB32(R1 + (R2 - R1) * fr##, G1 + (G2 - G1) * fr##, B1 + (B2 - B1) * fr##, A1 + (A2 - A1) * fr##)
End Function
Sub paint4 (x0, y0, c1 As _Unsigned Long, c2 As _Unsigned Long) ' needs max, min functions
Dim fillColor As _Unsigned Long, W, H, parentF, tick, ystart, ystop, xstart, xstop, x, y
fillColor = Point(x0, y0)
'PRINT fillColor
W = _Width - 1: H = _Height - 1
Dim temp(W, H)
temp(x0, y0) = 1: parentF = 1
PSet (x0, y0), Ink~&(c1, c2, Abs((y0 - _Height / 2) / (_Height / 2)))
While parentF = 1
parentF = 0: tick = tick + 1
ystart = max(y0 - tick, 0): ystop = min(y0 + tick, H)
y = ystart
While y <= ystop
xstart = max(x0 - tick, 0): xstop = min(x0 + tick, W)
x = xstart
While x <= xstop
If Point(x, y) = fillColor And temp(x, y) = 0 Then
If temp(max(0, x - 1), y) Then
temp(x, y) = 1: parentF = 1: PSet (x, y), Ink~&(c1, c2, Abs((y - _Height / 2) / (_Height / 2)))
ElseIf temp(min(x + 1, W), y) Then
temp(x, y) = 1: parentF = 1: PSet (x, y), Ink~&(c1, c2, Abs((y - _Height / 2) / (_Height / 2)))
ElseIf temp(x, max(y - 1, 0)) Then
temp(x, y) = 1: parentF = 1: PSet (x, y), Ink~&(c1, c2, Abs((y - _Height / 2) / (_Height / 2)))
ElseIf temp(x, min(y + 1, H)) Then
temp(x, y) = 1: parentF = 1: PSet (x, y), Ink~&(c1, c2, Abs((y - _Height / 2) / (_Height / 2)))
End If
End If
x = x + 1
Wend
y = y + 1
Wend
Wend
End Sub
Function min (n1, n2)
If n1 > n2 Then min = n2 Else min = n1
End Function
Function max (n1, n2)
If n1 < n2 Then max = n2 Else max = n1
End Function
' Description:
' Started from a mod of Galleon's in Wiki that both scales and rotates an image.
' This version scales the x-axis and y-axis independently allowing rotations of image just by changing X or Y Scales
' making this tightly coded routine a very powerful and versatile image tool.
Sub RotoZoom3 (X As Long, Y As Long, Image As Long, xScale As Single, yScale As Single, radianRotation As Single)
' This assumes you have set your drawing location with _DEST or default to screen.
' X, Y - is where you want to put the middle of the image
' Image - is the handle assigned with _LOADIMAGE
' xScale, yScale - are shrinkage < 1 or magnification > 1 on the given axis, 1 just uses image size.
' These are multipliers so .5 will create image .5 size on given axis and 2 for twice image size.
' radianRotation is the Angle in Radian units to rotate the image
' note: Radian units for rotation because it matches angle units of other Basic Trig functions
' and saves a little time converting from degree.
' Use the _D2R() function if you prefer to work in degree units for angles.
Dim px(3) As Single: Dim py(3) As Single ' simple arrays for x, y to hold the 4 corners of image
Dim W&, H&, sinr!, cosr!, i&, x2&, y2& ' variables for image manipulation
W& = _Width(Image&): H& = _Height(Image&)
px(0) = -W& / 2: py(0) = -H& / 2 'left top corner
px(1) = -W& / 2: py(1) = H& / 2 ' left bottom corner
px(2) = W& / 2: py(2) = H& / 2 ' right bottom
px(3) = W& / 2: py(3) = -H& / 2 ' right top
sinr! = Sin(-radianRotation): cosr! = Cos(-radianRotation) ' rotation helpers
For i& = 0 To 3 ' calc new point locations with rotation and zoom
x2& = xScale * (px(i&) * cosr! + sinr! * py(i&)) + X: y2& = yScale * (py(i&) * cosr! - px(i&) * sinr!) + Y
px(i&) = x2&: py(i&) = y2&
Next
_MapTriangle _Seamless(0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
_MapTriangle _Seamless(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
b = b + ...
Posts: 40
Threads: 2
Joined: May 2022
ah nice!
hey now that we're doing QB64 trig functions versus mathematics what can we all say about sin(x)/x when x=0?
Posts: 2,700
Threads: 124
Joined: Apr 2022
Reputation:
134
10-06-2022, 12:54 PM
(This post was last modified: 10-06-2022, 12:55 PM by bplus.)
(10-06-2022, 12:16 PM)triggered Wrote: Ah yes, vince must be talking about the parametric clock:
Code: (Select All) Option _Explicit
Do Until _ScreenExists: Loop
_Title "Parametric Clock"
Dim Shared MainScreen As Long
Dim Shared BackScreen As Long
MainScreen = _NewImage(600, 600, 32)
BackScreen = _NewImage(600, 600, 32)
Screen MainScreen
Randomize Timer
Dim Shared pi As Double
Dim Shared phi As Double
pi = 4 * Atn(1)
phi = (1 + Sqr(5)) / 2
Type TimeValue
Hour As Integer
Minute As Integer
Second As Double
TenthSecond As Double
End Type
Type Vector
x As Double
y As Double
End Type
Type ClockHand
Center As Vector
HandPosition As Vector
Length As Double
Angle As Double
Shade As _Unsigned Long
End Type
Dim Shared TheTime As TimeValue
Dim Shared HourHand As ClockHand
Dim Shared MinuteHand As ClockHand
Dim Shared SecondHand As ClockHand
Dim Shared TenthSecondHand As ClockHand
Dim Shared Mode As Integer
Dim Shared ModeList(12) As Integer
Dim Shared TimeShift As Double
TimeShift = 0
HourHand.Center.x = 0
HourHand.Center.y = 0
HourHand.Length = 150
MinuteHand.Length = HourHand.Length / (phi)
SecondHand.Length = HourHand.Length / (phi ^ 2)
TenthSecondHand.Length = HourHand.Length / (phi ^ 3)
HourHand.Shade = _RGB32(200, 50, 50, 255)
MinuteHand.Shade = _RGB32(65, 105, 225, 255)
SecondHand.Shade = _RGB32(255, 165, 0, 255)
TenthSecondHand.Shade = _RGB32(138, 43, 226, 255)
Call InitializeModes
Mode = 12
Call PrepareClockface(1)
Do
Call KeyProcess
Call UpdateTime(Timer + TimeShift)
Call UpdateClock
Call DrawEverything
_KeyClear
_Limit 60
Loop
System
Sub InitializeModes
Dim k As Integer
For k = 1 To 12
ModeList(k) = k
Next
End Sub
Sub PrepareClockface (metric As Integer)
Dim p As Double
Dim q As Long
_Dest BackScreen
Cls
Call ccircle(0, 0, HourHand.Length, HourHand.Shade)
p = Rnd
For q = 0 To ((Mode * 3600) - (metric)) Step (metric)
Call UpdateTime(q)
Call UpdateClock
Call lineSmooth(SecondHand.Center.x, SecondHand.Center.y, SecondHand.HandPosition.x, SecondHand.HandPosition.y, _RGB32(255 * p, 255 * Rnd * 155, 255 * (1 - p), 30))
Next
For q = 0 To ((Mode * 3600) - (3600)) Step (3600)
Call UpdateTime(q)
Call UpdateClock
Call ccircle(HourHand.HandPosition.x, HourHand.HandPosition.y, 6, HourHand.Shade)
Call ccirclefill(HourHand.HandPosition.x, HourHand.HandPosition.y, 5, _RGB32(0, 0, 0, 255))
Next
_Dest MainScreen
End Sub
Sub KeyProcess
If (_KeyDown(32) = -1) Then ' Space
TimeShift = -Timer
End If
If ((_KeyDown(114) = -1) Or (_KeyDown(84) = -1)) Then ' r or R
TimeShift = 0
End If
If (_KeyDown(19200) = -1) Then ' Leftarrow
Call DecreaseMode
Call PrepareClockface(1)
_Delay .1
End If
If (_KeyDown(19712) = -1) Then ' Rightarrow
Call IncreaseMode
Call PrepareClockface(1)
_Delay .1
End If
If (_KeyDown(18432) = -1) Then
TimeShift = TimeShift + 60 ' Uparrow
End If
If (_KeyDown(20480) = -1) Then ' Downarrow
TimeShift = TimeShift - 60
End If
End Sub
Sub UpdateTime (z As Double)
Dim t As Double
t = z
TheTime.Hour = Int(t / 3600)
t = t - TheTime.Hour * 3600
TheTime.Hour = TheTime.Hour Mod Mode
If (TheTime.Hour = 0) Then TheTime.Hour = Mode
TheTime.Minute = Int(t / 60)
t = t - TheTime.Minute * 60
TheTime.Second = t
TheTime.TenthSecond = (TheTime.Second - Int(TheTime.Second))
End Sub
Sub UpdateClock
HourHand.Angle = -((TheTime.Hour + (TheTime.Minute / 60) + (TheTime.Second / 3600)) / Mode) * 2 * pi + (pi / 2)
MinuteHand.Angle = -((TheTime.Minute / 60) + (TheTime.Second / 3600)) * 2 * pi + (pi / 2)
SecondHand.Angle = -(TheTime.Second / 60) * 2 * pi + (pi / 2)
'TenthSecondHand.Angle = -(TheTime.TenthSecond) * 2 * pi + (pi / 2)
HourHand.HandPosition.x = HourHand.Center.x + HourHand.Length * Cos(HourHand.Angle)
HourHand.HandPosition.y = HourHand.Center.y + HourHand.Length * Sin(HourHand.Angle)
MinuteHand.Center.x = HourHand.HandPosition.x
MinuteHand.Center.y = HourHand.HandPosition.y
MinuteHand.HandPosition.x = MinuteHand.Center.x + MinuteHand.Length * Cos(MinuteHand.Angle)
MinuteHand.HandPosition.y = MinuteHand.Center.y + MinuteHand.Length * Sin(MinuteHand.Angle)
SecondHand.Center.x = MinuteHand.HandPosition.x
SecondHand.Center.y = MinuteHand.HandPosition.y
SecondHand.HandPosition.x = SecondHand.Center.x + SecondHand.Length * Cos(SecondHand.Angle)
SecondHand.HandPosition.y = SecondHand.Center.y + SecondHand.Length * Sin(SecondHand.Angle)
'TenthSecondHand.Center.x = SecondHand.HandPosition.x
'TenthSecondHand.Center.y = SecondHand.HandPosition.y
'TenthSecondHand.HandPosition.x = TenthSecondHand.Center.x + TenthSecondHand.Length * Cos(TenthSecondHand.Angle)
'TenthSecondHand.HandPosition.y = TenthSecondHand.Center.y + TenthSecondHand.Length * Sin(TenthSecondHand.Angle)
End Sub
Sub DrawEverything
Cls
_PutImage (0, 0)-(_Width, _Height), BackScreen, MainScreen, (0, 0)-(_Width, _Height)
Call DrawModeList
Call DrawHUD
Call DrawClockHands
Call DrawDigitalClock
_Display
End Sub
Sub DrawModeList
Dim k As Integer
For k = 1 To UBound(ModeList)
If (Mode = k) Then
Color _RGB32(255, 255, 0, 255), _RGB32(0, 0, 255, 255)
Else
Color _RGB32(100, 100, 100, 255), _RGB32(0, 0, 0, 0)
End If
_PrintString ((4 + 5 * k) * 8, _Height - (1) * 16), LTrim$(RTrim$(Str$(ModeList(k))))
Next
Color _RGB32(200, 200, 0, 255), _RGB32(0, 0, 0, 0)
_PrintString ((4 + 1) * 8, _Height - (1) * 16), ">"
_PrintString ((4 + 5 * (UBound(ModeList) + 1)) * 8, _Height - (1) * 16), "<"
End Sub
Sub IncreaseMode
If (Mode < 12) Then
Mode = Mode + 1
Else
Mode = 1
End If
End Sub
Sub DecreaseMode
If (Mode = 1) Then
Mode = 12
Else
Mode = Mode - 1
End If
End Sub
Sub DrawClockHands
Dim k As Double
Dim ctmp As _Unsigned Long
Dim SeedLength As Double
SeedLength = 12
For k = 0 To 1 Step .01
ctmp = ColorMix(_RGB32(0, 0, 255, 255), HourHand.Shade, k)
ctmp = _RGB32(_Red32(ctmp), _Green32(ctmp), _Blue32(ctmp), k * _Alpha32(ctmp))
Call ccirclefill(HourHand.Center.x + (k * HourHand.Length) * Cos(HourHand.Angle), HourHand.Center.y + (k * HourHand.Length) * Sin(HourHand.Angle), k * SeedLength, ctmp)
Next
For k = 0 To 1 Step .01
ctmp = ColorMix(HourHand.Shade, MinuteHand.Shade, k)
ctmp = _RGB32(_Red32(ctmp), _Green32(ctmp), _Blue32(ctmp), _Alpha32(ctmp))
Call ccirclefill(MinuteHand.Center.x + (k * MinuteHand.Length) * Cos(MinuteHand.Angle), MinuteHand.Center.y + (k * MinuteHand.Length) * Sin(MinuteHand.Angle), SeedLength * (1 - k / phi), ctmp)
Next
For k = 0 To 1 Step .005
ctmp = ColorMix(MinuteHand.Shade, SecondHand.Shade, k)
ctmp = _RGB32(_Red32(ctmp), _Green32(ctmp), _Blue32(ctmp), _Alpha32(ctmp))
Call ccirclefill(SecondHand.Center.x + (k * SecondHand.Length) * Cos(SecondHand.Angle), SecondHand.Center.y + (k * SecondHand.Length) * Sin(SecondHand.Angle), (SeedLength * (1 - 1 / phi)) * (1 - k), ctmp)
Next
'FOR k = 0 TO 1 STEP .005
'ctmp = ColorMix(SecondHand.Shade, TenthSecondHand.Shade, k)
'ctmp = _RGB32(_RED32(ctmp), _GREEN32(ctmp), _BLUE32(ctmp), _ALPHA32(ctmp))
'CALL ccirclefill(TenthSecondHand.Center.x + (k * TenthSecondHand.Length) * COS(TenthSecondHand.Angle), TenthSecondHand.Center.y + (k * TenthSecondHand.Length) * SIN(TenthSecondHand.Angle), (SeedLength * (1 - 1 / phi)) * (1 - k), ctmp)
'NEXT
Call DrawPulley(HourHand.Center.x, HourHand.Center.x, 0, HourHand.HandPosition.x, HourHand.HandPosition.y, SeedLength + 2, _RGB32(255, 255, 255, 255))
Call DrawPulley(HourHand.HandPosition.x, HourHand.HandPosition.y, SeedLength + 2, MinuteHand.HandPosition.x, MinuteHand.HandPosition.y, (SeedLength * (1 - 1 / phi)) + 1, _RGB32(255, 255, 255, 255))
Call DrawPulley(MinuteHand.HandPosition.x, MinuteHand.HandPosition.y, (SeedLength * (1 - 1 / phi)) + 1, SecondHand.HandPosition.x, SecondHand.HandPosition.y, 0, _RGB32(255, 255, 255, 255))
'CALL DrawPulley(SecondHand.HandPosition.x, SecondHand.HandPosition.y, (SeedLength * (1 - 1 / phi)) + 1, TenthSecondHand.HandPosition.x, TenthSecondHand.HandPosition.y, 0, _RGB32(255, 255, 255, 255))
End Sub
Sub DrawDigitalClock
Dim t As String
Color _RGB32(200, 200, 0, 255), _RGB32(0, 0, 0, 0)
Dim h As String
Dim m As String
Dim s As String
Dim n As String
h = LTrim$(RTrim$(Str$(TheTime.Hour)))
If Len(h) = 1 Then h = "0" + h
m = LTrim$(RTrim$(Str$(TheTime.Minute)))
If Len(m) = 1 Then m = "0" + m
s = LTrim$(RTrim$(Str$(Int(TheTime.Second))))
If Len(s) = 1 Then s = "0" + s
n = LTrim$(RTrim$(Str$((Int(10 * TheTime.TenthSecond)))))
t = h + ":" + m + ":" + s ' + ":" + n
Locate 1, (_Width / 8) / 2 - Len(t) / 2
Print t
End Sub
Sub DrawHUD
Color _RGB32(0, 200, 200, 255), _RGB32(0, 0, 0, 0)
Locate 1, 2: Print "SPACE = Stopwatch"
Locate 2, 2: Print " R = Reset"
Locate 1, 59: Print "UpArrow = Time +"
Locate 2, 59: Print "DnArrow = Time -"
End Sub
Function ColorMix~& (Shade1 As _Unsigned Long, Shade2 As _Unsigned Long, param As Double)
ColorMix~& = _RGB32((1 - param) * _Red32(Shade1) + param * _Red32(Shade2), (1 - param) * _Green32(Shade1) + param * _Green32(Shade2), (1 - param) * _Blue32(Shade1) + param * _Blue32(Shade2))
End Function
Sub cpset (x1, y1, col As _Unsigned Long)
PSet (_Width / 2 + x1, -y1 + _Height / 2), col
End Sub
Sub cline (x1 As Double, y1 As Double, x2 As Double, y2 As Double, col As _Unsigned Long)
Line (_Width / 2 + x1, -y1 + _Height / 2)-(_Width / 2 + x2, -y2 + _Height / 2), col
End Sub
Sub ccircle (x1 As Double, y1 As Double, rad As Double, col As _Unsigned Long)
Circle (_Width / 2 + x1, -y1 + _Height / 2), rad, col
End Sub
Sub ccirclefill (x1 As Double, y1 As Double, rad As Double, col As _Unsigned Long)
Call CircleFill(_Width / 2 + x1, -y1 + _Height / 2, rad, col)
End Sub
Sub CircleFill (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
' CX = center x coordinate
' CY = center y coordinate
' R = radius
' C = fill color
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 DrawPulley (x1 As Double, y1 As Double, rad1 As Double, x2 As Double, y2 As Double, rad2 As Double, col As _Unsigned Long)
Dim ang As Double
ang = _Atan2(y2 - y1, x2 - x1) + pi / 2
Call lineSmooth(x1 + rad1 * Cos(ang), y1 + rad1 * Sin(ang), x2 + rad2 * Cos(ang), y2 + rad2 * Sin(ang), col)
Call lineSmooth(x1 - rad1 * Cos(ang), y1 - rad1 * Sin(ang), x2 - rad2 * Cos(ang), y2 - rad2 * Sin(ang), col)
Call ccircle(x1, y1, rad1, col)
Call ccircle(x2, y2, rad2, col)
End Sub
Sub lineSmooth (x0, y0, x1, y1, c As _Unsigned Long)
'Inspiration credit: {(FellippeHeitor)(qb64.org)(2020)}
' {https://en.wikipedia.org/w/index.php?title=Xiaolin_Wu%27s_line_algorithm&oldid=852445548}
'Edit: {(STxAxTIC)(2020-11-20)(Correction to alpha channel.)}
Dim plX As Integer, plY As Integer, plI
Dim steep As _Byte
steep = Abs(y1 - y0) > Abs(x1 - x0)
If steep Then
Swap x0, y0
Swap x1, y1
End If
If x0 > x1 Then
Swap x0, x1
Swap y0, y1
End If
Dim dx, dy, gradient
dx = x1 - x0
dy = y1 - y0
gradient = dy / dx
If dx = 0 Then
gradient = 1
End If
'handle first endpoint
Dim xend, yend, xgap, xpxl1, ypxl1
xend = _Round(x0)
yend = y0 + gradient * (xend - x0)
xgap = (1 - ((x0 + .5) - Int(x0 + .5)))
xpxl1 = xend 'this will be used in the main loop
ypxl1 = Int(yend)
If steep Then
plX = ypxl1
plY = xpxl1
plI = (1 - (yend - Int(yend))) * xgap
Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
plX = ypxl1 + 1
plY = xpxl1
plI = (yend - Int(yend)) * xgap
Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
Else
plX = xpxl1
plY = ypxl1
plI = (1 - (yend - Int(yend))) * xgap
Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
plX = xpxl1
plY = ypxl1 + 1
plI = (yend - Int(yend)) * xgap
Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
End If
Dim intery
intery = yend + gradient 'first y-intersection for the main loop
'handle second endpoint
Dim xpxl2, ypxl2
xend = _Round(x1)
yend = y1 + gradient * (xend - x1)
xgap = ((x1 + .5) - Int(x1 + .5))
xpxl2 = xend 'this will be used in the main loop
ypxl2 = Int(yend)
If steep Then
plX = ypxl2
plY = xpxl2
plI = (1 - (yend - Int(yend))) * xgap
Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
plX = ypxl2 + 1
plY = xpxl2
plI = (yend - Int(yend)) * xgap
Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
Else
plX = xpxl2
plY = ypxl2
plI = (1 - (yend - Int(yend))) * xgap
Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
plX = xpxl2
plY = ypxl2 + 1
plI = (yend - Int(yend)) * xgap
Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
End If
'main loop
Dim x
If steep Then
For x = xpxl1 + 1 To xpxl2 - 1
plX = Int(intery)
plY = x
plI = (1 - (intery - Int(intery)))
Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
plX = Int(intery) + 1
plY = x
plI = (intery - Int(intery))
Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
intery = intery + gradient
Next
Else
For x = xpxl1 + 1 To xpxl2 - 1
plX = x
plY = Int(intery)
plI = (1 - (intery - Int(intery)))
Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
plX = x
plY = Int(intery) + 1
plI = (intery - Int(intery))
Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
intery = intery + gradient
Next
End If
Exit Sub
'plot:
' Change to regular PSET for standard coordinate orientation.
'Call cpset(plX, plY, _RGB32(_Red32(c), _Green32(c), _Blue32(c), plI * _Alpha32(c)))
'Return
End Sub
This is the kind of conversions you have to do when you insist on Cartesia:
Code: (Select All) Sub cpset (x1, y1, col As _Unsigned Long)
PSet (_Width / 2 + x1, -y1 + _Height / 2), col
End Sub
Sub cline (x1 As Double, y1 As Double, x2 As Double, y2 As Double, col As _Unsigned Long)
Line (_Width / 2 + x1, -y1 + _Height / 2)-(_Width / 2 + x2, -y2 + _Height / 2), col
End Sub
Sub ccircle (x1 As Double, y1 As Double, rad As Double, col As _Unsigned Long)
Circle (_Width / 2 + x1, -y1 + _Height / 2), rad, col
End Sub
Sub ccirclefill (x1 As Double, y1 As Double, rad As Double, col As _Unsigned Long)
Call CircleFill(_Width / 2 + x1, -y1 + _Height / 2, rad, col)
End Sub
Hey are you STx? This is totally his style! ;-))
b = b + ...
Posts: 2,700
Threads: 124
Joined: Apr 2022
Reputation:
134
10-06-2022, 01:25 PM
(This post was last modified: 10-06-2022, 01:26 PM by bplus.)
(10-06-2022, 12:51 PM)triggered Wrote: ah nice!
hey now that we're doing QB64 trig functions versus mathematics what can we all say about sin(x)/x when x=0?
Looks like 1 ref: https://www.google.com/search?client=ope...8&oe=UTF-8
Internet says it's 1.
b = b + ...
Posts: 224
Threads: 7
Joined: Apr 2022
Reputation:
14
nice, there's also this B+ mod from back in the qb64 golden age, it's loaded with trig
Code: (Select All) CONST g = &HFF000088 'hnd5s and numbers
pi = _PI
sw = 800
sh = 600
s$ = "33111121131112121222132114211123113231"
SCREEN _NEWIMAGE(sw, sh, 32)
hhand& = _NEWIMAGE(360, 80, 32) ' make hour hand image and save
b = -pi / 2
PSET (sw / 2, sh / 2)
FOR a = 0 TO pi STEP 0.01
x = 140 * (0.8 * COS(a)) ^ 5 * ABS(3 * COS(8 * a) ^ 2) * SIN(a) * COS(b) - 176 * SIN(a) * SIN(b)
y = 140 * (0.8 * COS(a)) ^ 5 * ABS(3 * COS(8 * a) ^ 2) * SIN(a) * SIN(b) + 176 * SIN(a) * COS(b)
LINE -(sw / 2 + x, sh / 2 + y), g
NEXT
PAINT (sw / 2 + 10, sh / 2), g, g
PAINT (sw / 2 + 60, sh / 2), g, g
PAINT (sw / 2 + 120, sh / 2), g, g
PAINT (sw / 2 + 160, sh / 2), g, g
_PUTIMAGE , 0, hhand&, (sw / 2 - 180, sh / 2 - 39)-STEP(359, 79)
'check
'CLS
'RotoZoom sw / 2, sh / 2, hhand&, 1, 0
'CIRCLE (sw / 2, sh / 2), 6, &HFFFFFF00
SCREEN _NEWIMAGE(sw, sh, 32) ' cls screen without cls keep back transparent
mhand& = _NEWIMAGE(560, 80, 32) 'make minute hand
b = -pi / 2
FOR a = 0 TO pi STEP 0.01
x = 55 * (COS(a)) ^ 5 * ABS(2 * (COS(4 * a)) ^ 2 - 0.5) * SIN(a) * COS(b) - 270 * SIN(a) * SIN(b)
y = 55 * (COS(a)) ^ 5 * ABS(2 * (COS(4 * a)) ^ 2 - 0.5) * SIN(a) * SIN(b) + 270 * SIN(a) * COS(b)
LINE -(sw / 2 + x, sh / 2 + y), g
NEXT
PAINT (sw / 2 + 20, sh / 2), g, g
PAINT (sw / 2 + 120, sh / 2), g, g
PAINT (sw / 2 + 160, sh / 2), g, g
_PUTIMAGE , 0, mhand&, (sw / 2 - 280, sh / 2 - 39)-STEP(559, 79)
'check
'CLS
'RotoZoom sw / 2, sh / 2, mhand&, 1, 36
'RotoZoom sw / 2, sh / 2, hhand&, 1, 150
'CIRCLE (sw / 2, sh / 2), 6, &HFFFFFF00
CLS
face& = _NEWIMAGE(_WIDTH, _HEIGHT, 32)
fcirc sw / 2, sh / 2, 280 + 10, &HFFFF0000
fcirc sw / 2, sh / 2, 280 + 5, &HFFFFFFFF
fcirc sw / 2, sh / 2, 205, &HFFDDDDFF
FOR a = 0 TO 2 * pi STEP 0.01
x = 100 * COS(a) + 100 * COS(14 * a)
y = 100 * SIN(a) + 100 * SIN(14 * a)
IF a = 0 THEN PSET (sw / 2 + x, sh / 2 + y) ELSE LINE -(sw / 2 + x, sh / 2 + y), _RGB(0, 255, 128)
NEXT
fcirc sw / 2, sh / 2, 12, &HFFFFFF00
fcirc sw / 2, sh / 2, 6, &HFF000000
CIRCLE (sw / 2, sh / 2), 210 - 5, &HFF000000
CIRCLE (sw / 2, sh / 2), 280 + 5, &HFF000000
CIRCLE (sw / 2, sh / 2), 280 + 10, &HFF000000
a = -pi / 2
COLOR g
DO WHILE i < LEN(s$) - 1
i = i + 1
c$ = MID$(s$, i, 1)
b = a - 0.05 * (VAL(c$)) * 0.5
FOR k = 0 TO VAL(c$) - 1
i = i + 1
SELECT CASE MID$(s$, i, 1)
CASE "1"
LINE (sw / 2 + 210 * COS(b), sh / 2 + 210 * SIN(b))-STEP(70 * COS(b), 70 * SIN(b))
CASE "2"
IF VAL(c$) > 1 THEN c = b + 0.05 * 0.5 * ((k = 0) - (k <> 0)) ELSE c = b
LINE (sw / 2 + 210 * COS(c), sh / 2 + 210 * SIN(c))-STEP(70 * COS(c - 0.05 * 3), 70 * SIN(c - 0.05 * 3))
LINE (sw / 2 + 210 * COS(c), sh / 2 + 210 * SIN(c))-STEP(70 * COS(c + 0.05 * 3), 70 * SIN(c + 0.05 * 3))
CASE "3"
IF VAL(c$) > 1 THEN c = b + 0.05 * 0.5 * ((k = 0) - (k <> 0)) ELSE c = b
LINE (sw / 2 + 210 * COS(c - 0.05 * 0.8), sh / 2 + 210 * SIN(c - 0.05 * 0.8))-(sw / 2 + 280 * COS(c + 0.05 * 0.8), sh / 2 + 280 * SIN(c + 0.05 * 0.8))
LINE (sw / 2 + 210 * COS(c + 0.05 * 0.8), sh / 2 + 210 * SIN(c + 0.05 * 0.8))-(sw / 2 + 280 * COS(c - 0.05 * 0.8), sh / 2 + 280 * SIN(c - 0.05 * 0.8))
END SELECT
b = b + 0.05
NEXT
a = a + pi / 6
LOOP
_PUTIMAGE , 0, face&
DO
_PUTIMAGE , face&, 0
m = VAL(MID$(TIME$, 4, 2)) / 60
h = VAL(LEFT$(TIME$, 2))
IF h > 12 THEN h = h - 12
h = (h / 12 + m / 12) * 360
RotoZoom sw / 2, sh / 2, hhand&, 1, h - 90
RotoZoom sw / 2, sh / 2, mhand&, 1, m * 360 - 90
_DISPLAY
_LIMIT 100
LOOP UNTIL _KEYHIT = 27
SLEEP
SYSTEM
SUB RotoZoom (X AS LONG, Y AS LONG, hdl AS LONG, Scale AS SINGLE, Rotation AS SINGLE)
DIM px(3) AS SINGLE: DIM py(3) AS SINGLE
W& = _WIDTH(hdl): H& = _HEIGHT(hdl)
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(-Rotation / 57.2957795131): cosr! = COS(-Rotation / 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), hdl TO(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
_MAPTRIANGLE (0, 0)-(W& - 1, 0)-(W& - 1, H& - 1), hdl TO(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
END SUB
'from Steve Gold standard
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
|
Math's Trig Versus Basic's Trig Functions
