Thanks for the idea James. I had done this already for a Christmas app I made a few years ago. So today I added the snowflakes to it instead of just round snow. Check it out:
Code: (Select All)
'Snowflakes 2 by SierraKen
'July 16, 2022
'Thanks to B+ for the snowflake design!
'Thanks to James D. Jarvis for the idea.
Screen _NewImage(800, 600, 32)
Dim rr(600)
Dim stackx(2000), stacky(2000), stackr(2000)
Dim cx As Integer, cy As Integer, r As Integer, c As _Unsigned Long
Dim xc(2000), yc(2000), fx(2000), x(2000), y(2000)
size = 1
_Title "Snowflakes 2"
Do
_Limit 20
a$ = InKey$
If a$ = Chr$(27) Then End
'Hill
For sz = .25 To 700 Step .25
cl = cl + .05
Circle (400, 1100), sz, _RGB32(0, cl, 0)
Next sz
cl2 = cl
cl = 0
'Tree
tx = 390: ty = 400: r = 10: c = _RGB32(255, 0, 0)
Line (tx, ty)-(tx + 20, ty - 74), _RGB32(183, 127, 127), BF
Line (tx, ty - 75)-(tx + 20, ty - 75), _RGB32(127, 255, 127)
'left side
Line (tx, ty - 75)-(tx - 150, ty - 75), _RGB32(127, 255, 127)
Line (tx - 150, ty - 75)-(tx, ty - 150), _RGB32(127, 255, 127)
cx = tx - 150: cy = ty - 75
'fillCircle cx, cy, r, c
Line (tx, ty - 150)-(tx - 100, ty - 150), _RGB32(127, 255, 127)
Line (tx - 100, ty - 150)-(tx, ty - 200), _RGB32(127, 255, 127)
cx = tx - 100: cy = ty - 150
'fillCircle cx, cy, r, c
Line (tx, ty - 200)-(tx - 50, ty - 200), _RGB32(127, 255, 127)
Line (tx - 50, ty - 200)-(tx + 5, ty - 250), _RGB32(127, 255, 127)
cx = tx - 50: cy = ty - 200
'fillCircle cx, cy, r, c
'right side
Line (tx + 20, ty - 75)-(tx + 170, ty - 75), _RGB32(127, 255, 127)
Line (tx + 170, ty - 75)-(tx + 20, ty - 150), _RGB32(127, 255, 127)
cx = tx + 170: cy = ty - 75
'fillCircle cx, cy, r, c
Line (tx + 20, ty - 150)-(tx + 120, ty - 150), _RGB32(127, 255, 127)
Line (tx + 120, ty - 150)-(tx + 20, ty - 200), _RGB32(127, 255, 127)
cx = tx + 120: cy = ty - 150
'fillCircle cx, cy, r, c
Line (tx + 20, ty - 200)-(tx + 70, ty - 200), _RGB32(127, 255, 127)
Line (tx + 70, ty - 200)-(tx + 5, ty - 250), _RGB32(127, 255, 127)
cx = tx + 70: cy = ty - 200
'fillCircle cx, cy, r, c
cx = tx + 5: cy = ty - 260
r = 10
c = _RGB32(255, 255, 127)
'fillCircle cx, cy, r, c
Paint (tx, ty - 77), _RGB32(127, 255, 127)
If Rnd > .96 Then
tt = tt + 1
If tt > 495 Then tt = 0
xc(tt) = Rnd * _Width
yc(tt) = -40
rr(tt) = (Rnd * 20) + 10
fx(tt) = (Rnd * 8) - 4
End If
For t = 1 To tt
yc(t) = yc(t) + 1
yc(t) = yc(t) + (Rnd * 5)
fx(t) = fx(t) + (Rnd * 8) - 4
For m = 1 To 13 - 1
For angle = 0 To 720 Step 360 / 11
x(t) = xc(t) + rr(t) * Cos(m * _D2R(angle) - _Pi / 2)
y(t) = yc(t) + rr(t) * Sin(m * _D2R(angle) - _Pi / 2)
If angle = 0 Then PSet (x(t) + fx(t), y(t)) Else Line -(x(t) + fx(t), y(t))
Line (xc(t) + fx(t), yc(t))-(x(t) + fx(t), y(t))
Next
Next m
cl2 = Int(cl2)
For check = 100 To 200 Step .25
If Point(xc(t), yc(t) + rr(t) + 1) = _RGB32(0, check, 0) Then GoTo stacked:
Next check
If Point(xc(t), yc(t) + rr(t) + 1) = _RGB32(127, 255, 127) Then GoTo stacked:
'If Point(xc(t), yc(t) + rr(t) + 1) = _RGB32(255, 255, 127) Then GoTo stacked:
'If Point(xc(t), yc(t) + rr(t) + 1) = _RGB32(255, 0, 0) Then GoTo stacked:
Next t
nex:
If snow <> 0 Then
For sn = 1 To snow
cx = stackx(sn)
cy = stacky(sn)
r = stackr(sn)
c = _RGB32(252, 252, 252)
fillCircle cx, cy, r, c
Next sn
End If
_Display
Line (0, 0)-(_Width, _Height), _RGB32(0, 0, 0), BF
Loop
stacked:
snow = snow + 1
If snow > 1800 Then snow = 1: size = 1
If snow / 200 = Int(snow / 200) Then size = size * 1.4
stackx(snow) = xc(t)
stacky(snow) = yc(t) - (size / 2) + rr(t)
stackr(snow) = (rr(t) / 2) + size
xc(t) = -200: yc(t) = 800: rr(t) = 0
GoTo nex:
'from Steve Gold standard
Sub fillCircle (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