A mod of Archimedes Spiral

[bplus]

I just did this for another forum doing an Archimedes Spiral thread :D

Code: QB64: [Select]

1. OPTION _EXPLICIT
2. _TITLE "Draw Spinner and Web" 'B+ started 2019-06-15
3. ' Draw Spinner and web mod 2019-09-17
4. RANDOMIZE TIMER
5. DIM sc&, sx, sy, sh 'spider stuff
6. DIM a, tn, ta, tcx, tcy, tr, tx, ty, tdx, tdy, oldx, oldy 'web stuff
7. sc& = _SCREENIMAGE
8. _DELAY .1
9.  
10. DIM SHARED xmax AS INTEGER, ymax AS INTEGER
11. xmax = _DESKTOPWIDTH
12. ymax = _DESKTOPHEIGHT
13.  
14. SCREEN _NEWIMAGE(xmax, ymax, 32)
15. '_SCREENMOVE 300, 20
16. _FULLSCREEN
17.  
18. _DEST sc&
19. tn = 13: ta = _PI(2 / 13): tcx = .75 * xmax: tcy = .33 * ymax
20. FOR a = 1 TO tn
21.     LINE (tcx + xmax * COS(a * ta), tcy + xmax * SIN(a * ta))-(tcx + xmax * COS(a * ta + _PI), tcy + xmax * SIN(a * ta + _PI)), &H88FFFFFF
22. NEXT
23. _DEST 0
24.  
25. tx = tcx: ty = tcy: tdx = 5: tdy = 0
26. sx = tcx: sy = tcy
27. a = a + ta: tr = tr + ta
28. tx = tcx + tr * COS(a): ty = tcy + tr * SIN(a)
29. sh = _ATAN2(ty - sy, tx - sx)
30. tdx = 1 * COS(sh): tdy = 1 * SIN(sh)
31. WHILE INKEY$ <> CHR$(27)
32.     'update web
33.     IF ((sx - tx) ^ 2 + (sy - ty) ^ 2) ^ .5 < 5 THEN 'setup next target x, y nad new spider heading
34.         oldx = sx: oldy = sy
35.         sx = tx: sy = ty
36.         _DEST sc&
37.         LINE (oldx, oldy)-(sx, sy), &H66FFFFFF
38.         _DEST 0
39.         a = a + ta: tr = tr + 3 * ta
40.         tx = tcx + tr * COS(a): ty = tcy + tr * SIN(a)
41.         sh = _ATAN2(ty - sy, tx - sx)
42.         tdx = 1 * COS(sh): tdy = 1 * SIN(sh)
43.     ELSE
44.         'save image wo spider
45.         oldx = sx: oldy = sy
46.         sx = sx + tdx: sy = sy + tdy
47.         _DEST sc&
48.         LINE (oldx, oldy)-(sx, sy), &H66FFFFFF
49.         _DEST 0
50.     END IF
51.     _PUTIMAGE , sc&
52.     '_PRINTSTRING (500, 200), STR$(tx) + STR$(ty) + STR$(tdx) + STR$(tdy) + STR$(sh)
53.     'place spider
54.     drawSpinner sx, sy, 1, sh, &H88221100
55.     _DISPLAY
56.     _LIMIT 30
57. WEND
58.  
59.  
60. SUB drawSpinner (x AS INTEGER, y AS INTEGER, scale AS SINGLE, heading AS SINGLE, c AS _UNSIGNED LONG)
61.     DIM x1, x2, x3, x4, y1, y2, y3, y4, r, a, a1, a2, lg, d, rd, red, blue, green
62.     STATIC switch AS INTEGER
63.     switch = switch + 2
64.     switch = switch MOD 16 + 1
65.     red = _RED32(c): green = _GREEN32(c): blue = _BLUE32(c)
66.     r = 10 * scale
67.     x1 = x + r * COS(heading): y1 = y + r * SIN(heading)
68.     r = 2 * r 'lg lengths
69.     FOR lg = 1 TO 8
70.         IF lg < 5 THEN
71.             a = heading + .9 * lg * _PI(1 / 5) + (lg = switch) * _PI(1 / 10)
72.         ELSE
73.             a = heading - .9 * (lg - 4) * _PI(1 / 5) - (lg = switch) * _PI(1 / 10)
74.         END IF
75.         x2 = x1 + r * COS(a): y2 = y1 + r * SIN(a)
76.         drawLink x1, y1, 3 * scale, x2, y2, 2 * scale, _RGB32(red + 20, green + 10, blue + 5)
77.         IF lg = 1 OR lg = 2 OR lg = 7 OR lg = 8 THEN d = -1 ELSE d = 1
78.         a1 = a + d * _PI(1 / 12)
79.         x3 = x2 + r * 1.5 * COS(a1): y3 = y2 + r * 1.5 * SIN(a1)
80.         drawLink x2, y2, 2 * scale, x3, y3, scale, _RGB32(red + 35, green + 17, blue + 8)
81.         rd = INT(RND * 8) + 1
82.         a2 = a1 + d * _PI(1 / 8) * rd / 8
83.         x4 = x3 + r * 1.5 * COS(a2): y4 = y3 + r * 1.5 * SIN(a2)
84.         drawLink x3, y3, scale, x4, y4, scale, _RGB32(red + 50, green + 25, blue + 12)
85.     NEXT
86.     r = r * .5
87.     fcirc x1, y1, r, _RGB32(red - 20, green - 10, blue - 5)
88.     x2 = x1 + (r + 1) * COS(heading - _PI(1 / 12)): y2 = y1 + (r + 1) * SIN(heading - _PI(1 / 12))
89.     fcirc x2, y2, r * .2, &HFF000000
90.     x2 = x1 + (r + 1) * COS(heading + _PI(1 / 12)): y2 = y1 + (r + 1) * SIN(heading + _PI(1 / 12))
91.     fcirc x2, y2, r * .2, &HFF000000
92.     r = r * 2
93.     x1 = x + r * .9 * COS(heading + _PI): y1 = y + r * .9 * SIN(heading + _PI)
94.     TiltedEllipseFill 0, x1, y1, r, .7 * r, heading + _PI, _RGB32(red, green, blue)
95. END SUB
96.  
97. SUB drawLink (x1, y1, r1, x2, y2, r2, c AS _UNSIGNED LONG)
98.     DIM a, a1, a2, x3, x4, x5, x6, y3, y4, y5, y6
99.     a = _ATAN2(y2 - y1, x2 - x1)
100.     a1 = a + _PI(1 / 2)
101.     a2 = a - _PI(1 / 2)
102.     x3 = x1 + r1 * COS(a1): y3 = y1 + r1 * SIN(a1)
103.     x4 = x1 + r1 * COS(a2): y4 = y1 + r1 * SIN(a2)
104.     x5 = x2 + r2 * COS(a1): y5 = y2 + r2 * SIN(a1)
105.     x6 = x2 + r2 * COS(a2): y6 = y2 + r2 * SIN(a2)
106.     fquad x3, y3, x4, y4, x5, y5, x6, y6, c
107.     fcirc x1, y1, r1, c
108.     fcirc x2, y2, r2, c
109. END SUB
110.  
111. 'need 4 non linear points (not all on 1 line) list them clockwise so x2, y2 is opposite of x4, y4
112. 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)
113.     ftri x1, y1, x2, y2, x4, y4, c
114.     ftri x3, y3, x4, y4, x1, y1, c
115. END SUB
116.  
117. SUB ftri (x1, y1, x2, y2, x3, y3, K AS _UNSIGNED LONG)
118.     DIM a&
119.     a& = _NEWIMAGE(1, 1, 32)
120.     _DEST a&
121.     PSET (0, 0), K
122.     _DEST 0
123.     _MAPTRIANGLE _SEAMLESS(0, 0)-(0, 0)-(0, 0), a& TO(x1, y1)-(x2, y2)-(x3, y3)
124.     _FREEIMAGE a& '<<< this is important!
125. END SUB
126.  
127. SUB fcirc (CX AS INTEGER, CY AS INTEGER, R AS INTEGER, C AS _UNSIGNED LONG)
128.     DIM Radius AS INTEGER, RadiusError AS INTEGER
129.     DIM X AS INTEGER, Y AS INTEGER
130.     Radius = ABS(R): RadiusError = -Radius: X = Radius: Y = 0
131.     IF Radius = 0 THEN PSET (CX, CY), C: EXIT SUB
132.     LINE (CX - X, CY)-(CX + X, CY), C, BF
133.     WHILE X > Y
134.         RadiusError = RadiusError + Y * 2 + 1
135.         IF RadiusError >= 0 THEN
136.             IF X <> Y + 1 THEN
137.                 LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
138.                 LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
139.             END IF
140.             X = X - 1
141.             RadiusError = RadiusError - X * 2
142.         END IF
143.         Y = Y + 1
144.         LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
145.         LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
146.     WEND
147. END SUB
148.  
149. SUB TiltedEllipseFill (destHandle&, x0, y0, a, b, ang, c AS _UNSIGNED LONG)
150.     DIM max AS INTEGER, mx2 AS INTEGER, i AS INTEGER, j AS INTEGER, k AS SINGLE, lasti AS SINGLE, lastj AS SINGLE
151.     DIM prc AS _UNSIGNED LONG, tef AS LONG
152.     prc = _RGB32(255, 255, 255, 255)
153.     IF a > b THEN max = a + 1 ELSE max = b + 1
154.     mx2 = max + max
155.     tef = _NEWIMAGE(mx2, mx2)
156.     _DEST tef
157.     _SOURCE tef 'point wont read without this!
158.     FOR k = 0 TO 6.2832 + .05 STEP .1
159.         i = max + a * COS(k) * COS(ang) + b * SIN(k) * SIN(ang)
160.         j = max + a * COS(k) * SIN(ang) - b * SIN(k) * COS(ang)
161.         IF k <> 0 THEN
162.             LINE (lasti, lastj)-(i, j), prc
163.         ELSE
164.             PSET (i, j), prc
165.         END IF
166.         lasti = i: lastj = j
167.     NEXT
168.     DIM xleft(mx2) AS INTEGER, xright(mx2) AS INTEGER, x AS INTEGER, y AS INTEGER
169.     FOR y = 0 TO mx2
170.         x = 0
171.         WHILE POINT(x, y) <> prc AND x < mx2
172.             x = x + 1
173.         WEND
174.         xleft(y) = x
175.         WHILE POINT(x, y) = prc AND x < mx2
176.             x = x + 1
177.         WEND
178.         WHILE POINT(x, y) <> prc AND x < mx2
179.             x = x + 1
180.         WEND
181.         IF x = mx2 THEN xright(y) = xleft(y) ELSE xright(y) = x
182.     NEXT
183.     _DEST destHandle&
184.     FOR y = 0 TO mx2
185.         IF xleft(y) <> mx2 THEN LINE (xleft(y) + x0 - max, y + y0 - max)-(xright(y) + x0 - max, y + y0 - max), c, BF
186.     NEXT
187.     _FREEIMAGE tef
188. END SUB
189.  
190.  

[Aurel]

Thanks B+Mark !

[Qwerkey]

It is very good.  A possible improvement would be to get the rear of the spider's abdomen (where the spinnerets are) to trace out the forming web, just to ultimately please the arachnologists.

[Ashish]

Wow! Spider looks realistic.

[Jack002]

Nice program, B+! Super!

[bplus]

Thanks guys,

You know spiders get into everything, my dreams, my peace of mind, my



Oh no!!!