10-07-2022, 12:42 AM
Oh look it's almost that time of the month!
Code: (Select All)
_Title "Halloween Time" 'B+ 2019-10-22
' 2019-10-23 attempt to change transparency gradually to loose blinking
Const m = 350
Screen _NewImage(720, 720, 32)
_ScreenMove 500, 10
Dim Shared sprt(15, 15)
For y = 0 To 15
For x = 0 To 15
Read sprt(x, y)
Next
Next
Dim Shared sprt2(15, 15)
For y = 0 To 15
For x = 0 To 15
Read sprt2(x, y)
Next
Next
Dim Shared bx, by, bf
dt = 1
Do
Cls
'angles
hour% = Int(t# / 3600)
If hour% > 12 Then showHr# = t# / 3600 - 12 Else showHr# = t# / 3600
min# = t# / 60 - hour% * 60
sec# = t# - hour% * 3600 - Int(min#) * 60
'face
For r = 340 To 0 Step -1
If r < 150 Then
c~& = _RGB32(200 - 50 * r / 100, 150 - 100 * r / 100, 0)
Else
c~& = _RGB32(200 - 50 * r / 100, 150 - 100 * r / 100, 40 - r / 340)
End If
fcirc m, m, r, c~&
Next
For i = 0 To 59
If i Mod 5 = 0 Then r = 2 Else r = 1
Circle (350 + 330 * Cos(i * _Pi(2 / 60)), 350 + 330 * Sin(i * _Pi(2 / 60))), r
Next
'some triangles
t = t + dt
If t > 180 Then dt = -dt: t = 180
If t < 1 Then dt = -dt: t = 1
ry~& = _RGBA32(255, 255, 140, t)
ftri 290, 335, 305, 365, 335, 350, ry~&
ftri 410, 335, 395, 365, 365, 350, ry~&
ftri 330, 380, 350, 360, 370, 380, ry~&
ftri 290, 420, 350, 400, 350, 410, ry~&
ftri 410, 420, 350, 400, 350, 410, ry~&
fcirc m, m, 150, ry~& 'more orange glow
'arms and legs
x1 = 210 * Cos(showHr# * _Pi(2 / 12) - _Pi / 2)
y1 = 210 * Sin(showHr# * _Pi(2 / 12) - _Pi / 2)
x2 = 260 * Cos(min# * _Pi(2 / 60) - _Pi / 2)
y2 = 260 * Sin(min# * _Pi(2 / 60) - _Pi / 2)
Line (m, m)-Step(x1, y1), _RGB32(255, 255, 255, 50)
Line (m, m)-Step(x2, y2), _RGB32(255, 255, 255, 50)
drawSpinner m + x1, m + y1, .5, _Atan2(y1, x1), &HFF331800
drawSpinner m + x2, m + y2, .3, _Atan2(y2, x2), &HFF221100
'seconds fly by...
bx = 350 + 290 * Cos(sec# * _Pi(2 / 60) - _Pi / 2)
by = 350 + 290 * Sin(sec# * _Pi(2 / 60) - _Pi / 2)
drawb
_Display
_Limit 5
t# = Timer
Loop Until _KeyDown(27)
Data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
Data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
Data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
Data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
Data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
Data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
Data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
Data 0,0,1,1,0,0,0,0,0,0,0,1,1,0,0,0
Data 1,1,0,0,1,0,0,1,0,0,1,0,0,1,1,0
Data 0,0,0,0,0,1,1,1,1,1,0,0,0,0,0,0
Data 0,0,0,0,0,0,1,1,1,0,0,0,0,0,0,0
Data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
Data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
Data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
Data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
Data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
Data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
Data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
Data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
Data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
Data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
Data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
Data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
Data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
Data 0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0
Data 0,0,0,0,0,1,1,1,1,1,1,0,0,0,0,0
Data 0,0,0,0,1,0,1,1,1,0,0,1,0,0,0,0
Data 0,0,0,1,0,0,0,0,0,0,0,0,1,0,0,0
Data 0,0,1,0,0,0,0,0,0,0,0,0,0,1,0,0
Data 0,1,0,0,0,0,0,0,0,0,0,0,0,0,1,0
Data 0,1,0,0,0,0,0,0,0,0,0,0,0,0,1,0
Data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
Sub drawb
bf = (bf + 1) Mod 5
sz = 3
If bf = 0 Then
For y = 0 To 15
For x = 0 To 15
If sprt2(x, y) Then Line (x * sz + bx - 7.5 * sz, .5 * y * sz + by - 7.5 * sz)-Step(sz, sz), _RGB32(0, 0, 0), BF
Next
Next
Else
For y = 0 To 15
For x = 0 To 15
If sprt(x, y) Then Line (x * sz + bx - 7.5 * sz, y * sz + by - 7.5 * sz)-Step(sz, sz), _RGB32(0, 0, 0), BF
Next
Next
End If
End Sub
Sub drawSpinner (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 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 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 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 0, x1, y1, r, .7 * r, heading + _Pi, _RGB32(red, green, blue)
End Sub
Sub drawLink (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 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 (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 x1, y1, x2, y2, x4, y4, c
ftri x3, y3, x4, y4, x1, y1, c
End Sub
Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim a&
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
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 max 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 max = a + 1 Else max = b + 1
mx2 = max + max
tef = _NewImage(mx2, mx2)
_Dest tef
_Source tef 'point wont read without this!
For k = 0 To 6.2832 + .05 Step .1
i = max + a * Cos(k) * Cos(ang) + b * Sin(k) * Sin(ang)
j = max + 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 - max, y + y0 - max)-(xright(y) + x0 - max, y + y0 - max), c, BF
Next
_FreeImage tef
End Sub
b = b + ...