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 + ...