❅ Snowflake Design

[bplus]

Needs some improvements:

Code: QB64: [Select]

1. _Title "Snow Flake Design 1, click points inside triangle, e expand, c clear" ' B+ started 2018-12-07 for QB64
2. Const XMAX = 700
3. Const YMAX = 700
4. Const white = &HFFFFFFFF
5. Const black = &H0
6. Const red = &HFFFF0000
7. Screen _NewImage(XMAX, YMAX, 32)
8. _ScreenMove 250, 20
9. Dim Shared xc, yc, r, d6, datIndex, maxPoints
10. xc = XMAX / 2: yc = YMAX / 2: r = .5 * YMAX * .025: d6 = _Pi(.166666666): maxPoints = 500
11. Dim Shared aDat(1 To maxPoints), dDat(maxPoints)
12. drawArea
13. While _KeyDown(27) = 0
14.     mx = -1: my = -1: q = 0
15.     getClick mx, my, q
16.     If q <> 0 Then
17.         If Chr$(q) = "e" Then
18.             Cls
19.             For i = 0 To 5
20.                 For j = 1 To datIndex
21.                     x1 = xc + dDat(j) * YMAX * Cos(i * 2 * d6 + aDat(j))
22.                     y1 = yc + dDat(j) * YMAX * Sin(i * 2 * d6 + aDat(j))
23.                     fcirc x1, y1, r
24.                     x1 = xc + dDat(j) * YMAX * Cos(i * 2 * d6 - aDat(j))
25.                     y1 = yc + dDat(j) * YMAX * Sin(i * 2 * d6 - aDat(j))
26.                     fcirc x1, y1, r
27.                 Next
28.             Next
29.         ElseIf Chr$(q) = "q" Then
30.             End
31.         ElseIf Chr$(q) = "c" Then
32.             Cls
33.             drawArea
34.             datIndex = 0
35.         End If
36.     Else
37.         'clicked mx, my
38.         a = _Atan2(my - yc, mx - xc)
39.         If a >= 0 And a < d6 Then
40.             scaleDist = (((mx - xc) ^ 2 + (my - yc) ^ 2) ^ .5) / YMAX
41.             datIndex = datIndex + 1
42.             aDat(datIndex) = a
43.             dDat(datIndex) = scaleDist
44.             fcirc xc + dDat(datIndex) * YMAX * Cos(aDat(datIndex)), yc + dDat(datIndex) * YMAX * Sin(aDat(datIndex)), r
45.         End If
46.     End If
47.     _Display
48.     _Limit 60
49. Wend
50.  
51. Sub drawArea
52.     x1 = xc + .45 * YMAX * Cos(0)
53.     y1 = yc + .45 * YMAX * Sin(0)
54.     x2 = xc + .45 * YMAX * Cos(d6)
55.     y2 = yc + .45 * YMAX * Sin(d6)
56.     Line (xc, yc)-(x1, y1), red
57.     Line (xc, yc)-(x2, y2), red
58.     Line (x2, y2)-(x1, y1), red
59. End Sub
60.  
61. Sub getClick (mx, my, q)
62.     While _MouseInput: Wend ' clear previous mouse activity
63.     mx = -1: my = -1: q = 0
64.     Do While mx = -1 And my = -1
65.         q = _KeyHit
66.         If q = 27 Or (q > 31 And q < 126) Then Exit Sub
67.         i = _MouseInput: mb = _MouseButton(1)
68.         If mb Then
69.             Do While mb 'wait for release
70.                 q = _KeyHit
71.                 If q = 27 Or (q > 31 And q < 126) Then Exit Sub
72.                 i = _MouseInput: mb = _MouseButton(1): mx = _MouseX: my = _MouseY
73.                 _Limit 1000
74.             Loop
75.             Exit Sub
76.         End If
77.         _Limit 1000
78.     Loop
79. End Sub
80.  
81. Sub fcirc (CX As Long, CY As Long, R As Long)
82.     Dim subRadius As Long, RadiusError As Long
83.     Dim X As Long, Y As Long
84.  
85.     subRadius = Abs(R)
86.     RadiusError = -subRadius
87.     X = subRadius
88.     Y = 0
89.  
90.     If subRadius = 0 Then PSet (CX, CY): Exit Sub
91.  
92.     ' Draw the middle span here so we don't draw it twice in the main loop,
93.     ' which would be a problem with blending turned on.
94.     Line (CX - X, CY)-(CX + X, CY), , BF
95.  
96.     While X > Y
97.         RadiusError = RadiusError + Y * 2 + 1
98.         If RadiusError >= 0 Then
99.             If X <> Y + 1 Then
100.                 Line (CX - Y, CY - X)-(CX + Y, CY - X), , BF
101.                 Line (CX - Y, CY + X)-(CX + Y, CY + X), , BF
102.             End If
103.             X = X - 1
104.             RadiusError = RadiusError - X * 2
105.         End If
106.         Y = Y + 1
107.         Line (CX - X, CY - Y)-(CX + X, CY - Y), , BF
108.         Line (CX - X, CY + Y)-(CX + X, CY + Y), , BF
109.     Wend
110. End Sub
111.  
112.  

Step 1: dot triangle with ice molecules
 

Step 2: press e to expand