(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 SubHey are you STx? This is totally his style! ;-))
b = b + ...