Screensaver: Super Simple Snowfall (with accumulation)

[Dustinian]

Here is my own, simple snowfall program (with accumulation)! This was my first attempt at animation in QBasic. I heavily commented it, in case it helps others. I'm also very open to feedback!

Code: QB64: [Select]

1. 'SNOWFALL.BAS
2. '============
3.  
4. 'DESCRIPTION
5. '-----------
6. '   A holiday screensaver for QBasic.
7.  
8. 'AUTHOR
9. '------
10. '   Dustinian Camburides
11.  
12. 'PLATFORM
13. '--------
14. '   Written in QB64.
15. '   But designed to be QBasic/QuickBasic compatible.
16. '       Although, I haven't tested QBasic / QuickBasic compatability yet.
17.  
18. 'VERSION
19. '-------
20. '1.0, 2021-12-18: First working version.
21. '1.1, 2021-12-19: I was excited to keep working!
22. '   Added page flipping to reduce flicker!
23. '   Added background snowflakes at a smaller speed and dimmer color!
24. '   Set the formula to advance snowflakes to actually use the FALLSPEED constant.
25. '   Also started the timer before calculating all the snowflakes to smooth out the animation.
26.  
27. 'PLANNED ENHANCEMENTS
28. '--------------------
29. 'Maybe next year I will add...
30. '   - Actual, tested QBasic compatability (need to to a DosBox install and find a copy of QBasic).
31. '   - A more complex data structure for snowflakes that can store both X and Y coordinates in a dynamic array of user-defined types... so it can support more than one snowflake per column... and mabe some drift back-and-forth in the X-axis.
32.  
33. 'HOLIDAY MESSAGE
34. '---------------
35. 'But for now, I'm happy that I have my first QB64 program that has animation. Happy Holidays!
36.  
37. 'SUBS
38. Declare Sub CalculateSnowflakeColumn (SnowFlake As Integer, Accumulation As Integer, Rows As Integer, FallSpeed As Integer, Odds As Single)
39. Declare Sub DrawSnowflakeColumn (Snowflake As Integer, Accumulation As Integer, Column As Integer, Rows As Integer, SnowColor As Integer)
40.  
41. 'CONSTANTS
42. Const FALLSPEED = 1 'Snow falls this many pixels at a time.
43. Const COLUMNS = 319 'The screen is 320 pixels across (0-319) in Screen 7.
44. Const ROWS = 199 'The screen is 200 pixels tall (0-199) in Screen 7.
45. Const DELAY = 0.04 'The number of seconds between snowflake recalculation / re-draw... QBasic can't detect less than 0.04 seconds...
46. Const ODDS = 0.7 'The % chance a snowflake will be added to a column that doesn't have a snowflake... anything over 1% will results in "waves" of snowflakes.
47.  
48. 'VARIABLES
49. Dim intSnowflakes(COLUMNS) As Integer 'Array that holds the current Y-coordinate for a snowflake in this column... this means there can only be one snowflake per column at any given time.
50. Dim intBackgroundSnowflakes(COLUMNS) As Integer 'Same as above, but for the background.
51. Dim intAccumulation(COLUMNS) As Integer 'Array that holds the current accumulated pixels of snow in this column.
52. Dim intBackgroundAccumulation(COLUMNS) As Integer ' Same as above, but for the background.
53. Dim intColumn As Integer 'The current column in the loop.
54. Dim sngStart As Single 'The timer at the start of the delay loop.
55. Dim intBackgroundFrame As Integer 'Used to track whether the current frame will move the background snow...
56. Dim intFullColumns As Integer 'Used to track the number of columns that are full of snow...
57.  
58. 'INITIALIZE VARIABLES
59. 'For each column...
60. For intColumn = 0 To COLUMNS
61.     'Set all snowflakes to -1, indicating there is no snowflake in this column.
62.     intSnowflakes(intColumn) = -1
63.     intBackgroundSnowflakes(intColumn) = -1
64.     'Set all accumulation to 0, indicating there is no accumulation in this column.
65.     intAccumulation(intColumn) = 0
66.     intBackgroundAccumulation(intColumn) = 0
67. Next intColumn
68. intBackgroundFrame = 0
69. Randomize Timer
70.  
71. 'INITIALIZE SCREEN
72. 'Set the screen to mode 7 with an active page (where the cls, pset, and line commands occur) of 0 and a visible page (that the user sees) of 1.
73. Screen 7, , 0, 1
74. Color 15, 0
75. Cls
76.  
77. 'PROGRAM
78. 'While no key has been pressed...
79. While InKey$ = "" And intFullColumns < COLUMNS
80.     'Set the delay timer...
81.     Timer On
82.     sngStart = Timer
83.     'Reset the number of full columns...
84.     intFullColumns = 0
85.     'Flip whether the background snow will move on or off...
86.     intBackgroundFrame = Not intBackgroundFrame
87.     'For each column... calculate the changes to the snowfall...
88.     For intColumn = 0 To COLUMNS
89.         'If this is a background frame...
90.         If intBackgroundFrame Then
91.             'Recalculate background snow...
92.             Call CalculateSnowflakeColumn(intBackgroundSnowflakes(intColumn), intBackgroundAccumulation(intColumn), ROWS, FALLSPEED, ODDS)
93.             'Ensure background accumulation keeps up with foreground accumulation to smooth out the accumulation...
94.             If intAccumulation(intColumn) > intBackgroundAccumulation(intColumn) Then intBackgroundAccumulation(intColumn) = intAccumulation(intColumn)
95.         End If
96.         'Draw the background snow first...
97.         Call DrawSnowflakeColumn(intBackgroundSnowflakes(intColumn), intBackgroundAccumulation(intColumn), intColumn, ROWS, 7)
98.         'Recalculate the foreground snow...
99.         Call CalculateSnowflakeColumn(intSnowflakes(intColumn), intAccumulation(intColumn), ROWS, FALLSPEED, ODDS)
100.         'Draw the foreground snow next, on top of the background snow...
101.         Call DrawSnowflakeColumn(intSnowflakes(intColumn), intAccumulation(intColumn), intColumn, ROWS, 15)
102.         'Track whether or not this column is full of snow (program will terminate when all columns are full)...
103.         If intAccumulation(intColumn) = ROWS Then intFullColumns = intFullColumns + 1
104.     Next intColumn
105.     'Copy the active page (where we just drew the snow) to the visible page...
106.     PCopy 0, 1
107.     'Clear the active page for the next frame...
108.     Cls
109.     'Wait for the delay to pass before starting over...
110.     Do
111.     Loop Until Timer > sngStart + DELAY
112.     Timer Off
113. Wend
114. End
115.  
116. Sub CalculateSnowflakeColumn (Snowflake As Integer, Accumulation As Integer, Rows As Integer, FallSpeed As Integer, Odds As Single)
117.     'If there is a snowflake in the column (i.e. any value > -1) then...
118.     If Snowflake > -1 Then
119.         'If the snowflake has not fallen to the accumulation...
120.         If (Snowflake + FallSpeed) < (Rows - Accumulation) Then
121.             'Advance the snowflake...
122.             Snowflake = Snowflake + FallSpeed
123.         Else
124.             'Eliminate the flake...
125.             Snowflake = -1
126.             'Add to the accumulation...
127.             Accumulation = Accumulation + 1
128.         End If
129.     Else
130.         'If accumulation hasn't filled up the column...
131.         If Accumulation < Rows Then
132.             'Maybe add a flake...
133.             If (Rnd * 100) < Odds Then
134.                 Snowflake = 0
135.             End If
136.         End If
137.     End If
138. End Sub
139.  
140. Sub DrawSnowflakeColumn (Snowflake As Integer, Accumulation As Integer, Column As Integer, Rows As Integer, SnowColor As Integer)
141.     'If there is a snowflake in this column...
142.     If Snowflake > -1 Then
143.         'Draw the snowflake...
144.         PSet (Column, Snowflake), SnowColor
145.     End If
146.     'If there is accumulation in this column...
147.     If Accumulation > 0 Then
148.         'Draw the accumulation...
149.         Line (Column, Rows)-(Column, (Rows - Accumulation + 1)), SnowColor
150.     End If
151. End Sub

[STxAxTIC]

Welcome to the forum @Dustinian!

This is a lovely and timely program for the season we're in! (It's cold here, at least.)

 

As you may have discovered, QB64 does a little bit more than the original QB. It's possible to modernize this demo for full screen, 32-bit colors - whatever you can imagine. (I'll wait for guys like bplus to jump on this thread.)

Show us more!

[bplus]

First I'd like to say, welcome to the forum.

You have labeled variables with good names and have well documented code.

The QB techniques are a bit old, eg for this

Code: QB64: [Select]

1.     Do
2.     Loop Until Timer > sngStart + DELAY
3.     Timer Off
4.  

You could simply use _Limit for a steady loop around timer, _Limit 30 will do at most 30 loops in 1 sec if the code runs that fast, if not the speed is limited by the processing time.

I removed the timer for fast drawing to see if you get hairy snow like I:
 

yeah, so

to do same I went this way:

Code: QB64: [Select]

1. _Title "Accumulating snow"
2.  
3. Const sw = 1024, sh = 700, nSnow = 80000 ' screen width and height, number of snow particles
4. Screen _NewImage(sw, sh, 32) ' 32 for _RGB32(red, green, blue)
5. _ScreenMove 100, 40
6. Type snow
7.     As Single x, y, falling
8. End Type
9. ReDim Shared s(1 To nSnow) As snow ' snow fall array
10. snowTop = 1200
11. 'init snow
12. For i = 1 To snowTop
13.     newSnow i, -1
14. Next
15. While _KeyDown(27) = 0 ' until escape pressed
16.     ' show snow
17.     Cls
18.     For i = 1 To snowTop
19.         PSet (s(i).x, s(i).y), _RGB32(255, 255, 255) ' draw
20.         If s(i).falling Then
21.             If s(i).y >= sh - 1 Then
22.                 s(i).falling = 0
23.                 snowTop = snowTop + 1
24.                 newSnow snowTop, 0
25.             ElseIf Point(s(i).x, s(i).y + 1) <> _RGB32(255, 255, 255) Then ' continue falling
26.                 s(i).y = s(i).y + 1
27.             ElseIf Point(s(i).x, s(i).y + 1) = _RGB32(255, 255, 255) Then
28.                 If snowTop < nSnow Then ' start another particle
29.                     s(i).falling = 0
30.                     snowTop = snowTop + 1
31.                     newSnow snowTop, 0
32.                 End If
33.             End If
34.         End If
35.     Next
36.     _Display 'prevents blinking
37.     '_Limit 500 'controls snow fall speed
38. Wend
39.  
40. Sub newSnow (i, init)
41.     If init Then s(i).y = Rnd * 2 * sh - sh Else s(i).y = Rnd * -sh
42.     s(i).x = Rnd * sw
43.     s(i).falling = -1
44. End Sub
45.  
46.  
47.  

except mine gets slower because it redraws all particles which increase during run.

I think there is way to get snow to lay flat without tall and short columns and keep snowfall constant rate.

[Richard Frost]

I've never seen SCREEN 7 used before. Perhaps because you can do
page flipping with 9, and it has more dots to play with (640*350).

The TIMER ON and TIMER OFF are not necessary to use TIMER in the
way you are.  And your CPU might melt when the program crosses
midnite - a loop with no limit (lines 110 and 111). A better end
of loop condition would be:

    Loop Until Timer > ((sngStart + DELAY) mod 86400)

86400 = 24 hours * 60 minutes * 60 seconds, the duration of a day
on this planet. 

Are you aware that LONGs are generally faster then INTEGERs with
QB64?  Goes against the theory I learned, but such is the case.
But since you want backwards compatibility and the ultimate in
speed probably isn't required, INTEGERs are fine.

Nice demo.  I'll call Mr. Plow.

[Richard Frost]

My old attempt at snow - could use upgrading to the capabilities of QB64.

Arrow keys control the direction and speed of the snow.

Code: QB64: [Select]

1. DefInt A-Z
2.  
3. _Title "Xmas Tree"
4.  
5. q = 22000
6. q2 = 5000
7. z = 15
8. x = 640
9. sn = Val(Command$): If sn = 0 Then sn = 5000
10.  
11. Dim x(q), y(q), garr(q2), sarr(q2), p&(z), f(z)
12. Dim sd(x), sdm(x), bx(x), by(x), sx(sn), sy(sn), wp(sn)
13.  
14. begin:
15. GoSub init
16. Do: _Limit 20
17.     t# = Timer
18.     GoSub snow
19.     GoSub star
20.     If t# > sparkat# Then GoSub sparkle
21.     If t# > colorat# Then GoSub ccycle
22.     If t# > drawbt# Then GoSub drawballs
23.     i$ = InKey$
24.     If Len(i$) = 2 Then
25.         v = Asc(Right$(i$, 1))
26.         yinc = yinc - (v = 80) + (v = 72)
27.         xinc = xinc - (v = 77) + (v = 75)
28.     End If
29.     If i$ = Chr$(13) Then GoTo begin
30. Loop Until i$ = Chr$(27)
31. System
32. ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
33. timeinc:
34. tvar# = Timer + tinc!
35. If tvar# > 86399 Then tvar# = var# - 86400
36. Return
37. ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
38. ccycle:
39. cs = cs + 1 + (cs = 2) * 3 '        turn a string of bulbs on/off
40. i = cs * 4 + 3 '                    starting point for color
41. f(cs) = 1 - f(cs) '                 flag as on/off
42. For tc = 0 To 3 '                   4 shades per color
43.     If f(cs) Then z& = p&(i) Else z& = p&(i + tc)
44.     Palette i + tc, z& '            turn color on/off
45. Next tc
46. tinc! = .5: GoSub timeinc: colorat# = tvar#
47. Return
48. ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
49. sparkle:
50. sss = 1 - sss
51. If sss = 0 Then
52.     Put (spx, spy), sarr(), PSet '  restore area under sparkle
53. Else
54.     i = Rnd * (n - 1) + 1 '         pick random tree point
55.     spx = x(i) - 12
56.     spy = y(i)
57.     ti = Int(Rnd * 10) * 200 '      pick random sparkle (of 10)
58.     Get (spx, spy)-(spx + 25, spy + 25), sarr() ' save area to be plotted on
59.     Put (spx, spy), garr(ti), Or ' merge sparkle
60. End If
61. tinc! = .1 - (sss = 0) * Rnd
62. GoSub timeinc
63. sparkat# = tvar#
64. Return
65. ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
66. snow:
67. For d& = 0 To sn
68.     sf = sf + 1 + (sf = sn) * (sn + 1)
69.     xi = sx(sf)
70.     yi = sy(sf)
71.     sd = sd(xi)
72.     sdm = sdm(xi)
73.     If yi = (479 - sd) Then
74.         If (sd = 0) Or (Point(xi, yi + 1)) = 15 Then
75.             If sd = sdm Then
76.                 If Rnd > .7 Then wp(sf) = -15
77.             Else
78.                 sd(xi) = sd + 1
79.                 wp(sf) = -15
80.             End If
81.             For tty = yi To 479
82.                 PSet (xi, tty), -(Rnd > .3) * 15
83.             Next tty
84.         End If
85.     End If
86.     If wp(sf) < 15 Then PSet (sx(sf), sy(sf)), Abs(wp(sf))
87.     If (sf Mod 30) = 0 Then
88.         xdir = Rnd * xinc
89.         ydir = Rnd * yinc
90.     End If
91.     sx(sf) = sx(sf) + xdir
92.     sy(sf) = sy(sf) + ydir
93.     okx = (sx(sf) >= 0) And (sx(sf) < xm)
94.     oky = (sy(sf) >= 0) And (sy(sf) < ym)
95.     If okx And oky Then
96.         wp(sf) = Point(sx(sf), sy(sf))
97.         PSet (sx(sf), sy(sf)), 15
98.     Else
99.         wp(sf) = 0
100.         GoSub assign
101.     End If
102. Next d&
103. Return
104. ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
105. assign:
106. If Rnd > .5 Then
107.     sx(sf) = Rnd * (xm - 1)
108.     If yinc > 0 Then sy(sf) = 0 Else sy(sf) = 479
109. Else
110.     If xinc < 0 Then sx(sf) = xm - 1 Else sx(sf) = 0
111.     sy(sf) = Rnd * 478 + 1
112. End If
113. Return
114. ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
115. init:
116. Screen 12
117. _FullScreen _SquarePixels
118. Cls
119. Randomize Timer
120. xm = 640: ym = 480: q = 200: x1 = 12: y1 = 12
121. n = 0: xp = 0: ta = 45: ts = 4: needles = 0: bi = 0
122. For s = 0 To 9 ' make stars
123.     GoSub star
124.     Get (0, 0)-(25, 25), garr(s * q)
125.     Line (0, 0)-(25, 25), 0, BF
126. Next s
127. x1 = 320: y1 = 50: ta = 30: ts = 20 ' big treeptop star
128. GoSub setcolor
129. GoSub drawbase
130. GoSub drawtree
131. GoSub drawballs
132. GoSub snowinit
133. For i = 0 To 2
134.     f(i) = -(Rnd < .5)
135. Next i
136. q = 0
137. y1 = y1 - 15
138. ba# = Timer
139. tinc! = 2: GoSub timeinc: colorat# = tvar#
140. tinc! = 3: GoSub timeinc: sparkat# = tvar#
141. tinc! = 1: GoSub timeinc: keyat# = tvar#
142. If pn& = 0 Then
143.     pn& = 4
144.     pd& = 1
145.     xinc = 2
146.     yinc = 2
147. End If
148. Return
149. ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
150. snowinit:
151. For i = 1 To sn '                   create snow
152.     sx(i) = Rnd * xm
153.     sy(i) = Rnd * ym
154.     wp(i) = 0
155. Next i
156. For i = 1 To sn '                   show snow
157.     PSet (sx(i), sy(i)), 15
158. Next i
159. z1 = Rnd * 8 + 8
160. z2 = Rnd * 8 + 8
161. For x = 0 To xm '                   set drift limits
162.     ty1 = 6 * Sin(x / z1) + 10
163.     ty2 = 6 * Sin(x / z2) + 10
164.     If ty1 < ty2 Then y = ty2 Else y = ty1
165.     sdm(x) = y: sd(x) = 0
166. Next x
167. Return
168. ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
169. drawtree:
170. k = 20
171. For i! = 0 To 8.5 Step .1
172.     For x0 = -k To k
173.         x2 = 320 + i! * x0
174.         y2 = y1 + i! * 45
175.         For zz = 0 To 1
176.             xe = Rnd * 30 - 15
177.             ye = Rnd * 30 - 4
178.             Line (x2, y2)-(x2 + xe, y2 + ye), 2
179.             needles = needles + 1
180.         Next zz
181.         n = n + 1
182.         x(n) = x2
183.         y(n) = y2
184.     Next x0
185.     tk = k * 2
186.     i = n - tk + Rnd * tk '         random point from y level
187.     If i < 1 Then i = 1 '           bounds checking
188.     If i > n Then i = n
189.  
190.     If y(i) < 500 Then dball = -(Rnd > .1)
191.     If y(i) < 400 Then dball = -(Rnd > .1)
192.     If y(i) < 300 Then dball = -(Rnd > .1)
193.     If y(i) < 200 Then dball = -(Rnd > .5)
194.     If y(i) < 100 Then dball = -(Rnd > .8)
195.  
196.     If dball Then '                 do ball
197.         bi = bi + 1
198.         bx(bi) = x(i)
199.         by(bi) = y(i)
200.     End If
201.  
202.     For vv = 0 To 3 '               garland
203.         mr! = ma! * Atn(1) / 45
204.         xp = 320 + i! * k * Sin(mr!)
205.         Line (xp, y(i))-Step(1, 1), 15, BF
206.         ma! = (ma! + 87) Mod 360
207.     Next vv
208. Next i!
209. Return
210. ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
211. drawbase:
212. p& = &H1315
213. For y = 428 To 460
214.     Line (300, y)-(340, y), 1, , p&
215.     p& = (p& And &HFFF) * 8 + (p& And &HF000) / (2 ^ 12)
216. Next y
217. xl = -0
218. For y = 460 To 479 Step 1
219.     For x = 286 - xl To 354 + xl
220.         c = -(Rnd > .5) - (Rnd > .5)
221.         PSet (x, y), c
222.     Next x
223.     xl = xl + 1
224. Next y
225. Return
226. ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
227. drawballs:
228. For i = 1 To bi
229.     x = bx(i)
230.     y = by(i)
231.     c = (i Mod 3) * 4 + 6 '         light string
232.     For zz = 6 To 0 Step -1 '       shading (4 shades per color)
233.         tc = c - zz \ 2
234.         For qq = zz To 0 Step -1
235.             z1 = Rnd * 2
236.             z2 = Rnd * 2
237.             Circle (x + z1, y + z2), qq, tc
238.             Circle (x, y), qq, tc
239.         Next qq
240.     Next zz
241. Next i
242. 'tinc! = 600: GOSUB timeinc: drawbt# = tvar# ' redraw (snow covers balls)
243. Return
244. ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
245. star:
246. tsc = (tsc + 1) Mod 10
247. For a = 0 To 180 Step ta
248.     r! = a * Atn(1) / 45
249.     zx = Rnd * ts + 2
250.     zy = zx + 2
251.     x3 = x1 + zx * Cos(r!): x4 = x1 - zx * Cos(r!)
252.     y3 = y1 + zy * Sin(r!): y4 = y1 - zy * Sin(r!)
253.     Line (x3, y3)-(x4, y4), (tsc > 5) * -15
254. Next a
255. Return
256. ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
257. setcolor:
258. Restore
259. For c = 0 To 15
260.     Read gg, r, g, b
261.     p&(c) = CDbl(b) * 65536 + CDbl(g) * 256 + r
262.     Palette c, p&(c)
263. Next c
264. Return
265. ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
266. Data 0,0,0,0
267. Data 1,30,12,14
268. Data 2,22,34,22
269. Data 3,32,0,0
270. Data 4,50,10,10
271. Data 5,60,16,16
272. Data 6,63,20,20
273. Data 7,7,7,30
274. Data 8,10,10,50
275. Data 9,21,21,58
276. Data 10,31,31,63
277. Data 11,32,32,4
278. Data 12,42,42,10
279. Data 13,55,55,12
280. Data 14,63,63,20
281. Data 15,60,60,60
282.  

[Cobalt]

Pretty cool.

Now take it to the next level, instead of 2 layers of snow, multiple layers of snow moving in different directions, with different accumulation layers. With small 'gusts' of wind that blow some of the accumulation off the screen from time to time so it doesn't fill the whole screen.

Make this the creme de la creme of Snowfall Screen Savers!

[bplus]

Yeah if don't want to worry about accumulation:

Code: QB64: [Select]

1. _Title "Snowjob, drawn flakes" ' B+ mod 2018-12-5  <<<<<<<<<<<< 2021-12-21 tinkered with numbers
2.  
3. ' screen
4. Const XMAX = 1000
5. Const YMAX = 600
6. Screen _NewImage(XMAX, YMAX, 32)
7. '_ScreenMove 200, 100
8. _FullScreen ' <<<<<<<<<<<<<<<<< for screen saver
9.  
10. 'snow making machine
11. Type PARTICLE
12.     x As Single
13.     y As Single
14.     dx As Single
15.     dy As Single
16.     size As Single
17.     density As Single
18.     angle As Single
19.     dir As Single
20.     maxy As Single
21. End Type
22.  
23. '  background, try 3 backgrounds
24. wallpaper& = _NewImage(XMAX, YMAX, 32)
25. _Dest wallpaper&
26. drawLandscape
27. _Dest 0
28.  
29. nLayers = 15
30. flakes = 2 ^ (nLayers + 1) - 1
31. Dim snow(flakes) As PARTICLE
32. horizon = .5 * YMAX
33. For layer = nLayers To 1 Step -1
34.     For flake = 0 To 2 ^ layer
35.         snow(flake).x = Rnd * 2 * XMAX - .5 * XMAX
36.         snow(flake).y = Rnd * 2 * YMAX - YMAX ' <<<<<<<<<<<<<< fix clear clearing when first start by spreading over 2 screens
37.         snow(flake).dx = .1 * (nLayers + 1 - layer) * Cos(Rnd * _Pi(.6666) + _Pi(.0833))
38.         If snow(flake).dx < -.2 Then snow(flake).dx = -snow(flake).dx '              <<<<<<<<<<<<< add a little wind
39.         snow(flake).dy = .1 * (nLayers + 1 - layer) * Sin(Rnd * _Pi(.6666) + _Pi(.0833))
40.         If snow(flake).dy < .2 Then snow(flake).dy = .2 '                       <<<<<<<<<<<<<< make sure everything is falling
41.         snow(flake).size = .5 * (nLayers - layer)
42.         snow(flake).density = 2.3 + Rnd * .5
43.         snow(flake).angle = Rnd * _Pi
44.         If Rnd < .5 Then snow(flake).dir = -1 Else snow(flake).dir = 1
45.         snow(flake).maxy = horizon + (nLayers + 1 - layer) * 30
46.     Next
47. Next
48.  
49. While _KeyDown(27) = 0 ' <<<<<<<<<<<<< allow escape from full screen
50.     _PutImage , wallpaper&, 0
51.     For flake = flakes To 0 Step -1
52.         If Rnd < .2 Then
53.             snow(flake).x = snow(flake).x + snow(flake).dx + Rnd * 2 - 1
54.             snow(flake).y = snow(flake).y + snow(flake).dy + Rnd * 2 - 1
55.         Else
56.             snow(flake).x = snow(flake).x + snow(flake).dx
57.             snow(flake).y = snow(flake).y + snow(flake).dy
58.         End If
59.         If snow(flake).size <= 1 Then
60.             PSet (snow(flake).x, snow(flake).y), _RGBA32(255, 255, 255, 80)
61.         ElseIf snow(flake).size <= 2 Then
62.             Circle (snow(flake).x, snow(flake).y), 1, _RGBA32(255, 255, 255, 100)
63.         Else
64.             snow(flake).angle = snow(flake).angle + snow(flake).dir * _Pi(1 / 100) ' <<<<<< turn flakes more
65.             rFlake snow(flake).x, snow(flake).y, snow(flake).size, snow(flake).density, snow(flake).angle
66.         End If
67.         If snow(flake).y > snow(flake).maxy Or snow(flake).x < -.5 * XMAX Or snow(flake).x > 1.5 * XMAX Then
68.             snow(flake).x = Rnd * 2 * XMAX - .5 * XMAX
69.             snow(flake).y = Rnd * YMAX - 1.1 * YMAX
70.         End If
71.     Next
72.     _Display
73.     _Limit 60
74. Wend
75.  
76. Sub rFlake (x, y, r, DV, rAng)
77.     'DV = flake density
78.     Color _RGBA32(225, 225, 245, r ^ 2 * 30)
79.     For a = 0 To 5
80.         armX = x + r * Cos(a * _Pi(1 / 3) + rAng)
81.         armY = y + r * Sin(a * _Pi(1 / 3) + rAng)
82.         Line (x, y)-(armX, armY)
83.         If r > 2.5 Then rFlake armX, armY, r / DV, DV, rAng
84.     Next
85. End Sub
86.  
87. Sub midInk (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
88.     Color _RGB(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
89. End Sub
90.  
91. Function rand% (lo%, hi%)
92.     rand% = Int(Rnd * (hi% - lo% + 1)) + lo%
93. End Function
94.  
95. Sub drawLandscape
96.     'needs midInk, rand
97.     'the sky
98.     For i = 0 To YMAX
99.         midInk 0, 0, 28, 220, 120, 128, i / YMAX '<<<<<<<<<<<<  dark on top lighter redder lower
100.         Line (0, i)-(XMAX, i)
101.     Next
102.     'the land
103.     startH = YMAX - 300
104.     rgb = 135 ' <<<<<<<<<<<<<<<<<<<<<< less white
105.     For mountain = 1 To 6
106.         Xright = 0
107.         y = startH
108.         While Xright < XMAX
109.             ' upDown = local up / down over range, change along Y
110.             ' range = how far up / down, along X
111.             upDown = (Rnd * .8 - .35) * (mountain * .5)
112.             range = Xright + rand%(15, 35) * 3.5 / mountain
113.             lastx = Xright - 1
114.             Color _RGB32(rgb + 40, rgb - 30, rgb)
115.             For X = Xright To range
116.                 y = y + upDown
117.                 Line (lastx, y)-(X, YMAX), , BF 'just lines weren't filling right
118.                 lastx = X
119.             Next
120.             Xright = range
121.         Wend
122.         '_DELAY 1
123.         rgb = rand%(rgb, rgb + 20)
124.         startH = startH + rand%(5, 20)
125.     Next
126. End Sub
127.  
128.  
129.  

Edit: tinkered with numbers

Edit again for full screen saver.

[Richard Frost]

As usual, Bplus' effort is the prettiest.  But it's a bit slow.
And the near flakes are so large that when they hit the ground,
the planet should spit in two, or aliens jump out and demand
cheese products.

[bplus]

Slow?! Oh you're from Canada!

Code: QB64: [Select]

1. _Title "Snowjob, drawn flakes" ' B+ mod 2018-12-5  <<<<<<<<<<<< 2021-12-21 tinkered with numbers
2.  
3. ' screen
4. Const XMAX = 1000
5. Const YMAX = 600
6. Screen _NewImage(XMAX, YMAX, 32)
7. '_ScreenMove 200, 100
8. _FullScreen ' <<<<<<<<<<<<<<<<< for screen saver
9.  
10. 'snow making machine
11. Type PARTICLE
12.     x As Single
13.     y As Single
14.     dx As Single
15.     dy As Single
16.     size As Single
17.     density As Single
18.     angle As Single
19.     dir As Single
20.     maxy As Single
21. End Type
22.  
23. '  background, try 3 backgrounds
24. wallpaper& = _NewImage(XMAX, YMAX, 32)
25. _Dest wallpaper&
26. drawLandscape
27. _Dest 0
28.  
29. nLayers = 15
30. flakes = 2 ^ (nLayers + 1) - 1
31. Dim snow(flakes) As PARTICLE
32. horizon = .5 * YMAX
33. For layer = nLayers To 1 Step -1
34.     For flake = 0 To 2 ^ layer
35.         snow(flake).x = Rnd * 2 * XMAX - .5 * XMAX
36.         snow(flake).y = Rnd * 2 * YMAX - YMAX ' <<<<<<<<<<<<<< fix clear clearing when first start by spreading over 2 screens
37.         snow(flake).dx = 3 * (nLayers + 1 - layer) * Cos(Rnd * _Pi(.6666) + _Pi(.0833))
38.         If snow(flake).dx < -.2 Then snow(flake).dx = -snow(flake).dx '              <<<<<<<<<<<<< add a little wind
39.         snow(flake).dy = 3 * (nLayers + 1 - layer) * Sin(Rnd * _Pi(.6666) + _Pi(.0833))
40.         If snow(flake).dy < .2 Then snow(flake).dy = .2 '                       <<<<<<<<<<<<<< make sure everything is falling
41.         snow(flake).size = .5 * (nLayers - layer)
42.         snow(flake).density = 2.3 + Rnd * .5
43.         snow(flake).angle = Rnd * _Pi
44.         If Rnd < .5 Then snow(flake).dir = -1 Else snow(flake).dir = 1
45.         snow(flake).maxy = horizon + (nLayers + 1 - layer) * 30
46.     Next
47. Next
48.  
49. While _KeyDown(27) = 0 ' <<<<<<<<<<<<< allow escape from full screen
50.     _PutImage , wallpaper&, 0
51.     For flake = flakes To 0 Step -1
52.         If Rnd < .2 Then
53.             snow(flake).x = snow(flake).x + snow(flake).dx + Rnd * 2 - 1
54.             snow(flake).y = snow(flake).y + snow(flake).dy + Rnd * 2 - 1
55.         Else
56.             snow(flake).x = snow(flake).x + snow(flake).dx
57.             snow(flake).y = snow(flake).y + snow(flake).dy
58.         End If
59.         If snow(flake).size <= 1 Then
60.             PSet (snow(flake).x, snow(flake).y), _RGBA32(255, 255, 255, 80)
61.         ElseIf snow(flake).size <= 2 Then
62.             Circle (snow(flake).x, snow(flake).y), 1, _RGBA32(255, 255, 255, 100)
63.         Else
64.             snow(flake).angle = snow(flake).angle + snow(flake).dir * _Pi(1 / 100) ' <<<<<< turn flakes more
65.             rFlake snow(flake).x, snow(flake).y, snow(flake).size, snow(flake).density, snow(flake).angle
66.         End If
67.         If snow(flake).y > snow(flake).maxy Or snow(flake).x < -.5 * XMAX Or snow(flake).x > 1.5 * XMAX Then
68.             snow(flake).x = Rnd * 2 * XMAX - .5 * XMAX
69.             snow(flake).y = Rnd * YMAX - 1.1 * YMAX
70.         End If
71.     Next
72.     _Display
73.     '_Limit 60
74. Wend
75.  
76. Sub rFlake (x, y, r, DV, rAng)
77.     'DV = flake density
78.     Color _RGBA32(225, 225, 245, r ^ 2 * 30)
79.     For a = 0 To 5
80.         armX = x + r * Cos(a * _Pi(1 / 3) + rAng)
81.         armY = y + r * Sin(a * _Pi(1 / 3) + rAng)
82.         Line (x, y)-(armX, armY)
83.         If r > 2.5 Then rFlake armX, armY, r / DV, DV, rAng
84.     Next
85. End Sub
86.  
87. Sub midInk (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
88.     Color _RGB(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
89. End Sub
90.  
91. Function rand% (lo%, hi%)
92.     rand% = Int(Rnd * (hi% - lo% + 1)) + lo%
93. End Function
94.  
95. Sub drawLandscape
96.     'needs midInk, rand
97.     'the sky
98.     For i = 0 To YMAX
99.         midInk 0, 0, 28, 220, 120, 128, i / YMAX '<<<<<<<<<<<<  dark on top lighter redder lower
100.         Line (0, i)-(XMAX, i)
101.     Next
102.     'the land
103.     startH = YMAX - 300
104.     rgb = 135 ' <<<<<<<<<<<<<<<<<<<<<< less white
105.     For mountain = 1 To 6
106.         Xright = 0
107.         y = startH
108.         While Xright < XMAX
109.             ' upDown = local up / down over range, change along Y
110.             ' range = how far up / down, along X
111.             upDown = (Rnd * .8 - .35) * (mountain * .5)
112.             range = Xright + rand%(15, 35) * 3.5 / mountain
113.             lastx = Xright - 1
114.             Color _RGB32(rgb + 40, rgb - 30, rgb)
115.             For X = Xright To range
116.                 y = y + upDown
117.                 Line (lastx, y)-(X, YMAX), , BF 'just lines weren't filling right
118.                 lastx = X
119.             Next
120.             Xright = range
121.         Wend
122.         '_DELAY 1
123.         rgb = rand%(rgb, rgb + 20)
124.         startH = startH + rand%(5, 20)
125.     Next
126. End Sub
127.  
128.  
129.  

O Canada our home and native land...

Actually this code was made for image backgrounds for Christmas challenge a few years back.

[Richard Frost]

Much faster, therefore more convincing.  I tinkered with it a little to
try and get more speed (fewer layers and flakes), but just crashed it.

You qualify to put a pom-pom on your hat.  Eh?

[Dustinian]

Wow! A lot of great feedback on my first post! I've taken a lot of the feedback to heart.

• Hairy Snow @bplus, great feedback! I added a "settle" function that gives spikey accumulation an increasingly likely chance to settle left or right when the delta is 2 pixels or more.
• Screen 9 @Richard Frost, great feedback! I've made this change!
• Timer Crossing Midnight @Richard Frost, great feedback, I had not considered midnight! I've made a similar change to the one you suggested (your exact suggestion didn't work for me... using MOD to get the remainder after seconds causes a 1 second delay every other second... the same problem you pointed out would occur after midnight, but every second now. So I just added another condition to the loop that sngStart had to be >= Timer for the loop to continue.

Code: QB64: [Select]

1. 'SNOWFALL.BAS
2. '============
3.  
4. 'DESCRIPTION
5. '-----------
6. '   A holiday screensaver for QBasic.
7.  
8. 'AUTHOR
9. '------
10. '   Dustinian Camburides
11.  
12. 'PLATFORM
13. '--------
14. '   Written in QB64.
15. '   But designed to be QBasic/QuickBasic compatible.
16. '       Although, I haven't tested QBasic / QuickBasic compatability yet.
17.  
18. 'VERSION
19. '-------
20. '1.0, 2021-12-18: First working version.
21. '1.1, 2021-12-19: I was excited to keep working!
22. '   Added page-flipping to reduce flicker!
23. '   Added background snowflakes at a smaller speed and dimmer color!
24. '   Set the formula to advance snowflakes to actually use the FALLSPEED constant.
25. '   Also started the timer before calculating all the snowflakes to smooth out the animation.
26. '1.2, 2021-12-23: Updates with encouragement from the great folks at qb64.org/forum!
27. '   Added a "settle" function to let "spiky" snow accumulation settle. (Thank you for the suggestion bplus!)
28. '   Updated the delay so it doesn't break when it starts before midnight and ends after midnight. (Thank you for the suggestion Richard Frost!)
29. '   Shifted to screen 9 to keep page-flipping, but at a higher resolution. (Thank you for the suggestion Richard Frost!)
30.  
31. 'PLANNED ENHANCEMENTS
32. '--------------------
33. 'Maybe next year I will add...
34. '   - Actual, tested QBasic compatability (need to to a DosBox install and find a copy of QBasic).
35. '   - A more complex data structure for snowflakes that can store both X and Y coordinates in a dynamic array of user-defined types... so it can support more than one snowflake per column... and mabe some drift back-and-forth in the X-axis.
36.  
37. 'HOLIDAY MESSAGE
38. '---------------
39. 'But for now, I'm happy that I have my first QB64 program that has animation. Happy Holidays!
40.  
41. 'SUBS
42. Declare Sub CalculateSnowflakeColumn (SnowFlake As Integer, Accumulation As Integer, Rows As Integer, FallSpeed As Integer, Odds As Single)
43. Declare Sub DrawSnowflakeColumn (Snowflake As Integer, Accumulation As Integer, Column As Integer, Rows As Integer, SnowColor As Integer)
44. Declare SettleAccumulation (LeftAccumulation As Integer, Accumulation As Integer, RightAccumulation As Integer)
45.  
46. 'CONSTANTS
47. Const FALLSPEED = 1 'Snow falls this many pixels per frame.
48. Const COLUMNS = 639 'The screen is 640 pixels across (0-639) in Screen 9.
49. Const ROWS = 349 'The screen is 350 pixels tall (0-349) in Screen 9.
50. Const DELAY = 0.04 'The number of seconds between snowflake recalculation / re-draw... QBasic can't detect less than 0.04 seconds...
51. Const ODDS = 0.7 'The % chance a snowflake will be added to a column that doesn't have a snowflake... anything over 1% will results in "waves" of snowflakes.
52.  
53. 'VARIABLES
54. Dim intSnowflakes(COLUMNS) As Integer 'Array that holds the current Y-coordinate for a snowflake per column... this means there can only be one snowflake per column at any given time.
55. Dim intBackgroundSnowflakes(COLUMNS) As Integer 'Same as above, but for the background.
56. Dim intAccumulation(COLUMNS) As Integer 'Array that holds the current accumulated pixels of snow per column.
57. Dim intBackgroundAccumulation(COLUMNS) As Integer ' Same as above, but for the background.
58. Dim intColumn As Integer 'The current column in the loop.
59. Dim sngStart As Single 'The timer at the start of the delay loop.
60. Dim intBackgroundFrame As Integer 'Whether the current frame will move the background snow...
61. Dim intFullColumns As Integer 'Used to track the number of columns that are full of snow...
62.  
63. 'INITIALIZE VARIABLES
64. 'For each column...
65. For intColumn = 0 To COLUMNS
66.     'Set all snowflakes to -1, indicating there is no snowflake in this column.
67.     intSnowflakes(intColumn) = -1
68.     intBackgroundSnowflakes(intColumn) = -1
69.     'Set all accumulation to 0, indicating there is no accumulation in this column.
70.     intAccumulation(intColumn) = 0
71.     intBackgroundAccumulation(intColumn) = 0
72. Next intColumn
73. intBackgroundFrame = 0
74. Timer On
75. Randomize Timer
76.  
77. 'INITIALIZE SCREEN
78. 'Set the screen to mode 9 with an active page (where the cls, pset, and line commands occur) of 0 and a visible page (that the user sees) of 1.
79. Screen 9, , 0, 1
80. Color 15, 0
81. Cls
82.  
83. 'PROGRAM
84. 'While no key has been pressed...
85. While InKey$ = "" And intFullColumns < COLUMNS
86.     'Set the delay timer...
87.     sngStart = Timer
88.     'Reset the number of full columns...
89.     intFullColumns = 0
90.     'Flip whether the background snow will move on or off...
91.     intBackgroundFrame = Not intBackgroundFrame
92.     'For each column... calculate the changes to the snowfall...
93.     For intColumn = 0 To COLUMNS
94.         'Settle the accumulation...
95.         If intColumn > 0 And intColumn < COLUMNS Then
96.             Call SettleAccumulation(intAccumulation(intColumn - 1), intAccumulation(intColumn), intAccumulation(intColumn + 1))
97.             Call SettleAccumulation(intBackgroundAccumulation(intColumn - 1), intBackgroundAccumulation(intColumn), intBackgroundAccumulation(intColumn + 1))
98.         End If
99.         'If this is a background frame...
100.         If intBackgroundFrame Then
101.             'Recalculate background snow...
102.             Call CalculateSnowflakeColumn(intBackgroundSnowflakes(intColumn), intBackgroundAccumulation(intColumn), ROWS, FALLSPEED, ODDS)
103.             'Ensure background accumulation keeps up with foreground accumulation to smooth out the accumulation...
104.             If intAccumulation(intColumn) > intBackgroundAccumulation(intColumn) Then intBackgroundAccumulation(intColumn) = intAccumulation(intColumn)
105.         End If
106.         'Draw the background snow first...
107.         Call DrawSnowflakeColumn(intBackgroundSnowflakes(intColumn), intBackgroundAccumulation(intColumn), intColumn, ROWS, 7)
108.         'Recalculate the foreground snow...
109.         Call CalculateSnowflakeColumn(intSnowflakes(intColumn), intAccumulation(intColumn), ROWS, FALLSPEED, ODDS)
110.         'Draw the foreground snow next, on top of the background snow...
111.         Call DrawSnowflakeColumn(intSnowflakes(intColumn), intAccumulation(intColumn), intColumn, ROWS, 15)
112.         'Track whether or not this column is full of snow (program will terminate when all columns are full)...
113.         If intAccumulation(intColumn) = ROWS Then intFullColumns = intFullColumns + 1
114.     Next intColumn
115.     'Copy the active page (where we just drew the snow) to the visible page...
116.     PCopy 0, 1
117.     'Clear the active page for the next frame...
118.     Cls
119.     'Wait for the delay to pass before starting over...
120.     While (Timer < (sngStart + DELAY)) And (Timer >= sngStart)
121.     Wend
122. Wend
123. Timer Off
124. PCopy 0, 1
125. End
126.  
127. Sub CalculateSnowflakeColumn (Snowflake As Integer, Accumulation As Integer, Rows As Integer, FallSpeed As Integer, Odds As Single)
128.     'If there is a snowflake in the column (i.e. any value > -1) then...
129.     If Snowflake > -1 Then
130.         'If the snowflake has not fallen to the accumulation...
131.         If (Snowflake + FallSpeed) < (Rows - Accumulation) Then
132.             'Advance the snowflake...
133.             Snowflake = Snowflake + FallSpeed
134.         Else
135.             'Eliminate the flake...
136.             Snowflake = -1
137.             'Add to the accumulation...
138.             Accumulation = Accumulation + 1
139.         End If
140.     Else
141.         'If accumulation hasn't filled up the column...
142.         If Accumulation < Rows Then
143.             'Maybe add a flake...
144.             If (Rnd * 100) < Odds Then
145.                 Snowflake = 0
146.             End If
147.         End If
148.     End If
149. End Sub
150.  
151. Sub DrawSnowflakeColumn (Snowflake As Integer, Accumulation As Integer, Column As Integer, Rows As Integer, SnowColor As Integer)
152.     'If there is a snowflake in this column...
153.     If Snowflake > -1 Then
154.         'Draw the snowflake...
155.         PSet (Column, Snowflake), SnowColor
156.     End If
157.     'If there is accumulation in this column...
158.     If Accumulation > 0 Then
159.         'Draw the accumulation...
160.         Line (Column, Rows)-(Column, (Rows - Accumulation + 1)), SnowColor
161.     End If
162. End Sub
163.  
164. Sub SettleAccumulation (LeftAccumulation As Integer, Accumulation As Integer, RightAccumulation As Integer)
165.     'If accumulation should settle left...
166.     If ((Rnd * (Accumulation - LeftAccumulation)) > 2) Then
167.         'Shift accumulation to the left
168.         LeftAccumulation = LeftAccumulation + 1
169.         Accumulation = Accumulation - 1
170.         'If accumulation should settle right...
171.     ElseIf ((Rnd * (Accumulation - RightAccumulation)) > 2) Then
172.         'Shift accumulation to the right
173.         RightAccumulation = RightAccumulation + 1
174.         Accumulation = Accumulation - 1
175.     End If
176. End Sub
177.  

[DANILIN]

I forgot to turn off my computer