3-shear rotation issue rotating to 30, 60, 120, 150, 210, 240, 300, 330 degrees

[madscijr]

I've been playing with some basic 2D raster drawing / plotting / manipulation routines (operating on a 2-D array).

For rotating a 2-D sprite array to an arbitrary angle, I found a 3-shear rotation routine that works after some massaging, but am seeing this issue where the quality drops when rotating to multiples of 30 degrees (specifically 30, 60, 120, 150, 210, 240, 300, and 330 degrees are the sour spots, 90, 180, & 270 are OK).

If anyone has a minute, run the program and try option 5 or 6, and notice how it looks when it gets to any of those angles.

To quickly find the rotation logic, search for "Sub ShearRotate".

What gives? Any help much appreciated...

Code: QB64: [Select]

1. ' ################################################################################################################################################################
2. ' #TOP
3.  
4. ' Basic 2D plotting functions
5. ' Version 1.00 by madscijr
6. ' with help from various (sources cited below).
7. ' ################################################################################################################################################################
8.  
9. ' =============================================================================
10. ' GLOBAL DECLARATIONS
11. ' =============================================================================
12.  
13. ' boolean constants
14. Const FALSE = 0
15. Const TRUE = Not FALSE
16.  
17. ' -----------------------------------------------------------------------------
18. ' USER DEFINED TYPES
19. ' -----------------------------------------------------------------------------
20. Type RotationType
21.     origx As Integer
22.     origy As Integer
23.     'z as integer
24.     c As Integer
25. End Type ' RotationType
26.  
27. ' -----------------------------------------------------------------------------
28. ' GLOBAL VARIABLES
29. ' -----------------------------------------------------------------------------
30. Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
31. Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
32. Dim Shared m_bDebug: m_bDebug = FALSE
33.  
34. ' =============================================================================
35. ' BEGIN MAIN PROGRAM
36. ' =============================================================================
37. Dim in$
38.  
39. ' ****************************************************************************************************************************************************************
40. ' ACTIVATE DEBUGGING WINDOW
41. If m_bDebug = TRUE Then
42.     $Console
43.     _Delay 4
44.     _Console On
45.     _Echo "Started " + m_ProgramName$
46.     _Echo "Debugging on..."
47. End If
48. ' ****************************************************************************************************************************************************************
49.  
50. ' -----------------------------------------------------------------------------
51. ' START THE MENU
52. main
53.  
54. ' -----------------------------------------------------------------------------
55. ' DONE
56. Print m_ProgramName$ + " finished."
57. 'Screen 0
58. Input "Press <ENTER> to continue", in$
59.  
60. ' ****************************************************************************************************************************************************************
61. ' DEACTIVATE DEBUGGING WINDOW
62. If m_bDebug = TRUE Then
63.     _Console Off
64. End If
65. ' ****************************************************************************************************************************************************************
66.  
67. ' -----------------------------------------------------------------------------
68. ' EXIT
69. System ' return control to the operating system
70. End
71.  
72. ' =============================================================================
73. ' END MAIN PROGRAM
74. ' =============================================================================
75.  
76. ' /////////////////////////////////////////////////////////////////////////////
77. ' MAIN MENU
78.  
79. Sub main
80.     Dim RoutineName As String: RoutineName = "main"
81.     Dim in$
82.  
83.     Screen _NewImage(1280, 1024, 32): _ScreenMove 0, 0
84.     Do
85.         Cls
86.         Print m_ProgramName$
87.         Print
88.         Print "Some basic 2D plotting"
89.         Print
90.         Print "1. PlotPointTest"
91.         Print "2. PlotSquareTest"
92.         Print "3. PlotCircleTest"
93.         Print "4. PlotLineTest"
94.         Print "5. ShearRotateTest1"
95.         Print "6. ShearRotateTest2"
96.         Print
97.         Print "What to do? ('q' to exit)"
98.  
99.         Input in$: in$ = LCase$(Left$(in$, 1))
100.  
101.         If in$ = "1" Then
102.             PlotPointTest
103.         ElseIf in$ = "2" Then
104.             PlotSquareTest
105.         ElseIf in$ = "3" Then
106.             PlotCircleTest
107.         ElseIf in$ = "4" Then
108.             PlotLineTest
109.         ElseIf in$ = "5" Then
110.             ShearRotateTest1
111.         ElseIf in$ = "6" Then
112.             ShearRotateTest2
113.         End If
114.     Loop Until in$ = "q"
115. End Sub ' main
116.  
117. ' /////////////////////////////////////////////////////////////////////////////
118. ' MyArray(1 To 32, 1 To 32) AS STRING
119.  
120. Sub PlotPoint (X As Integer, Y As Integer, S As String, MyArray() As String)
121.     If (X >= LBound(MyArray, 2)) Then
122.         If (X <= UBound(MyArray, 2)) Then
123.             If (Y >= LBound(MyArray, 1)) Then
124.                 If (Y <= UBound(MyArray, 1)) Then
125.                     If Len(S) = 1 Then
126.                         MyArray(Y, X) = S
127.                     Else
128.                         If Len(S) > 1 Then
129.                             MyArray(Y, X) = Left$(S, 1)
130.                         End If
131.                     End If
132.                 End If
133.             End If
134.         End If
135.     End If
136. End Sub ' PlotPoint
137.  
138. ' /////////////////////////////////////////////////////////////////////////////
139.  
140. Sub PlotPointTest
141.     Dim MyArray(1 To 32, 1 To 32) As String
142.     Dim iX As Integer
143.     Dim iY As Integer
144.     Dim in$
145.     Dim X As Integer
146.     Dim Y As Integer
147.     Dim L As Integer
148.     Dim iChar As Integer
149.  
150.     ClearArray MyArray(), "."
151.     iChar = 64
152.  
153.     Cls
154.     Print "Plot a point."
155.     Print ArrayToStringTest(MyArray())
156.     Print
157.  
158.     Do
159.         Print "Type x,y (1-32, 1-32) coordinate to plot point at."
160.         Input "X,Y OR 0 TO QUIT? "; X, Y
161.         If X > 0 And Y > 0 Then
162.             iChar = iChar + 1
163.             If iChar > 90 Then iChar = 65
164.  
165.             Print "X=" + cstr$(X) + ", Y=" + cstr$(Y)
166.             PlotPoint X, Y, Chr$(iChar), MyArray()
167.  
168.             Print "Current point plotted, drawn with " + Chr$(34) + Chr$(iChar) + Chr$(34) + ":"
169.             Print ArrayToStringTest(MyArray())
170.             Print
171.  
172.         Else
173.             Exit Do
174.         End If
175.     Loop
176. End Sub ' PlotPointTest
177.  
178. ' /////////////////////////////////////////////////////////////////////////////
179.  
180. Sub PlotSquare (X1 As Integer, Y1 As Integer, L As Integer, S As String, MyArray() As String)
181.     Dim X As Integer
182.     Dim X2 As Integer
183.     Dim Y As Integer
184.     Dim Y2 As Integer
185.     Dim sChar$
186.  
187.     If Len(S) = 1 Then
188.         sChar$ = S
189.     Else
190.         If Len(S) = 0 Then
191.             sChar$ = " "
192.         Else
193.             sChar$ = Left$(S, 1)
194.         End If
195.     End If
196.  
197.     X2 = (X1 + L) - 1
198.     Y2 = (Y1 + L) - 1
199.     For X = X1 To X2
200.         For Y = Y1 To Y2
201.             PlotPoint X, Y, sChar$, MyArray()
202.         Next Y
203.     Next X
204. End Sub ' PlotSquare
205.  
206. ' /////////////////////////////////////////////////////////////////////////////
207.  
208. Sub PlotSquareTest
209.     Dim MyArray(1 To 32, 1 To 32) As String
210.     Dim iX As Integer
211.     Dim iY As Integer
212.     Dim in$
213.     Dim X As Integer
214.     Dim Y As Integer
215.     Dim L As Integer
216.     Dim iChar As Integer
217.  
218.     ClearArray MyArray(), "."
219.     iChar = 64
220.  
221.     Cls
222.     Print "Enter parameters to draw a square."
223.     Print ArrayToStringTest(MyArray())
224.     Print
225.     Do
226.         Print "Type top left x,y (1-32, 1-32) coordinate to plot square,"
227.         Print "and size (1-32) of square."
228.         Input "X,Y,L OR 0 TO QUIT? "; X, Y, L
229.         If X > 0 And Y > 0 And L > 0 Then
230.             iChar = iChar + 1
231.             If iChar > 90 Then iChar = 65
232.  
233.             Print
234.             Print "X=" + cstr$(X)
235.             Print "Y=" + cstr$(Y)
236.             Print "L=" + cstr$(L)
237.             Print
238.             PlotSquare X, Y, L, Chr$(iChar), MyArray()
239.  
240.             Print "Square plotted, drawn with " + Chr$(34) + Chr$(iChar) + Chr$(34) + ":"
241.             Print ArrayToStringTest(MyArray())
242.             Print
243.         Else
244.             Exit Do
245.         End If
246.     Loop
247. End Sub ' PlotSquareTest
248.  
249. ' /////////////////////////////////////////////////////////////////////////////
250. ' Fast circle drawing in pure Atari BASIC#
251. ' https://atariwiki.org/wiki/Wiki.jsp?page=Super%20fast%20circle%20routine
252.  
253. ' * Magazine: Moj Mikro, 1989/3
254. ' * Author : Zlatko Bleha
255. ' * Page : 27 - 31
256. ' * Atari BASIC listing on disk (tokenized): M8903282.BAS
257. ' * Atari BASIC listing (listed): M8903282.LST
258.  
259. ' Next example is demonstration of implementing mentioned circle algorithm
260. ' in pure Atari BASIC. This program shows how much faster it is compared to
261. ' classic program using sine and cosine functions from Atari BASIC
262. ' (shown in last example).
263.  
264. ' Basic Listing M8903282.LST#
265. '1 REM *******************************
266. '2 REM PROGRAM  : FAST CIRCLE DRAWING
267. '3 REM AUTHOR   : ZLATKO BLEHA
268. '4 REM PUBLISHER: MOJ MIKRO MAGAZINE
269. '5 REM ISSUE NO.: 1989, NO.3, PAGE 29
270. '6 REM *******************************
271. '7 REM
272. '10 GRAPHICS 8:SETCOLOR 2,0,0:COLOR 3
273. '20 PRINT "ENTER X, Y AND R"
274. '30 INPUT X,Y,R
275. '40 IF R=0 THEN PLOT X,Y:END
276. '50 B=R:C=0:A=R-1
277. '60 PLOT X+C,Y+B
278. '70 PLOT X+C,Y-B
279. '80 PLOT X-C,Y-B
280. '90 PLOT X-C,Y+B
281. '100 PLOT X+B,Y+C
282. '110 PLOT X+B,Y-C
283. '120 PLOT X-B,Y-C
284. '130 PLOT X-B,Y+C
285. '140 C=C+1
286. '150 A=A+1-C-C
287. '160 IF A>=0 THEN 190
288. '170 B=B-1
289. '180 A=A+B+B
290. '190 IF B>=C THEN 60
291.  
292. ' Use some valid values for coordinates and radius, for example:
293. ' X=40, Y=40, R=30
294. ' X=130, Y=90, R=60
295. ' Slow circle drawing in Atari BASIC#
296. ' * Magazine: Moj Mikro, 1989/3
297. ' * Author : Zlatko Bleha
298. ' * Page : 27 - 31
299. ' * Atari BASIC listing on disk (tokenized): M8903281.BAS
300. ' * Atari BASIC listing (listed): M8903281.LST
301.  
302. ' This is classic example for drawing circles from Atari BASIC
303. ' using sine and cosine functions. Unfortunatelly, this is very slow
304. ' way of doing it and not recommended.
305. ' Just use routine shown above and everybody will be happy
306.  
307. ' Basic Listing M8903281.LST#
308. '1 REM *******************************
309. '2 REM PROGRAM  : SLOW CIRCLE DRAWING
310. '3 REM AUTHOR   : ZLATKO BLEHA
311. '4 REM PUBLISHER: MOJ MIKRO MAGAZINE
312. '5 REM ISSUE NO.: 1989, NO.3, PAGE 29
313. '6 REM *******************************
314. '7 REM
315. '10 GRAPHICS 8:SETCOLOR 2,0,0:COLOR 3
316. '20 FOR A=0 TO 6.28 STEP 0.02
317. '30 X=SIN(A)*50+150
318. '40 Y=COS(A)*50+80
319. '50 PLOT X,Y
320. '60 NEXT A
321.  
322. ' Conclusion#
323. ' Returning back to first program with the fastest way of drawing circles...
324. ' There is one more thing to note. In case you want to use PLOT subroutine,
325. ' which is part of the main circle routine, then read following explanation.
326. ' PLOT routine is written so it can be used easily from Atari BASIC program
327. ' independently from main circle routine, by using like this:
328. ' A=USR(30179,POK,X,Y)
329. '
330. ' POK   1 (drawing a pixel), 0 (erasing a pixel)
331. ' X     X coordinate of the pixel
332. ' Y     Y coordinate of the pixel
333. '
334. ' The routine alone is not any faster than normal PLOT command
335. ' from Atari BASIC, because USR command takes approximately 75%
336. ' of whole execution. But, used as part of the main circle routine
337. ' it does not matter anymore, because it is integrated in one larger
338. ' entity. There the execution is very fast, with no overhead.
339. ' PLOT routine is here for you to examine anyway.
340. ' You never know if you will maybe need it in the future.
341.  
342. ' More on plotting circles:
343. '     Drawing a circle in BASIC - fast
344. '     https://www.cpcwiki.eu/forum/programming/drawing-a-circle-in-basic-fast/
345.  
346. ' X,Y     = center point of circle
347. ' R       = radius
348. ' S       = char to draw
349. ' MyArray = 2D string array to plot circle in
350.  
351. Sub PlotCircle (X As Integer, Y As Integer, R As Integer, S As String, MyArray() As String)
352.     Dim A As Integer
353.     Dim B As Integer
354.     Dim C As Integer
355.     Dim S2 As String
356.  
357.     If Len(S) = 1 Then
358.         S2 = S
359.     Else
360.         If Len(S) = 0 Then
361.             S2 = " "
362.         Else
363.             S2 = Left$(S, 1)
364.         End If
365.     End If
366.  
367.     If R > 0 Then
368.         B = R
369.         C = 0
370.         A = R - 1
371.         Do
372.             PlotPoint X + C, Y + B, S2, MyArray()
373.             PlotPoint X + C, Y - B, S2, MyArray()
374.             PlotPoint X - C, Y - B, S2, MyArray()
375.             PlotPoint X - C, Y + B, S2, MyArray()
376.             PlotPoint X + B, Y + C, S2, MyArray()
377.             PlotPoint X + B, Y - C, S2, MyArray()
378.             PlotPoint X - B, Y - C, S2, MyArray()
379.             PlotPoint X - B, Y + C, S2, MyArray()
380.             C = C + 1
381.             A = A + 1 - C - C
382.             If A < 0 Then ' IF A>=0 THEN 190
383.                 B = B - 1
384.                 A = A + B + B
385.             End If
386.             If B < C Then Exit Do ' 190 IF B>=C THEN 60
387.         Loop
388.     End If
389. End Sub ' PlotCircle
390.  
391. ' /////////////////////////////////////////////////////////////////////////////
392.  
393. Sub PlotCircleTest
394.     Dim MyArray(1 To 32, 1 To 32) As String
395.     Dim iX As Integer
396.     Dim iY As Integer
397.     Dim in$
398.     Dim X As Integer
399.     Dim Y As Integer
400.     Dim R As Integer
401.     Dim iChar As Integer
402.  
403.     ClearArray MyArray(), "."
404.     iChar = 64
405.  
406.     Cls
407.     Print "Plot a raster circle"
408.     Print "Based on Fast circle drawing in pure Atari BASIC by Zlatko Bleha."
409.     Print
410.     Print "Enter parameters to draw a circle."
411.     Print ArrayToStringTest(MyArray())
412.     Print
413.  
414.     Do
415.         Print "Type center point x,y (1-32, 1-32) coordinate to plot circle,"
416.         Print "and radius (1-32) of circle."
417.         Input "X,Y,R OR 0 TO QUIT: "; X, Y, R
418.         If X > 0 And Y > 0 And R > 0 Then
419.             iChar = iChar + 1
420.             If iChar > 90 Then iChar = 65
421.  
422.             Print "X=" + cstr$(X)
423.             Print "Y=" + cstr$(Y)
424.             Print "R=" + cstr$(R)
425.  
426.             PlotCircle X, Y, R, Chr$(iChar), MyArray()
427.  
428.             Print "Circle plotted, drawn with " + Chr$(34) + Chr$(iChar) + Chr$(34) + ":"
429.             Print ArrayToStringTest(MyArray())
430.             Print
431.         Else
432.             Exit Do
433.         End If
434.     Loop
435.  
436. End Sub ' PlotCircleTest
437.  
438. ' /////////////////////////////////////////////////////////////////////////////
439. ' Based on "BRESNHAM.BAS" by Kurt Kuzba. (4/16/96)
440. ' From: http://www.thedubber.altervista.org/qbsrc.htm
441.  
442. Sub PlotLine (x1%, y1%, x2%, y2%, c$, MyArray() As String)
443.     Dim iLoop%
444.     Dim steep%: steep% = 0
445.     Dim ev%: ev% = 0
446.     Dim sx%
447.     Dim sy%
448.     Dim dx%
449.     Dim dy%
450.  
451.     If (x2% - x1%) > 0 Then
452.         sx% = 1
453.     Else
454.         sx% = -1
455.     End If
456.  
457.     dx% = Abs(x2% - x1%)
458.     If (y2% - y1%) > 0 Then
459.         sy% = 1
460.     Else
461.         sy% = -1
462.     End If
463.  
464.     dy% = Abs(y2% - y1%)
465.     If (dy% > dx%) Then
466.         steep% = 1
467.         Swap x1%, y1%
468.         Swap dx%, dy%
469.         Swap sx%, sy%
470.     End If
471.  
472.     ev% = 2 * dy% - dx%
473.     For iLoop% = 0 To dx% - 1
474.         If steep% = 1 Then
475.             ''PSET (y1%, x1%), c%:
476.             'LOCATE y1%, x1%
477.             'PRINT c$;
478.             PlotPoint y1%, x1%, c$, MyArray()
479.         Else
480.             ''PSET (x1%, y1%), c%
481.             'LOCATE x1%, y1%
482.             'PRINT c$;
483.             PlotPoint x1%, y1%, c$, MyArray()
484.         End If
485.  
486.         While ev% >= 0
487.             y1% = y1% + sy%
488.             ev% = ev% - 2 * dx%
489.         Wend
490.         x1% = x1% + sx%
491.         ev% = ev% + 2 * dy%
492.     Next iLoop%
493.     ''PSET (x2%, y2%), c%
494.     'LOCATE x2%, y2%
495.     'PRINT c$;
496.     PlotPoint x2%, y2%, c$, MyArray()
497. End Sub ' PlotLine
498.  
499. ' /////////////////////////////////////////////////////////////////////////////
500.  
501. Sub PlotLineTest
502.     Dim MyArray(1 To 32, 1 To 32) As String
503.     Dim in$
504.     Dim X1 As Integer
505.     Dim Y1 As Integer
506.     Dim X2 As Integer
507.     Dim Y2 As Integer
508.     Dim iChar As Integer
509.  
510.     ClearArray MyArray(), "."
511.     iChar = 64
512.  
513.     Cls
514.     Print "Plot line with Bresenham Algorithm"
515.     Print "based on BRESNHAM.BAS by Kurt Kuzba (4/16/96)."
516.     Print
517.     Print ArrayToStringTest(MyArray())
518.     Do
519.         Print "Enter coordinate values for "
520.         Print "line start point x1, y1 (1-32, 1-32)"
521.         Print "line end   point x2, y2 (1-32, 1-32)"
522.         Input "ENTER X1,Y1,X2,Y2 OR 0 TO QUIT: "; X1, Y1, X2, Y2
523.         If X1 > 0 And Y1 > 0 And X2 > 0 And Y2 > 0 Then
524.             iChar = iChar + 1
525.             If iChar > 90 Then iChar = 65
526.  
527.             Print "X1=" + cstr$(X1)
528.             Print "Y1=" + cstr$(Y1)
529.             Print "X2=" + cstr$(X2)
530.             Print "Y2=" + cstr$(Y2)
531.  
532.             PlotLine X1, Y1, X2, Y2, Chr$(iChar), MyArray()
533.  
534.             Print "Line plotted, drawn with " + Chr$(34) + Chr$(iChar) + Chr$(34) + ":"
535.             Print ArrayToStringTest(MyArray())
536.  
537.         Else
538.             Exit Do
539.         End If
540.     Loop
541. End Sub ' PlotLineTest
542.  
543. ' /////////////////////////////////////////////////////////////////////////////
544. ' 3 shear method testing
545.  
546. ' _PUT Rotation Help
547. ' https://www.qb64.org/forum/index.php?topic=1959.0
548.  
549. ' 3 Shear Rotation - rotates without any aliasing(holes)
550. ' https://www.freebasic.net/forum/viewtopic.php?t=24557
551.  
552. ' From: leopardpm
553. ' Date: Apr 02, 2016 1:21
554. ' Last edited by leopardpm on Apr 02, 2016 17:18, edited 1 time in total.
555. '
556. ' This is just a little 3-shear rotation routine
557. ' (I am using 3-shear because it leaves no gaps/aliasing)
558. ' that I was wondering if anyone sees how to make it faster.
559. ' Obviously, I am just thinking about inside the double loop.
560.  
561. ' Thanks again to BasicCoder2 for linking me to this little routine, it is wonderful so far!
562.  
563. '''                      roto-zooming algorithm
564. '''                    coded by Michael S. Nissen
565. '''                        jernmager@yahoo.dk
566. '
567. ''' ===============================================================
568. ''' Recoded to run on FBC 32/64 bit WIN, Version 1.05.0, 2016, by MrSwiss
569. ''' Heavy flickering before going Full-Screen on 64 Bit !!!
570. ''' This seems NOT to be the Case on 32 Bit ...
571. ''' ===============================================================
572. '
573. 'Type Pixel
574. '  As Single   X, Y
575. '  As ULong    C
576. 'End Type
577. '
578. '''  dim vars
579. 'Dim shared as Any Ptr Img_Buffer
580. '''  write the name of the .bmp image you want to rotozoom here:
581. '''  (it has to be sqare ie. 100x100 pixels, 760x760 pixels or whatever)
582. 'Dim As String Img_Name = "phobos.bmp"
583. 'Dim shared as Integer X_Mid, Y_Mid, scrn_wid, scrn_hgt, P1, P2, P3, P4, C
584. 'Dim shared as Short Img_Hgt, Img_Wid, Img_Lft, Img_Rgt, Img_Top, Img_Btm, X, Y
585. 'Dim Shared As Single Cos_Ang, Sin_Ang, Rot_Fac_X, Rot_Fac_Y, Angle = 0, Scale = 1
586. '
587. ''' changed Function to Sub (+ recoded arguments list)
588. 'Sub Calc_rotozoom ( ByRef Cos_Ang As Single, _
589. '               ByRef Sin_Ang As Single, _
590. '               ByVal S_Fact  As Single, _
591. '               ByVal NewAng  As Single )
592. '  Cos_Ang = Cos(NewAng)*S_Fact
593. '  Sin_Ang = Sin(NewAng)*S_Fact
594. 'End Sub
595. '
596. '''  full screen
597. 'ScreenInfo scrn_wid, scrn_hgt
598. 'screenRes scrn_wid, scrn_hgt, 32,,1
599. '
600. '''  dim screenpointer (has to be done after screenres)
601. 'Dim As ULong Ptr Scrn_Ptr = Screenptr
602. '
603. '''  place image in center of screen
604. 'X_Mid = scrn_wid\2
605. 'Y_Mid = scrn_hgt\2
606. 'Calc_rotozoom(Cos_Ang, Sin_Ang, Scale, Angle)
607. '
608. '''  find image dimensions
609. 'Open Img_Name For Binary As #1
610. 'Get #1, 19, Img_Wid
611. 'Get #1, 23, Img_Hgt
612. 'Close #1
613. '
614. '''  prepare to dim the array that will hold the image.
615. 'Img_Rgt = (Img_Wid-1)\2
616. 'Img_Lft = -Img_Rgt
617. 'Img_Btm = (Img_Hgt-1)\2
618. 'Img_Top = -Img_Btm
619. '
620. '''  dim array to hold image. Note: pixel (0, 0) is in the center.
621. 'Dim As Pixel Pixel(Img_Lft to Img_Rgt, Img_Top to Img_Btm)
622. '
623. '''  imagecreate sprite and load image to sprite
624. 'Img_Buffer = ImageCreate (Img_Wid, Img_Hgt)
625. 'Bload (Img_Name, Img_Buffer)
626. '
627. '''  load image from sprite to array with point command
628. 'For Y = Img_Top to Img_Btm
629. '  For X = Img_Lft to Img_Rgt
630. '    With Pixel(X, Y)
631. '      .X = X_Mid+X
632. '      .Y = Y_Mid+Y
633. '      C = Point (X-Img_Top, Y-Img_Lft, Img_buffer)
634. '      If C <> RGB(255, 0, 255) Then
635. '        .C = C
636. '      Else
637. '        .C = RGB(0, 0, 0)
638. '      End If
639. '    End With
640. '  Next X
641. 'Next Y
642. '
643. '''  we don't need the sprite anymore, kill it
644. 'ImageDestroy Img_Buffer
645. 'Img_Buffer = 0
646. '
647. '''  main program loop
648. 'Do
649. '
650. '  ''  scale in/out with uparrow/downarrow
651. '  If Multikey(80) Then
652. '    Scale *= 1.03
653. '    Calc_rotozoom(Cos_Ang, Sin_Ang, Scale, Angle)
654. '  ElseIf Multikey(72) Then
655. '    Scale *= 0.97
656. '    Calc_rotozoom(Cos_Ang, Sin_Ang, Scale, Angle)
657. '  End If
658. '
659. '  ''  rotate left/right with leftarrow/rightarrow
660. '  If Multikey(77) Then
661. '    Angle -= 0.03
662. '    Calc_rotozoom(Cos_Ang, Sin_Ang, Scale, Angle)
663. '  ElseIf Multikey(75) Then
664. '    Angle += 0.03
665. '    Calc_rotozoom(Cos_Ang, Sin_Ang, Scale, Angle)
666. '  End If
667. '
668. '  ''  lock screen in order to use screen pointers
669. '  ScreenLock
670. '
671. '    ''  draw pixel in center of image
672. '    Scrn_Ptr[ X_Mid + Y_Mid * scrn_wid ] = Pixel(0, 0).C
673. '    ''  draw all other pixels - 4 at a time
674. '    For Y = Img_Top to 0
675. '      For X = Img_Lft to -1
676. '        ''  find pixel positions
677. '        P1 = (X_Mid+X) + (Y_Mid+Y) * scrn_wid
678. '        P2 = (X_Mid-X) + (Y_Mid-Y) * scrn_wid
679. '        P3 = (X_Mid+Y) + (Y_Mid-X) * scrn_wid
680. '        P4 = (X_Mid-Y) + (Y_Mid+X) * scrn_wid
681. '        ''  erase old pixels (paint them black)
682. '        Scrn_Ptr[P1] = 0
683. '        Scrn_Ptr[P2] = 0
684. '        Scrn_Ptr[P3] = 0
685. '        Scrn_Ptr[P4] = 0
686. '        ''  rotate and zoom
687. '        Rot_Fac_X = X*Cos_Ang - Y*Sin_Ang
688. '        Rot_Fac_Y = X*Sin_Ang + Y*Cos_Ang
689. '        If Rot_Fac_X < Img_Lft Or Rot_Fac_X > Img_Rgt Then Continue For
690. '        If Rot_Fac_Y < Img_Top Or Rot_Fac_Y > Img_Btm Then Continue For
691. '        ''  draw new pixels
692. '        Scrn_Ptr[P1] = Pixel(Rot_Fac_X, Rot_Fac_Y).C
693. '        Scrn_Ptr[P2] = Pixel(-Rot_Fac_X, -Rot_Fac_Y).C
694. '        Scrn_Ptr[P3] = Pixel(Rot_Fac_Y, -Rot_Fac_X).C
695. '        Scrn_Ptr[P4] = Pixel(-Rot_Fac_Y, Rot_Fac_X).C
696. '      Next X
697. '    Next Y
698. '
699. '  ScreenUnLock
700. '
701. '  Sleep 10, 1
702. 'Loop Until InKey() = Chr(27)
703.  
704. ' UPDATES:
705. ' Fixed bug where values 135, 224, and 314 all resolve to -45 degrees.
706. ' Fixed bug where an angle of 46-135 degrees caused the image to be flipped wrong.
707.  
708. ' TODO:
709. ' Fix issue where image looks bad at 30, 60, 120, 150, 210, 240, 300, 330 degrees
710.  
711. Sub ShearRotate (OldArray() As RotationType, NewArray() As RotationType, angle1 As Integer, iEmpty As Integer)
712.     Const Pi = 4 * Atn(1)
713.  
714.     Dim angle As Integer
715.     Dim TwoPi As Double: TwoPi = 8 * Atn(1)
716.     Dim RtoD As Double: RtoD = 180 / Pi ' radians * RtoD = degrees
717.     Dim DtoR As Double: DtoR = Pi / 180 ' degrees * DtoR = radians
718.     Dim x As Integer
719.     Dim y As Integer
720.     Dim nangle As Integer
721.     Dim nx As Integer
722.     Dim ny As Integer
723.     Dim flipper As Integer
724.     Dim rotr As Double
725.     Dim shear1 As Double
726.     Dim shear2 As Double
727.     Dim clr As Integer
728.     Dim y1 As _Byte
729.     Dim xy1 As _Byte
730.     Dim fy As _Byte
731.     Dim fx As _Byte
732.     Dim in$
733.     Dim sLine As String
734.  
735.     ' initialize new with empty
736.     ReDim NewArray(LBound(OldArray, 1) To UBound(OldArray, 1), LBound(OldArray, 2) To UBound(OldArray, 2), 127) As RotationType
737.     For x = LBound(NewArray, 1) To UBound(NewArray, 1)
738.         For y = LBound(NewArray, 2) To UBound(NewArray, 2)
739.             NewArray(x, y, 0).origx = x
740.             NewArray(x, y, 0).origy = y
741.             NewArray(x, y, 0).c = iEmpty
742.         Next y
743.     Next x
744.  
745.     ' angle is reversed
746.     angle = 360 - angle1
747.  
748.     ' Shearing each element 3 times in one shot
749.     nangle = angle
750.  
751.     ' this pre-processing portion basically rotates by 90 to get
752.     ' between -45 and 45 degrees, where the 3-shear routine works correctly...
753.     If angle > 45 And angle < 225 Then
754.         If angle < 135 Then
755.             nangle = angle - 90
756.         Else
757.             nangle = angle - 180
758.         End If
759.     End If
760.     If angle > 135 And angle < 315 Then
761.         If angle < 225 Then
762.             nangle = angle - 180
763.         Else
764.             nangle = angle - 270
765.         End If
766.     End If
767.     If nangle < 0 Then
768.         nangle = nangle + 360
769.     End If
770.     If nangle > 359 Then
771.         nangle = nangle - 360
772.     End If
773.  
774.     rotr = nangle * DtoR
775.     shear1 = Tan(rotr / 2) ' correct way
776.     shear2 = Sin(rotr)
777.  
778.     ' *** NOTE: this had a bug where the values 135, 224, and 314
779.     ' ***       all resolve to -45 degrees.
780.     ' ***       Fixed by changing < to <=
781.  
782.     'if angle >  45 and angle < 134 then
783.     If angle > 45 And angle <= 134 Then
784.         flipper = 1
785.     ElseIf angle > 134 And angle <= 224 Then
786.         flipper = 2
787.     ElseIf angle > 224 And angle <= 314 Then
788.         ' *** NOTE: this had a bug where this flipper was wrong
789.         '           Fixed by adding case 7
790.         'flipper = 3
791.         flipper = 7
792.     Else
793.         flipper = 0
794.     End If
795.  
796.     ' Here is where it needs some optimizing possibly... kinda slow...
797.     For y = LBound(NewArray, 2) To UBound(NewArray, 2)
798.         For x = LBound(NewArray, 1) To UBound(NewArray, 1)
799.             Select Case flipper
800.                 Case 1:
801.                     nx = -y
802.                     ny = x
803.                 Case 2:
804.                     nx = -x
805.                     ny = -y
806.                 Case 3:
807.                     nx = -y
808.                     ny = -x
809.                 Case 4:
810.                     nx = -x
811.                     ny = y
812.                 Case 5:
813.                     nx = x
814.                     ny = -y
815.                 Case 6:
816.                     nx = y
817.                     ny = x
818.                 Case 7:
819.                     nx = y
820.                     ny = -x
821.                 Case Else:
822.                     nx = x
823.                     ny = y
824.             End Select
825.  
826.             clr = OldArray(nx, ny, 0).c
827.  
828.             y1 = y * shear1
829.             xy1 = x + y1
830.             fy = (y - xy1 * shear2)
831.             fx = xy1 + fy * shear1
832.  
833.             If fx >= -16 And fx <= 16 Then
834.                 If fy >= -16 And fy <= 16 Then
835.                     NewArray(fx, fy, 0).c = clr
836.                     NewArray(fx, fy, 0).origx = fx
837.                     NewArray(fx, fy, 0).origy = fy
838.                 End If
839.             End If
840.         Next x
841.     Next y
842. End Sub ' ShearRotate
843.  
844. ' /////////////////////////////////////////////////////////////////////////////
845.  
846. Sub ShearRotateTest1
847.     Dim RoArray1(-16 To 16, -16 To 16, 127) As RotationType
848.     Dim RoArray2(-16 To 16, -16 To 16, 127) As RotationType
849.     Dim sMap As String
850.     Dim D As Integer
851.     Dim in$
852.  
853.     ' GET A SHAPE TO BE ROTATED
854.     Cls
855.     Print "3 shear rotation based on code by leopardpm"
856.     Print
857.  
858.     sMap = TestSprite1$
859.  
860.     ' CONVERT SHAPE TO ARRAY
861.     StringToRotationArray RoArray1(), sMap, "."
862.     Print "Initial contents of Rotation Array:"
863.     Print RotationArrayToStringTest(RoArray1())
864.     Print
865.  
866.     ' ROTATE THE SHAPE
867.     Do
868.         Print "Type degrees to rotate (0 TO 360) or non-numeric value to quit."
869.         Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)."
870.  
871.         Input "Degrees to rotate (q to quit)? "; in$
872.         If IsNum%(in$) Then
873.             D = Val(in$)
874.             If D >= 0 And D <= 360 Then
875.                 ShearRotate RoArray1(), RoArray2(), D, Asc(".")
876.                 Print
877.                 Print "Rotated by " + cstr$(D) + " degrees:"
878.                 Print RotationArrayToStringTest(RoArray2())
879.                 Print
880.             Else
881.                 Exit Do
882.             End If
883.         Else
884.             Exit Do
885.         End If
886.     Loop
887. End Sub ' ShearRotateTest1
888.  
889. ' /////////////////////////////////////////////////////////////////////////////
890.  
891. Sub ShearRotateTest2
892.     Dim RoArray1(-16 To 16, -16 To 16, 127) As RotationType
893.     Dim RoArray2(-16 To 16, -16 To 16, 127) As RotationType
894.     Dim sMap As String
895.     Dim D As Integer
896.     Dim D1 As Integer
897.     Dim in$
898.     Dim bFinished As Integer
899.  
900.     ' GET A SHAPE TO BE ROTATED
901.     Cls
902.     Print "3 shear rotation based on code by leopardpm"
903.     sMap = TestSprite1$
904.  
905.     ' CONVERT SHAPE TO ARRAY
906.     StringToRotationArray RoArray1(), sMap, "."
907.  
908.     ' GET START ANGLE
909.     D = 0
910.     Print
911.     Print "Rotated by " + cstr$(D) + " degrees:"
912.     Print RotationArrayToStringTest(RoArray1())
913.     Print
914.     Print "Type an angle (-360 to 360) to rotate to, "
915.     Print "or blank to increase by 1 degree, or q to quit."
916.     Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)."
917.     Print "Hold down <ENTER> to rotate continually."
918.     Input "Angle (q to quit)? ", in$
919.     If Len(in$) > 0 Then
920.         If IsNum%(in$) Then
921.             D1 = Val(in$)
922.         Else
923.             D1 = -500
924.         End If
925.     Else
926.         D1 = 1
927.     End If
928.  
929.     ' ROTATE TO EACH ANGLE
930.     If D1 >= -360 And D1 <= 360 Then
931.         bFinished = FALSE
932.         Do
933.             ' ROTATE CLOCKWISE
934.             For D = D1 To 360
935.                 Cls
936.                 ShearRotate RoArray1(), RoArray2(), D, Asc(".")
937.                 Print
938.                 Print "Rotated by " + cstr$(D) + " degrees:"
939.                 Print RotationArrayToStringTest(RoArray2())
940.                 Print
941.  
942.                 Print "Type an angle (-360 to 360) to rotate to, "
943.                 Print "or blank to increase by 1 degree, or q to quit."
944.                 Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)."
945.                 Print "Hold down <ENTER> to rotate continually."
946.                 Input "Angle (q to quit)? ", in$
947.                 If Len(in$) > 0 Then
948.                     If IsNum%(in$) Then
949.                         D = Val(in$)
950.                         If D >= 0 And D <= 360 Then
951.                             D = D - 1
952.                         Else
953.                             bFinished = TRUE
954.                             Exit For
955.                         End If
956.                     Else
957.                         bFinished = TRUE
958.                         Exit For
959.                     End If
960.                 End If
961.             Next D
962.             If bFinished = TRUE Then Exit Do
963.  
964.             ' ROTATE COUNTER-CLOCKWISE
965.             For D = 360 To D1 Step -1
966.                 Cls
967.                 ShearRotate RoArray1(), RoArray2(), D, Asc(".")
968.                 Print
969.                 Print "Rotated by " + cstr$(D) + " degrees:"
970.  
971.                 Print RotationArrayToStringTest(RoArray2())
972.                 Print
973.  
974.                 Print "Type an angle (0 to 360) to rotate to, "
975.                 Print "or blank to increase by 1 degree, or q to quit."
976.                 Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)."
977.                 Print "Hold down <ENTER> to rotate continually."
978.                 Input "Angle (q to quit)? ", in$
979.                 If Len(in$) > 0 Then
980.                     If IsNum%(in$) Then
981.                         D = Val(in$)
982.                         If D >= 0 And D <= 360 Then
983.                             D = D + 1
984.                         Else
985.                             bFinished = TRUE
986.                             Exit For
987.                         End If
988.                     Else
989.                         bFinished = TRUE
990.                         Exit For
991.                     End If
992.                 End If
993.             Next D
994.             If bFinished = TRUE Then Exit Do
995.         Loop
996.     End If
997. End Sub ' ShearRotateTest2
998.  
999. ' /////////////////////////////////////////////////////////////////////////////
1000.  
1001. Function TestSprite1$
1002.     Dim m$
1003.     m$ = ""
1004.     '                   11111111112222222222333
1005.     '          12345678901234567890123456789012
1006.     m$ = m$ + "11111111111111111111111111111111" + Chr$(13) ' 1
1007.     m$ = m$ + "4..............................2" + Chr$(13) ' 2
1008.     m$ = m$ + "4....##.....#######.....####...2" + Chr$(13) ' 3
1009.     m$ = m$ + "4...####....##...###...######..2" + Chr$(13) ' 4
1010.     m$ = m$ + "4..##..##...##...###..##....##.2" + Chr$(13) ' 5
1011.     m$ = m$ + "4.##....##..#######...##.......2" + Chr$(13) ' 6
1012.     m$ = m$ + "4.########..#######...##.......2" + Chr$(13) ' 7
1013.     m$ = m$ + "4.########..##...###..##....##.2" + Chr$(13) ' 8
1014.     m$ = m$ + "4.##....##..##...###...######..2" + Chr$(13) ' 9
1015.     m$ = m$ + "4.##....##..#######.....####...2" + Chr$(13) ' 10
1016.     m$ = m$ + "4..............................2" + Chr$(13) ' 11
1017.     m$ = m$ + "4..............................2" + Chr$(13) ' 12
1018.     m$ = m$ + "4..ABBBBBBBBBBBBBBBBBBBBBBBBC..2" + Chr$(13) ' 13
1019.     m$ = m$ + "4..A...........EE...........C..2" + Chr$(13) ' 14
1020.     m$ = m$ + "4..A..........FFFF..........C..2" + Chr$(13) ' 15
1021.     m$ = m$ + "4..A.........GGGGGG.........C..2" + Chr$(13) ' 16
1022.     m$ = m$ + "4..A........HHHHHHHH........C..2" + Chr$(13) ' 17
1023.     m$ = m$ + "4..A.......IIIIIIIIII.......C..2" + Chr$(13) ' 18
1024.     m$ = m$ + "4..A......JJJJJJJJJJJJ......C..2" + Chr$(13) ' 19
1025.     m$ = m$ + "4..DDDDDDDDDDDDDDDDDDDDDDDDDC..2" + Chr$(13) ' 20
1026.     m$ = m$ + "4..............................2" + Chr$(13) ' 21
1027.     m$ = m$ + "4..............................2" + Chr$(13) ' 22
1028.     m$ = m$ + "4.######....########..########.2" + Chr$(13) ' 23
1029.     m$ = m$ + "4.#######...########..########.2" + Chr$(13) ' 24
1030.     m$ = m$ + "4.##...###..##........##.......2" + Chr$(13) ' 25
1031.     m$ = m$ + "4.##....##..########..#######..2" + Chr$(13) ' 26
1032.     m$ = m$ + "4.##....##..########..#######..2" + Chr$(13) ' 27
1033.     m$ = m$ + "4.##...###..##........##.......2" + Chr$(13) ' 28
1034.     m$ = m$ + "4.#######...##........##.......2" + Chr$(13) ' 29
1035.     m$ = m$ + "4.######....########..##.......2" + Chr$(13) ' 30
1036.     m$ = m$ + "4..............................2" + Chr$(13) ' 31
1037.     m$ = m$ + "33333333333333333333333333333332" + Chr$(13) ' 32
1038.     TestSprite1$ = m$
1039. End Function ' TestSprite1$
1040.  
1041. ' /////////////////////////////////////////////////////////////////////////////
1042.  
1043. Function TestSprite2$
1044.     Dim m$
1045.     m$ = ""
1046.     '                   11111111112222222222333
1047.     '          12345678901234567890123456789012
1048.     m$ = m$ + "...............AA..............." + Chr$(13) ' 1
1049.     m$ = m$ + "..............//BB.............." + Chr$(13) ' 2
1050.     m$ = m$ + ".............??..CC............." + Chr$(13) ' 3
1051.     m$ = m$ + "............==....DD............" + Chr$(13) ' 4
1052.     m$ = m$ + "...........++......EE..........." + Chr$(13) ' 5
1053.     m$ = m$ + "..........&&........FF.........." + Chr$(13) ' 6
1054.     m$ = m$ + ".........zz..........GG........." + Chr$(13) ' 7
1055.     m$ = m$ + "........yy............HH........" + Chr$(13) ' 8
1056.     m$ = m$ + ".......xx..............II......." + Chr$(13) ' 9
1057.     m$ = m$ + "......ww................JJ......" + Chr$(13) ' 10
1058.     m$ = m$ + ".....vv..................KK....." + Chr$(13) ' 11
1059.     m$ = m$ + "....uu....................LL...." + Chr$(13) ' 12
1060.     m$ = m$ + "...tt......DDAAAAAAA.......MM..." + Chr$(13) ' 13
1061.     m$ = m$ + "..ss.......DDAAAAAAA........NN.." + Chr$(13) ' 14
1062.     m$ = m$ + ".rr........DD.....BB.........OO." + Chr$(13) ' 15
1063.     m$ = m$ + "qq.........DD.....BB..........PP" + Chr$(13) ' 16
1064.     m$ = m$ + "pp.........DD.....BB..........QQ" + Chr$(13) ' 17
1065.     m$ = m$ + ".oo........DD.....BB.........RR." + Chr$(13) ' 18
1066.     m$ = m$ + "..nn.......CCCCCCCBB........SS.." + Chr$(13) ' 19
1067.     m$ = m$ + "...mm......CCCCCCCBB.......TT..." + Chr$(13) ' 20
1068.     m$ = m$ + "....ll....................UU...." + Chr$(13) ' 21
1069.     m$ = m$ + ".....kk..................VV....." + Chr$(13) ' 22
1070.     m$ = m$ + "......jj................WW......" + Chr$(13) ' 23
1071.     m$ = m$ + ".......ii..............XX......." + Chr$(13) ' 24
1072.     m$ = m$ + "........hh............YY........" + Chr$(13) ' 25
1073.     m$ = m$ + ".........gg..........ZZ........." + Chr$(13) ' 26
1074.     m$ = m$ + "..........ff........@@.........." + Chr$(13) ' 27
1075.     m$ = m$ + "...........ee......##..........." + Chr$(13) ' 28
1076.     m$ = m$ + "............dd....$$............" + Chr$(13) ' 29
1077.     m$ = m$ + ".............cc..%%............." + Chr$(13) ' 30
1078.     m$ = m$ + "..............bb\\.............." + Chr$(13) ' 31
1079.     m$ = m$ + "...............aa..............." + Chr$(13) ' 32
1080.     TestSprite2$ = m$
1081. End Function ' TestSprite2$
1082.  
1083. ' /////////////////////////////////////////////////////////////////////////////
1084.  
1085. Function ArrayToString$ (MyArray( 1 To 32 , 1 To 32) As String)
1086.     Dim MyString As String
1087.     Dim iY As Integer
1088.     Dim iX As Integer
1089.     Dim sLine As String
1090.     MyString = ""
1091.     For iY = LBound(MyArray, 1) To UBound(MyArray, 1)
1092.         sLine = ""
1093.         For iX = LBound(MyArray, 2) To UBound(MyArray, 2)
1094.             sLine = sLine + MyArray(iY, iX)
1095.         Next iX
1096.         MyString = MyString + sLine + Chr$(13)
1097.     Next iY
1098.     ArrayToString$ = MyString
1099. End Function ' ArrayToString$
1100.  
1101. ' /////////////////////////////////////////////////////////////////////////////
1102.  
1103. Function ArrayToStringTest$ (MyArray() As String)
1104.     Dim MyString As String
1105.     Dim iY As Integer
1106.     Dim iX As Integer
1107.     Dim sLine As String
1108.     MyString = ""
1109.  
1110.     MyString = MyString + "           11111111112222222222333" + Chr$(13)
1111.     MyString = MyString + "  12345678901234567890123456789012" + Chr$(13)
1112.     For iY = LBound(MyArray, 1) To UBound(MyArray, 1)
1113.         sLine = ""
1114.         sLine = sLine + Right$("  " + cstr$(iY), 2)
1115.         For iX = LBound(MyArray, 2) To UBound(MyArray, 2)
1116.             sLine = sLine + MyArray(iY, iX)
1117.         Next iX
1118.         sLine = sLine + Right$("  " + cstr$(iY), 2)
1119.         MyString = MyString + sLine + Chr$(13)
1120.     Next iY
1121.     MyString = MyString + "  12345678901234567890123456789012" + Chr$(13)
1122.     MyString = MyString + "           11111111112222222222333" + Chr$(13)
1123.     ArrayToStringTest$ = MyString
1124. End Function ' ArrayToStringTest$
1125.  
1126. ' /////////////////////////////////////////////////////////////////////////////
1127.  
1128. Function RotationArrayToStringTest$ (RoArray() As RotationType)
1129.     Dim MyString As String
1130.     Dim iY As Integer
1131.     Dim iX As Integer
1132.     Dim sLine As String
1133.     MyString = ""
1134.     MyString = MyString + "   ---------------- ++++++++++++++++" + Chr$(13)
1135.     MyString = MyString + "   1111111                   1111111" + Chr$(13)
1136.     MyString = MyString + "   654321098765432101234567890123456" + Chr$(13)
1137.     For iY = LBound(RoArray, 1) To UBound(RoArray, 1)
1138.         sLine = ""
1139.         sLine = sLine + Right$("    " + cstr$(iY), 3)
1140.         For iX = LBound(RoArray, 2) To UBound(RoArray, 2)
1141.             sLine = sLine + Chr$(RoArray(iX, iY, 0).c)
1142.         Next iX
1143.         sLine = sLine + Right$("   " + cstr$(iY), 3)
1144.         MyString = MyString + sLine + Chr$(13)
1145.     Next iY
1146.     MyString = MyString + "   654321098765432101234567890123456" + Chr$(13)
1147.     MyString = MyString + "   1111111                   1111111" + Chr$(13)
1148.     MyString = MyString + "   ---------------- ++++++++++++++++" + Chr$(13)
1149.     RotationArrayToStringTest$ = MyString
1150. End Function ' RotationArrayToStringTest$
1151.  
1152. ' /////////////////////////////////////////////////////////////////////////////
1153. ' 1. split string by line breaks CHR$(13)
1154. ' 2. split lines up to 1 column per char
1155. ' 3. count rows, columns
1156. ' 4. DIM array, making sure array has
1157. '    a) an _ODD_ number of rows/columns, with a center point
1158. '    b) index is in cartesian format, where center is (0,0)
1159. ' 5. populate array with contents of string
1160.  
1161. ' dimension #1 = columns
1162. ' dimension #2 = rows
1163.  
1164. Sub StringToRotationArray (RoArray() As RotationType, MyString As String, EmptyChar As String)
1165.     Dim RoutineName As String: RoutineName = "StringToRotationArray"
1166.     ReDim arrLines$(0)
1167.     Dim delim$
1168.     Dim iRow%
1169.     Dim iCol%
1170.     Dim sChar$
1171.     Dim iColCount As Integer
1172.     Dim iRowCount As Integer
1173.     Dim iCount As Integer
1174.     Dim bAddedRow As Integer: bAddedRow = FALSE
1175.     Dim bAddedColumn As Integer: bAddedColumn = FALSE
1176.     Dim iHalf1 As Integer
1177.     Dim iHalf2 As Integer
1178.     Dim iFrom1 As Integer
1179.     Dim iFrom2 As Integer
1180.     Dim iTo1 As Integer
1181.     Dim iTo2 As Integer
1182.     Dim iEmpty As Integer
1183.     Dim iX As Integer
1184.     Dim iY As Integer
1185.  
1186.     delim$ = Chr$(13)
1187.     split MyString, delim$, arrLines$()
1188.  
1189.     iRowCount = UBound(arrLines$) + 1
1190.  
1191.     ' look at all the rows and find the max # of columns used
1192.     iColCount = 0
1193.     For iRow% = LBound(arrLines$) To UBound(arrLines$)
1194.  
1195.         ' count the columns for this row
1196.         iCount = 0
1197.         For iCol% = 1 To Len(arrLines$(iRow%))
1198.             iCount = iCount + 1
1199.         Next iCol%
1200.  
1201.         ' if this row has the most so far, then set that to the max
1202.         If iCount > iColCount Then
1203.             iColCount = iCount
1204.         End If
1205.     Next iRow%
1206.  
1207.     ' adjust columns to be odd
1208.     If IsEven%(iColCount) Then
1209.         iColCount = iColCount + 1
1210.         bAddedColumn = TRUE
1211.     End If
1212.  
1213.     ' calculate array bounds for columns
1214.     iHalf1 = (iColCount - 1) / 2
1215.     iFrom1 = 0 - iHalf1
1216.     iTo1 = iHalf1
1217.  
1218.     ' adjust rows to be odd
1219.     If IsEven%(iRowCount) Then
1220.         iRowCount = iRowCount + 1
1221.         bAddedRow = TRUE
1222.     End If
1223.  
1224.     ' calculate array bounds for rows
1225.     iHalf2 = (iRowCount - 1) / 2
1226.     iFrom2 = 0 - iHalf2
1227.     iTo2 = iHalf2
1228.  
1229.     ' size array to new bounds
1230.     ReDim RoArray(iFrom1 To iTo1, iFrom2 To iTo2, 127) As RotationType
1231.  
1232.     ' get value for empty
1233.     If Len(EmptyChar) > 0 Then
1234.         iEmpty = Asc(EmptyChar)
1235.     Else
1236.         iEmpty = 32 ' (use space as default)
1237.     End If
1238.  
1239.     ' clear array
1240.     For iY = LBound(RoArray, 2) To UBound(RoArray, 2)
1241.         For iX = LBound(RoArray, 1) To UBound(RoArray, 1)
1242.             RoArray(iX, iY, 0).c = iEmpty
1243.             RoArray(iX, iY, 0).origx = iX
1244.             RoArray(iX, iY, 0).origy = iY
1245.         Next iX
1246.     Next iY
1247.  
1248.     ' fill array
1249.     iY = LBound(RoArray, 2) - 1
1250.     For iRow% = LBound(arrLines$) To UBound(arrLines$)
1251.         iY = iY + 1
1252.         iX = LBound(RoArray, 1) - 1
1253.         For iCol% = 1 To Len(arrLines$(iRow%))
1254.             iX = iX + 1
1255.             sChar$ = Mid$(arrLines$(iRow%), iCol%, 1)
1256.             RoArray(iX, iY, 0).c = Asc(sChar$)
1257.         Next iCol%
1258.     Next iRow%
1259.  
1260. End Sub ' StringToRotationArray
1261.  
1262. ' /////////////////////////////////////////////////////////////////////////////
1263.  
1264. Sub StringToArray (MyArray() As String, MyString As String)
1265.     Dim delim$
1266.     ReDim arrLines$(0)
1267.     Dim iRow%
1268.     Dim iCol%
1269.     Dim sChar$
1270.     Dim iDim1 As Integer
1271.     Dim iDim2 As Integer
1272.     iDim1 = LBound(MyArray, 1)
1273.     iDim2 = LBound(MyArray, 2)
1274.     delim$ = Chr$(13)
1275.     split MyString, delim$, arrLines$()
1276.     For iRow% = LBound(arrLines$) To UBound(arrLines$)
1277.         If iRow% <= UBound(MyArray, 2) Then
1278.             For iCol% = 1 To Len(arrLines$(iRow%))
1279.                 If iCol% <= UBound(MyArray, 1) Then
1280.                     sChar$ = Mid$(arrLines$(iRow%), iCol%, 1)
1281.  
1282.                     If Len(sChar$) > 1 Then
1283.                         sChar$ = Left$(sChar$, 1)
1284.                     Else
1285.                         If Len(sChar$) = 0 Then
1286.                             sChar$ = "."
1287.                         End If
1288.                     End If
1289.                     MyArray(iRow% + iDim1, (iCol% - 1) + iDim2) = sChar$
1290.                 Else
1291.                     ' Exit if out of bounds
1292.                     Exit For
1293.                 End If
1294.             Next iCol%
1295.         Else
1296.             ' Exit if out of bounds
1297.             Exit For
1298.         End If
1299.     Next iRow%
1300. End Sub ' StringToArray
1301.  
1302. ' /////////////////////////////////////////////////////////////////////////////
1303.  
1304. 'SUB ClearArray (MyArray(1 To 32, 1 To 32) AS STRING, MyString As String)
1305. Sub ClearArray (MyArray() As String, MyString As String)
1306.     Dim iRow As Integer
1307.     Dim iCol As Integer
1308.     Dim sChar$
1309.     If Len(MyString) = 1 Then
1310.         sChar$ = MyString
1311.     Else
1312.         If Len(MyString) = 0 Then
1313.             sChar$ = " "
1314.         Else
1315.             sChar$ = Left$(MyString, 1)
1316.         End If
1317.     End If
1318.     For iRow = LBound(MyArray, 1) To UBound(MyArray, 1)
1319.         For iCol = LBound(MyArray, 2) To UBound(MyArray, 2)
1320.             MyArray(iRow, iCol) = sChar$
1321.         Next iCol
1322.     Next iRow
1323. End Sub ' ClearArray
1324.  
1325. ' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1326. ' BEGIN GENERAL PURPOSE ROUTINES
1327. ' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1328.  
1329. ' /////////////////////////////////////////////////////////////////////////////
1330.  
1331. Function cstr$ (myValue)
1332.     'cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
1333.     cstr$ = _Trim$(Str$(myValue))
1334. End Function ' cstr$
1335.  
1336. Function cstrl$ (myValue As Long)
1337.     cstrl$ = _Trim$(Str$(myValue))
1338. End Function ' cstrl$
1339.  
1340. ' /////////////////////////////////////////////////////////////////////////////
1341.  
1342. Function IIF (Condition, IfTrue, IfFalse)
1343.     If Condition Then IIF = IfTrue Else IIF = IfFalse
1344. End Function
1345.  
1346. ' /////////////////////////////////////////////////////////////////////////////
1347.  
1348. Function IIFSTR$ (Condition, IfTrue$, IfFalse$)
1349.     If Condition Then IIFSTR$ = IfTrue$ Else IIFSTR$ = IfFalse$
1350. End Function
1351.  
1352. ' /////////////////////////////////////////////////////////////////////////////
1353. ' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
1354.  
1355. Function IsEven% (n)
1356.     If n Mod 2 = 0 Then
1357.         IsEven% = TRUE
1358.     Else
1359.         IsEven% = FALSE
1360.     End If
1361. End Function ' IsEven%
1362.  
1363. ' /////////////////////////////////////////////////////////////////////////////
1364. ' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
1365.  
1366. Function IsOdd% (n)
1367.     If n Mod 2 = 1 Then
1368.         IsOdd% = TRUE
1369.     Else
1370.         IsOdd% = FALSE
1371.     End If
1372. End Function ' IsOdd%
1373.  
1374. ' /////////////////////////////////////////////////////////////////////////////
1375. ' By sMcNeill from https://www.qb64.org/forum/index.php?topic=896.0
1376.  
1377. Function IsNum% (text$)
1378.     Dim a$
1379.     Dim b$
1380.     a$ = _Trim$(text$)
1381.     b$ = _Trim$(Str$(Val(text$)))
1382.     If a$ = b$ Then
1383.         IsNum% = TRUE
1384.     Else
1385.         IsNum% = FALSE
1386.     End If
1387. End Function ' IsNum%
1388.  
1389. ' /////////////////////////////////////////////////////////////////////////////
1390. ' Split and join strings
1391. ' https://www.qb64.org/forum/index.php?topic=1073.0
1392.  
1393. 'Combine all elements of in$() into a single string with delimiter$ separating the elements.
1394.  
1395. Function join$ (in$(), delimiter$)
1396.     result$ = in$(LBound(in$))
1397.     For i = LBound(in$) + 1 To UBound(in$)
1398.         result$ = result$ + delimiter$ + in$(i)
1399.     Next i
1400.     join$ = result$
1401. End Function ' join$
1402.  
1403. ' /////////////////////////////////////////////////////////////////////////////
1404. ' FROM: String Manipulation
1405. ' http://www.[abandoned, outdated and now likely malicious qb64 dot net website - don’t go there]/forum/index_topic_5964-0/
1406. '
1407. 'SUMMARY:
1408. '   Purpose:  A library of custom functions that transform strings.
1409. '   Author:   Dustinian Camburides (dustinian@gmail.com)
1410. '   Platform: QB64 (www.[abandoned, outdated and now likely malicious qb64 dot net website - don’t go there])
1411. '   Revision: 1.6
1412. '   Updated:  5/28/2012
1413.  
1414. 'SUMMARY:
1415. '[Replace$] replaces all instances of the [Find] sub-string with the [Add] sub-string within the [Text] string.
1416. 'INPUT:
1417. 'Text: The input string; the text that's being manipulated.
1418. 'Find: The specified sub-string; the string sought within the [Text] string.
1419. 'Add: The sub-string that's being added to the [Text] string.
1420.  
1421. Function Replace$ (Text1 As String, Find1 As String, Add1 As String)
1422.     ' VARIABLES:
1423.     Dim Text2 As String
1424.     Dim Find2 As String
1425.     Dim Add2 As String
1426.     Dim lngLocation As Long ' The address of the [Find] substring within the [Text] string.
1427.     Dim strBefore As String ' The characters before the string to be replaced.
1428.     Dim strAfter As String ' The characters after the string to be replaced.
1429.  
1430.     ' INITIALIZE:
1431.     ' MAKE COPIESSO THE ORIGINAL IS NOT MODIFIED (LIKE ByVal IN VBA)
1432.     Text2 = Text1
1433.     Find2 = Find1
1434.     Add2 = Add1
1435.  
1436.     lngLocation = InStr(1, Text2, Find2)
1437.  
1438.     ' PROCESSING:
1439.     ' While [Find2] appears in [Text2]...
1440.     While lngLocation
1441.         ' Extract all Text2 before the [Find2] substring:
1442.         strBefore = Left$(Text2, lngLocation - 1)
1443.  
1444.         ' Extract all text after the [Find2] substring:
1445.         strAfter = Right$(Text2, ((Len(Text2) - (lngLocation + Len(Find2) - 1))))
1446.  
1447.         ' Return the substring:
1448.         Text2 = strBefore + Add2 + strAfter
1449.  
1450.         ' Locate the next instance of [Find2]:
1451.         lngLocation = InStr(1, Text2, Find2)
1452.  
1453.         ' Next instance of [Find2]...
1454.     Wend
1455.  
1456.     ' OUTPUT:
1457.     Replace$ = Text2
1458. End Function ' Replace$
1459.  
1460. ' /////////////////////////////////////////////////////////////////////////////
1461. ' Split and join strings
1462. ' https://www.qb64.org/forum/index.php?topic=1073.0
1463. '
1464. ' FROM luke, QB64 Developer
1465. ' Date: February 15, 2019, 04:11:07 AM »
1466. '
1467. ' Given a string of words separated by spaces (or any other character),
1468. ' splits it into an array of the words. I've no doubt many people have
1469. ' written a version of this over the years and no doubt there's a million
1470. ' ways to do it, but I thought I'd put mine here so we have at least one
1471. ' version. There's also a join function that does the opposite
1472. ' array -> single string.
1473. '
1474. ' Code is hopefully reasonably self explanatory with comments and a little demo.
1475. ' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.
1476.  
1477. 'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences
1478. 'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$().
1479. '
1480. 'delimiter$ must be one character long.
1481. 'result$() must have been REDIMmed previously.
1482.  
1483. Sub split (in$, delimiter$, result$())
1484.     ReDim result$(-1)
1485.     start = 1
1486.     Do
1487.         While Mid$(in$, start, 1) = delimiter$
1488.             start = start + 1
1489.             If start > Len(in$) Then Exit Sub
1490.         Wend
1491.         finish = InStr(start, in$, delimiter$)
1492.         If finish = 0 Then finish = Len(in$) + 1
1493.         ReDim _Preserve result$(0 To UBound(result$) + 1)
1494.         result$(UBound(result$)) = Mid$(in$, start, finish - start)
1495.         start = finish + 1
1496.     Loop While start <= Len(in$)
1497. End Sub ' split
1498.  
1499. ' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1500. ' END GENERAL PURPOSE ROUTINES
1501. ' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1502.  
1503. ' #END
1504. ' ################################################################################################################################################################
1505.  

[Petr]

I tried to write text rotation using text commands on a text screen in my own way. It's gratifying that my rendering is as bad as yours. I guess that's the screen resolution. Try to write down the coordinates of individual points and you will see for yourself. They must not be a pair with the same coordinates, but because you rotate in a field (as I understood by a quick look at your program), some characters are printed on top of each other. I am adding a simplified custom version for text rotation. Uncommenting the GoTo command starts the same thing in the graphical design, where it works nicely. What is there otherwise? Coordinate calculation. What is the character ratio - witdht/height in text mode? 1: 1. What is the aspect ratio of the character in graphics mode? For FONT 16 it is 8 pixels wide, 16 pixels high. I guess that's the problem.

Maybe it can really be done better in text mode, if someone can do it, I'll be happy to learn something new.

Code: QB64: [Select]

1. Screen _NewImage(60, 60, 0) 'text screen 60x60
2.  
3. 'TEXT MODE
4. text$ = "It's a SCREEN resolution?"
5.  
6.  
7. Lenght = Len(text$)
8.  
9. Type XY
10.     X As Integer
11.     Y As Integer
12. End Type
13. Dim XY(Lenght) As XY
14.  
15. 'GoTo graphic        'uncomment this for view better output
16.  
17. Do
18.     angle = angle + 0.01
19.     For coordinate = 0 To Lenght
20.         XY(coordinate).X = 30 + Sin(angle) * coordinate
21.         XY(coordinate).Y = 30 + Cos(angle) * coordinate
22.     Next
23.  
24.     For PrintIt = 0 To Lenght
25.         Locate XY(PrintIt).Y, XY(PrintIt).X: Print Mid$(text$, PrintIt, 1)
26.     Next
27.     _Limit 15
28.     Cls
29. Loop
30.  
31. 'GRAPHIC MODE
32. graphic:
33. Screen _NewImage(800, 800, 256)
34.  
35.  
36.  
37. Do
38.     angle = angle + 0.01
39.     For coordinate = 0 To Lenght
40.         XY(coordinate).X = 400 + Sin(angle) * coordinate * 16
41.         XY(coordinate).Y = 400 + Cos(angle) * coordinate * 16
42.     Next
43.  
44.     For PrintIt = 0 To Lenght
45.         _PrintString (XY(PrintIt).X, XY(PrintIt).Y), Mid$(text$, PrintIt, 1)
46.     Next
47.     _Limit 15
48.     Cls
49. Loop
50.  

[STxAxTIC]

Just by the looks of things, it's a binning problem. Without digging into the code, I know that rotations are usually done in some kind of polar coordinates, in which case a differential "box" is a weird pie-slice type shape. In regular screen/cartesian coordinates, of course, boxes are just boxes. Point is, I think some letters are drawing directly on top of others in your special cases. Just an armchair speculation.

[madscijr]

They must not be a pair with the same coordinates, but because you rotate in a field (as I understood by a quick look at your program), some characters are printed on top of each other.

Aha! That totally makes sense.
Thanks for your reply.

I took your example and added a check to see if any characters are missing at a given angle
(code below) - it happens a lot!

Perhaps if we check first to make sure we aren't overwriting a character,
we add it to a "find somewhere for this to go" list and skip it for now,
then at the end, we go through that list, and place each of them in the nearest optimal blank space?
I'm not sure what the logic to determine which is the optimal space would be,
we'd have to play with it...
Anyway, thanks for your reply, that definitely explains it.

Code: QB64: [Select]

1. ' ################################################################################################################################################################
2. ' Petr's rotation routine
3. ' https://www.qb64.org/forum/index.php?topic=4502.msg139260#msg139260
4.  
5. ' Changes: missing characters check added by madscijr
6. ' ################################################################################################################################################################
7.  
8. ' boolean constants
9. Const FALSE = 0
10. Const TRUE = Not FALSE
11.  
12. ' UDTs
13. Type XY
14.     X As Integer
15.     Y As Integer
16. End Type
17.  
18. ' global variables
19. Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
20. Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
21.  
22. ' local variables
23. Dim in$
24.  
25. ' start menu
26. Screen 0: _ScreenMove 0, 0
27. main
28.  
29. ' done
30. Input "Press <ENTER> to continue", in$
31. System ' return control to the operating system
32. End
33.  
34. ' /////////////////////////////////////////////////////////////////////////////
35. ' MAIN MENU
36.  
37. Sub main
38.     Dim in$
39.  
40.     Do
41.         Cls
42.         Print m_ProgramName$
43.         Print
44.         Print "Petr's rotation demo"
45.         Print
46.         Print "1. TEXT MODE"
47.         Print "2. GRAPHIC MODE"
48.         Print
49.         Print "What to do? ('q' to exit)"
50.  
51.         Input in$: in$ = LCase$(Left$(in$, 1))
52.  
53.         If in$ = "1" Then
54.             PetrRotateTextMode
55.         ElseIf in$ = "2" Then
56.             PetrRotateGraphicMode
57.         End If
58.  
59.         _KeyClear
60.     Loop Until in$ = "q"
61. End Sub ' main
62.  
63. ' /////////////////////////////////////////////////////////////////////////////
64. ' TEXT MODE
65.  
66. Sub PetrRotateTextMode
67.     Dim text$
68.     Dim Lenght As Integer
69.     ReDim XY(-1) As XY
70.     Dim angle As Single
71.     Dim coordinate As Integer
72.     Dim PrintIt As Integer
73.     Dim chars$
74.     Dim missing$
75.     Dim in$
76.  
77.     Screen _NewImage(60, 60, 0) ' text screen 60x60
78.     _ScreenMove 0, 0
79.  
80.     text$ = "It's a SCREEN resolution?"
81.     Lenght = Len(text$)
82.     ReDim XY(Lenght) As XY
83.     angle = 0
84.     missing$ = ""
85.  
86.     Cls
87.     Do
88.         Cls
89.         angle = angle + 0.01
90.         For coordinate = 0 To Lenght
91.             XY(coordinate).X = 30 + Sin(angle) * coordinate
92.             XY(coordinate).Y = 30 + Cos(angle) * coordinate
93.         Next coordinate
94.         For PrintIt = 0 To Lenght
95.             Locate XY(PrintIt).Y, XY(PrintIt).X
96.             Print Mid$(text$, PrintIt, 1)
97.         Next PrintIt
98.         chars$ = CharsMissing$(text$, 5, 0, 0, 0)
99.         missing$ = Replace$(chars$, " ", "")
100.  
101.         Locate 1, 1
102.         Print "rotation angle: " + _Trim$(Str$(angle))
103.         Print "rotation text : " + Chr$(34) + text$ + Chr$(34)
104.         Print "chars missing : " + IIFSTR$(Len(missing$) = 0, "(none)", Chr$(34) + chars$ + Chr$(34))
105.         If Len(missing$) > 0 Then
106.             Input "PRESS <ENTER> TO CONTINUE OR q TO QUIT"; in$
107.             If in$ = "q" Then Exit Do
108.         Else
109.             Print "PRESS <ESC> TO QUIT"
110.         End If
111.  
112.         _Limit 15
113.     Loop Until _KeyDown(27) ' leave loop when ESC key pressed
114.     _KeyClear
115. End Sub ' PetrRotateTextMode
116.  
117. ' /////////////////////////////////////////////////////////////////////////////
118.  
119. Function CharsMissing$ (MyString As String, iStartLine1 As Integer, iEndLine1 As Integer, iStartColumn1 As Integer, iEndColumn1 As Integer)
120.     Dim x As Integer
121.     Dim y As Integer
122.     Dim iLen As Integer
123.     Dim TestString As String
124.     Dim i154 As Integer
125.     Dim iPinkFlag As Integer
126.     Dim iStartLine As Integer
127.     Dim iEndLine As Integer
128.     Dim iStartColumn As Integer
129.     Dim iEndColumn As Integer
130.  
131.     If iStartLine1 > 0 And iStartLine1 <= _Height(0) Then
132.         iStartLine = iStartLine1
133.     Else
134.         iStartLine = 1
135.     End If
136.     If iEndLine1 > 0 And iEndLine1 <= _Height(0) Then
137.         iEndLine = iEndLine1
138.     Else
139.         iEndLine = _Height(0)
140.     End If
141.     If iStartColumn1 > 0 And iStartColumn1 <= _Width(0) Then
142.         iStartColumn = iStartColumn1
143.     Else
144.         iStartColumn = 1
145.     End If
146.     If iEndColumn1 > 0 And iEndColumn1 <= _Width(0) Then
147.         iEndColumn = iEndColumn1
148.     Else
149.         iEndColumn = _Width(0)
150.     End If
151.  
152.     TestString = MyString
153.  
154.     iLen = Len(MyString)
155.  
156.     For x = iStartColumn To iEndColumn
157.         For y = iStartLine To iEndLine
158.             'codeorcolor% = SCREEN (row%, column% [, colorflag%])
159.             i154 = Screen(y, x)
160.             iPinkFlag = InStr(1, TestString, Chr$(i154))
161.             If iPinkFlag > 0 Then
162.                 If iPinkFlag = 1 Then
163.                     TestString = " " + Right$(TestString, Len(TestString) - 1)
164.                 ElseIf iPinkFlag = Len(TestString) Then
165.                     TestString = Left$(TestString, Len(TestString) - 1) + " "
166.                     'TestString = left$(TestString, len(TestString)-1)
167.                 Else
168.                     TestString = Left$(TestString, iPinkFlag - 1) + " " + Right$(TestString, Len(TestString) - iPinkFlag)
169.                     'TestString = left$(TestString, iPinkFlag-1) + right$(TestString, Len(TestString)-iPinkFlag)
170.                 End If
171.             End If
172.         Next y
173.     Next x
174.  
175.     'CharsMissing$ = Replace$ (TestString, " ", "")
176.     CharsMissing$ = TestString
177. End Function ' CharsMissing$
178.  
179. ' /////////////////////////////////////////////////////////////////////////////
180. ' GRAPHIC MODE
181.  
182. Sub PetrRotateGraphicMode
183.     Dim text$
184.     Dim Lenght As Integer
185.     ReDim XY(-1) As XY
186.     Dim angle As Double
187.     Dim coordinate As Integer
188.     Dim PrintIt As Integer
189.  
190.     Screen _NewImage(800, 800, 256)
191.     _ScreenMove 0, 0
192.  
193.     text$ = "It's a SCREEN resolution?"
194.     Lenght = Len(text$)
195.     ReDim XY(Lenght) As XY
196.     angle = 0
197.  
198.     Do
199.         Cls
200.         Print "PRESS <ESC> TO QUIT"
201.         angle = angle + 0.01
202.         For coordinate = 0 To Lenght
203.             XY(coordinate).X = 400 + Sin(angle) * coordinate * 16
204.             XY(coordinate).Y = 400 + Cos(angle) * coordinate * 16
205.         Next coordinate
206.         For PrintIt = 0 To Lenght
207.             _PrintString (XY(PrintIt).X, XY(PrintIt).Y), Mid$(text$, PrintIt, 1)
208.         Next PrintIt
209.         _Limit 15
210.     Loop Until _KeyDown(27) ' leave loop when ESC key pressed
211.     _KeyClear
212. End Sub ' PetrRotateGraphicMode
213.  
214. ' /////////////////////////////////////////////////////////////////////////////
215.  
216. Function cstr$ (myValue)
217.     'cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
218.     cstr$ = _Trim$(Str$(myValue))
219. End Function ' cstr$
220.  
221. ' /////////////////////////////////////////////////////////////////////////////
222.  
223. Function IIF (Condition, IfTrue, IfFalse)
224.     If Condition Then IIF = IfTrue Else IIF = IfFalse
225. End Function
226.  
227. ' /////////////////////////////////////////////////////////////////////////////
228.  
229. Function IIFSTR$ (Condition, IfTrue$, IfFalse$)
230.     If Condition Then IIFSTR$ = IfTrue$ Else IIFSTR$ = IfFalse$
231. End Function
232.  
233. ' /////////////////////////////////////////////////////////////////////////////
234. ' FROM: String Manipulation
235. ' found at abandoned, outdated and now likely malicious qb64 dot net website
236. ' http://www.qb64.[net]/forum/index_topic_5964-0/
237. '
238. 'SUMMARY:
239. '   Purpose:  A library of custom functions that transform strings.
240. '   Author:   Dustinian Camburides (dustinian@gmail.com)
241. '   Platform: QB64 (www.qb64.org)
242. '   Revision: 1.6
243. '   Updated:  5/28/2012
244.  
245. 'SUMMARY:
246. '[Replace$] replaces all instances of the [Find] sub-string with the [Add] sub-string within the [Text] string.
247. 'INPUT:
248. 'Text: The input string; the text that's being manipulated.
249. 'Find: The specified sub-string; the string sought within the [Text] string.
250. 'Add: The sub-string that's being added to the [Text] string.
251.  
252. Function Replace$ (Text1 As String, Find1 As String, Add1 As String)
253.     ' VARIABLES:
254.     Dim Text2 As String
255.     Dim Find2 As String
256.     Dim Add2 As String
257.     Dim lngLocation As Long ' The address of the [Find] substring within the [Text] string.
258.     Dim strBefore As String ' The characters before the string to be replaced.
259.     Dim strAfter As String ' The characters after the string to be replaced.
260.  
261.     ' INITIALIZE:
262.     ' MAKE COPIESSO THE ORIGINAL IS NOT MODIFIED (LIKE ByVal IN VBA)
263.     Text2 = Text1
264.     Find2 = Find1
265.     Add2 = Add1
266.  
267.     lngLocation = InStr(1, Text2, Find2)
268.  
269.     ' PROCESSING:
270.     ' While [Find2] appears in [Text2]...
271.     While lngLocation
272.         ' Extract all Text2 before the [Find2] substring:
273.         strBefore = Left$(Text2, lngLocation - 1)
274.  
275.         ' Extract all text after the [Find2] substring:
276.         strAfter = Right$(Text2, ((Len(Text2) - (lngLocation + Len(Find2) - 1))))
277.  
278.         ' Return the substring:
279.         Text2 = strBefore + Add2 + strAfter
280.  
281.         ' Locate the next instance of [Find2]:
282.         lngLocation = InStr(1, Text2, Find2)
283.  
284.         ' Next instance of [Find2]...
285.     Wend
286.  
287.     ' OUTPUT:
288.     Replace$ = Text2
289. End Function ' Replace$
290.  

[madscijr]

Just by the looks of things, it's a binning problem. Without digging into the code, I know that rotations are usually done in some kind of polar coordinates, in which case a differential "box" is a weird pie-slice type shape. In regular screen/cartesian coordinates, of course, boxes are just boxes. Point is, I think some letters are drawing directly on top of others in your special cases. Just an armchair speculation.

I think you're right. @Petr replied with a little demo program that illustrates just that.
Thanks for your reply!

[madscijr]

Well @Petr and @STxAxTIC, I tried writing some logic to handle the issue you pointed out.
It takes any points that would have overwritten an already occupied point on the screen,
and tries to place them in an adjacent unused space.
This is more of a proof of concept, the logic is simple and surely flawed,
but it seems to produce better looking results than without it?

Before & after #1.
Rotated to 30 degrees.

Old logic (ShearRotateTest2) has many lost points:
  [ You are not allowed to view this attachment ]  

New logic (ShearRotateTest3) has a lot less lost points:
  [ You are not allowed to view this attachment ]  

Before & after #2 (simpler example!)
Rotated to 30 degrees.

Old logic (ShearRotateTest2) has lost points:
  [ You are not allowed to view this attachment ]  

New logic (ShearRotateTest3) has no lost points:
  [ You are not allowed to view this attachment ]  

Run the below code and judge for yourself.
You will see menu options

Code: [Select]

6. ShearRotateTest2 (auto advances 0-360 degrees)"
7. ShearRotateTest2 (auto advances 0-360 degrees) (uses Petr's text)"
8. ShearRotateTest3 (tries to correct for missing points)"
9. ShearRotateTest3 (tries to correct for missing points) (uses Petr's text)"
Choose option 6 or 7 for the original "lossy" rotation (the only difference is 7 uses the string from @Petr 's program).
It now counts and displays the # of "lost" points that are overwritten, for the current rotation angle.
You'll see the lost points show up at 30, 60, 120, 150, etc. angles.

Choose option 8 or 9 for the new logic (the only difference is 9 uses the string from @Petr 's program).
It counts and displays the # of "lost" points that were not successfully relocated, for the current rotation angle.
You'll see a lot less lost points now at 30, 60, 120, 150, etc. angles.

The way the current logic works is, it keeps looking for an empty space farther out in the given direction until it either finds one or reaches the boundary of the screen.
So it could theoretically plot a point 2 or more spaces away that are no longer adjacent, yielding some funky looking results.
I think the logic could be improved where, if it doesn't find an empty space immediatly above/below, to the right/left, or diagonally,
it can try looking one space in the opposite directions, and if not, then quit.

Thoughts?

Code: QB64: [Select]

1. ' ################################################################################################################################################################
2. ' #TOP
3.  
4. ' Basic 2D plotting functions
5. ' Version 1.00 by madscijr
6. ' with help from various (sources cited below).
7. ' ################################################################################################################################################################
8.  
9. ' =============================================================================
10. ' GLOBAL DECLARATIONS
11. ' =============================================================================
12.  
13. ' boolean constants
14. Const FALSE = 0
15. Const TRUE = Not FALSE
16.  
17. ' -----------------------------------------------------------------------------
18. ' USER DEFINED TYPES
19. ' -----------------------------------------------------------------------------
20. Type RotationType
21.     origx As Integer
22.     origy As Integer
23.     'z as integer
24.     c As Integer
25. End Type ' RotationType
26.  
27. ' -----------------------------------------------------------------------------
28. ' GLOBAL VARIABLES
29. ' -----------------------------------------------------------------------------
30. Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
31. Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
32. Dim Shared m_bDebug: m_bDebug = TRUE
33.  
34. ' =============================================================================
35. ' BEGIN MAIN PROGRAM
36. ' =============================================================================
37. Dim in$
38.  
39. ' ****************************************************************************************************************************************************************
40. ' ACTIVATE DEBUGGING WINDOW
41. If m_bDebug = TRUE Then
42.     $Console
43.     _Delay 4
44.     _Console On
45.     _Echo "Started " + m_ProgramName$
46.     _Echo "Debugging on..."
47. End If
48. ' ****************************************************************************************************************************************************************
49.  
50. ' -----------------------------------------------------------------------------
51. ' START THE MENU
52. main
53.  
54. ' -----------------------------------------------------------------------------
55. ' DONE
56. Print m_ProgramName$ + " finished."
57. 'Screen 0
58. Input "Press <ENTER> to continue", in$
59.  
60. ' ****************************************************************************************************************************************************************
61. ' DEACTIVATE DEBUGGING WINDOW
62. If m_bDebug = TRUE Then
63.     _Console Off
64. End If
65. ' ****************************************************************************************************************************************************************
66.  
67. ' -----------------------------------------------------------------------------
68. ' EXIT
69. System ' return control to the operating system
70. End
71.  
72. ' =============================================================================
73. ' END MAIN PROGRAM
74. ' =============================================================================
75.  
76. ' /////////////////////////////////////////////////////////////////////////////
77. ' MAIN MENU
78.  
79. Sub main
80.     Dim RoutineName As String: RoutineName = "main"
81.     Dim in$
82.  
83.     Screen _NewImage(1280, 1024, 32): _ScreenMove 0, 0
84.     Do
85.         Cls
86.         Print m_ProgramName$
87.         Print
88.         Print "Some basic 2D plotting"
89.         Print
90.         Print "1. PlotPointTest"
91.         Print "2. PlotSquareTest"
92.         Print "3. PlotCircleTest"
93.         Print "4. PlotLineTest"
94.         Print "5. ShearRotateTest1"
95.         Print "6. ShearRotateTest2 (auto advances 0-360 degrees)"
96.         Print "7. ShearRotateTest2 (auto advances 0-360 degrees) (uses Petr's text)"
97.         Print "8. ShearRotateTest3 (tries to correct for missing points)"
98.         Print "9. ShearRotateTest3 (tries to correct for missing points) (uses Petr's text)"
99.         Print
100.         Print "What to do? ('q' to exit)"
101.  
102.         Input in$: in$ = LCase$(Left$(in$, 1))
103.  
104.         If in$ = "1" Then
105.             PlotPointTest
106.         ElseIf in$ = "2" Then
107.             PlotSquareTest
108.         ElseIf in$ = "3" Then
109.             PlotCircleTest
110.         ElseIf in$ = "4" Then
111.             PlotLineTest
112.         ElseIf in$ = "5" Then
113.             ShearRotateTest1
114.         ElseIf in$ = "6" Then
115.             ShearRotateTest2 TestSprite1$
116.         ElseIf in$ = "7" Then
117.             ShearRotateTest2 PetrText1$
118.         ElseIf in$ = "8" Then
119.             ShearRotateTest3 TestSprite1$
120.         ElseIf in$ = "9" Then
121.             ShearRotateTest3 PetrText1$
122.         End If
123.     Loop Until in$ = "q"
124. End Sub ' main
125.  
126. ' /////////////////////////////////////////////////////////////////////////////
127. ' MyArray(1 To 32, 1 To 32) AS STRING
128.  
129. Sub PlotPoint (X As Integer, Y As Integer, S As String, MyArray() As String)
130.     If (X >= LBound(MyArray, 2)) Then
131.         If (X <= UBound(MyArray, 2)) Then
132.             If (Y >= LBound(MyArray, 1)) Then
133.                 If (Y <= UBound(MyArray, 1)) Then
134.                     If Len(S) = 1 Then
135.                         MyArray(Y, X) = S
136.                     Else
137.                         If Len(S) > 1 Then
138.                             MyArray(Y, X) = Left$(S, 1)
139.                         End If
140.                     End If
141.                 End If
142.             End If
143.         End If
144.     End If
145. End Sub ' PlotPoint
146.  
147. ' /////////////////////////////////////////////////////////////////////////////
148.  
149. Sub PlotPointTest
150.     Dim MyArray(1 To 32, 1 To 32) As String
151.     Dim iX As Integer
152.     Dim iY As Integer
153.     Dim in$
154.     Dim X As Integer
155.     Dim Y As Integer
156.     Dim L As Integer
157.     Dim iChar As Integer
158.  
159.     ClearArray MyArray(), "."
160.     iChar = 64
161.  
162.     Cls
163.     Print "Plot a point."
164.     Print ArrayToStringTest(MyArray())
165.     Print
166.  
167.     Do
168.         Print "Type x,y (1-32, 1-32) coordinate to plot point at."
169.         Input "X,Y OR 0 TO QUIT? "; X, Y
170.         If X > 0 And Y > 0 Then
171.             iChar = iChar + 1
172.             If iChar > 90 Then iChar = 65
173.  
174.             Print "X=" + cstr$(X) + ", Y=" + cstr$(Y)
175.             PlotPoint X, Y, Chr$(iChar), MyArray()
176.  
177.             Print "Current point plotted, drawn with " + Chr$(34) + Chr$(iChar) + Chr$(34) + ":"
178.             Print ArrayToStringTest(MyArray())
179.             Print
180.  
181.         Else
182.             Exit Do
183.         End If
184.     Loop
185. End Sub ' PlotPointTest
186.  
187. ' /////////////////////////////////////////////////////////////////////////////
188.  
189. Sub PlotSquare (X1 As Integer, Y1 As Integer, L As Integer, S As String, MyArray() As String)
190.     Dim X As Integer
191.     Dim X2 As Integer
192.     Dim Y As Integer
193.     Dim Y2 As Integer
194.     Dim sChar$
195.  
196.     If Len(S) = 1 Then
197.         sChar$ = S
198.     Else
199.         If Len(S) = 0 Then
200.             sChar$ = " "
201.         Else
202.             sChar$ = Left$(S, 1)
203.         End If
204.     End If
205.  
206.     X2 = (X1 + L) - 1
207.     Y2 = (Y1 + L) - 1
208.     For X = X1 To X2
209.         For Y = Y1 To Y2
210.             PlotPoint X, Y, sChar$, MyArray()
211.         Next Y
212.     Next X
213. End Sub ' PlotSquare
214.  
215. ' /////////////////////////////////////////////////////////////////////////////
216.  
217. Sub PlotSquareTest
218.     Dim MyArray(1 To 32, 1 To 32) As String
219.     Dim iX As Integer
220.     Dim iY As Integer
221.     Dim in$
222.     Dim X As Integer
223.     Dim Y As Integer
224.     Dim L As Integer
225.     Dim iChar As Integer
226.  
227.     ClearArray MyArray(), "."
228.     iChar = 64
229.  
230.     Cls
231.     Print "Enter parameters to draw a square."
232.     Print ArrayToStringTest(MyArray())
233.     Print
234.     Do
235.         Print "Type top left x,y (1-32, 1-32) coordinate to plot square,"
236.         Print "and size (1-32) of square."
237.         Input "X,Y,L OR 0 TO QUIT? "; X, Y, L
238.         If X > 0 And Y > 0 And L > 0 Then
239.             iChar = iChar + 1
240.             If iChar > 90 Then iChar = 65
241.  
242.             Print
243.             Print "X=" + cstr$(X)
244.             Print "Y=" + cstr$(Y)
245.             Print "L=" + cstr$(L)
246.             Print
247.             PlotSquare X, Y, L, Chr$(iChar), MyArray()
248.  
249.             Print "Square plotted, drawn with " + Chr$(34) + Chr$(iChar) + Chr$(34) + ":"
250.             Print ArrayToStringTest(MyArray())
251.             Print
252.         Else
253.             Exit Do
254.         End If
255.     Loop
256. End Sub ' PlotSquareTest
257.  
258. ' /////////////////////////////////////////////////////////////////////////////
259. ' Fast circle drawing in pure Atari BASIC#
260. ' https://atariwiki.org/wiki/Wiki.jsp?page=Super%20fast%20circle%20routine
261.  
262. ' * Magazine: Moj Mikro, 1989/3
263. ' * Author : Zlatko Bleha
264. ' * Page : 27 - 31
265. ' * Atari BASIC listing on disk (tokenized): M8903282.BAS
266. ' * Atari BASIC listing (listed): M8903282.LST
267.  
268. ' Next example is demonstration of implementing mentioned circle algorithm
269. ' in pure Atari BASIC. This program shows how much faster it is compared to
270. ' classic program using sine and cosine functions from Atari BASIC
271. ' (shown in last example).
272.  
273. ' Basic Listing M8903282.LST#
274. '1 REM *******************************
275. '2 REM PROGRAM  : FAST CIRCLE DRAWING
276. '3 REM AUTHOR   : ZLATKO BLEHA
277. '4 REM PUBLISHER: MOJ MIKRO MAGAZINE
278. '5 REM ISSUE NO.: 1989, NO.3, PAGE 29
279. '6 REM *******************************
280. '7 REM
281. '10 GRAPHICS 8:SETCOLOR 2,0,0:COLOR 3
282. '20 PRINT "ENTER X, Y AND R"
283. '30 INPUT X,Y,R
284. '40 IF R=0 THEN PLOT X,Y:END
285. '50 B=R:C=0:A=R-1
286. '60 PLOT X+C,Y+B
287. '70 PLOT X+C,Y-B
288. '80 PLOT X-C,Y-B
289. '90 PLOT X-C,Y+B
290. '100 PLOT X+B,Y+C
291. '110 PLOT X+B,Y-C
292. '120 PLOT X-B,Y-C
293. '130 PLOT X-B,Y+C
294. '140 C=C+1
295. '150 A=A+1-C-C
296. '160 IF A>=0 THEN 190
297. '170 B=B-1
298. '180 A=A+B+B
299. '190 IF B>=C THEN 60
300.  
301. ' Use some valid values for coordinates and radius, for example:
302. ' X=40, Y=40, R=30
303. ' X=130, Y=90, R=60
304. ' Slow circle drawing in Atari BASIC#
305. ' * Magazine: Moj Mikro, 1989/3
306. ' * Author : Zlatko Bleha
307. ' * Page : 27 - 31
308. ' * Atari BASIC listing on disk (tokenized): M8903281.BAS
309. ' * Atari BASIC listing (listed): M8903281.LST
310.  
311. ' This is classic example for drawing circles from Atari BASIC
312. ' using sine and cosine functions. Unfortunatelly, this is very slow
313. ' way of doing it and not recommended.
314. ' Just use routine shown above and everybody will be happy
315.  
316. ' Basic Listing M8903281.LST#
317. '1 REM *******************************
318. '2 REM PROGRAM  : SLOW CIRCLE DRAWING
319. '3 REM AUTHOR   : ZLATKO BLEHA
320. '4 REM PUBLISHER: MOJ MIKRO MAGAZINE
321. '5 REM ISSUE NO.: 1989, NO.3, PAGE 29
322. '6 REM *******************************
323. '7 REM
324. '10 GRAPHICS 8:SETCOLOR 2,0,0:COLOR 3
325. '20 FOR A=0 TO 6.28 STEP 0.02
326. '30 X=SIN(A)*50+150
327. '40 Y=COS(A)*50+80
328. '50 PLOT X,Y
329. '60 NEXT A
330.  
331. ' Conclusion#
332. ' Returning back to first program with the fastest way of drawing circles...
333. ' There is one more thing to note. In case you want to use PLOT subroutine,
334. ' which is part of the main circle routine, then read following explanation.
335. ' PLOT routine is written so it can be used easily from Atari BASIC program
336. ' independently from main circle routine, by using like this:
337. ' A=USR(30179,POK,X,Y)
338. '
339. ' POK   1 (drawing a pixel), 0 (erasing a pixel)
340. ' X     X coordinate of the pixel
341. ' Y     Y coordinate of the pixel
342. '
343. ' The routine alone is not any faster than normal PLOT command
344. ' from Atari BASIC, because USR command takes approximately 75%
345. ' of whole execution. But, used as part of the main circle routine
346. ' it does not matter anymore, because it is integrated in one larger
347. ' entity. There the execution is very fast, with no overhead.
348. ' PLOT routine is here for you to examine anyway.
349. ' You never know if you will maybe need it in the future.
350.  
351. ' More on plotting circles:
352. '     Drawing a circle in BASIC - fast
353. '     https://www.cpcwiki.eu/forum/programming/drawing-a-circle-in-basic-fast/
354.  
355. ' X,Y     = center point of circle
356. ' R       = radius
357. ' S       = char to draw
358. ' MyArray = 2D string array to plot circle in
359.  
360. Sub PlotCircle (X As Integer, Y As Integer, R As Integer, S As String, MyArray() As String)
361.     Dim A As Integer
362.     Dim B As Integer
363.     Dim C As Integer
364.     Dim S2 As String
365.  
366.     If Len(S) = 1 Then
367.         S2 = S
368.     Else
369.         If Len(S) = 0 Then
370.             S2 = " "
371.         Else
372.             S2 = Left$(S, 1)
373.         End If
374.     End If
375.  
376.     If R > 0 Then
377.         B = R
378.         C = 0
379.         A = R - 1
380.         Do
381.             PlotPoint X + C, Y + B, S2, MyArray()
382.             PlotPoint X + C, Y - B, S2, MyArray()
383.             PlotPoint X - C, Y - B, S2, MyArray()
384.             PlotPoint X - C, Y + B, S2, MyArray()
385.             PlotPoint X + B, Y + C, S2, MyArray()
386.             PlotPoint X + B, Y - C, S2, MyArray()
387.             PlotPoint X - B, Y - C, S2, MyArray()
388.             PlotPoint X - B, Y + C, S2, MyArray()
389.             C = C + 1
390.             A = A + 1 - C - C
391.             If A < 0 Then ' IF A>=0 THEN 190
392.                 B = B - 1
393.                 A = A + B + B
394.             End If
395.             If B < C Then Exit Do ' 190 IF B>=C THEN 60
396.         Loop
397.     End If
398. End Sub ' PlotCircle
399.  
400. ' /////////////////////////////////////////////////////////////////////////////
401.  
402. Sub PlotCircleTest
403.     Dim MyArray(1 To 32, 1 To 32) As String
404.     Dim iX As Integer
405.     Dim iY As Integer
406.     Dim in$
407.     Dim X As Integer
408.     Dim Y As Integer
409.     Dim R As Integer
410.     Dim iChar As Integer
411.  
412.     ClearArray MyArray(), "."
413.     iChar = 64
414.  
415.     Cls
416.     Print "Plot a raster circle"
417.     Print "Based on Fast circle drawing in pure Atari BASIC by Zlatko Bleha."
418.     Print
419.     Print "Enter parameters to draw a circle."
420.     Print ArrayToStringTest(MyArray())
421.     Print
422.  
423.     Do
424.         Print "Type center point x,y (1-32, 1-32) coordinate to plot circle,"
425.         Print "and radius (1-32) of circle."
426.         Input "X,Y,R OR 0 TO QUIT: "; X, Y, R
427.         If X > 0 And Y > 0 And R > 0 Then
428.             iChar = iChar + 1
429.             If iChar > 90 Then iChar = 65
430.  
431.             Print "X=" + cstr$(X)
432.             Print "Y=" + cstr$(Y)
433.             Print "R=" + cstr$(R)
434.  
435.             PlotCircle X, Y, R, Chr$(iChar), MyArray()
436.  
437.             Print "Circle plotted, drawn with " + Chr$(34) + Chr$(iChar) + Chr$(34) + ":"
438.             Print ArrayToStringTest(MyArray())
439.             Print
440.         Else
441.             Exit Do
442.         End If
443.     Loop
444.  
445. End Sub ' PlotCircleTest
446.  
447. ' /////////////////////////////////////////////////////////////////////////////
448. ' Based on "BRESNHAM.BAS" by Kurt Kuzba. (4/16/96)
449. ' From: http://www.thedubber.altervista.org/qbsrc.htm
450.  
451. Sub PlotLine (x1%, y1%, x2%, y2%, c$, MyArray() As String)
452.     Dim iLoop%
453.     Dim steep%: steep% = 0
454.     Dim ev%: ev% = 0
455.     Dim sx%
456.     Dim sy%
457.     Dim dx%
458.     Dim dy%
459.  
460.     If (x2% - x1%) > 0 Then
461.         sx% = 1
462.     Else
463.         sx% = -1
464.     End If
465.  
466.     dx% = Abs(x2% - x1%)
467.     If (y2% - y1%) > 0 Then
468.         sy% = 1
469.     Else
470.         sy% = -1
471.     End If
472.  
473.     dy% = Abs(y2% - y1%)
474.     If (dy% > dx%) Then
475.         steep% = 1
476.         Swap x1%, y1%
477.         Swap dx%, dy%
478.         Swap sx%, sy%
479.     End If
480.  
481.     ev% = 2 * dy% - dx%
482.     For iLoop% = 0 To dx% - 1
483.         If steep% = 1 Then
484.             ''PSET (y1%, x1%), c%:
485.             'LOCATE y1%, x1%
486.             'PRINT c$;
487.             PlotPoint y1%, x1%, c$, MyArray()
488.         Else
489.             ''PSET (x1%, y1%), c%
490.             'LOCATE x1%, y1%
491.             'PRINT c$;
492.             PlotPoint x1%, y1%, c$, MyArray()
493.         End If
494.  
495.         While ev% >= 0
496.             y1% = y1% + sy%
497.             ev% = ev% - 2 * dx%
498.         Wend
499.         x1% = x1% + sx%
500.         ev% = ev% + 2 * dy%
501.     Next iLoop%
502.     ''PSET (x2%, y2%), c%
503.     'LOCATE x2%, y2%
504.     'PRINT c$;
505.     PlotPoint x2%, y2%, c$, MyArray()
506. End Sub ' PlotLine
507.  
508. ' /////////////////////////////////////////////////////////////////////////////
509.  
510. Sub PlotLineTest
511.     Dim MyArray(1 To 32, 1 To 32) As String
512.     Dim in$
513.     Dim X1 As Integer
514.     Dim Y1 As Integer
515.     Dim X2 As Integer
516.     Dim Y2 As Integer
517.     Dim iChar As Integer
518.  
519.     ClearArray MyArray(), "."
520.     iChar = 64
521.  
522.     Cls
523.     Print "Plot line with Bresenham Algorithm"
524.     Print "based on BRESNHAM.BAS by Kurt Kuzba (4/16/96)."
525.     Print
526.     Print ArrayToStringTest(MyArray())
527.     Do
528.         Print "Enter coordinate values for "
529.         Print "line start point x1, y1 (1-32, 1-32)"
530.         Print "line end   point x2, y2 (1-32, 1-32)"
531.         Input "ENTER X1,Y1,X2,Y2 OR 0 TO QUIT: "; X1, Y1, X2, Y2
532.         If X1 > 0 And Y1 > 0 And X2 > 0 And Y2 > 0 Then
533.             iChar = iChar + 1
534.             If iChar > 90 Then iChar = 65
535.  
536.             Print "X1=" + cstr$(X1)
537.             Print "Y1=" + cstr$(Y1)
538.             Print "X2=" + cstr$(X2)
539.             Print "Y2=" + cstr$(Y2)
540.  
541.             PlotLine X1, Y1, X2, Y2, Chr$(iChar), MyArray()
542.  
543.             Print "Line plotted, drawn with " + Chr$(34) + Chr$(iChar) + Chr$(34) + ":"
544.             Print ArrayToStringTest(MyArray())
545.  
546.         Else
547.             Exit Do
548.         End If
549.     Loop
550. End Sub ' PlotLineTest
551.  
552. ' /////////////////////////////////////////////////////////////////////////////
553. ' 3 shear method testing
554.  
555. ' _PUT Rotation Help
556. ' https://www.qb64.org/forum/index.php?topic=1959.0
557.  
558. ' 3 Shear Rotation - rotates without any aliasing(holes)
559. ' https://www.freebasic.net/forum/viewtopic.php?t=24557
560.  
561. ' From: leopardpm
562. ' Date: Apr 02, 2016 1:21
563. ' Last edited by leopardpm on Apr 02, 2016 17:18, edited 1 time in total.
564. '
565. ' This is just a little 3-shear rotation routine
566. ' (I am using 3-shear because it leaves no gaps/aliasing)
567. ' that I was wondering if anyone sees how to make it faster.
568. ' Obviously, I am just thinking about inside the double loop.
569.  
570. ' Thanks again to BasicCoder2 for linking me to this little routine, it is wonderful so far!
571.  
572. '''                      roto-zooming algorithm
573. '''                    coded by Michael S. Nissen
574. '''                        jernmager@yahoo.dk
575. '
576. ''' ===============================================================
577. ''' Recoded to run on FBC 32/64 bit WIN, Version 1.05.0, 2016, by MrSwiss
578. ''' Heavy flickering before going Full-Screen on 64 Bit !!!
579. ''' This seems NOT to be the Case on 32 Bit ...
580. ''' ===============================================================
581. '
582. 'Type Pixel
583. '  As Single   X, Y
584. '  As ULong    C
585. 'End Type
586. '
587. '''  dim vars
588. 'Dim shared as Any Ptr Img_Buffer
589. '''  write the name of the .bmp image you want to rotozoom here:
590. '''  (it has to be sqare ie. 100x100 pixels, 760x760 pixels or whatever)
591. 'Dim As String Img_Name = "phobos.bmp"
592. 'Dim shared as Integer X_Mid, Y_Mid, scrn_wid, scrn_hgt, P1, P2, P3, P4, C
593. 'Dim shared as Short Img_Hgt, Img_Wid, Img_Lft, Img_Rgt, Img_Top, Img_Btm, X, Y
594. 'Dim Shared As Single Cos_Ang, Sin_Ang, Rot_Fac_X, Rot_Fac_Y, Angle = 0, Scale = 1
595. '
596. ''' changed Function to Sub (+ recoded arguments list)
597. 'Sub Calc_rotozoom ( ByRef Cos_Ang As Single, _
598. '               ByRef Sin_Ang As Single, _
599. '               ByVal S_Fact  As Single, _
600. '               ByVal NewAng  As Single )
601. '  Cos_Ang = Cos(NewAng)*S_Fact
602. '  Sin_Ang = Sin(NewAng)*S_Fact
603. 'End Sub
604. '
605. '''  full screen
606. 'ScreenInfo scrn_wid, scrn_hgt
607. 'screenRes scrn_wid, scrn_hgt, 32,,1
608. '
609. '''  dim screenpointer (has to be done after screenres)
610. 'Dim As ULong Ptr Scrn_Ptr = Screenptr
611. '
612. '''  place image in center of screen
613. 'X_Mid = scrn_wid\2
614. 'Y_Mid = scrn_hgt\2
615. 'Calc_rotozoom(Cos_Ang, Sin_Ang, Scale, Angle)
616. '
617. '''  find image dimensions
618. 'Open Img_Name For Binary As #1
619. 'Get #1, 19, Img_Wid
620. 'Get #1, 23, Img_Hgt
621. 'Close #1
622. '
623. '''  prepare to dim the array that will hold the image.
624. 'Img_Rgt = (Img_Wid-1)\2
625. 'Img_Lft = -Img_Rgt
626. 'Img_Btm = (Img_Hgt-1)\2
627. 'Img_Top = -Img_Btm
628. '
629. '''  dim array to hold image. Note: pixel (0, 0) is in the center.
630. 'Dim As Pixel Pixel(Img_Lft to Img_Rgt, Img_Top to Img_Btm)
631. '
632. '''  imagecreate sprite and load image to sprite
633. 'Img_Buffer = ImageCreate (Img_Wid, Img_Hgt)
634. 'Bload (Img_Name, Img_Buffer)
635. '
636. '''  load image from sprite to array with point command
637. 'For Y = Img_Top to Img_Btm
638. '  For X = Img_Lft to Img_Rgt
639. '    With Pixel(X, Y)
640. '      .X = X_Mid+X
641. '      .Y = Y_Mid+Y
642. '      C = Point (X-Img_Top, Y-Img_Lft, Img_buffer)
643. '      If C <> RGB(255, 0, 255) Then
644. '        .C = C
645. '      Else
646. '        .C = RGB(0, 0, 0)
647. '      End If
648. '    End With
649. '  Next X
650. 'Next Y
651. '
652. '''  we don't need the sprite anymore, kill it
653. 'ImageDestroy Img_Buffer
654. 'Img_Buffer = 0
655. '
656. '''  main program loop
657. 'Do
658. '
659. '  ''  scale in/out with uparrow/downarrow
660. '  If Multikey(80) Then
661. '    Scale *= 1.03
662. '    Calc_rotozoom(Cos_Ang, Sin_Ang, Scale, Angle)
663. '  ElseIf Multikey(72) Then
664. '    Scale *= 0.97
665. '    Calc_rotozoom(Cos_Ang, Sin_Ang, Scale, Angle)
666. '  End If
667. '
668. '  ''  rotate left/right with leftarrow/rightarrow
669. '  If Multikey(77) Then
670. '    Angle -= 0.03
671. '    Calc_rotozoom(Cos_Ang, Sin_Ang, Scale, Angle)
672. '  ElseIf Multikey(75) Then
673. '    Angle += 0.03
674. '    Calc_rotozoom(Cos_Ang, Sin_Ang, Scale, Angle)
675. '  End If
676. '
677. '  ''  lock screen in order to use screen pointers
678. '  ScreenLock
679. '
680. '    ''  draw pixel in center of image
681. '    Scrn_Ptr[ X_Mid + Y_Mid * scrn_wid ] = Pixel(0, 0).C
682. '    ''  draw all other pixels - 4 at a time
683. '    For Y = Img_Top to 0
684. '      For X = Img_Lft to -1
685. '        ''  find pixel positions
686. '        P1 = (X_Mid+X) + (Y_Mid+Y) * scrn_wid
687. '        P2 = (X_Mid-X) + (Y_Mid-Y) * scrn_wid
688. '        P3 = (X_Mid+Y) + (Y_Mid-X) * scrn_wid
689. '        P4 = (X_Mid-Y) + (Y_Mid+X) * scrn_wid
690. '        ''  erase old pixels (paint them black)
691. '        Scrn_Ptr[P1] = 0
692. '        Scrn_Ptr[P2] = 0
693. '        Scrn_Ptr[P3] = 0
694. '        Scrn_Ptr[P4] = 0
695. '        ''  rotate and zoom
696. '        Rot_Fac_X = X*Cos_Ang - Y*Sin_Ang
697. '        Rot_Fac_Y = X*Sin_Ang + Y*Cos_Ang
698. '        If Rot_Fac_X < Img_Lft Or Rot_Fac_X > Img_Rgt Then Continue For
699. '        If Rot_Fac_Y < Img_Top Or Rot_Fac_Y > Img_Btm Then Continue For
700. '        ''  draw new pixels
701. '        Scrn_Ptr[P1] = Pixel(Rot_Fac_X, Rot_Fac_Y).C
702. '        Scrn_Ptr[P2] = Pixel(-Rot_Fac_X, -Rot_Fac_Y).C
703. '        Scrn_Ptr[P3] = Pixel(Rot_Fac_Y, -Rot_Fac_X).C
704. '        Scrn_Ptr[P4] = Pixel(-Rot_Fac_Y, Rot_Fac_X).C
705. '      Next X
706. '    Next Y
707. '
708. '  ScreenUnLock
709. '
710. '  Sleep 10, 1
711. 'Loop Until InKey() = Chr(27)
712.  
713. ' UPDATES:
714. ' Fixed bug where values 135, 224, and 314 all resolve to -45 degrees.
715. ' Fixed bug where an angle of 46-135 degrees caused the image to be flipped wrong.
716.  
717. ' TODO:
718. ' Fix issue where image looks bad at 30, 60, 120, 150, 210, 240, 300, 330 degrees
719.  
720. Sub ShearRotate (OldArray() As RotationType, NewArray() As RotationType, angle1 As Integer, iEmpty As Integer)
721.     Const Pi = 4 * Atn(1)
722.  
723.     Dim angle As Integer
724.     Dim TwoPi As Double: TwoPi = 8 * Atn(1)
725.     Dim RtoD As Double: RtoD = 180 / Pi ' radians * RtoD = degrees
726.     Dim DtoR As Double: DtoR = Pi / 180 ' degrees * DtoR = radians
727.     Dim x As Integer
728.     Dim y As Integer
729.     Dim nangle As Integer
730.     Dim nx As Integer
731.     Dim ny As Integer
732.     Dim flipper As Integer
733.     Dim rotr As Double
734.     Dim shear1 As Double
735.     Dim shear2 As Double
736.     Dim clr As Integer
737.     Dim y1 As _Byte
738.     Dim xy1 As _Byte
739.     Dim fy As _Byte
740.     Dim fx As _Byte
741.     Dim in$
742.     Dim sLine As String
743.  
744.     ' initialize new with empty
745.     ReDim NewArray(LBound(OldArray, 1) To UBound(OldArray, 1), LBound(OldArray, 2) To UBound(OldArray, 2), 127) As RotationType
746.     For x = LBound(NewArray, 1) To UBound(NewArray, 1)
747.         For y = LBound(NewArray, 2) To UBound(NewArray, 2)
748.             NewArray(x, y, 0).origx = x
749.             NewArray(x, y, 0).origy = y
750.             NewArray(x, y, 0).c = iEmpty
751.         Next y
752.     Next x
753.  
754.     ' angle is reversed
755.     angle = 360 - angle1
756.  
757.     ' Shearing each element 3 times in one shot
758.     nangle = angle
759.  
760.     ' this pre-processing portion basically rotates by 90 to get
761.     ' between -45 and 45 degrees, where the 3-shear routine works correctly...
762.     If angle > 45 And angle < 225 Then
763.         If angle < 135 Then
764.             nangle = angle - 90
765.         Else
766.             nangle = angle - 180
767.         End If
768.     End If
769.     If angle > 135 And angle < 315 Then
770.         If angle < 225 Then
771.             nangle = angle - 180
772.         Else
773.             nangle = angle - 270
774.         End If
775.     End If
776.     If nangle < 0 Then
777.         nangle = nangle + 360
778.     End If
779.     If nangle > 359 Then
780.         nangle = nangle - 360
781.     End If
782.  
783.     rotr = nangle * DtoR
784.     shear1 = Tan(rotr / 2) ' correct way
785.     shear2 = Sin(rotr)
786.  
787.     ' *** NOTE: this had a bug where the values 135, 224, and 314
788.     ' ***       all resolve to -45 degrees.
789.     ' ***       Fixed by changing < to <=
790.  
791.     'if angle >  45 and angle < 134 then
792.     If angle > 45 And angle <= 134 Then
793.         flipper = 1
794.     ElseIf angle > 134 And angle <= 224 Then
795.         flipper = 2
796.     ElseIf angle > 224 And angle <= 314 Then
797.         ' *** NOTE: this had a bug where this flipper was wrong
798.         '           Fixed by adding case 7
799.         'flipper = 3
800.         flipper = 7
801.     Else
802.         flipper = 0
803.     End If
804.  
805.     ' Here is where it needs some optimizing possibly... kinda slow...
806.     For y = LBound(NewArray, 2) To UBound(NewArray, 2)
807.         For x = LBound(NewArray, 1) To UBound(NewArray, 1)
808.             Select Case flipper
809.                 Case 1:
810.                     nx = -y
811.                     ny = x
812.                 Case 2:
813.                     nx = -x
814.                     ny = -y
815.                 Case 3:
816.                     nx = -y
817.                     ny = -x
818.                 Case 4:
819.                     nx = -x
820.                     ny = y
821.                 Case 5:
822.                     nx = x
823.                     ny = -y
824.                 Case 6:
825.                     nx = y
826.                     ny = x
827.                 Case 7:
828.                     nx = y
829.                     ny = -x
830.                 Case Else:
831.                     nx = x
832.                     ny = y
833.             End Select
834.  
835.             clr = OldArray(nx, ny, 0).c
836.  
837.             y1 = y * shear1
838.             xy1 = x + y1
839.             fy = (y - xy1 * shear2)
840.             fx = xy1 + fy * shear1
841.  
842.             If fx >= -16 And fx <= 16 Then
843.                 If fy >= -16 And fy <= 16 Then
844.                     NewArray(fx, fy, 0).c = clr
845.                     NewArray(fx, fy, 0).origx = fx
846.                     NewArray(fx, fy, 0).origy = fy
847.                 End If
848.             End If
849.         Next x
850.     Next y
851. End Sub ' ShearRotate
852.  
853. ' /////////////////////////////////////////////////////////////////////////////
854. ' Same as ShearRotate, except adds iOverwriteCount parameter,
855. ' and counts how many points are overwriting existing points,
856. ' and return that value byref in parameter iOverwriteCount.
857.  
858. Sub ShearRotate1 (OldArray() As RotationType, NewArray() As RotationType, angle1 As Integer, iEmpty As Integer, iOverwriteCount As Integer)
859.     Const Pi = 4 * Atn(1)
860.  
861.     Dim angle As Integer
862.     Dim TwoPi As Double: TwoPi = 8 * Atn(1)
863.     Dim RtoD As Double: RtoD = 180 / Pi ' radians * RtoD = degrees
864.     Dim DtoR As Double: DtoR = Pi / 180 ' degrees * DtoR = radians
865.     Dim x As Integer
866.     Dim y As Integer
867.     Dim nangle As Integer
868.     Dim nx As Integer
869.     Dim ny As Integer
870.     Dim flipper As Integer
871.     Dim rotr As Double
872.     Dim shear1 As Double
873.     Dim shear2 As Double
874.     Dim clr As Integer
875.     Dim y1 As _Byte
876.     Dim xy1 As _Byte
877.     Dim fy As _Byte
878.     Dim fx As _Byte
879.     Dim in$
880.     Dim sLine As String
881.  
882.     ' initialize new with empty
883.     ReDim NewArray(LBound(OldArray, 1) To UBound(OldArray, 1), LBound(OldArray, 2) To UBound(OldArray, 2), 127) As RotationType
884.     For x = LBound(NewArray, 1) To UBound(NewArray, 1)
885.         For y = LBound(NewArray, 2) To UBound(NewArray, 2)
886.             NewArray(x, y, 0).origx = x
887.             NewArray(x, y, 0).origy = y
888.             NewArray(x, y, 0).c = iEmpty
889.         Next y
890.     Next x
891.  
892.     ' angle is reversed
893.     angle = 360 - angle1
894.  
895.     ' Shearing each element 3 times in one shot
896.     nangle = angle
897.  
898.     ' this pre-processing portion basically rotates by 90 to get
899.     ' between -45 and 45 degrees, where the 3-shear routine works correctly...
900.     If angle > 45 And angle < 225 Then
901.         If angle < 135 Then
902.             nangle = angle - 90
903.         Else
904.             nangle = angle - 180
905.         End If
906.     End If
907.     If angle > 135 And angle < 315 Then
908.         If angle < 225 Then
909.             nangle = angle - 180
910.         Else
911.             nangle = angle - 270
912.         End If
913.     End If
914.     If nangle < 0 Then
915.         nangle = nangle + 360
916.     End If
917.     If nangle > 359 Then
918.         nangle = nangle - 360
919.     End If
920.  
921.     rotr = nangle * DtoR
922.     shear1 = Tan(rotr / 2) ' correct way
923.     shear2 = Sin(rotr)
924.  
925.     ' *** NOTE: this had a bug where the values 135, 224, and 314
926.     ' ***       all resolve to -45 degrees.
927.     ' ***       Fixed by changing < to <=
928.  
929.     'if angle >  45 and angle < 134 then
930.     If angle > 45 And angle <= 134 Then
931.         flipper = 1
932.     ElseIf angle > 134 And angle <= 224 Then
933.         flipper = 2
934.     ElseIf angle > 224 And angle <= 314 Then
935.         ' *** NOTE: this had a bug where this flipper was wrong
936.         '           Fixed by adding case 7
937.         'flipper = 3
938.         flipper = 7
939.     Else
940.         flipper = 0
941.     End If
942.  
943.     ' Here is where it needs some optimizing possibly... kinda slow...
944.     iOverwriteCount = 0
945.     For y = LBound(NewArray, 2) To UBound(NewArray, 2)
946.         For x = LBound(NewArray, 1) To UBound(NewArray, 1)
947.             Select Case flipper
948.                 Case 1:
949.                     nx = -y
950.                     ny = x
951.                 Case 2:
952.                     nx = -x
953.                     ny = -y
954.                 Case 3:
955.                     nx = -y
956.                     ny = -x
957.                 Case 4:
958.                     nx = -x
959.                     ny = y
960.                 Case 5:
961.                     nx = x
962.                     ny = -y
963.                 Case 6:
964.                     nx = y
965.                     ny = x
966.                 Case 7:
967.                     nx = y
968.                     ny = -x
969.                 Case Else:
970.                     nx = x
971.                     ny = y
972.             End Select
973.  
974.             clr = OldArray(nx, ny, 0).c
975.  
976.             y1 = y * shear1
977.             xy1 = x + y1
978.             fy = (y - xy1 * shear2)
979.             fx = xy1 + fy * shear1
980.  
981.             If fx >= -16 And fx <= 16 Then
982.                 If fy >= -16 And fy <= 16 Then
983.  
984.                     ' count points that will be overwritten
985.                     If NewArray(fx, fy, 0).c <> iEmpty Then
986.                         iOverwriteCount = iOverwriteCount + 1
987.                     End If
988.  
989.                     NewArray(fx, fy, 0).c = clr
990.                     NewArray(fx, fy, 0).origx = fx
991.                     NewArray(fx, fy, 0).origy = fy
992.                 End If
993.             End If
994.         Next x
995.     Next y
996. End Sub ' ShearRotate1
997.  
998. ' /////////////////////////////////////////////////////////////////////////////
999. ' Tries to fix the problem of 2 points resolving to the same coordinate
1000. ' (one overwrites the other, which becomes "lost")
1001.  
1002. ' Returns # points missing (that could not be corrected) in iMissing parameter.
1003.  
1004. Sub ShearRotate2 (OldArray() As RotationType, NewArray() As RotationType, angle1 As Integer, iEmpty As Integer, iMissing As Integer)
1005.     Const Pi = 4 * Atn(1)
1006.  
1007.     Dim angle As Integer
1008.     Dim TwoPi As Double: TwoPi = 8 * Atn(1)
1009.     Dim RtoD As Double: RtoD = 180 / Pi ' radians * RtoD = degrees
1010.     Dim DtoR As Double: DtoR = Pi / 180 ' degrees * DtoR = radians
1011.     Dim x As Integer
1012.     Dim y As Integer
1013.     Dim nangle As Integer
1014.     Dim nx As Integer
1015.     Dim ny As Integer
1016.     Dim flipper As Integer
1017.     Dim rotr As Double
1018.     Dim shear1 As Double
1019.     Dim shear2 As Double
1020.     Dim clr As Integer
1021.     Dim y1 As _Byte
1022.     Dim xy1 As _Byte
1023.     Dim fy As _Byte
1024.     Dim fx As _Byte
1025.     Dim in$
1026.     Dim sLine As String
1027.     ReDim arrLost(-1) As RotationType
1028.     Dim iLoop As Integer
1029.     Dim bFound As Integer
1030.  
1031.     ' initialize new with empty
1032.     ReDim NewArray(LBound(OldArray, 1) To UBound(OldArray, 1), LBound(OldArray, 2) To UBound(OldArray, 2), 127) As RotationType
1033.     For x = LBound(NewArray, 1) To UBound(NewArray, 1)
1034.         For y = LBound(NewArray, 2) To UBound(NewArray, 2)
1035.             NewArray(x, y, 0).origx = x
1036.             NewArray(x, y, 0).origy = y
1037.             NewArray(x, y, 0).c = iEmpty
1038.         Next y
1039.     Next x
1040.  
1041.     ' angle is reversed
1042.     angle = 360 - angle1
1043.  
1044.     ' Shearing each element 3 times in one shot
1045.     nangle = angle
1046.  
1047.     ' this pre-processing portion basically rotates by 90 to get
1048.     ' between -45 and 45 degrees, where the 3-shear routine works correctly...
1049.     If angle > 45 And angle < 225 Then
1050.         If angle < 135 Then
1051.             nangle = angle - 90
1052.         Else
1053.             nangle = angle - 180
1054.         End If
1055.     End If
1056.     If angle > 135 And angle < 315 Then
1057.         If angle < 225 Then
1058.             nangle = angle - 180
1059.         Else
1060.             nangle = angle - 270
1061.         End If
1062.     End If
1063.     If nangle < 0 Then
1064.         nangle = nangle + 360
1065.     End If
1066.     If nangle > 359 Then
1067.         nangle = nangle - 360
1068.     End If
1069.  
1070.     rotr = nangle * DtoR
1071.     shear1 = Tan(rotr / 2) ' correct way
1072.     shear2 = Sin(rotr)
1073.  
1074.     ' *** NOTE: this had a bug where the values 135, 224, and 314
1075.     ' ***       all resolve to -45 degrees.
1076.     ' ***       Fixed by changing < to <=
1077.  
1078.     'if angle >  45 and angle < 134 then
1079.     If angle > 45 And angle <= 134 Then
1080.         flipper = 1
1081.     ElseIf angle > 134 And angle <= 224 Then
1082.         flipper = 2
1083.     ElseIf angle > 224 And angle <= 314 Then
1084.         ' *** NOTE: this had a bug where this flipper was wrong
1085.         '           Fixed by adding case 7
1086.         'flipper = 3
1087.         flipper = 7
1088.     Else
1089.         flipper = 0
1090.     End If
1091.  
1092.     ' Here is where it needs some optimizing possibly... kinda slow...
1093.     For y = LBound(NewArray, 2) To UBound(NewArray, 2)
1094.         For x = LBound(NewArray, 1) To UBound(NewArray, 1)
1095.             Select Case flipper
1096.                 Case 1:
1097.                     nx = -y
1098.                     ny = x
1099.                 Case 2:
1100.                     nx = -x
1101.                     ny = -y
1102.                 Case 3:
1103.                     nx = -y
1104.                     ny = -x
1105.                 Case 4:
1106.                     nx = -x
1107.                     ny = y
1108.                 Case 5:
1109.                     nx = x
1110.                     ny = -y
1111.                 Case 6:
1112.                     nx = y
1113.                     ny = x
1114.                 Case 7:
1115.                     nx = y
1116.                     ny = -x
1117.                 Case Else:
1118.                     nx = x
1119.                     ny = y
1120.             End Select
1121.  
1122.             clr = OldArray(nx, ny, 0).c
1123.  
1124.             y1 = y * shear1
1125.             xy1 = x + y1
1126.             fy = (y - xy1 * shear2)
1127.             fx = xy1 + fy * shear1
1128.  
1129.             If fx >= -16 And fx <= 16 Then
1130.                 If fy >= -16 And fy <= 16 Then
1131.                     ' only draw here if this spot is empty
1132.                     If NewArray(fx, fy, 0).c = iEmpty Then
1133.                         NewArray(fx, fy, 0).c = clr
1134.                         NewArray(fx, fy, 0).origx = fx
1135.                         NewArray(fx, fy, 0).origy = fy
1136.                     Else
1137.                         ' don't draw, but save it to a list to handle later
1138.                         ReDim _Preserve arrLost(0 To UBound(arrLost) + 1) As RotationType
1139.                         arrLost(UBound(arrLost)).c = clr
1140.                         arrLost(UBound(arrLost)).origx = fx
1141.                         arrLost(UBound(arrLost)).origy = fy
1142.                     End If
1143.                 End If
1144.             End If
1145.         Next x
1146.     Next y
1147.  
1148.     ' try to place any points that would have overwritten to a spot nearby
1149.     ' can nearby be determined by the angle of rotation?
1150.     ' perhaps if we divide the screen up into 4 zones:
1151.     '
1152.     ' --------------------------------------
1153.     '|                   |                  |
1154.     '| zone 4            | zone 1           |
1155.     '| 271-359 degrees)  | (1-89 degrees)   |
1156.     '|--------------------------------------|
1157.     '|                   |                  |
1158.     '| zone 3            | zone 2           |
1159.     '| (181-269 degrees) | (91-179 degrees) |
1160.     '|                   |                  |
1161.     ' --------------------------------------
1162.  
1163.     ' in zone   search direction (y,x)
1164.     ' -------   ----------------------
1165.     ' 1         up   + right
1166.     ' 2         down + right
1167.     ' 3         down + left
1168.     ' 4         up   + left
1169.  
1170.     iMissing = 0
1171.     For iLoop = 0 To UBound(arrLost)
1172.         bFound = FindEmptyShearRotationPoint%(arrLost(iLoop), angle1, iEmpty, x, y, NewArray())
1173.         If bFound = TRUE Then
1174.             If m_bDebug = TRUE Then
1175.                 _Echo "Plotted  missing point " + Chr$(34) + Chr$(arrLost(iLoop).c) + Chr$(34) + " to (x=" + cstr$(x) + ", y=" + cstr$(y) + ")"
1176.             End If
1177.         Else
1178.             iMissing = iMissing + 1
1179.             If m_bDebug = TRUE Then
1180.                 _Echo "Detected missing point " + Chr$(34) + Chr$(arrLost(iLoop).c) + Chr$(34) + " at (x=" + cstr$(x) + ", y=" + cstr$(y) + ")"
1181.             End If
1182.         End If
1183.     Next iLoop
1184.  
1185. End Sub ' ShearRotate2
1186.  
1187. ' /////////////////////////////////////////////////////////////////////////////
1188. ' Receives
1189. ' FindMe (RotationType) = contains the starting location (.origx, .origy) to start looking from, and the value (.c) to write
1190. ' angle1 (Integer) = angle we were rotating to, to determine direction to look in
1191. ' iEmpty (Integer) = value to test against for empty
1192. ' destX (Integer) = if an empty spot is found, returns the x location here byref
1193. ' destY (Integer) = if an empty spot is found, returns the y location here byref
1194. ' NewArray() (RotationType array (x,y,127) ) = array representing the screen to search in and plot to
1195.  
1196. ' Returns
1197. ' FALSE if no empty spot was found
1198. ' TRUE if an empty spot was found, and x,y location returned byref in destX,destY parameters
1199.  
1200. Function FindEmptyShearRotationPoint% (FindMe As RotationType, angle1 As Integer, iEmpty As Integer, destX As Integer, destY As Integer, NewArray() As RotationType)
1201.     Dim bResult As Integer: bResult = FALSE
1202.     Dim x As Integer
1203.     Dim y As Integer
1204.     Dim dirX As Integer
1205.     Dim dirY As Integer
1206.  
1207.     destX = 0
1208.     destY = 0
1209.  
1210.     ' Choose search direction depending on the angle
1211.     If angle1 > 0 And angle1 < 90 Then
1212.         dirX = 1
1213.         dirY = -1
1214.     ElseIf angle1 > 90 And angle1 < 180 Then
1215.         dirX = 1
1216.         dirY = 1
1217.     ElseIf angle1 > 180 And angle1 < 270 Then
1218.         dirX = -1
1219.         dirY = 1
1220.     ElseIf angle1 > 270 And angle1 < 360 Then
1221.         dirX = -1
1222.         dirY = -1
1223.     Else
1224.         dirX = 0
1225.         dirY = 0
1226.     End If
1227.  
1228.     If dirX <> 0 Then
1229.         x = FindMe.origx
1230.         y = FindMe.origy
1231.         Do
1232.             ' quit if we're out of bounds
1233.             If x < LBound(NewArray, 1) Then Exit Do
1234.             If x > UBound(NewArray, 1) Then Exit Do
1235.             If y < LBound(NewArray, 2) Then Exit Do
1236.             If y > UBound(NewArray, 2) Then Exit Do
1237.  
1238.             ' look along y axis for a blank spot
1239.             destX = x
1240.             destY = y + dirY
1241.             If destX >= LBound(NewArray, 1) Then
1242.                 If destX <= UBound(NewArray, 1) Then
1243.                     If destY >= LBound(NewArray, 2) Then
1244.                         If destY <= UBound(NewArray, 2) Then
1245.                             If NewArray(destX, destY, 0).c = iEmpty Then
1246.                                 NewArray(destX, destY, 0).c = FindMe.c
1247.                                 bResult = TRUE
1248.                                 Exit Do
1249.                             End If
1250.                         End If
1251.                     End If
1252.                 End If
1253.             End If
1254.  
1255.             ' look along x axis for a blank spot
1256.             destX = x + dirX
1257.             destY = y
1258.             If destX >= LBound(NewArray, 1) Then
1259.                 If destX <= UBound(NewArray, 1) Then
1260.                     If destY >= LBound(NewArray, 2) Then
1261.                         If destY <= UBound(NewArray, 2) Then
1262.                             If NewArray(x + dirX, y, 0).c = iEmpty Then
1263.                                 NewArray(destX, destY, 0).c = FindMe.c
1264.                                 bResult = TRUE
1265.                                 Exit Do
1266.                             End If
1267.                         End If
1268.                     End If
1269.                 End If
1270.             End If
1271.  
1272.             ' look diagonally for a blank spot
1273.             destX = x + dirX
1274.             destY = y + dirY
1275.             If destX >= LBound(NewArray, 1) Then
1276.                 If destX <= UBound(NewArray, 1) Then
1277.                     If destY >= LBound(NewArray, 2) Then
1278.                         If destY <= UBound(NewArray, 2) Then
1279.                             If NewArray(x + dirX, y + dirY, 0).c = iEmpty Then
1280.                                 NewArray(destX, destY, 0).c = FindMe.c
1281.                                 bResult = TRUE
1282.                                 Exit Do
1283.                             End If
1284.                         End If
1285.                     End If
1286.                 End If
1287.             End If
1288.  
1289.             ' Keep looking
1290.             x = x + dirX
1291.             y = y + dirY
1292.         Loop
1293.     End If
1294.  
1295.     ' Return result
1296.     FindEmptyShearRotationPoint% = bResult
1297. End Function ' FindEmptyShearRotationPoint%
1298.  
1299. ' /////////////////////////////////////////////////////////////////////////////
1300.  
1301. Sub ShearRotateTest1
1302.     Dim RoArray1(-16 To 16, -16 To 16, 127) As RotationType
1303.     Dim RoArray2(-16 To 16, -16 To 16, 127) As RotationType
1304.     Dim sMap As String
1305.     Dim D As Integer
1306.     Dim in$
1307.  
1308.     ' GET A SHAPE TO BE ROTATED
1309.     Cls
1310.     Print "3 shear rotation based on code by leopardpm"
1311.     Print
1312.  
1313.     sMap = TestSprite1$
1314.  
1315.     ' CONVERT SHAPE TO ARRAY
1316.     StringToRotationArray RoArray1(), sMap, "."
1317.     Print "Initial contents of Rotation Array:"
1318.     Print RotationArrayToStringTest(RoArray1())
1319.     Print
1320.  
1321.     ' ROTATE THE SHAPE
1322.     Do
1323.         Print "Type degrees to rotate (0 TO 360) or non-numeric value to quit."
1324.         Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)."
1325.  
1326.         Input "Degrees to rotate (q to quit)? "; in$
1327.         If IsNum%(in$) Then
1328.             D = Val(in$)
1329.             If D >= 0 And D <= 360 Then
1330.                 ShearRotate RoArray1(), RoArray2(), D, Asc(".")
1331.                 Print
1332.                 Print "Rotated by " + cstr$(D) + " degrees:"
1333.                 Print RotationArrayToStringTest(RoArray2())
1334.                 Print
1335.             Else
1336.                 Exit Do
1337.             End If
1338.         Else
1339.             Exit Do
1340.         End If
1341.     Loop
1342. End Sub ' ShearRotateTest1
1343.  
1344. ' /////////////////////////////////////////////////////////////////////////////
1345. ' Now receives parameter sMap
1346. ' which comes from TestSprite1$, TestSprite2$, TestSprite3$, etc.
1347.  
1348. ' e.g. ShearRotateTest2 TestSprite1$
1349.  
1350. Sub ShearRotateTest2 (sMap As String)
1351.     Dim RoArray1(-16 To 16, -16 To 16, 127) As RotationType
1352.     Dim RoArray2(-16 To 16, -16 To 16, 127) As RotationType
1353.     'Dim sMap As String
1354.     Dim D As Integer
1355.     Dim D1 As Integer
1356.     Dim in$
1357.     Dim bFinished As Integer
1358.     Dim iOverwriteCount As Integer
1359.  
1360.     ' GET A SHAPE TO BE ROTATED
1361.     Cls
1362.     Print "3 shear rotation based on code by leopardpm"
1363.     'sMap = TestSprite1$
1364.  
1365.     ' CONVERT SHAPE TO ARRAY
1366.     StringToRotationArray RoArray1(), sMap, "."
1367.  
1368.     ' GET START ANGLE
1369.     D = 0
1370.     Print
1371.     Print "Rotated by " + cstr$(D) + " degrees:"
1372.     Print RotationArrayToStringTest(RoArray1())
1373.     Print
1374.     Print "Type an angle (-360 to 360) to rotate to, "
1375.     Print "or blank to increase by 1 degree, or q to quit."
1376.     Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)."
1377.     Print "Hold down <ENTER> to rotate continually."
1378.     Input "Angle (q to quit)? ", in$
1379.     If Len(in$) > 0 Then
1380.         If IsNum%(in$) Then
1381.             D1 = Val(in$)
1382.         Else
1383.             D1 = -500
1384.         End If
1385.     Else
1386.         D1 = 1
1387.     End If
1388.  
1389.     ' ROTATE TO EACH ANGLE
1390.     If D1 >= -360 And D1 <= 360 Then
1391.         bFinished = FALSE
1392.         Do
1393.             ' ROTATE CLOCKWISE
1394.             For D = D1 To 360
1395.                 Cls
1396.                 ShearRotate1 RoArray1(), RoArray2(), D, Asc("."), iOverwriteCount
1397.                 Print
1398.                 'Print "Rotated by " + cstr$(D) + " degrees:"
1399.                 Print "Rotated by " + cstr$(D) + " degrees" + IIFSTR$(iOverwriteCount = 0, "", " (" + cstr$(iOverwriteCount) + " points overwritten)") + ":"
1400.  
1401.                 Print RotationArrayToStringTest(RoArray2())
1402.                 Print
1403.  
1404.                 Print "Type an angle (-360 to 360) to rotate to, "
1405.                 Print "or blank to increase by 1 degree, or q to quit."
1406.                 Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)."
1407.                 Print "Hold down <ENTER> to rotate continually."
1408.                 Input "Angle (q to quit)? ", in$
1409.                 If Len(in$) > 0 Then
1410.                     If IsNum%(in$) Then
1411.                         D = Val(in$)
1412.                         If D >= 0 And D <= 360 Then
1413.                             D = D - 1
1414.                         Else
1415.                             bFinished = TRUE
1416.                             Exit For
1417.                         End If
1418.                     Else
1419.                         bFinished = TRUE
1420.                         Exit For
1421.                     End If
1422.                 End If
1423.             Next D
1424.             If bFinished = TRUE Then Exit Do
1425.  
1426.             ' ROTATE COUNTER-CLOCKWISE
1427.             For D = 360 To D1 Step -1
1428.                 Cls
1429.                 ShearRotate1 RoArray1(), RoArray2(), D, Asc("."), iOverwriteCount
1430.                 Print
1431.                 'Print "Rotated by " + cstr$(D) + " degrees:"
1432.                 Print "Rotated by " + cstr$(D) + " degrees" + IIFSTR$(iOverwriteCount = 0, "", " (" + cstr$(iOverwriteCount) + " points overwritten)") + ":"
1433.  
1434.                 Print RotationArrayToStringTest(RoArray2())
1435.                 Print
1436.  
1437.                 Print "Type an angle (0 to 360) to rotate to, "
1438.                 Print "or blank to increase by 1 degree, or q to quit."
1439.                 Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)."
1440.                 Print "Hold down <ENTER> to rotate continually."
1441.                 Input "Angle (q to quit)? ", in$
1442.                 If Len(in$) > 0 Then
1443.                     If IsNum%(in$) Then
1444.                         D = Val(in$)
1445.                         If D >= 0 And D <= 360 Then
1446.                             D = D + 1
1447.                         Else
1448.                             bFinished = TRUE
1449.                             Exit For
1450.                         End If
1451.                     Else
1452.                         bFinished = TRUE
1453.                         Exit For
1454.                     End If
1455.                 End If
1456.             Next D
1457.             If bFinished = TRUE Then Exit Do
1458.         Loop
1459.     End If
1460. End Sub ' ShearRotateTest2
1461.  
1462. ' /////////////////////////////////////////////////////////////////////////////
1463. ' Tries to correct for missing points.
1464.  
1465. ' Receives parameter sMap
1466. ' which comes from TestSprite1$, TestSprite2$, TestSprite3$, etc.
1467.  
1468. ' e.g. ShearRotateTest3 TestSprite1$
1469.  
1470. Sub ShearRotateTest3 (sMap As String)
1471.     Dim RoArray1(-16 To 16, -16 To 16, 127) As RotationType
1472.     Dim RoArray2(-16 To 16, -16 To 16, 127) As RotationType
1473.     'Dim sMap As String
1474.     Dim D As Integer
1475.     Dim D1 As Integer
1476.     Dim in$
1477.     Dim bFinished As Integer
1478.     Dim iMissing As Integer
1479.  
1480.     ' GET A SHAPE TO BE ROTATED
1481.     Cls
1482.     Print "3 shear rotation based on code by leopardpm"
1483.     'sMap = TestSprite1$
1484.  
1485.     ' CONVERT SHAPE TO ARRAY
1486.     StringToRotationArray RoArray1(), sMap, "."
1487.  
1488.     ' GET START ANGLE
1489.     D = 0
1490.     Print
1491.     Print "Rotated by " + cstr$(D) + " degrees:"
1492.     Print RotationArrayToStringTest(RoArray1())
1493.     Print
1494.     Print "Type an angle (-360 to 360) to rotate to, "
1495.     Print "or blank to increase by 1 degree, or q to quit."
1496.     Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)."
1497.     Print "Hold down <ENTER> to rotate continually."
1498.     Input "Angle (q to quit)? ", in$
1499.     If Len(in$) > 0 Then
1500.         If IsNum%(in$) Then
1501.             D1 = Val(in$)
1502.         Else
1503.             D1 = -500
1504.         End If
1505.     Else
1506.         D1 = 1
1507.     End If
1508.  
1509.     ' ROTATE TO EACH ANGLE
1510.     If D1 >= -360 And D1 <= 360 Then
1511.         bFinished = FALSE
1512.         Do
1513.             ' ROTATE CLOCKWISE
1514.             For D = D1 To 360
1515.                 Cls
1516.                 ShearRotate2 RoArray1(), RoArray2(), D, Asc("."), iMissing
1517.                 Print
1518.                 'Print "Rotated by " + cstr$(D) + " degrees:"
1519.                 Print "Rotated by " + cstr$(D) + " degrees" + IIFSTR$(iMissing = 0, "", " (" + cstr$(iMissing) + " points missing)") + ":"
1520.  
1521.                 Print RotationArrayToStringTest(RoArray2())
1522.                 Print
1523.  
1524.                 Print "Type an angle (-360 to 360) to rotate to, "
1525.                 Print "or blank to increase by 1 degree, or q to quit."
1526.                 Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)."
1527.                 Print "Hold down <ENTER> to rotate continually."
1528.                 Input "Angle (q to quit)? ", in$
1529.                 If Len(in$) > 0 Then
1530.                     If IsNum%(in$) Then
1531.                         D = Val(in$)
1532.                         If D >= 0 And D <= 360 Then
1533.                             D = D - 1
1534.                         Else
1535.                             bFinished = TRUE
1536.                             Exit For
1537.                         End If
1538.                     Else
1539.                         bFinished = TRUE
1540.                         Exit For
1541.                     End If
1542.                 End If
1543.             Next D
1544.             If bFinished = TRUE Then Exit Do
1545.  
1546.             ' ROTATE COUNTER-CLOCKWISE
1547.             For D = 360 To D1 Step -1
1548.                 Cls
1549.                 ShearRotate2 RoArray1(), RoArray2(), D, Asc("."), iMissing
1550.                 Print
1551.                 'Print "Rotated by " + cstr$(D) + " degrees:"
1552.                 Print "Rotated by " + cstr$(D) + " degrees" + IIFSTR$(iMissing = 0, "", " (" + cstr$(iMissing) + " points missing)") + ":"
1553.  
1554.                 Print RotationArrayToStringTest(RoArray2())
1555.                 Print
1556.  
1557.                 Print "Type an angle (0 to 360) to rotate to, "
1558.                 Print "or blank to increase by 1 degree, or q to quit."
1559.                 Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)."
1560.                 Print "Hold down <ENTER> to rotate continually."
1561.                 Input "Angle (q to quit)? ", in$
1562.                 If Len(in$) > 0 Then
1563.                     If IsNum%(in$) Then
1564.                         D = Val(in$)
1565.                         If D >= 0 And D <= 360 Then
1566.                             D = D + 1
1567.                         Else
1568.                             bFinished = TRUE
1569.                             Exit For
1570.                         End If
1571.                     Else
1572.                         bFinished = TRUE
1573.                         Exit For
1574.                     End If
1575.                 End If
1576.             Next D
1577.             If bFinished = TRUE Then Exit Do
1578.         Loop
1579.     End If
1580. End Sub ' ShearRotateTest3
1581.  
1582. ' /////////////////////////////////////////////////////////////////////////////
1583.  
1584. Function TestSprite1$
1585.     Dim m$
1586.     m$ = ""
1587.     '                   11111111112222222222333
1588.     '          12345678901234567890123456789012
1589.     m$ = m$ + "11111111111111111111111111111111" + Chr$(13) ' 1
1590.     m$ = m$ + "4..............................2" + Chr$(13) ' 2
1591.     m$ = m$ + "4....##.....#######.....####...2" + Chr$(13) ' 3
1592.     m$ = m$ + "4...####....##...###...######..2" + Chr$(13) ' 4
1593.     m$ = m$ + "4..##..##...##...###..##....##.2" + Chr$(13) ' 5
1594.     m$ = m$ + "4.##....##..#######...##.......2" + Chr$(13) ' 6
1595.     m$ = m$ + "4.########..#######...##.......2" + Chr$(13) ' 7
1596.     m$ = m$ + "4.########..##...###..##....##.2" + Chr$(13) ' 8
1597.     m$ = m$ + "4.##....##..##...###...######..2" + Chr$(13) ' 9
1598.     m$ = m$ + "4.##....##..#######.....####...2" + Chr$(13) ' 10
1599.     m$ = m$ + "4..............................2" + Chr$(13) ' 11
1600.     m$ = m$ + "4..............................2" + Chr$(13) ' 12
1601.     m$ = m$ + "4..ABBBBBBBBBBBBBBBBBBBBBBBBC..2" + Chr$(13) ' 13
1602.     m$ = m$ + "4..A...........EE...........C..2" + Chr$(13) ' 14
1603.     m$ = m$ + "4..A..........FFFF..........C..2" + Chr$(13) ' 15
1604.     m$ = m$ + "4..A.........GGGGGG.........C..2" + Chr$(13) ' 16
1605.     m$ = m$ + "4..A........HHHHHHHH........C..2" + Chr$(13) ' 17
1606.     m$ = m$ + "4..A.......IIIIIIIIII.......C..2" + Chr$(13) ' 18
1607.     m$ = m$ + "4..A......JJJJJJJJJJJJ......C..2" + Chr$(13) ' 19
1608.     m$ = m$ + "4..DDDDDDDDDDDDDDDDDDDDDDDDDC..2" + Chr$(13) ' 20
1609.     m$ = m$ + "4..............................2" + Chr$(13) ' 21
1610.     m$ = m$ + "4..............................2" + Chr$(13) ' 22
1611.     m$ = m$ + "4.######....########..########.2" + Chr$(13) ' 23
1612.     m$ = m$ + "4.#######...########..########.2" + Chr$(13) ' 24
1613.     m$ = m$ + "4.##...###..##........##.......2" + Chr$(13) ' 25
1614.     m$ = m$ + "4.##....##..########..#######..2" + Chr$(13) ' 26
1615.     m$ = m$ + "4.##....##..########..#######..2" + Chr$(13) ' 27
1616.     m$ = m$ + "4.##...###..##........##.......2" + Chr$(13) ' 28
1617.     m$ = m$ + "4.#######...##........##.......2" + Chr$(13) ' 29
1618.     m$ = m$ + "4.######....########..##.......2" + Chr$(13) ' 30
1619.     m$ = m$ + "4..............................2" + Chr$(13) ' 31
1620.     m$ = m$ + "33333333333333333333333333333332" + Chr$(13) ' 32
1621.     TestSprite1$ = m$
1622. End Function ' TestSprite1$
1623.  
1624. ' /////////////////////////////////////////////////////////////////////////////
1625.  
1626. Function TestSprite2$
1627.     Dim m$
1628.     m$ = ""
1629.     '                   11111111112222222222333
1630.     '          12345678901234567890123456789012
1631.     m$ = m$ + "...............AA..............." + Chr$(13) ' 1
1632.     m$ = m$ + "..............//BB.............." + Chr$(13) ' 2
1633.     m$ = m$ + ".............??..CC............." + Chr$(13) ' 3
1634.     m$ = m$ + "............==....DD............" + Chr$(13) ' 4
1635.     m$ = m$ + "...........++......EE..........." + Chr$(13) ' 5
1636.     m$ = m$ + "..........&&........FF.........." + Chr$(13) ' 6
1637.     m$ = m$ + ".........zz..........GG........." + Chr$(13) ' 7
1638.     m$ = m$ + "........yy............HH........" + Chr$(13) ' 8
1639.     m$ = m$ + ".......xx..............II......." + Chr$(13) ' 9
1640.     m$ = m$ + "......ww................JJ......" + Chr$(13) ' 10
1641.     m$ = m$ + ".....vv..................KK....." + Chr$(13) ' 11
1642.     m$ = m$ + "....uu....................LL...." + Chr$(13) ' 12
1643.     m$ = m$ + "...tt......DDAAAAAAA.......MM..." + Chr$(13) ' 13
1644.     m$ = m$ + "..ss.......DDAAAAAAA........NN.." + Chr$(13) ' 14
1645.     m$ = m$ + ".rr........DD.....BB.........OO." + Chr$(13) ' 15
1646.     m$ = m$ + "qq.........DD.....BB..........PP" + Chr$(13) ' 16
1647.     m$ = m$ + "pp.........DD.....BB..........QQ" + Chr$(13) ' 17
1648.     m$ = m$ + ".oo........DD.....BB.........RR." + Chr$(13) ' 18
1649.     m$ = m$ + "..nn.......CCCCCCCBB........SS.." + Chr$(13) ' 19
1650.     m$ = m$ + "...mm......CCCCCCCBB.......TT..." + Chr$(13) ' 20
1651.     m$ = m$ + "....ll....................UU...." + Chr$(13) ' 21
1652.     m$ = m$ + ".....kk..................VV....." + Chr$(13) ' 22
1653.     m$ = m$ + "......jj................WW......" + Chr$(13) ' 23
1654.     m$ = m$ + ".......ii..............XX......." + Chr$(13) ' 24
1655.     m$ = m$ + "........hh............YY........" + Chr$(13) ' 25
1656.     m$ = m$ + ".........gg..........ZZ........." + Chr$(13) ' 26
1657.     m$ = m$ + "..........ff........@@.........." + Chr$(13) ' 27
1658.     m$ = m$ + "...........ee......##..........." + Chr$(13) ' 28
1659.     m$ = m$ + "............dd....$$............" + Chr$(13) ' 29
1660.     m$ = m$ + ".............cc..%%............." + Chr$(13) ' 30
1661.     m$ = m$ + "..............bb\\.............." + Chr$(13) ' 31
1662.     m$ = m$ + "...............aa..............." + Chr$(13) ' 32
1663.     TestSprite2$ = m$
1664. End Function ' TestSprite2$
1665.  
1666. ' /////////////////////////////////////////////////////////////////////////////
1667.  
1668. Function PetrText1$
1669.     Dim m$
1670.     m$ = ""
1671.     '                   11111111112222222222333
1672.     '          12345678901234567890123456789012
1673.     m$ = m$ + "................................" + Chr$(13) ' 1
1674.     m$ = m$ + "................................" + Chr$(13) ' 2
1675.     m$ = m$ + "................................" + Chr$(13) ' 3
1676.     m$ = m$ + "................................" + Chr$(13) ' 4
1677.     m$ = m$ + "................................" + Chr$(13) ' 5
1678.     m$ = m$ + "................................" + Chr$(13) ' 6
1679.     m$ = m$ + "................................" + Chr$(13) ' 7
1680.     m$ = m$ + "................................" + Chr$(13) ' 8
1681.     m$ = m$ + "................................" + Chr$(13) ' 9
1682.     m$ = m$ + "................................" + Chr$(13) ' 10
1683.     m$ = m$ + "................................" + Chr$(13) ' 11
1684.     m$ = m$ + "................................" + Chr$(13) ' 12
1685.     m$ = m$ + "................................" + Chr$(13) ' 13
1686.     m$ = m$ + "................................" + Chr$(13) ' 14
1687.     m$ = m$ + "....It's a SCREEN resolution?..." + Chr$(13) ' 15
1688.     m$ = m$ + "................................" + Chr$(13) ' 16
1689.     m$ = m$ + "................................" + Chr$(13) ' 17
1690.     m$ = m$ + "................................" + Chr$(13) ' 18
1691.     m$ = m$ + "................................" + Chr$(13) ' 19
1692.     m$ = m$ + "................................" + Chr$(13) ' 20
1693.     m$ = m$ + "................................" + Chr$(13) ' 21
1694.     m$ = m$ + "................................" + Chr$(13) ' 22
1695.     m$ = m$ + "................................" + Chr$(13) ' 23
1696.     m$ = m$ + "................................" + Chr$(13) ' 24
1697.     m$ = m$ + "................................" + Chr$(13) ' 25
1698.     m$ = m$ + "................................" + Chr$(13) ' 26
1699.     m$ = m$ + "................................" + Chr$(13) ' 27
1700.     m$ = m$ + "................................" + Chr$(13) ' 28
1701.     m$ = m$ + "................................" + Chr$(13) ' 29
1702.     m$ = m$ + "................................" + Chr$(13) ' 30
1703.     m$ = m$ + "................................" + Chr$(13) ' 31
1704.     m$ = m$ + "................................" + Chr$(13) ' 32
1705.     PetrText1$ = m$
1706. End Function ' PetrText1$
1707.  
1708. ' /////////////////////////////////////////////////////////////////////////////
1709.  
1710. Function ArrayToString$ (MyArray( 1 To 32 , 1 To 32) As String)
1711.     Dim MyString As String
1712.     Dim iY As Integer
1713.     Dim iX As Integer
1714.     Dim sLine As String
1715.     MyString = ""
1716.     For iY = LBound(MyArray, 1) To UBound(MyArray, 1)
1717.         sLine = ""
1718.         For iX = LBound(MyArray, 2) To UBound(MyArray, 2)
1719.             sLine = sLine + MyArray(iY, iX)
1720.         Next iX
1721.         MyString = MyString + sLine + Chr$(13)
1722.     Next iY
1723.     ArrayToString$ = MyString
1724. End Function ' ArrayToString$
1725.  
1726. ' /////////////////////////////////////////////////////////////////////////////
1727.  
1728. Function ArrayToStringTest$ (MyArray() As String)
1729.     Dim MyString As String
1730.     Dim iY As Integer
1731.     Dim iX As Integer
1732.     Dim sLine As String
1733.     MyString = ""
1734.  
1735.     MyString = MyString + "           11111111112222222222333" + Chr$(13)
1736.     MyString = MyString + "  12345678901234567890123456789012" + Chr$(13)
1737.     For iY = LBound(MyArray, 1) To UBound(MyArray, 1)
1738.         sLine = ""
1739.         sLine = sLine + Right$("  " + cstr$(iY), 2)
1740.         For iX = LBound(MyArray, 2) To UBound(MyArray, 2)
1741.             sLine = sLine + MyArray(iY, iX)
1742.         Next iX
1743.         sLine = sLine + Right$("  " + cstr$(iY), 2)
1744.         MyString = MyString + sLine + Chr$(13)
1745.     Next iY
1746.     MyString = MyString + "  12345678901234567890123456789012" + Chr$(13)
1747.     MyString = MyString + "           11111111112222222222333" + Chr$(13)
1748.     ArrayToStringTest$ = MyString
1749. End Function ' ArrayToStringTest$
1750.  
1751. ' /////////////////////////////////////////////////////////////////////////////
1752.  
1753. Function RotationArrayToStringTest$ (RoArray() As RotationType)
1754.     Dim MyString As String
1755.     Dim iY As Integer
1756.     Dim iX As Integer
1757.     Dim sLine As String
1758.     MyString = ""
1759.     MyString = MyString + "   ---------------- ++++++++++++++++" + Chr$(13)
1760.     MyString = MyString + "   1111111                   1111111" + Chr$(13)
1761.     MyString = MyString + "   654321098765432101234567890123456" + Chr$(13)
1762.     For iY = LBound(RoArray, 1) To UBound(RoArray, 1)
1763.         sLine = ""
1764.         sLine = sLine + Right$("    " + cstr$(iY), 3)
1765.         For iX = LBound(RoArray, 2) To UBound(RoArray, 2)
1766.             sLine = sLine + Chr$(RoArray(iX, iY, 0).c)
1767.         Next iX
1768.         sLine = sLine + Right$("   " + cstr$(iY), 3)
1769.         MyString = MyString + sLine + Chr$(13)
1770.     Next iY
1771.     MyString = MyString + "   654321098765432101234567890123456" + Chr$(13)
1772.     MyString = MyString + "   1111111                   1111111" + Chr$(13)
1773.     MyString = MyString + "   ---------------- ++++++++++++++++" + Chr$(13)
1774.     RotationArrayToStringTest$ = MyString
1775. End Function ' RotationArrayToStringTest$
1776.  
1777. ' /////////////////////////////////////////////////////////////////////////////
1778. ' 1. split string by line breaks CHR$(13)
1779. ' 2. split lines up to 1 column per char
1780. ' 3. count rows, columns
1781. ' 4. DIM array, making sure array has
1782. '    a) an _ODD_ number of rows/columns, with a center point
1783. '    b) index is in cartesian format, where center is (0,0)
1784. ' 5. populate array with contents of string
1785.  
1786. ' dimension #1 = columns
1787. ' dimension #2 = rows
1788.  
1789. Sub StringToRotationArray (RoArray() As RotationType, MyString As String, EmptyChar As String)
1790.     Dim RoutineName As String: RoutineName = "StringToRotationArray"
1791.     ReDim arrLines$(0)
1792.     Dim delim$
1793.     Dim iRow%
1794.     Dim iCol%
1795.     Dim sChar$
1796.     Dim iColCount As Integer
1797.     Dim iRowCount As Integer
1798.     Dim iCount As Integer
1799.     Dim bAddedRow As Integer: bAddedRow = FALSE
1800.     Dim bAddedColumn As Integer: bAddedColumn = FALSE
1801.     Dim iHalf1 As Integer
1802.     Dim iHalf2 As Integer
1803.     Dim iFrom1 As Integer
1804.     Dim iFrom2 As Integer
1805.     Dim iTo1 As Integer
1806.     Dim iTo2 As Integer
1807.     Dim iEmpty As Integer
1808.     Dim iX As Integer
1809.     Dim iY As Integer
1810.  
1811.     delim$ = Chr$(13)
1812.     split MyString, delim$, arrLines$()
1813.  
1814.     iRowCount = UBound(arrLines$) + 1
1815.  
1816.     ' look at all the rows and find the max # of columns used
1817.     iColCount = 0
1818.     For iRow% = LBound(arrLines$) To UBound(arrLines$)
1819.  
1820.         ' count the columns for this row
1821.         iCount = 0
1822.         For iCol% = 1 To Len(arrLines$(iRow%))
1823.             iCount = iCount + 1
1824.         Next iCol%
1825.  
1826.         ' if this row has the most so far, then set that to the max
1827.         If iCount > iColCount Then
1828.             iColCount = iCount
1829.         End If
1830.     Next iRow%
1831.  
1832.     ' adjust columns to be odd
1833.     If IsEven%(iColCount) Then
1834.         iColCount = iColCount + 1
1835.         bAddedColumn = TRUE
1836.     End If
1837.  
1838.     ' calculate array bounds for columns
1839.     iHalf1 = (iColCount - 1) / 2
1840.     iFrom1 = 0 - iHalf1
1841.     iTo1 = iHalf1
1842.  
1843.     ' adjust rows to be odd
1844.     If IsEven%(iRowCount) Then
1845.         iRowCount = iRowCount + 1
1846.         bAddedRow = TRUE
1847.     End If
1848.  
1849.     ' calculate array bounds for rows
1850.     iHalf2 = (iRowCount - 1) / 2
1851.     iFrom2 = 0 - iHalf2
1852.     iTo2 = iHalf2
1853.  
1854.     ' size array to new bounds
1855.     ReDim RoArray(iFrom1 To iTo1, iFrom2 To iTo2, 127) As RotationType
1856.  
1857.     ' get value for empty
1858.     If Len(EmptyChar) > 0 Then
1859.         iEmpty = Asc(EmptyChar)
1860.     Else
1861.         iEmpty = 32 ' (use space as default)
1862.     End If
1863.  
1864.     ' clear array
1865.     For iY = LBound(RoArray, 2) To UBound(RoArray, 2)
1866.         For iX = LBound(RoArray, 1) To UBound(RoArray, 1)
1867.             RoArray(iX, iY, 0).c = iEmpty
1868.             RoArray(iX, iY, 0).origx = iX
1869.             RoArray(iX, iY, 0).origy = iY
1870.         Next iX
1871.     Next iY
1872.  
1873.     ' fill array
1874.     iY = LBound(RoArray, 2) - 1
1875.     For iRow% = LBound(arrLines$) To UBound(arrLines$)
1876.         iY = iY + 1
1877.         iX = LBound(RoArray, 1) - 1
1878.         For iCol% = 1 To Len(arrLines$(iRow%))
1879.             iX = iX + 1
1880.             sChar$ = Mid$(arrLines$(iRow%), iCol%, 1)
1881.             RoArray(iX, iY, 0).c = Asc(sChar$)
1882.         Next iCol%
1883.     Next iRow%
1884.  
1885. End Sub ' StringToRotationArray
1886.  
1887. ' /////////////////////////////////////////////////////////////////////////////
1888.  
1889. Sub StringToArray (MyArray() As String, MyString As String)
1890.     Dim delim$
1891.     ReDim arrLines$(0)
1892.     Dim iRow%
1893.     Dim iCol%
1894.     Dim sChar$
1895.     Dim iDim1 As Integer
1896.     Dim iDim2 As Integer
1897.     iDim1 = LBound(MyArray, 1)
1898.     iDim2 = LBound(MyArray, 2)
1899.     delim$ = Chr$(13)
1900.     split MyString, delim$, arrLines$()
1901.     For iRow% = LBound(arrLines$) To UBound(arrLines$)
1902.         If iRow% <= UBound(MyArray, 2) Then
1903.             For iCol% = 1 To Len(arrLines$(iRow%))
1904.                 If iCol% <= UBound(MyArray, 1) Then
1905.                     sChar$ = Mid$(arrLines$(iRow%), iCol%, 1)
1906.  
1907.                     If Len(sChar$) > 1 Then
1908.                         sChar$ = Left$(sChar$, 1)
1909.                     Else
1910.                         If Len(sChar$) = 0 Then
1911.                             sChar$ = "."
1912.                         End If
1913.                     End If
1914.                     MyArray(iRow% + iDim1, (iCol% - 1) + iDim2) = sChar$
1915.                 Else
1916.                     ' Exit if out of bounds
1917.                     Exit For
1918.                 End If
1919.             Next iCol%
1920.         Else
1921.             ' Exit if out of bounds
1922.             Exit For
1923.         End If
1924.     Next iRow%
1925. End Sub ' StringToArray
1926.  
1927. ' /////////////////////////////////////////////////////////////////////////////
1928.  
1929. 'SUB ClearArray (MyArray(1 To 32, 1 To 32) AS STRING, MyString As String)
1930. Sub ClearArray (MyArray() As String, MyString As String)
1931.     Dim iRow As Integer
1932.     Dim iCol As Integer
1933.     Dim sChar$
1934.     If Len(MyString) = 1 Then
1935.         sChar$ = MyString
1936.     Else
1937.         If Len(MyString) = 0 Then
1938.             sChar$ = " "
1939.         Else
1940.             sChar$ = Left$(MyString, 1)
1941.         End If
1942.     End If
1943.     For iRow = LBound(MyArray, 1) To UBound(MyArray, 1)
1944.         For iCol = LBound(MyArray, 2) To UBound(MyArray, 2)
1945.             MyArray(iRow, iCol) = sChar$
1946.         Next iCol
1947.     Next iRow
1948. End Sub ' ClearArray
1949.  
1950. ' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1951. ' BEGIN GENERAL PURPOSE ROUTINES
1952. ' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1953.  
1954. ' /////////////////////////////////////////////////////////////////////////////
1955.  
1956. Function cstr$ (myValue)
1957.     'cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
1958.     cstr$ = _Trim$(Str$(myValue))
1959. End Function ' cstr$
1960.  
1961. Function cstrl$ (myValue As Long)
1962.     cstrl$ = _Trim$(Str$(myValue))
1963. End Function ' cstrl$
1964.  
1965. ' /////////////////////////////////////////////////////////////////////////////
1966.  
1967. Function IIF (Condition, IfTrue, IfFalse)
1968.     If Condition Then IIF = IfTrue Else IIF = IfFalse
1969. End Function
1970.  
1971. ' /////////////////////////////////////////////////////////////////////////////
1972.  
1973. Function IIFSTR$ (Condition, IfTrue$, IfFalse$)
1974.     If Condition Then IIFSTR$ = IfTrue$ Else IIFSTR$ = IfFalse$
1975. End Function
1976.  
1977. ' /////////////////////////////////////////////////////////////////////////////
1978. ' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
1979.  
1980. Function IsEven% (n)
1981.     If n Mod 2 = 0 Then
1982.         IsEven% = TRUE
1983.     Else
1984.         IsEven% = FALSE
1985.     End If
1986. End Function ' IsEven%
1987.  
1988. ' /////////////////////////////////////////////////////////////////////////////
1989. ' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
1990.  
1991. Function IsOdd% (n)
1992.     If n Mod 2 = 1 Then
1993.         IsOdd% = TRUE
1994.     Else
1995.         IsOdd% = FALSE
1996.     End If
1997. End Function ' IsOdd%
1998.  
1999. ' /////////////////////////////////////////////////////////////////////////////
2000. ' By sMcNeill from https://www.qb64.org/forum/index.php?topic=896.0
2001.  
2002. Function IsNum% (text$)
2003.     Dim a$
2004.     Dim b$
2005.     a$ = _Trim$(text$)
2006.     b$ = _Trim$(Str$(Val(text$)))
2007.     If a$ = b$ Then
2008.         IsNum% = TRUE
2009.     Else
2010.         IsNum% = FALSE
2011.     End If
2012. End Function ' IsNum%
2013.  
2014. ' /////////////////////////////////////////////////////////////////////////////
2015. ' Split and join strings
2016. ' https://www.qb64.org/forum/index.php?topic=1073.0
2017.  
2018. 'Combine all elements of in$() into a single string with delimiter$ separating the elements.
2019.  
2020. Function join$ (in$(), delimiter$)
2021.     result$ = in$(LBound(in$))
2022.     For i = LBound(in$) + 1 To UBound(in$)
2023.         result$ = result$ + delimiter$ + in$(i)
2024.     Next i
2025.     join$ = result$
2026. End Function ' join$
2027.  
2028. ' /////////////////////////////////////////////////////////////////////////////
2029. ' FROM: String Manipulation
2030. ' http://www.[abandoned, outdated and now likely malicious qb64 dot net website - don’t go there]/forum/index_topic_5964-0/
2031. '
2032. 'SUMMARY:
2033. '   Purpose:  A library of custom functions that transform strings.
2034. '   Author:   Dustinian Camburides (dustinian@gmail.com)
2035. '   Platform: QB64 (www.[abandoned, outdated and now likely malicious qb64 dot net website - don’t go there])
2036. '   Revision: 1.6
2037. '   Updated:  5/28/2012
2038.  
2039. 'SUMMARY:
2040. '[Replace$] replaces all instances of the [Find] sub-string with the [Add] sub-string within the [Text] string.
2041. 'INPUT:
2042. 'Text: The input string; the text that's being manipulated.
2043. 'Find: The specified sub-string; the string sought within the [Text] string.
2044. 'Add: The sub-string that's being added to the [Text] string.
2045.  
2046. Function Replace$ (Text1 As String, Find1 As String, Add1 As String)
2047.     ' VARIABLES:
2048.     Dim Text2 As String
2049.     Dim Find2 As String
2050.     Dim Add2 As String
2051.     Dim lngLocation As Long ' The address of the [Find] substring within the [Text] string.
2052.     Dim strBefore As String ' The characters before the string to be replaced.
2053.     Dim strAfter As String ' The characters after the string to be replaced.
2054.  
2055.     ' INITIALIZE:
2056.     ' MAKE COPIESSO THE ORIGINAL IS NOT MODIFIED (LIKE ByVal IN VBA)
2057.     Text2 = Text1
2058.     Find2 = Find1
2059.     Add2 = Add1
2060.  
2061.     lngLocation = InStr(1, Text2, Find2)
2062.  
2063.     ' PROCESSING:
2064.     ' While [Find2] appears in [Text2]...
2065.     While lngLocation
2066.         ' Extract all Text2 before the [Find2] substring:
2067.         strBefore = Left$(Text2, lngLocation - 1)
2068.  
2069.         ' Extract all text after the [Find2] substring:
2070.         strAfter = Right$(Text2, ((Len(Text2) - (lngLocation + Len(Find2) - 1))))
2071.  
2072.         ' Return the substring:
2073.         Text2 = strBefore + Add2 + strAfter
2074.  
2075.         ' Locate the next instance of [Find2]:
2076.         lngLocation = InStr(1, Text2, Find2)
2077.  
2078.         ' Next instance of [Find2]...
2079.     Wend
2080.  
2081.     ' OUTPUT:
2082.     Replace$ = Text2
2083. End Function ' Replace$
2084.  
2085. ' /////////////////////////////////////////////////////////////////////////////
2086. ' Split and join strings
2087. ' https://www.qb64.org/forum/index.php?topic=1073.0
2088. '
2089. ' FROM luke, QB64 Developer
2090. ' Date: February 15, 2019, 04:11:07 AM »
2091. '
2092. ' Given a string of words separated by spaces (or any other character),
2093. ' splits it into an array of the words. I've no doubt many people have
2094. ' written a version of this over the years and no doubt there's a million
2095. ' ways to do it, but I thought I'd put mine here so we have at least one
2096. ' version. There's also a join function that does the opposite
2097. ' array -> single string.
2098. '
2099. ' Code is hopefully reasonably self explanatory with comments and a little demo.
2100. ' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.
2101.  
2102. 'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences
2103. 'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$().
2104. '
2105. 'delimiter$ must be one character long.
2106. 'result$() must have been REDIMmed previously.
2107.  
2108. Sub split (in$, delimiter$, result$())
2109.     ReDim result$(-1)
2110.     start = 1
2111.     Do
2112.         While Mid$(in$, start, 1) = delimiter$
2113.             start = start + 1
2114.             If start > Len(in$) Then Exit Sub
2115.         Wend
2116.         finish = InStr(start, in$, delimiter$)
2117.         If finish = 0 Then finish = Len(in$) + 1
2118.         ReDim _Preserve result$(0 To UBound(result$) + 1)
2119.         result$(UBound(result$)) = Mid$(in$, start, finish - start)
2120.         start = finish + 1
2121.     Loop While start <= Len(in$)
2122. End Sub ' split
2123.  
2124. ' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2125. ' END GENERAL PURPOSE ROUTINES
2126. ' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2127.  
2128. ' #END
2129. ' ################################################################################################################################################################
2130.  

[STxAxTIC]

Hello,

So I played with this a little bit last night, and then deleted my response because I hated it. I hate it a little less today so lemme give this a try... So consider a problematic angle like 30 degrees. Of course the argument applies for all the bad angles, but let me just use 30 for a second.

To get a good view for 30, calculate the view for the two neighboring angles, namely 29 and 31. Also of course calculate what the view at 30 *should* be - the skeletal, bony snapshot of your image. To hang meat on those bones, we can borrow from 29 and 31. First you can run a check to see at which points 29 and 31 overlap. With that info, you can certainly lay those shared points over your view of 30. Basically you've done the binary AND of 29 an 31. Feel* me? If so, in this lingo, you can also do the OR of 29 and 31 to get more points to send to 30. Of course if you just use a pure OR, then the view of 30 will just be the blurred sum of 29 and 31. You want to avoid that, and there are a number of ways to proceed, but...

Tell me if this ballpark feels right. It should do better than a pathfinding-like solution. If it's too much work, then what you've got should basically work but it might add weird fuzz where you dont want it.

[madscijr]

So I played with this a little bit last night, and then deleted my response because I hated it. I hate it a little less today so lemme give this a try...

What's to hate?  You're just thinking through the problem, it's fine. Thanks for your response!

So consider a problematic angle like 30 degrees. Of course the argument applies for all the bad angles, but let me just use 30 for a second.

To get a good view for 30, calculate the view for the two neighboring angles, namely 29 and 31. Also of course calculate what the view at 30 *should* be - the skeletal, bony snapshot of your image. To hang meat on those bones, we can borrow from 29 and 31.

First you can run a check to see at which points 29 and 31 overlap. With that info, you can certainly lay those shared points over your view of 30. Basically you've done the binary AND of 29 an 31. Fee me?

Interesting approach...

If so, in this lingo, you can also do the OR of 29 and 31 to get more points to send to 30. Of course if you just use a pure OR, then the view of 30 will just be the blurred sum of 29 and 31. You want to avoid that, and there are a number of ways to proceed, but...

This is where it gets fuzzy... What ways might you suggest to avoid just getting the blurred sum of 29 and 31?

Tell me if this ballpark feels right. It should do better than a pathfinding-like solution. If it's too much work, then what you've got should basically work but it might add weird fuzz where you dont want it.

Your idea definitely has me thinking. The pathfinding version I posted could definitely be made smarter.

There are 2 questions here -
1. how can we get it to render a more accurate result, and
2. how can we do it more efficiently and save processing cycles?

Thanks again for your response and the interesting ideas!

[madscijr]

@Petr and @STxAxTIC

Here is the latest code, I just added in circle fill and ellipse routines by @SMcNeill and @bplus.
I want to add a "fill" routine too, which I have not ever tried before.
I saw this thread that might provide the method
https://qb64forum.alephc.xyz//index.php?topic=1914.0

Anyway, here is the latest version...

Code: QB64: [Select]

1. ' ################################################################################################################################################################
2. ' #TOP
3.  
4. ' Basic 2D plotting functions
5. ' Version 1.00 by madscijr
6. ' with help from various (sources cited below).
7. ' ################################################################################################################################################################
8.  
9. ' =============================================================================
10. ' GLOBAL DECLARATIONS
11. ' =============================================================================
12.  
13. ' boolean constants
14. Const FALSE = 0
15. Const TRUE = Not FALSE
16.  
17. ' -----------------------------------------------------------------------------
18. ' USER DEFINED TYPES
19. ' -----------------------------------------------------------------------------
20. Type RotationType
21.     origx As Integer
22.     origy As Integer
23.     'z as integer
24.     c As Integer
25. End Type ' RotationType
26.  
27. ' -----------------------------------------------------------------------------
28. ' GLOBAL VARIABLES
29. ' -----------------------------------------------------------------------------
30. Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
31. Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
32. Dim Shared m_bDebug: m_bDebug = TRUE
33.  
34. ' =============================================================================
35. ' BEGIN MAIN PROGRAM
36. ' =============================================================================
37. Dim in$
38.  
39. ' ****************************************************************************************************************************************************************
40. ' ACTIVATE DEBUGGING WINDOW
41. If m_bDebug = TRUE Then
42.     $Console
43.     _Delay 4
44.     _Console On
45.     _Echo "Started " + m_ProgramName$
46.     _Echo "Debugging on..."
47. End If
48. ' ****************************************************************************************************************************************************************
49.  
50. ' -----------------------------------------------------------------------------
51. ' START THE MENU
52. main
53.  
54. ' -----------------------------------------------------------------------------
55. ' DONE
56. Print m_ProgramName$ + " finished."
57. 'Screen 0
58. Input "Press <ENTER> to continue", in$
59.  
60. ' ****************************************************************************************************************************************************************
61. ' DEACTIVATE DEBUGGING WINDOW
62. If m_bDebug = TRUE Then
63.     _Console Off
64. End If
65. ' ****************************************************************************************************************************************************************
66.  
67. ' -----------------------------------------------------------------------------
68. ' EXIT
69. System ' return control to the operating system
70. End
71.  
72. ' =============================================================================
73. ' END MAIN PROGRAM
74. ' =============================================================================
75.  
76. ' /////////////////////////////////////////////////////////////////////////////
77. ' MAIN MENU
78.  
79. Sub main
80.     Dim RoutineName As String: RoutineName = "main"
81.     Dim in$
82.  
83.     Screen _NewImage(1280, 1024, 32): _ScreenMove 0, 0
84.     Do
85.         Cls
86.         Print m_ProgramName$
87.         Print
88.         Print "Some basic 2D plotting"
89.         Print
90.         Print " 1. PlotPointTest"
91.         Print " 2. PlotSquareTest"
92.         Print " 3. PlotCircleTest"
93.         Print " 4. CircleFillTest"
94.         Print " 5. EllipseTest"
95.         Print " 6. EllipseFillTest"
96.         Print " 7. PlotLineTest"
97.         Print " 8. ShearRotateTest1"
98.         Print " 9. ShearRotateTest2 (auto advances 0-360 degrees)"
99.         Print "10. ShearRotateTest2 (auto advances 0-360 degrees) (uses Petr's text)"
100.         Print "11. ShearRotateTest3 (tries to correct for missing points)"
101.         Print "12. ShearRotateTest3 (tries to correct for missing points) (uses Petr's text)"
102.         Print
103.         Print "What to do? ('q' to exit)"
104.  
105.         Input in$: in$ = LCase$(_Trim$(in$))
106.  
107.         If in$ = "1" Then
108.             PlotPointTest
109.         ElseIf in$ = "2" Then
110.             PlotSquareTest
111.         ElseIf in$ = "3" Then
112.             PlotCircleTest
113.         ElseIf in$ = "4" Then
114.             CircleFillTest
115.         ElseIf in$ = "5" Then
116.             EllipseTest
117.         ElseIf in$ = "6" Then
118.             EllipseFillTest
119.         ElseIf in$ = "7" Then
120.             PlotLineTest
121.         ElseIf in$ = "8" Then
122.             ShearRotateTest1
123.         ElseIf in$ = "9" Then
124.             ShearRotateTest2 TestSprite1$
125.         ElseIf in$ = "10" Then
126.             ShearRotateTest2 PetrText1$
127.         ElseIf in$ = "11" Then
128.             ShearRotateTest3 TestSprite1$
129.         ElseIf in$ = "12" Then
130.             ShearRotateTest3 PetrText1$
131.         End If
132.     Loop Until in$ = "q"
133. End Sub ' main
134.  
135. ' /////////////////////////////////////////////////////////////////////////////
136. ' MyArray(1 To 32, 1 To 32) AS STRING
137.  
138. Sub PlotPoint (X As Integer, Y As Integer, S As String, MyArray() As String)
139.     If (X >= LBound(MyArray, 2)) Then
140.         If (X <= UBound(MyArray, 2)) Then
141.             If (Y >= LBound(MyArray, 1)) Then
142.                 If (Y <= UBound(MyArray, 1)) Then
143.                     If Len(S) = 1 Then
144.                         MyArray(Y, X) = S
145.                     Else
146.                         If Len(S) > 1 Then
147.                             MyArray(Y, X) = Left$(S, 1)
148.                         End If
149.                     End If
150.                 End If
151.             End If
152.         End If
153.     End If
154. End Sub ' PlotPoint
155.  
156. ' /////////////////////////////////////////////////////////////////////////////
157.  
158. Sub PlotPointTest
159.     Dim MyArray(1 To 32, 1 To 32) As String
160.     Dim iX As Integer
161.     Dim iY As Integer
162.     Dim in$
163.     Dim X As Integer
164.     Dim Y As Integer
165.     Dim L As Integer
166.     Dim iChar As Integer
167.  
168.     ClearArray MyArray(), "."
169.     iChar = 64
170.  
171.     Cls
172.     Print "Plot a point."
173.     Print ArrayToStringTest(MyArray())
174.     Print
175.  
176.     Do
177.         Print "Type x,y (1-32, 1-32) coordinate to plot point at."
178.         Input "X,Y OR 0 TO QUIT? "; X, Y
179.         If X > 0 And Y > 0 Then
180.             iChar = iChar + 1
181.             If iChar > 90 Then iChar = 65
182.  
183.             Print "X=" + cstr$(X) + ", Y=" + cstr$(Y)
184.             PlotPoint X, Y, Chr$(iChar), MyArray()
185.  
186.             Print "Current point plotted, drawn with " + Chr$(34) + Chr$(iChar) + Chr$(34) + ":"
187.             Print ArrayToStringTest(MyArray())
188.             Print
189.  
190.         Else
191.             Exit Do
192.         End If
193.     Loop
194. End Sub ' PlotPointTest
195.  
196. ' /////////////////////////////////////////////////////////////////////////////
197.  
198. Sub PlotSquare (X1 As Integer, Y1 As Integer, L As Integer, S As String, MyArray() As String)
199.     Dim X As Integer
200.     Dim X2 As Integer
201.     Dim Y As Integer
202.     Dim Y2 As Integer
203.     Dim sChar$
204.  
205.     If Len(S) = 1 Then
206.         sChar$ = S
207.     Else
208.         If Len(S) = 0 Then
209.             sChar$ = " "
210.         Else
211.             sChar$ = Left$(S, 1)
212.         End If
213.     End If
214.  
215.     X2 = (X1 + L) - 1
216.     Y2 = (Y1 + L) - 1
217.     For X = X1 To X2
218.         For Y = Y1 To Y2
219.             PlotPoint X, Y, sChar$, MyArray()
220.         Next Y
221.     Next X
222. End Sub ' PlotSquare
223.  
224. ' /////////////////////////////////////////////////////////////////////////////
225.  
226. Sub PlotSquareTest
227.     Dim MyArray(1 To 32, 1 To 32) As String
228.     Dim iX As Integer
229.     Dim iY As Integer
230.     Dim in$
231.     Dim X As Integer
232.     Dim Y As Integer
233.     Dim L As Integer
234.     Dim iChar As Integer
235.  
236.     ClearArray MyArray(), "."
237.     iChar = 64
238.  
239.     Cls
240.     Print "Enter parameters to draw a square."
241.     Print ArrayToStringTest(MyArray())
242.     Print
243.     Do
244.         Print "Type top left x,y (1-32, 1-32) coordinate to plot square,"
245.         Print "and size (1-32) of square."
246.         Input "X,Y,L OR 0 TO QUIT? "; X, Y, L
247.         If X > 0 And Y > 0 And L > 0 Then
248.             iChar = iChar + 1
249.             If iChar > 90 Then iChar = 65
250.  
251.             Print
252.             Print "X=" + cstr$(X)
253.             Print "Y=" + cstr$(Y)
254.             Print "L=" + cstr$(L)
255.             Print
256.             PlotSquare X, Y, L, Chr$(iChar), MyArray()
257.  
258.             Print "Square plotted, drawn with " + Chr$(34) + Chr$(iChar) + Chr$(34) + ":"
259.             Print ArrayToStringTest(MyArray())
260.             Print
261.         Else
262.             Exit Do
263.         End If
264.     Loop
265. End Sub ' PlotSquareTest
266.  
267. ' /////////////////////////////////////////////////////////////////////////////
268. ' Fast circle drawing in pure Atari BASIC#
269. ' https://atariwiki.org/wiki/Wiki.jsp?page=Super%20fast%20circle%20routine
270.  
271. ' * Magazine: Moj Mikro, 1989/3
272. ' * Author : Zlatko Bleha
273. ' * Page : 27 - 31
274. ' * Atari BASIC listing on disk (tokenized): M8903282.BAS
275. ' * Atari BASIC listing (listed): M8903282.LST
276.  
277. ' Next example is demonstration of implementing mentioned circle algorithm
278. ' in pure Atari BASIC. This program shows how much faster it is compared to
279. ' classic program using sine and cosine functions from Atari BASIC
280. ' (shown in last example).
281.  
282. ' Basic Listing M8903282.LST#
283. '1 REM *******************************
284. '2 REM PROGRAM  : FAST CIRCLE DRAWING
285. '3 REM AUTHOR   : ZLATKO BLEHA
286. '4 REM PUBLISHER: MOJ MIKRO MAGAZINE
287. '5 REM ISSUE NO.: 1989, NO.3, PAGE 29
288. '6 REM *******************************
289. '7 REM
290. '10 GRAPHICS 8:SETCOLOR 2,0,0:COLOR 3
291. '20 PRINT "ENTER X, Y AND R"
292. '30 INPUT X,Y,R
293. '40 IF R=0 THEN PLOT X,Y:END
294. '50 B=R:C=0:A=R-1
295. '60 PLOT X+C,Y+B
296. '70 PLOT X+C,Y-B
297. '80 PLOT X-C,Y-B
298. '90 PLOT X-C,Y+B
299. '100 PLOT X+B,Y+C
300. '110 PLOT X+B,Y-C
301. '120 PLOT X-B,Y-C
302. '130 PLOT X-B,Y+C
303. '140 C=C+1
304. '150 A=A+1-C-C
305. '160 IF A>=0 THEN 190
306. '170 B=B-1
307. '180 A=A+B+B
308. '190 IF B>=C THEN 60
309.  
310. ' Use some valid values for coordinates and radius, for example:
311. ' X=40, Y=40, R=30
312. ' X=130, Y=90, R=60
313. ' Slow circle drawing in Atari BASIC#
314. ' * Magazine: Moj Mikro, 1989/3
315. ' * Author : Zlatko Bleha
316. ' * Page : 27 - 31
317. ' * Atari BASIC listing on disk (tokenized): M8903281.BAS
318. ' * Atari BASIC listing (listed): M8903281.LST
319.  
320. ' This is classic example for drawing circles from Atari BASIC
321. ' using sine and cosine functions. Unfortunatelly, this is very slow
322. ' way of doing it and not recommended.
323. ' Just use routine shown above and everybody will be happy
324.  
325. ' Basic Listing M8903281.LST#
326. '1 REM *******************************
327. '2 REM PROGRAM  : SLOW CIRCLE DRAWING
328. '3 REM AUTHOR   : ZLATKO BLEHA
329. '4 REM PUBLISHER: MOJ MIKRO MAGAZINE
330. '5 REM ISSUE NO.: 1989, NO.3, PAGE 29
331. '6 REM *******************************
332. '7 REM
333. '10 GRAPHICS 8:SETCOLOR 2,0,0:COLOR 3
334. '20 FOR A=0 TO 6.28 STEP 0.02
335. '30 X=SIN(A)*50+150
336. '40 Y=COS(A)*50+80
337. '50 PLOT X,Y
338. '60 NEXT A
339.  
340. ' Conclusion#
341. ' Returning back to first program with the fastest way of drawing circles...
342. ' There is one more thing to note. In case you want to use PLOT subroutine,
343. ' which is part of the main circle routine, then read following explanation.
344. ' PLOT routine is written so it can be used easily from Atari BASIC program
345. ' independently from main circle routine, by using like this:
346. ' A=USR(30179,POK,X,Y)
347. '
348. ' POK   1 (drawing a pixel), 0 (erasing a pixel)
349. ' X     X coordinate of the pixel
350. ' Y     Y coordinate of the pixel
351. '
352. ' The routine alone is not any faster than normal PLOT command
353. ' from Atari BASIC, because USR command takes approximately 75%
354. ' of whole execution. But, used as part of the main circle routine
355. ' it does not matter anymore, because it is integrated in one larger
356. ' entity. There the execution is very fast, with no overhead.
357. ' PLOT routine is here for you to examine anyway.
358. ' You never know if you will maybe need it in the future.
359.  
360. ' More on plotting circles:
361. '     Drawing a circle in BASIC - fast
362. '     https://www.cpcwiki.eu/forum/programming/drawing-a-circle-in-basic-fast/
363.  
364. ' X,Y     = center point of circle
365. ' R       = radius
366. ' S       = char to draw
367. ' MyArray = 2D string array to plot circle in
368.  
369. Sub PlotCircle (X As Integer, Y As Integer, R As Integer, S As String, MyArray() As String)
370.     Dim A As Integer
371.     Dim B As Integer
372.     Dim C As Integer
373.     Dim S2 As String
374.  
375.     If Len(S) = 1 Then
376.         S2 = S
377.     Else
378.         If Len(S) = 0 Then
379.             S2 = " "
380.         Else
381.             S2 = Left$(S, 1)
382.         End If
383.     End If
384.  
385.     If R > 0 Then
386.         B = R
387.         C = 0
388.         A = R - 1
389.         Do
390.             PlotPoint X + C, Y + B, S2, MyArray()
391.             PlotPoint X + C, Y - B, S2, MyArray()
392.             PlotPoint X - C, Y - B, S2, MyArray()
393.             PlotPoint X - C, Y + B, S2, MyArray()
394.             PlotPoint X + B, Y + C, S2, MyArray()
395.             PlotPoint X + B, Y - C, S2, MyArray()
396.             PlotPoint X - B, Y - C, S2, MyArray()
397.             PlotPoint X - B, Y + C, S2, MyArray()
398.             C = C + 1
399.             A = A + 1 - C - C
400.             If A < 0 Then ' IF A>=0 THEN 190
401.                 B = B - 1
402.                 A = A + B + B
403.             End If
404.             If B < C Then Exit Do ' 190 IF B>=C THEN 60
405.         Loop
406.     End If
407. End Sub ' PlotCircle
408.  
409. ' /////////////////////////////////////////////////////////////////////////////
410.  
411. Sub PlotCircleTest
412.     Dim MyArray(1 To 32, 1 To 32) As String
413.     Dim iX As Integer
414.     Dim iY As Integer
415.     Dim in$
416.     Dim X As Integer
417.     Dim Y As Integer
418.     Dim R As Integer
419.     Dim iChar As Integer
420.  
421.     ClearArray MyArray(), "."
422.     iChar = 64
423.  
424.     Cls
425.     Print "Plot a raster circle"
426.     Print "Based on Fast circle drawing in pure Atari BASIC by Zlatko Bleha."
427.     Print
428.     Print "Enter parameters to draw a circle."
429.     Print ArrayToStringTest(MyArray())
430.     Print
431.  
432.     Do
433.         Print "Type center point x,y (1-32, 1-32) coordinate to plot circle,"
434.         Print "and radius (1-32) of circle."
435.         Input "X,Y,R OR 0 TO QUIT: "; X, Y, R
436.         If X > 0 And Y > 0 And R > 0 Then
437.             iChar = iChar + 1
438.             If iChar > 90 Then iChar = 65
439.  
440.             Print "X=" + cstr$(X)
441.             Print "Y=" + cstr$(Y)
442.             Print "R=" + cstr$(R)
443.  
444.             PlotCircle X, Y, R, Chr$(iChar), MyArray()
445.  
446.             Print "Circle plotted, drawn with " + Chr$(34) + Chr$(iChar) + Chr$(34) + ":"
447.             Print ArrayToStringTest(MyArray())
448.             Print
449.         Else
450.             Exit Do
451.         End If
452.     Loop
453.  
454. End Sub ' PlotCircleTest
455.  
456. ' /////////////////////////////////////////////////////////////////////////////
457. ' Re: Is this fast enough as general circle fill?
458. ' https://qb64forum.alephc.xyz/index.php?topic=298.msg1913#msg1913
459.  
460. ' From: SMcNeill
461. ' Date: « Reply #30 on: June 26, 2018, 03:34:18 pm »
462. '
463. ' Sometimes, computers do things that are completely counter-intuitive to us, and
464. ' we find ourselves having to step back as programmers and simply say, "WOW!!"
465. ' Here's a perfect example of that:
466. ' Here we look at two different circle fill routines -- one, which I'd assume to
467. ' be faster, which precalculates the offset needed to find the endpoints for each
468. ' line which composes a circle, and another, which is the same old CircleFill
469. ' program which I've shared countless times over the years with people on various
470. ' QB64 forums.
471. '
472. ' When all is said and done though, CircleFill is STILL even faster than
473. ' CircleFillFast, which pregenerates those end-points for us!
474.  
475. Sub CircleFill (CX As Integer, CY As Integer, R As Integer, S As String, MyArray() As String)
476.     Dim Radius As Integer
477.     Dim RadiusError As Integer
478.     Dim X As Integer
479.     Dim Y As Integer
480.     Dim iLoopX As Integer
481.     Dim iLoopY As Integer
482.  
483.     Radius = Abs(R)
484.     RadiusError = -Radius
485.     X = Radius
486.     Y = 0
487.  
488.     If Radius = 0 Then
489.         'PSET (CX, CY), C
490.         PlotPoint CX, CY, S, MyArray()
491.         Exit Sub
492.     End If
493.  
494.     ' Draw the middle span here so we don't draw it twice in the main loop,
495.     ' which would be a problem with blending turned on.
496.     'LINE (CX - X, CY)-(CX + X, CY), C, BF
497.     For iLoopX = CX - X To CX + X
498.         PlotPoint iLoopX, CY, S, MyArray()
499.     Next iLoopX
500.  
501.     While X > Y
502.         RadiusError = RadiusError + Y * 2 + 1
503.         If RadiusError >= 0 Then
504.             If X <> Y + 1 Then
505.                 'LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
506.                 iLoopY = CY - X
507.                 For iLoopX = CX - Y To CX + Y
508.                     PlotPoint iLoopX, iLoopY, S, MyArray()
509.                 Next iLoopX
510.  
511.                 'LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
512.                 iLoopY = CY + X
513.                 For iLoopX = CX - Y To CX + Y
514.                     PlotPoint iLoopX, iLoopY, S, MyArray()
515.                 Next iLoopX
516.             End If
517.             X = X - 1
518.             RadiusError = RadiusError - X * 2
519.         End If
520.         Y = Y + 1
521.         'LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
522.         iLoopY = CY - Y
523.         For iLoopX = CX - X To CX + X
524.             PlotPoint iLoopX, iLoopY, S, MyArray()
525.         Next iLoopX
526.  
527.         'LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
528.         iLoopY = CY + Y
529.         For iLoopX = CX - X To CX + X
530.             PlotPoint iLoopX, iLoopY, S, MyArray()
531.         Next iLoopX
532.     Wend
533. End Sub ' CircleFill
534.  
535. ' /////////////////////////////////////////////////////////////////////////////
536.  
537. Sub CircleFillTest
538.     Dim MyArray(1 To 32, 1 To 32) As String
539.     Dim iX As Integer
540.     Dim iY As Integer
541.     Dim in$
542.     Dim X As Integer
543.     Dim Y As Integer
544.     Dim R As Integer
545.     Dim iChar As Integer
546.  
547.     ClearArray MyArray(), "."
548.     iChar = 64
549.  
550.     Cls
551.     Print "Plot a filled circle"
552.     Print "Based on CircleFill by SMcNeill."
553.     Print
554.     Print "Enter parameters to draw a circle."
555.     Print ArrayToStringTest(MyArray())
556.     Print
557.  
558.     Do
559.         Print "Type center point x,y (1-32, 1-32) coordinate to plot circle,"
560.         Print "and radius (1-32) of circle."
561.         Input "X,Y,R OR 0 TO QUIT: "; X, Y, R
562.         If X > 0 And Y > 0 And R > 0 Then
563.             iChar = iChar + 1
564.             If iChar > 90 Then iChar = 65
565.  
566.             Print "X=" + cstr$(X)
567.             Print "Y=" + cstr$(Y)
568.             Print "R=" + cstr$(R)
569.  
570.             'PlotCircle X, Y, R, Chr$(iChar), MyArray()
571.             CircleFill X, Y, R, Chr$(iChar), MyArray()
572.  
573.             Print "Circle plotted, drawn with " + Chr$(34) + Chr$(iChar) + Chr$(34) + ":"
574.             Print ArrayToStringTest(MyArray())
575.             Print
576.         Else
577.             Exit Do
578.         End If
579.     Loop
580.  
581. End Sub ' CircleFillTest
582.  
583. ' /////////////////////////////////////////////////////////////////////////////
584. ' Re: Is this fast enough as general circle fill?
585. ' https://qb64forum.alephc.xyz/index.php?topic=298.msg3588#msg3588
586.  
587. ' From: bplus
588. ' Date: « Reply #59 on: August 30, 2018, 09:18:34 am »
589.  
590. Sub Ellipse (CX As Integer, CY As Integer, xRadius As Integer, yRadius As Integer, S As String, MyArray() As String)
591.     Dim scale As Single
592.     Dim xs As Integer
593.     Dim x As Integer
594.     Dim y As Integer
595.     Dim lastx As Integer
596.     Dim lasty As Integer
597.     Dim iLoopX As Integer
598.     Dim iLoopY As Integer
599.  
600.     scale = yRadius / xRadius
601.     xs = xRadius * xRadius
602.  
603.     'PSET (CX, CY - yRadius)
604.     PlotPoint CX, CY - yRadius, S, MyArray()
605.  
606.     'PSET (CX, CY + yRadius)
607.     PlotPoint CX, CY + yRadius, S, MyArray()
608.  
609.     lastx = 0: lasty = yRadius
610.     For x = 1 To xRadius
611.         y = scale * Sqr(xs - x * x)
612.         'LINE (CX + lastx, CY - lasty)-(CX + x, CY - y)
613.         PlotLine CX + lastx, CY - lasty, CX + x, CY - y, S, MyArray()
614.  
615.         'LINE (CX + lastx, CY + lasty)-(CX + x, CY + y)
616.         PlotLine CX + lastx, CY + lasty, CX + x, CY + y, S, MyArray()
617.  
618.         'LINE (CX - lastx, CY - lasty)-(CX - x, CY - y)
619.         PlotLine CX - lastx, CY - lasty, CX - x, CY - y, S, MyArray()
620.  
621.         'LINE (CX - lastx, CY + lasty)-(CX - x, CY + y)
622.         PlotLine CX - lastx, CY + lasty, CX - x, CY + y, S, MyArray()
623.  
624.         lastx = x
625.         lasty = y
626.     Next x
627. End Sub ' Ellipse
628.  
629. ' /////////////////////////////////////////////////////////////////////////////
630.  
631. Sub EllipseTest
632.     Dim MyArray(1 To 32, 1 To 32) As String
633.     Dim iX As Integer
634.     Dim iY As Integer
635.     Dim in$
636.     Dim X As Integer
637.     Dim Y As Integer
638.     Dim RX As Integer
639.     Dim RY As Integer
640.     Dim iChar As Integer
641.  
642.     ClearArray MyArray(), "."
643.     iChar = 64
644.  
645.     Cls
646.     Print "Plot an ellipse"
647.     Print "Based on ellipse by bplus."
648.     Print
649.     Print "Enter parameters to draw an ellipse."
650.     Print ArrayToStringTest(MyArray())
651.     Print
652.  
653.     Do
654.         Print "Type center point x,y (1-32, 1-32) coordinate to plot ellipse,"
655.         Print "and x radius (1-32) and y radius (1-32) of ellipse."
656.         Input "X,Y,RX,RY OR 0 TO QUIT: "; X, Y, RX, RY
657.         If X > 0 And Y > 0 And RX > 0 And RY > 0 Then
658.             iChar = iChar + 1
659.             If iChar > 90 Then iChar = 65
660.  
661.             Print "X =" + cstr$(X)
662.             Print "Y =" + cstr$(Y)
663.             Print "RX=" + cstr$(RX)
664.             Print "RY=" + cstr$(RY)
665.  
666.             Ellipse X, Y, RX, RY, Chr$(iChar), MyArray()
667.  
668.             Print "Ellipse plotted, drawn with " + Chr$(34) + Chr$(iChar) + Chr$(34) + ":"
669.             Print ArrayToStringTest(MyArray())
670.             Print
671.         Else
672.             Exit Do
673.         End If
674.     Loop
675.  
676. End Sub ' EllipseTest
677.  
678. ' /////////////////////////////////////////////////////////////////////////////
679. ' Re: Is this fast enough as general circle fill?
680. ' https://qb64forum.alephc.xyz/index.php?topic=298.msg3588#msg3588
681.  
682. ' From: bplus
683. ' Date: « Reply #59 on: August 30, 2018, 09:18:34 am »
684. '
685. ' Here is my ellipse and filled ellipse routines, no where near
686. ' Steve's level of performance. The speed is cut in half at
687. ' least because you probably have to do a whole quadrants worth
688. ' of calculations (ellipse not as symmetric as circle).
689. '
690. ' But I am sure this code can be optimized more than it is:
691.  
692. Sub EllipseFill (CX As Integer, CY As Integer, xRadius As Integer, yRadius As Integer, S As String, MyArray() As String)
693.     Dim scale As Single
694.     Dim x As Integer
695.     Dim y As Integer
696.     Dim iLoopX As Integer
697.     Dim iLoopY As Integer
698.  
699.     scale = yRadius / xRadius
700.  
701.     'LINE (CX, CY - yRadius)-(CX, CY + yRadius), , BF
702.     For iLoopY = CY - yRadius To CY + yRadius
703.         PlotPoint CX, iLoopY, S, MyArray()
704.     Next iLoopY
705.  
706.     For x = 1 To xRadius
707.         y = scale * Sqr(xRadius * xRadius - x * x)
708.  
709.         'LINE (CX + x, CY - y)-(CX + x, CY + y), , BF
710.         iLoopX = CX + x
711.         For iLoopY = CY - y To CY + y
712.             PlotPoint iLoopX, iLoopY, S, MyArray()
713.         Next iLoopY
714.  
715.         'LINE (CX - x, CY - y)-(CX - x, CY + y), , BF
716.         iLoopX = CX - x
717.         For iLoopY = CY - y To CY + y
718.             PlotPoint iLoopX, iLoopY, S, MyArray()
719.         Next iLoopY
720.     Next x
721. End Sub ' EllipseFill
722.  
723. ' /////////////////////////////////////////////////////////////////////////////
724.  
725. Sub EllipseFillTest
726.     Dim MyArray(1 To 32, 1 To 32) As String
727.     Dim iX As Integer
728.     Dim iY As Integer
729.     Dim in$
730.     Dim X As Integer
731.     Dim Y As Integer
732.     Dim RX As Integer
733.     Dim RY As Integer
734.     Dim iChar As Integer
735.  
736.     ClearArray MyArray(), "."
737.     iChar = 64
738.  
739.     Cls
740.     Print "Plot a filled ellipse"
741.     Print "Based on fellipse by bplus."
742.     Print
743.     Print "Enter parameters to draw an ellipse."
744.     Print ArrayToStringTest(MyArray())
745.     Print
746.  
747.     Do
748.         Print "Type center point x,y (1-32, 1-32) coordinate to plot ellipse,"
749.         Print "and x radius (1-32) and y radius (1-32) of ellipse."
750.         Input "X,Y,RX,RY OR 0 TO QUIT: "; X, Y, RX, RY
751.         If X > 0 And Y > 0 And RX > 0 And RY > 0 Then
752.             iChar = iChar + 1
753.             If iChar > 90 Then iChar = 65
754.  
755.             Print "X =" + cstr$(X)
756.             Print "Y =" + cstr$(Y)
757.             Print "RX=" + cstr$(RX)
758.             Print "RY=" + cstr$(RY)
759.  
760.             EllipseFill X, Y, RX, RY, Chr$(iChar), MyArray()
761.  
762.             Print "Ellipse plotted, drawn with " + Chr$(34) + Chr$(iChar) + Chr$(34) + ":"
763.             Print ArrayToStringTest(MyArray())
764.             Print
765.         Else
766.             Exit Do
767.         End If
768.     Loop
769.  
770. End Sub ' EllipseFillTest
771.  
772. ' /////////////////////////////////////////////////////////////////////////////
773. ' Based on "BRESNHAM.BAS" by Kurt Kuzba. (4/16/96)
774. ' From: http://www.thedubber.altervista.org/qbsrc.htm
775.  
776. Sub PlotLine (x1%, y1%, x2%, y2%, c$, MyArray() As String)
777.     Dim iLoop%
778.     Dim steep%: steep% = 0
779.     Dim ev%: ev% = 0
780.     Dim sx%
781.     Dim sy%
782.     Dim dx%
783.     Dim dy%
784.  
785.     If (x2% - x1%) > 0 Then
786.         sx% = 1
787.     Else
788.         sx% = -1
789.     End If
790.  
791.     dx% = Abs(x2% - x1%)
792.     If (y2% - y1%) > 0 Then
793.         sy% = 1
794.     Else
795.         sy% = -1
796.     End If
797.  
798.     dy% = Abs(y2% - y1%)
799.     If (dy% > dx%) Then
800.         steep% = 1
801.         Swap x1%, y1%
802.         Swap dx%, dy%
803.         Swap sx%, sy%
804.     End If
805.  
806.     ev% = 2 * dy% - dx%
807.     For iLoop% = 0 To dx% - 1
808.         If steep% = 1 Then
809.             ''PSET (y1%, x1%), c%:
810.             'LOCATE y1%, x1%
811.             'PRINT c$;
812.             PlotPoint y1%, x1%, c$, MyArray()
813.         Else
814.             ''PSET (x1%, y1%), c%
815.             'LOCATE x1%, y1%
816.             'PRINT c$;
817.             PlotPoint x1%, y1%, c$, MyArray()
818.         End If
819.  
820.         While ev% >= 0
821.             y1% = y1% + sy%
822.             ev% = ev% - 2 * dx%
823.         Wend
824.         x1% = x1% + sx%
825.         ev% = ev% + 2 * dy%
826.     Next iLoop%
827.     ''PSET (x2%, y2%), c%
828.     'LOCATE x2%, y2%
829.     'PRINT c$;
830.     PlotPoint x2%, y2%, c$, MyArray()
831. End Sub ' PlotLine
832.  
833. ' /////////////////////////////////////////////////////////////////////////////
834.  
835. Sub PlotLineTest
836.     Dim MyArray(1 To 32, 1 To 32) As String
837.     Dim in$
838.     Dim X1 As Integer
839.     Dim Y1 As Integer
840.     Dim X2 As Integer
841.     Dim Y2 As Integer
842.     Dim iChar As Integer
843.  
844.     ClearArray MyArray(), "."
845.     iChar = 64
846.  
847.     Cls
848.     Print "Plot line with Bresenham Algorithm"
849.     Print "based on BRESNHAM.BAS by Kurt Kuzba (4/16/96)."
850.     Print
851.     Print ArrayToStringTest(MyArray())
852.     Do
853.         Print "Enter coordinate values for "
854.         Print "line start point x1, y1 (1-32, 1-32)"
855.         Print "line end   point x2, y2 (1-32, 1-32)"
856.         Input "ENTER X1,Y1,X2,Y2 OR 0 TO QUIT: "; X1, Y1, X2, Y2
857.         If X1 > 0 And Y1 > 0 And X2 > 0 And Y2 > 0 Then
858.             iChar = iChar + 1
859.             If iChar > 90 Then iChar = 65
860.  
861.             Print "X1=" + cstr$(X1)
862.             Print "Y1=" + cstr$(Y1)
863.             Print "X2=" + cstr$(X2)
864.             Print "Y2=" + cstr$(Y2)
865.  
866.             PlotLine X1, Y1, X2, Y2, Chr$(iChar), MyArray()
867.  
868.             Print "Line plotted, drawn with " + Chr$(34) + Chr$(iChar) + Chr$(34) + ":"
869.             Print ArrayToStringTest(MyArray())
870.  
871.         Else
872.             Exit Do
873.         End If
874.     Loop
875. End Sub ' PlotLineTest
876.  
877. ' /////////////////////////////////////////////////////////////////////////////
878. ' 3 shear method testing
879.  
880. ' _PUT Rotation Help
881. ' https://www.qb64.org/forum/index.php?topic=1959.0
882.  
883. ' 3 Shear Rotation - rotates without any aliasing(holes)
884. ' https://www.freebasic.net/forum/viewtopic.php?t=24557
885.  
886. ' From: leopardpm
887. ' Date: Apr 02, 2016 1:21
888. ' Last edited by leopardpm on Apr 02, 2016 17:18, edited 1 time in total.
889. '
890. ' This is just a little 3-shear rotation routine
891. ' (I am using 3-shear because it leaves no gaps/aliasing)
892. ' that I was wondering if anyone sees how to make it faster.
893. ' Obviously, I am just thinking about inside the double loop.
894.  
895. ' Thanks again to BasicCoder2 for linking me to this little routine, it is wonderful so far!
896.  
897. '''                      roto-zooming algorithm
898. '''                    coded by Michael S. Nissen
899. '''                        jernmager@yahoo.dk
900. '
901. ''' ===============================================================
902. ''' Recoded to run on FBC 32/64 bit WIN, Version 1.05.0, 2016, by MrSwiss
903. ''' Heavy flickering before going Full-Screen on 64 Bit !!!
904. ''' This seems NOT to be the Case on 32 Bit ...
905. ''' ===============================================================
906. '
907. 'Type Pixel
908. '  As Single   X, Y
909. '  As ULong    C
910. 'End Type
911. '
912. '''  dim vars
913. 'Dim shared as Any Ptr Img_Buffer
914. '''  write the name of the .bmp image you want to rotozoom here:
915. '''  (it has to be sqare ie. 100x100 pixels, 760x760 pixels or whatever)
916. 'Dim As String Img_Name = "phobos.bmp"
917. 'Dim shared as Integer X_Mid, Y_Mid, scrn_wid, scrn_hgt, P1, P2, P3, P4, C
918. 'Dim shared as Short Img_Hgt, Img_Wid, Img_Lft, Img_Rgt, Img_Top, Img_Btm, X, Y
919. 'Dim Shared As Single Cos_Ang, Sin_Ang, Rot_Fac_X, Rot_Fac_Y, Angle = 0, Scale = 1
920. '
921. ''' changed Function to Sub (+ recoded arguments list)
922. 'Sub Calc_rotozoom ( ByRef Cos_Ang As Single, _
923. '               ByRef Sin_Ang As Single, _
924. '               ByVal S_Fact  As Single, _
925. '               ByVal NewAng  As Single )
926. '  Cos_Ang = Cos(NewAng)*S_Fact
927. '  Sin_Ang = Sin(NewAng)*S_Fact
928. 'End Sub
929. '
930. '''  full screen
931. 'ScreenInfo scrn_wid, scrn_hgt
932. 'screenRes scrn_wid, scrn_hgt, 32,,1
933. '
934. '''  dim screenpointer (has to be done after screenres)
935. 'Dim As ULong Ptr Scrn_Ptr = Screenptr
936. '
937. '''  place image in center of screen
938. 'X_Mid = scrn_wid\2
939. 'Y_Mid = scrn_hgt\2
940. 'Calc_rotozoom(Cos_Ang, Sin_Ang, Scale, Angle)
941. '
942. '''  find image dimensions
943. 'Open Img_Name For Binary As #1
944. 'Get #1, 19, Img_Wid
945. 'Get #1, 23, Img_Hgt
946. 'Close #1
947. '
948. '''  prepare to dim the array that will hold the image.
949. 'Img_Rgt = (Img_Wid-1)\2
950. 'Img_Lft = -Img_Rgt
951. 'Img_Btm = (Img_Hgt-1)\2
952. 'Img_Top = -Img_Btm
953. '
954. '''  dim array to hold image. Note: pixel (0, 0) is in the center.
955. 'Dim As Pixel Pixel(Img_Lft to Img_Rgt, Img_Top to Img_Btm)
956. '
957. '''  imagecreate sprite and load image to sprite
958. 'Img_Buffer = ImageCreate (Img_Wid, Img_Hgt)
959. 'Bload (Img_Name, Img_Buffer)
960. '
961. '''  load image from sprite to array with point command
962. 'For Y = Img_Top to Img_Btm
963. '  For X = Img_Lft to Img_Rgt
964. '    With Pixel(X, Y)
965. '      .X = X_Mid+X
966. '      .Y = Y_Mid+Y
967. '      C = Point (X-Img_Top, Y-Img_Lft, Img_buffer)
968. '      If C <> RGB(255, 0, 255) Then
969. '        .C = C
970. '      Else
971. '        .C = RGB(0, 0, 0)
972. '      End If
973. '    End With
974. '  Next X
975. 'Next Y
976. '
977. '''  we don't need the sprite anymore, kill it
978. 'ImageDestroy Img_Buffer
979. 'Img_Buffer = 0
980. '
981. '''  main program loop
982. 'Do
983. '
984. '  ''  scale in/out with uparrow/downarrow
985. '  If Multikey(80) Then
986. '    Scale *= 1.03
987. '    Calc_rotozoom(Cos_Ang, Sin_Ang, Scale, Angle)
988. '  ElseIf Multikey(72) Then
989. '    Scale *= 0.97
990. '    Calc_rotozoom(Cos_Ang, Sin_Ang, Scale, Angle)
991. '  End If
992. '
993. '  ''  rotate left/right with leftarrow/rightarrow
994. '  If Multikey(77) Then
995. '    Angle -= 0.03
996. '    Calc_rotozoom(Cos_Ang, Sin_Ang, Scale, Angle)
997. '  ElseIf Multikey(75) Then
998. '    Angle += 0.03
999. '    Calc_rotozoom(Cos_Ang, Sin_Ang, Scale, Angle)
1000. '  End If
1001. '
1002. '  ''  lock screen in order to use screen pointers
1003. '  ScreenLock
1004. '
1005. '    ''  draw pixel in center of image
1006. '    Scrn_Ptr[ X_Mid + Y_Mid * scrn_wid ] = Pixel(0, 0).C
1007. '    ''  draw all other pixels - 4 at a time
1008. '    For Y = Img_Top to 0
1009. '      For X = Img_Lft to -1
1010. '        ''  find pixel positions
1011. '        P1 = (X_Mid+X) + (Y_Mid+Y) * scrn_wid
1012. '        P2 = (X_Mid-X) + (Y_Mid-Y) * scrn_wid
1013. '        P3 = (X_Mid+Y) + (Y_Mid-X) * scrn_wid
1014. '        P4 = (X_Mid-Y) + (Y_Mid+X) * scrn_wid
1015. '        ''  erase old pixels (paint them black)
1016. '        Scrn_Ptr[P1] = 0
1017. '        Scrn_Ptr[P2] = 0
1018. '        Scrn_Ptr[P3] = 0
1019. '        Scrn_Ptr[P4] = 0
1020. '        ''  rotate and zoom
1021. '        Rot_Fac_X = X*Cos_Ang - Y*Sin_Ang
1022. '        Rot_Fac_Y = X*Sin_Ang + Y*Cos_Ang
1023. '        If Rot_Fac_X < Img_Lft Or Rot_Fac_X > Img_Rgt Then Continue For
1024. '        If Rot_Fac_Y < Img_Top Or Rot_Fac_Y > Img_Btm Then Continue For
1025. '        ''  draw new pixels
1026. '        Scrn_Ptr[P1] = Pixel(Rot_Fac_X, Rot_Fac_Y).C
1027. '        Scrn_Ptr[P2] = Pixel(-Rot_Fac_X, -Rot_Fac_Y).C
1028. '        Scrn_Ptr[P3] = Pixel(Rot_Fac_Y, -Rot_Fac_X).C
1029. '        Scrn_Ptr[P4] = Pixel(-Rot_Fac_Y, Rot_Fac_X).C
1030. '      Next X
1031. '    Next Y
1032. '
1033. '  ScreenUnLock
1034. '
1035. '  Sleep 10, 1
1036. 'Loop Until InKey() = Chr(27)
1037.  
1038. ' UPDATES:
1039. ' Fixed bug where values 135, 224, and 314 all resolve to -45 degrees.
1040. ' Fixed bug where an angle of 46-135 degrees caused the image to be flipped wrong.
1041.  
1042. ' TODO:
1043. ' Fix issue where image looks bad at 30, 60, 120, 150, 210, 240, 300, 330 degrees
1044.  
1045. Sub ShearRotate (OldArray() As RotationType, NewArray() As RotationType, angle1 As Integer, iEmpty As Integer)
1046.     Const Pi = 4 * Atn(1)
1047.  
1048.     Dim angle As Integer
1049.     Dim TwoPi As Double: TwoPi = 8 * Atn(1)
1050.     Dim RtoD As Double: RtoD = 180 / Pi ' radians * RtoD = degrees
1051.     Dim DtoR As Double: DtoR = Pi / 180 ' degrees * DtoR = radians
1052.     Dim x As Integer
1053.     Dim y As Integer
1054.     Dim nangle As Integer
1055.     Dim nx As Integer
1056.     Dim ny As Integer
1057.     Dim flipper As Integer
1058.     Dim rotr As Double
1059.     Dim shear1 As Double
1060.     Dim shear2 As Double
1061.     Dim clr As Integer
1062.     Dim y1 As _Byte
1063.     Dim xy1 As _Byte
1064.     Dim fy As _Byte
1065.     Dim fx As _Byte
1066.     Dim in$
1067.     Dim sLine As String
1068.  
1069.     ' initialize new with empty
1070.     ReDim NewArray(LBound(OldArray, 1) To UBound(OldArray, 1), LBound(OldArray, 2) To UBound(OldArray, 2), 127) As RotationType
1071.     For x = LBound(NewArray, 1) To UBound(NewArray, 1)
1072.         For y = LBound(NewArray, 2) To UBound(NewArray, 2)
1073.             NewArray(x, y, 0).origx = x
1074.             NewArray(x, y, 0).origy = y
1075.             NewArray(x, y, 0).c = iEmpty
1076.         Next y
1077.     Next x
1078.  
1079.     ' angle is reversed
1080.     angle = 360 - angle1
1081.  
1082.     ' Shearing each element 3 times in one shot
1083.     nangle = angle
1084.  
1085.     ' this pre-processing portion basically rotates by 90 to get
1086.     ' between -45 and 45 degrees, where the 3-shear routine works correctly...
1087.     If angle > 45 And angle < 225 Then
1088.         If angle < 135 Then
1089.             nangle = angle - 90
1090.         Else
1091.             nangle = angle - 180
1092.         End If
1093.     End If
1094.     If angle > 135 And angle < 315 Then
1095.         If angle < 225 Then
1096.             nangle = angle - 180
1097.         Else
1098.             nangle = angle - 270
1099.         End If
1100.     End If
1101.     If nangle < 0 Then
1102.         nangle = nangle + 360
1103.     End If
1104.     If nangle > 359 Then
1105.         nangle = nangle - 360
1106.     End If
1107.  
1108.     rotr = nangle * DtoR
1109.     shear1 = Tan(rotr / 2) ' correct way
1110.     shear2 = Sin(rotr)
1111.  
1112.     ' *** NOTE: this had a bug where the values 135, 224, and 314
1113.     ' ***       all resolve to -45 degrees.
1114.     ' ***       Fixed by changing < to <=
1115.  
1116.     'if angle >  45 and angle < 134 then
1117.     If angle > 45 And angle <= 134 Then
1118.         flipper = 1
1119.     ElseIf angle > 134 And angle <= 224 Then
1120.         flipper = 2
1121.     ElseIf angle > 224 And angle <= 314 Then
1122.         ' *** NOTE: this had a bug where this flipper was wrong
1123.         '           Fixed by adding case 7
1124.         'flipper = 3
1125.         flipper = 7
1126.     Else
1127.         flipper = 0
1128.     End If
1129.  
1130.     ' Here is where it needs some optimizing possibly... kinda slow...
1131.     For y = LBound(NewArray, 2) To UBound(NewArray, 2)
1132.         For x = LBound(NewArray, 1) To UBound(NewArray, 1)
1133.             Select Case flipper
1134.                 Case 1:
1135.                     nx = -y
1136.                     ny = x
1137.                 Case 2:
1138.                     nx = -x
1139.                     ny = -y
1140.                 Case 3:
1141.                     nx = -y
1142.                     ny = -x
1143.                 Case 4:
1144.                     nx = -x
1145.                     ny = y
1146.                 Case 5:
1147.                     nx = x
1148.                     ny = -y
1149.                 Case 6:
1150.                     nx = y
1151.                     ny = x
1152.                 Case 7:
1153.                     nx = y
1154.                     ny = -x
1155.                 Case Else:
1156.                     nx = x
1157.                     ny = y
1158.             End Select
1159.  
1160.             clr = OldArray(nx, ny, 0).c
1161.  
1162.             y1 = y * shear1
1163.             xy1 = x + y1
1164.             fy = (y - xy1 * shear2)
1165.             fx = xy1 + fy * shear1
1166.  
1167.             If fx >= -16 And fx <= 16 Then
1168.                 If fy >= -16 And fy <= 16 Then
1169.                     NewArray(fx, fy, 0).c = clr
1170.                     NewArray(fx, fy, 0).origx = fx
1171.                     NewArray(fx, fy, 0).origy = fy
1172.                 End If
1173.             End If
1174.         Next x
1175.     Next y
1176. End Sub ' ShearRotate
1177.  
1178. ' /////////////////////////////////////////////////////////////////////////////
1179. ' Same as ShearRotate, except adds iOverwriteCount parameter,
1180. ' and counts how many points are overwriting existing points,
1181. ' and return that value byref in parameter iOverwriteCount.
1182.  
1183. Sub ShearRotate1 (OldArray() As RotationType, NewArray() As RotationType, angle1 As Integer, iEmpty As Integer, iOverwriteCount As Integer)
1184.     Const Pi = 4 * Atn(1)
1185.  
1186.     Dim angle As Integer
1187.     Dim TwoPi As Double: TwoPi = 8 * Atn(1)
1188.     Dim RtoD As Double: RtoD = 180 / Pi ' radians * RtoD = degrees
1189.     Dim DtoR As Double: DtoR = Pi / 180 ' degrees * DtoR = radians
1190.     Dim x As Integer
1191.     Dim y As Integer
1192.     Dim nangle As Integer
1193.     Dim nx As Integer
1194.     Dim ny As Integer
1195.     Dim flipper As Integer
1196.     Dim rotr As Double
1197.     Dim shear1 As Double
1198.     Dim shear2 As Double
1199.     Dim clr As Integer
1200.     Dim y1 As _Byte
1201.     Dim xy1 As _Byte
1202.     Dim fy As _Byte
1203.     Dim fx As _Byte
1204.     Dim in$
1205.     Dim sLine As String
1206.  
1207.     ' initialize new with empty
1208.     ReDim NewArray(LBound(OldArray, 1) To UBound(OldArray, 1), LBound(OldArray, 2) To UBound(OldArray, 2), 127) As RotationType
1209.     For x = LBound(NewArray, 1) To UBound(NewArray, 1)
1210.         For y = LBound(NewArray, 2) To UBound(NewArray, 2)
1211.             NewArray(x, y, 0).origx = x
1212.             NewArray(x, y, 0).origy = y
1213.             NewArray(x, y, 0).c = iEmpty
1214.         Next y
1215.     Next x
1216.  
1217.     ' angle is reversed
1218.     angle = 360 - angle1
1219.  
1220.     ' Shearing each element 3 times in one shot
1221.     nangle = angle
1222.  
1223.     ' this pre-processing portion basically rotates by 90 to get
1224.     ' between -45 and 45 degrees, where the 3-shear routine works correctly...
1225.     If angle > 45 And angle < 225 Then
1226.         If angle < 135 Then
1227.             nangle = angle - 90
1228.         Else
1229.             nangle = angle - 180
1230.         End If
1231.     End If
1232.     If angle > 135 And angle < 315 Then
1233.         If angle < 225 Then
1234.             nangle = angle - 180
1235.         Else
1236.             nangle = angle - 270
1237.         End If
1238.     End If
1239.     If nangle < 0 Then
1240.         nangle = nangle + 360
1241.     End If
1242.     If nangle > 359 Then
1243.         nangle = nangle - 360
1244.     End If
1245.  
1246.     rotr = nangle * DtoR
1247.     shear1 = Tan(rotr / 2) ' correct way
1248.     shear2 = Sin(rotr)
1249.  
1250.     ' *** NOTE: this had a bug where the values 135, 224, and 314
1251.     ' ***       all resolve to -45 degrees.
1252.     ' ***       Fixed by changing < to <=
1253.  
1254.     'if angle >  45 and angle < 134 then
1255.     If angle > 45 And angle <= 134 Then
1256.         flipper = 1
1257.     ElseIf angle > 134 And angle <= 224 Then
1258.         flipper = 2
1259.     ElseIf angle > 224 And angle <= 314 Then
1260.         ' *** NOTE: this had a bug where this flipper was wrong
1261.         '           Fixed by adding case 7
1262.         'flipper = 3
1263.         flipper = 7
1264.     Else
1265.         flipper = 0
1266.     End If
1267.  
1268.     ' Here is where it needs some optimizing possibly... kinda slow...
1269.     iOverwriteCount = 0
1270.     For y = LBound(NewArray, 2) To UBound(NewArray, 2)
1271.         For x = LBound(NewArray, 1) To UBound(NewArray, 1)
1272.             Select Case flipper
1273.                 Case 1:
1274.                     nx = -y
1275.                     ny = x
1276.                 Case 2:
1277.                     nx = -x
1278.                     ny = -y
1279.                 Case 3:
1280.                     nx = -y
1281.                     ny = -x
1282.                 Case 4:
1283.                     nx = -x
1284.                     ny = y
1285.                 Case 5:
1286.                     nx = x
1287.                     ny = -y
1288.                 Case 6:
1289.                     nx = y
1290.                     ny = x
1291.                 Case 7:
1292.                     nx = y
1293.                     ny = -x
1294.                 Case Else:
1295.                     nx = x
1296.                     ny = y
1297.             End Select
1298.  
1299.             clr = OldArray(nx, ny, 0).c
1300.  
1301.             y1 = y * shear1
1302.             xy1 = x + y1
1303.             fy = (y - xy1 * shear2)
1304.             fx = xy1 + fy * shear1
1305.  
1306.             If fx >= -16 And fx <= 16 Then
1307.                 If fy >= -16 And fy <= 16 Then
1308.  
1309.                     ' count points that will be overwritten
1310.                     If NewArray(fx, fy, 0).c <> iEmpty Then
1311.                         iOverwriteCount = iOverwriteCount + 1
1312.                     End If
1313.  
1314.                     NewArray(fx, fy, 0).c = clr
1315.                     NewArray(fx, fy, 0).origx = fx
1316.                     NewArray(fx, fy, 0).origy = fy
1317.                 End If
1318.             End If
1319.         Next x
1320.     Next y
1321. End Sub ' ShearRotate1
1322.  
1323. ' /////////////////////////////////////////////////////////////////////////////
1324. ' Tries to fix the problem of 2 points resolving to the same coordinate
1325. ' (one overwrites the other, which becomes "lost")
1326.  
1327. ' Returns # points missing (that could not be corrected) in iMissing parameter.
1328.  
1329. Sub ShearRotate2 (OldArray() As RotationType, NewArray() As RotationType, angle1 As Integer, iEmpty As Integer, iMissing As Integer)
1330.     Const Pi = 4 * Atn(1)
1331.  
1332.     Dim angle As Integer
1333.     Dim TwoPi As Double: TwoPi = 8 * Atn(1)
1334.     Dim RtoD As Double: RtoD = 180 / Pi ' radians * RtoD = degrees
1335.     Dim DtoR As Double: DtoR = Pi / 180 ' degrees * DtoR = radians
1336.     Dim x As Integer
1337.     Dim y As Integer
1338.     Dim nangle As Integer
1339.     Dim nx As Integer
1340.     Dim ny As Integer
1341.     Dim flipper As Integer
1342.     Dim rotr As Double
1343.     Dim shear1 As Double
1344.     Dim shear2 As Double
1345.     Dim clr As Integer
1346.     Dim y1 As _Byte
1347.     Dim xy1 As _Byte
1348.     Dim fy As _Byte
1349.     Dim fx As _Byte
1350.     Dim in$
1351.     Dim sLine As String
1352.     ReDim arrLost(-1) As RotationType
1353.     Dim iLoop As Integer
1354.     Dim bFound As Integer
1355.  
1356.     ' initialize new with empty
1357.     ReDim NewArray(LBound(OldArray, 1) To UBound(OldArray, 1), LBound(OldArray, 2) To UBound(OldArray, 2), 127) As RotationType
1358.     For x = LBound(NewArray, 1) To UBound(NewArray, 1)
1359.         For y = LBound(NewArray, 2) To UBound(NewArray, 2)
1360.             NewArray(x, y, 0).origx = x
1361.             NewArray(x, y, 0).origy = y
1362.             NewArray(x, y, 0).c = iEmpty
1363.         Next y
1364.     Next x
1365.  
1366.     ' angle is reversed
1367.     angle = 360 - angle1
1368.  
1369.     ' Shearing each element 3 times in one shot
1370.     nangle = angle
1371.  
1372.     ' this pre-processing portion basically rotates by 90 to get
1373.     ' between -45 and 45 degrees, where the 3-shear routine works correctly...
1374.     If angle > 45 And angle < 225 Then
1375.         If angle < 135 Then
1376.             nangle = angle - 90
1377.         Else
1378.             nangle = angle - 180
1379.         End If
1380.     End If
1381.     If angle > 135 And angle < 315 Then
1382.         If angle < 225 Then
1383.             nangle = angle - 180
1384.         Else
1385.             nangle = angle - 270
1386.         End If
1387.     End If
1388.     If nangle < 0 Then
1389.         nangle = nangle + 360
1390.     End If
1391.     If nangle > 359 Then
1392.         nangle = nangle - 360
1393.     End If
1394.  
1395.     rotr = nangle * DtoR
1396.     shear1 = Tan(rotr / 2) ' correct way
1397.     shear2 = Sin(rotr)
1398.  
1399.     ' *** NOTE: this had a bug where the values 135, 224, and 314
1400.     ' ***       all resolve to -45 degrees.
1401.     ' ***       Fixed by changing < to <=
1402.  
1403.     'if angle >  45 and angle < 134 then
1404.     If angle > 45 And angle <= 134 Then
1405.         flipper = 1
1406.     ElseIf angle > 134 And angle <= 224 Then
1407.         flipper = 2
1408.     ElseIf angle > 224 And angle <= 314 Then
1409.         ' *** NOTE: this had a bug where this flipper was wrong
1410.         '           Fixed by adding case 7
1411.         'flipper = 3
1412.         flipper = 7
1413.     Else
1414.         flipper = 0
1415.     End If
1416.  
1417.     ' Here is where it needs some optimizing possibly... kinda slow...
1418.     For y = LBound(NewArray, 2) To UBound(NewArray, 2)
1419.         For x = LBound(NewArray, 1) To UBound(NewArray, 1)
1420.             Select Case flipper
1421.                 Case 1:
1422.                     nx = -y
1423.                     ny = x
1424.                 Case 2:
1425.                     nx = -x
1426.                     ny = -y
1427.                 Case 3:
1428.                     nx = -y
1429.                     ny = -x
1430.                 Case 4:
1431.                     nx = -x
1432.                     ny = y
1433.                 Case 5:
1434.                     nx = x
1435.                     ny = -y
1436.                 Case 6:
1437.                     nx = y
1438.                     ny = x
1439.                 Case 7:
1440.                     nx = y
1441.                     ny = -x
1442.                 Case Else:
1443.                     nx = x
1444.                     ny = y
1445.             End Select
1446.  
1447.             clr = OldArray(nx, ny, 0).c
1448.  
1449.             y1 = y * shear1
1450.             xy1 = x + y1
1451.             fy = (y - xy1 * shear2)
1452.             fx = xy1 + fy * shear1
1453.  
1454.             If fx >= -16 And fx <= 16 Then
1455.                 If fy >= -16 And fy <= 16 Then
1456.                     ' only draw here if this spot is empty
1457.                     If NewArray(fx, fy, 0).c = iEmpty Then
1458.                         NewArray(fx, fy, 0).c = clr
1459.                         NewArray(fx, fy, 0).origx = fx
1460.                         NewArray(fx, fy, 0).origy = fy
1461.                     Else
1462.                         ' don't draw, but save it to a list to handle later
1463.                         ReDim _Preserve arrLost(0 To UBound(arrLost) + 1) As RotationType
1464.                         arrLost(UBound(arrLost)).c = clr
1465.                         arrLost(UBound(arrLost)).origx = fx
1466.                         arrLost(UBound(arrLost)).origy = fy
1467.                     End If
1468.                 End If
1469.             End If
1470.         Next x
1471.     Next y
1472.  
1473.     ' try to place any points that would have overwritten to a spot nearby
1474.     ' can nearby be determined by the angle of rotation?
1475.     ' perhaps if we divide the screen up into 4 zones:
1476.     '
1477.     ' --------------------------------------
1478.     '|                   |                  |
1479.     '| zone 4            | zone 1           |
1480.     '| 271-359 degrees)  | (1-89 degrees)   |
1481.     '|--------------------------------------|
1482.     '|                   |                  |
1483.     '| zone 3            | zone 2           |
1484.     '| (181-269 degrees) | (91-179 degrees) |
1485.     '|                   |                  |
1486.     ' --------------------------------------
1487.  
1488.     ' in zone   search direction (y,x)
1489.     ' -------   ----------------------
1490.     ' 1         up   + right
1491.     ' 2         down + right
1492.     ' 3         down + left
1493.     ' 4         up   + left
1494.  
1495.     iMissing = 0
1496.     For iLoop = 0 To UBound(arrLost)
1497.         bFound = FindEmptyShearRotationPoint%(arrLost(iLoop), angle1, iEmpty, x, y, NewArray())
1498.         If bFound = TRUE Then
1499.             If m_bDebug = TRUE Then
1500.                 _Echo "Plotted  missing point " + Chr$(34) + Chr$(arrLost(iLoop).c) + Chr$(34) + " to (x=" + cstr$(x) + ", y=" + cstr$(y) + ")"
1501.             End If
1502.         Else
1503.             iMissing = iMissing + 1
1504.             If m_bDebug = TRUE Then
1505.                 _Echo "Detected missing point " + Chr$(34) + Chr$(arrLost(iLoop).c) + Chr$(34) + " at (x=" + cstr$(x) + ", y=" + cstr$(y) + ")"
1506.             End If
1507.         End If
1508.     Next iLoop
1509.  
1510. End Sub ' ShearRotate2
1511.  
1512. ' /////////////////////////////////////////////////////////////////////////////
1513. ' Receives
1514. ' FindMe (RotationType) = contains the starting location (.origx, .origy) to start looking from, and the value (.c) to write
1515. ' angle1 (Integer) = angle we were rotating to, to determine direction to look in
1516. ' iEmpty (Integer) = value to test against for empty
1517. ' destX (Integer) = if an empty spot is found, returns the x location here byref
1518. ' destY (Integer) = if an empty spot is found, returns the y location here byref
1519. ' NewArray() (RotationType array (x,y,127) ) = array representing the screen to search in and plot to
1520.  
1521. ' Returns
1522. ' FALSE if no empty spot was found
1523. ' TRUE if an empty spot was found, and x,y location returned byref in destX,destY parameters
1524.  
1525. Function FindEmptyShearRotationPoint% (FindMe As RotationType, angle1 As Integer, iEmpty As Integer, destX As Integer, destY As Integer, NewArray() As RotationType)
1526.     Dim bResult As Integer: bResult = FALSE
1527.     Dim x As Integer
1528.     Dim y As Integer
1529.     Dim dirX As Integer
1530.     Dim dirY As Integer
1531.  
1532.     destX = 0
1533.     destY = 0
1534.  
1535.     ' Choose search direction depending on the angle
1536.     If angle1 > 0 And angle1 < 90 Then
1537.         dirX = 1
1538.         dirY = -1
1539.     ElseIf angle1 > 90 And angle1 < 180 Then
1540.         dirX = 1
1541.         dirY = 1
1542.     ElseIf angle1 > 180 And angle1 < 270 Then
1543.         dirX = -1
1544.         dirY = 1
1545.     ElseIf angle1 > 270 And angle1 < 360 Then
1546.         dirX = -1
1547.         dirY = -1
1548.     Else
1549.         dirX = 0
1550.         dirY = 0
1551.     End If
1552.  
1553.     If dirX <> 0 Then
1554.         x = FindMe.origx
1555.         y = FindMe.origy
1556.         Do
1557.             ' quit if we're out of bounds
1558.             If x < LBound(NewArray, 1) Then Exit Do
1559.             If x > UBound(NewArray, 1) Then Exit Do
1560.             If y < LBound(NewArray, 2) Then Exit Do
1561.             If y > UBound(NewArray, 2) Then Exit Do
1562.  
1563.             ' =============================================================================
1564.             ' BEGIN PRIMARY SEARCH
1565.             ' =============================================================================
1566.             ' look along y axis for a blank spot
1567.             destX = x
1568.             destY = y + dirY
1569.             If destX >= LBound(NewArray, 1) Then
1570.                 If destX <= UBound(NewArray, 1) Then
1571.                     If destY >= LBound(NewArray, 2) Then
1572.                         If destY <= UBound(NewArray, 2) Then
1573.                             If NewArray(destX, destY, 0).c = iEmpty Then
1574.                                 NewArray(destX, destY, 0).c = FindMe.c
1575.                                 bResult = TRUE
1576.                                 Exit Do
1577.                             End If
1578.                         End If
1579.                     End If
1580.                 End If
1581.             End If
1582.  
1583.             ' look along x axis for a blank spot
1584.             destX = x + dirX
1585.             destY = y
1586.             If destX >= LBound(NewArray, 1) Then
1587.                 If destX <= UBound(NewArray, 1) Then
1588.                     If destY >= LBound(NewArray, 2) Then
1589.                         If destY <= UBound(NewArray, 2) Then
1590.                             If NewArray(x + dirX, y, 0).c = iEmpty Then
1591.                                 NewArray(destX, destY, 0).c = FindMe.c
1592.                                 bResult = TRUE
1593.                                 Exit Do
1594.                             End If
1595.                         End If
1596.                     End If
1597.                 End If
1598.             End If
1599.  
1600.             ' look diagonally for a blank spot
1601.             destX = x + dirX
1602.             destY = y + dirY
1603.             If destX >= LBound(NewArray, 1) Then
1604.                 If destX <= UBound(NewArray, 1) Then
1605.                     If destY >= LBound(NewArray, 2) Then
1606.                         If destY <= UBound(NewArray, 2) Then
1607.                             If NewArray(x + dirX, y + dirY, 0).c = iEmpty Then
1608.                                 NewArray(destX, destY, 0).c = FindMe.c
1609.                                 bResult = TRUE
1610.                                 Exit Do
1611.                             End If
1612.                         End If
1613.                     End If
1614.                 End If
1615.             End If
1616.             ' =============================================================================
1617.             ' END PRIMARY SEARCH
1618.             ' =============================================================================
1619.  
1620.             ' =============================================================================
1621.             ' BEGIN SECONDARY SEARCH
1622.             ' =============================================================================
1623.             'yoda
1624.             ' =============================================================================
1625.             ' END SECONDARY SEARCH
1626.             ' =============================================================================
1627.  
1628.             ' Keep looking
1629.             x = x + dirX
1630.             y = y + dirY
1631.         Loop
1632.     End If
1633.  
1634.     ' Return result
1635.     FindEmptyShearRotationPoint% = bResult
1636. End Function ' FindEmptyShearRotationPoint%
1637.  
1638. ' /////////////////////////////////////////////////////////////////////////////
1639.  
1640. Sub ShearRotateTest1
1641.     Dim RoArray1(-16 To 16, -16 To 16, 127) As RotationType
1642.     Dim RoArray2(-16 To 16, -16 To 16, 127) As RotationType
1643.     Dim sMap As String
1644.     Dim D As Integer
1645.     Dim in$
1646.  
1647.     ' GET A SHAPE TO BE ROTATED
1648.     Cls
1649.     Print "3 shear rotation based on code by leopardpm"
1650.     Print
1651.  
1652.     sMap = TestSprite1$
1653.  
1654.     ' CONVERT SHAPE TO ARRAY
1655.     StringToRotationArray RoArray1(), sMap, "."
1656.     Print "Initial contents of Rotation Array:"
1657.     Print RotationArrayToStringTest(RoArray1())
1658.     Print
1659.  
1660.     ' ROTATE THE SHAPE
1661.     Do
1662.         Print "Type degrees to rotate (0 TO 360) or non-numeric value to quit."
1663.         Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)."
1664.  
1665.         Input "Degrees to rotate (q to quit)? "; in$
1666.         If IsNum%(in$) Then
1667.             D = Val(in$)
1668.             If D >= 0 And D <= 360 Then
1669.                 ShearRotate RoArray1(), RoArray2(), D, Asc(".")
1670.                 Print
1671.                 Print "Rotated by " + cstr$(D) + " degrees:"
1672.                 Print RotationArrayToStringTest(RoArray2())
1673.                 Print
1674.             Else
1675.                 Exit Do
1676.             End If
1677.         Else
1678.             Exit Do
1679.         End If
1680.     Loop
1681. End Sub ' ShearRotateTest1
1682.  
1683. ' /////////////////////////////////////////////////////////////////////////////
1684. ' Now receives parameter sMap
1685. ' which comes from TestSprite1$, TestSprite2$, TestSprite3$, etc.
1686.  
1687. ' e.g. ShearRotateTest2 TestSprite1$
1688.  
1689. Sub ShearRotateTest2 (sMap As String)
1690.     Dim RoArray1(-16 To 16, -16 To 16, 127) As RotationType
1691.     Dim RoArray2(-16 To 16, -16 To 16, 127) As RotationType
1692.     'Dim sMap As String
1693.     Dim D As Integer
1694.     Dim D1 As Integer
1695.     Dim in$
1696.     Dim bFinished As Integer
1697.     Dim iOverwriteCount As Integer
1698.  
1699.     ' GET A SHAPE TO BE ROTATED
1700.     Cls
1701.     Print "3 shear rotation based on code by leopardpm"
1702.     'sMap = TestSprite1$
1703.  
1704.     ' CONVERT SHAPE TO ARRAY
1705.     StringToRotationArray RoArray1(), sMap, "."
1706.  
1707.     ' GET START ANGLE
1708.     D = 0
1709.     Print
1710.     Print "Rotated by " + cstr$(D) + " degrees:"
1711.     Print RotationArrayToStringTest(RoArray1())
1712.     Print
1713.     Print "Type an angle (-360 to 360) to rotate to, "
1714.     Print "or blank to increase by 1 degree, or q to quit."
1715.     Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)."
1716.     Print "Hold down <ENTER> to rotate continually."
1717.     Input "Angle (q to quit)? ", in$
1718.     If Len(in$) > 0 Then
1719.         If IsNum%(in$) Then
1720.             D1 = Val(in$)
1721.         Else
1722.             D1 = -500
1723.         End If
1724.     Else
1725.         D1 = 1
1726.     End If
1727.  
1728.     ' ROTATE TO EACH ANGLE
1729.     If D1 >= -360 And D1 <= 360 Then
1730.         bFinished = FALSE
1731.         Do
1732.             ' ROTATE CLOCKWISE
1733.             For D = D1 To 360
1734.                 Cls
1735.                 ShearRotate1 RoArray1(), RoArray2(), D, Asc("."), iOverwriteCount
1736.                 Print
1737.                 'Print "Rotated by " + cstr$(D) + " degrees:"
1738.                 Print "Rotated by " + cstr$(D) + " degrees" + IIFSTR$(iOverwriteCount = 0, "", " (" + cstr$(iOverwriteCount) + " points overwritten)") + ":"
1739.  
1740.                 Print RotationArrayToStringTest(RoArray2())
1741.                 Print
1742.  
1743.                 Print "Type an angle (-360 to 360) to rotate to, "
1744.                 Print "or blank to increase by 1 degree, or q to quit."
1745.                 Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)."
1746.                 Print "Hold down <ENTER> to rotate continually."
1747.                 Input "Angle (q to quit)? ", in$
1748.                 If Len(in$) > 0 Then
1749.                     If IsNum%(in$) Then
1750.                         D = Val(in$)
1751.                         If D >= 0 And D <= 360 Then
1752.                             D = D - 1
1753.                         Else
1754.                             bFinished = TRUE
1755.                             Exit For
1756.                         End If
1757.                     Else
1758.                         bFinished = TRUE
1759.                         Exit For
1760.                     End If
1761.                 End If
1762.             Next D
1763.             If bFinished = TRUE Then Exit Do
1764.  
1765.             ' ROTATE COUNTER-CLOCKWISE
1766.             For D = 360 To D1 Step -1
1767.                 Cls
1768.                 ShearRotate1 RoArray1(), RoArray2(), D, Asc("."), iOverwriteCount
1769.                 Print
1770.                 'Print "Rotated by " + cstr$(D) + " degrees:"
1771.                 Print "Rotated by " + cstr$(D) + " degrees" + IIFSTR$(iOverwriteCount = 0, "", " (" + cstr$(iOverwriteCount) + " points overwritten)") + ":"
1772.  
1773.                 Print RotationArrayToStringTest(RoArray2())
1774.                 Print
1775.  
1776.                 Print "Type an angle (0 to 360) to rotate to, "
1777.                 Print "or blank to increase by 1 degree, or q to quit."
1778.                 Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)."
1779.                 Print "Hold down <ENTER> to rotate continually."
1780.                 Input "Angle (q to quit)? ", in$
1781.                 If Len(in$) > 0 Then
1782.                     If IsNum%(in$) Then
1783.                         D = Val(in$)
1784.                         If D >= 0 And D <= 360 Then
1785.                             D = D + 1
1786.                         Else
1787.                             bFinished = TRUE
1788.                             Exit For
1789.                         End If
1790.                     Else
1791.                         bFinished = TRUE
1792.                         Exit For
1793.                     End If
1794.                 End If
1795.             Next D
1796.             If bFinished = TRUE Then Exit Do
1797.         Loop
1798.     End If
1799. End Sub ' ShearRotateTest2
1800.  
1801. ' /////////////////////////////////////////////////////////////////////////////
1802. ' Tries to correct for missing points.
1803.  
1804. ' Receives parameter sMap
1805. ' which comes from TestSprite1$, TestSprite2$, TestSprite3$, etc.
1806.  
1807. ' e.g. ShearRotateTest3 TestSprite1$
1808.  
1809. Sub ShearRotateTest3 (sMap As String)
1810.     Dim RoArray1(-16 To 16, -16 To 16, 127) As RotationType
1811.     Dim RoArray2(-16 To 16, -16 To 16, 127) As RotationType
1812.     'Dim sMap As String
1813.     Dim D As Integer
1814.     Dim D1 As Integer
1815.     Dim in$
1816.     Dim bFinished As Integer
1817.     Dim iMissing As Integer
1818.  
1819.     ' GET A SHAPE TO BE ROTATED
1820.     Cls
1821.     Print "3 shear rotation based on code by leopardpm"
1822.     'sMap = TestSprite1$
1823.  
1824.     ' CONVERT SHAPE TO ARRAY
1825.     StringToRotationArray RoArray1(), sMap, "."
1826.  
1827.     ' GET START ANGLE
1828.     D = 0
1829.     Print
1830.     Print "Rotated by " + cstr$(D) + " degrees:"
1831.     Print RotationArrayToStringTest(RoArray1())
1832.     Print
1833.     Print "Type an angle (-360 to 360) to rotate to, "
1834.     Print "or blank to increase by 1 degree, or q to quit."
1835.     Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)."
1836.     Print "Hold down <ENTER> to rotate continually."
1837.     Input "Angle (q to quit)? ", in$
1838.     If Len(in$) > 0 Then
1839.         If IsNum%(in$) Then
1840.             D1 = Val(in$)
1841.         Else
1842.             D1 = -500
1843.         End If
1844.     Else
1845.         D1 = 1
1846.     End If
1847.  
1848.     ' ROTATE TO EACH ANGLE
1849.     If D1 >= -360 And D1 <= 360 Then
1850.         bFinished = FALSE
1851.         Do
1852.             ' ROTATE CLOCKWISE
1853.             For D = D1 To 360
1854.                 Cls
1855.                 ShearRotate2 RoArray1(), RoArray2(), D, Asc("."), iMissing
1856.                 Print
1857.                 'Print "Rotated by " + cstr$(D) + " degrees:"
1858.                 Print "Rotated by " + cstr$(D) + " degrees" + IIFSTR$(iMissing = 0, "", " (" + cstr$(iMissing) + " points missing)") + ":"
1859.  
1860.                 Print RotationArrayToStringTest(RoArray2())
1861.                 Print
1862.  
1863.                 Print "Type an angle (-360 to 360) to rotate to, "
1864.                 Print "or blank to increase by 1 degree, or q to quit."
1865.                 Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)."
1866.                 Print "Hold down <ENTER> to rotate continually."
1867.                 Input "Angle (q to quit)? ", in$
1868.                 If Len(in$) > 0 Then
1869.                     If IsNum%(in$) Then
1870.                         D = Val(in$)
1871.                         If D >= 0 And D <= 360 Then
1872.                             D = D - 1
1873.                         Else
1874.                             bFinished = TRUE
1875.                             Exit For
1876.                         End If
1877.                     Else
1878.                         bFinished = TRUE
1879.                         Exit For
1880.                     End If
1881.                 End If
1882.             Next D
1883.             If bFinished = TRUE Then Exit Do
1884.  
1885.             ' ROTATE COUNTER-CLOCKWISE
1886.             For D = 360 To D1 Step -1
1887.                 Cls
1888.                 ShearRotate2 RoArray1(), RoArray2(), D, Asc("."), iMissing
1889.                 Print
1890.                 'Print "Rotated by " + cstr$(D) + " degrees:"
1891.                 Print "Rotated by " + cstr$(D) + " degrees" + IIFSTR$(iMissing = 0, "", " (" + cstr$(iMissing) + " points missing)") + ":"
1892.  
1893.                 Print RotationArrayToStringTest(RoArray2())
1894.                 Print
1895.  
1896.                 Print "Type an angle (0 to 360) to rotate to, "
1897.                 Print "or blank to increase by 1 degree, or q to quit."
1898.                 Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)."
1899.                 Print "Hold down <ENTER> to rotate continually."
1900.                 Input "Angle (q to quit)? ", in$
1901.                 If Len(in$) > 0 Then
1902.                     If IsNum%(in$) Then
1903.                         D = Val(in$)
1904.                         If D >= 0 And D <= 360 Then
1905.                             D = D + 1
1906.                         Else
1907.                             bFinished = TRUE
1908.                             Exit For
1909.                         End If
1910.                     Else
1911.                         bFinished = TRUE
1912.                         Exit For
1913.                     End If
1914.                 End If
1915.             Next D
1916.             If bFinished = TRUE Then Exit Do
1917.         Loop
1918.     End If
1919. End Sub ' ShearRotateTest3
1920.  
1921. ' /////////////////////////////////////////////////////////////////////////////
1922.  
1923. Function TestSprite1$
1924.     Dim m$
1925.     m$ = ""
1926.     '                   11111111112222222222333
1927.     '          12345678901234567890123456789012
1928.     m$ = m$ + "11111111111111111111111111111111" + Chr$(13) ' 1
1929.     m$ = m$ + "4..............................2" + Chr$(13) ' 2
1930.     m$ = m$ + "4....##.....#######.....####...2" + Chr$(13) ' 3
1931.     m$ = m$ + "4...####....##...###...######..2" + Chr$(13) ' 4
1932.     m$ = m$ + "4..##..##...##...###..##....##.2" + Chr$(13) ' 5
1933.     m$ = m$ + "4.##....##..#######...##.......2" + Chr$(13) ' 6
1934.     m$ = m$ + "4.########..#######...##.......2" + Chr$(13) ' 7
1935.     m$ = m$ + "4.########..##...###..##....##.2" + Chr$(13) ' 8
1936.     m$ = m$ + "4.##....##..##...###...######..2" + Chr$(13) ' 9
1937.     m$ = m$ + "4.##....##..#######.....####...2" + Chr$(13) ' 10
1938.     m$ = m$ + "4..............................2" + Chr$(13) ' 11
1939.     m$ = m$ + "4..............................2" + Chr$(13) ' 12
1940.     m$ = m$ + "4..ABBBBBBBBBBBBBBBBBBBBBBBBC..2" + Chr$(13) ' 13
1941.     m$ = m$ + "4..A...........EE...........C..2" + Chr$(13) ' 14
1942.     m$ = m$ + "4..A..........FFFF..........C..2" + Chr$(13) ' 15
1943.     m$ = m$ + "4..A.........GGGGGG.........C..2" + Chr$(13) ' 16
1944.     m$ = m$ + "4..A........HHHHHHHH........C..2" + Chr$(13) ' 17
1945.     m$ = m$ + "4..A.......IIIIIIIIII.......C..2" + Chr$(13) ' 18
1946.     m$ = m$ + "4..A......JJJJJJJJJJJJ......C..2" + Chr$(13) ' 19
1947.     m$ = m$ + "4..DDDDDDDDDDDDDDDDDDDDDDDDDC..2" + Chr$(13) ' 20
1948.     m$ = m$ + "4..............................2" + Chr$(13) ' 21
1949.     m$ = m$ + "4..............................2" + Chr$(13) ' 22
1950.     m$ = m$ + "4.######....########..########.2" + Chr$(13) ' 23
1951.     m$ = m$ + "4.#######...########..########.2" + Chr$(13) ' 24
1952.     m$ = m$ + "4.##...###..##........##.......2" + Chr$(13) ' 25
1953.     m$ = m$ + "4.##....##..########..#######..2" + Chr$(13) ' 26
1954.     m$ = m$ + "4.##....##..########..#######..2" + Chr$(13) ' 27
1955.     m$ = m$ + "4.##...###..##........##.......2" + Chr$(13) ' 28
1956.     m$ = m$ + "4.#######...##........##.......2" + Chr$(13) ' 29
1957.     m$ = m$ + "4.######....########..##.......2" + Chr$(13) ' 30
1958.     m$ = m$ + "4..............................2" + Chr$(13) ' 31
1959.     m$ = m$ + "33333333333333333333333333333332" + Chr$(13) ' 32
1960.     TestSprite1$ = m$
1961. End Function ' TestSprite1$
1962.  
1963. ' /////////////////////////////////////////////////////////////////////////////
1964.  
1965. Function TestSprite2$
1966.     Dim m$
1967.     m$ = ""
1968.     '                   11111111112222222222333
1969.     '          12345678901234567890123456789012
1970.     m$ = m$ + "...............AA..............." + Chr$(13) ' 1
1971.     m$ = m$ + "..............//BB.............." + Chr$(13) ' 2
1972.     m$ = m$ + ".............??..CC............." + Chr$(13) ' 3
1973.     m$ = m$ + "............==....DD............" + Chr$(13) ' 4
1974.     m$ = m$ + "...........++......EE..........." + Chr$(13) ' 5
1975.     m$ = m$ + "..........&&........FF.........." + Chr$(13) ' 6
1976.     m$ = m$ + ".........zz..........GG........." + Chr$(13) ' 7
1977.     m$ = m$ + "........yy............HH........" + Chr$(13) ' 8
1978.     m$ = m$ + ".......xx..............II......." + Chr$(13) ' 9
1979.     m$ = m$ + "......ww................JJ......" + Chr$(13) ' 10
1980.     m$ = m$ + ".....vv..................KK....." + Chr$(13) ' 11
1981.     m$ = m$ + "....uu....................LL...." + Chr$(13) ' 12
1982.     m$ = m$ + "...tt......DDAAAAAAA.......MM..." + Chr$(13) ' 13
1983.     m$ = m$ + "..ss.......DDAAAAAAA........NN.." + Chr$(13) ' 14
1984.     m$ = m$ + ".rr........DD.....BB.........OO." + Chr$(13) ' 15
1985.     m$ = m$ + "qq.........DD.....BB..........PP" + Chr$(13) ' 16
1986.     m$ = m$ + "pp.........DD.....BB..........QQ" + Chr$(13) ' 17
1987.     m$ = m$ + ".oo........DD.....BB.........RR." + Chr$(13) ' 18
1988.     m$ = m$ + "..nn.......CCCCCCCBB........SS.." + Chr$(13) ' 19
1989.     m$ = m$ + "...mm......CCCCCCCBB.......TT..." + Chr$(13) ' 20
1990.     m$ = m$ + "....ll....................UU...." + Chr$(13) ' 21
1991.     m$ = m$ + ".....kk..................VV....." + Chr$(13) ' 22
1992.     m$ = m$ + "......jj................WW......" + Chr$(13) ' 23
1993.     m$ = m$ + ".......ii..............XX......." + Chr$(13) ' 24
1994.     m$ = m$ + "........hh............YY........" + Chr$(13) ' 25
1995.     m$ = m$ + ".........gg..........ZZ........." + Chr$(13) ' 26
1996.     m$ = m$ + "..........ff........@@.........." + Chr$(13) ' 27
1997.     m$ = m$ + "...........ee......##..........." + Chr$(13) ' 28
1998.     m$ = m$ + "............dd....$$............" + Chr$(13) ' 29
1999.     m$ = m$ + ".............cc..%%............." + Chr$(13) ' 30
2000.     m$ = m$ + "..............bb\\.............." + Chr$(13) ' 31
2001.     m$ = m$ + "...............aa..............." + Chr$(13) ' 32
2002.     TestSprite2$ = m$
2003. End Function ' TestSprite2$
2004.  
2005. ' /////////////////////////////////////////////////////////////////////////////
2006.  
2007. Function PetrText1$
2008.     Dim m$
2009.     m$ = ""
2010.     '                   11111111112222222222333
2011.     '          12345678901234567890123456789012
2012.     m$ = m$ + "................................" + Chr$(13) ' 1
2013.     m$ = m$ + "................................" + Chr$(13) ' 2
2014.     m$ = m$ + "................................" + Chr$(13) ' 3
2015.     m$ = m$ + "................................" + Chr$(13) ' 4
2016.     m$ = m$ + "................................" + Chr$(13) ' 5
2017.     m$ = m$ + "................................" + Chr$(13) ' 6
2018.     m$ = m$ + "................................" + Chr$(13) ' 7
2019.     m$ = m$ + "................................" + Chr$(13) ' 8
2020.     m$ = m$ + "................................" + Chr$(13) ' 9
2021.     m$ = m$ + "................................" + Chr$(13) ' 10
2022.     m$ = m$ + "................................" + Chr$(13) ' 11
2023.     m$ = m$ + "................................" + Chr$(13) ' 12
2024.     m$ = m$ + "................................" + Chr$(13) ' 13
2025.     m$ = m$ + "................................" + Chr$(13) ' 14
2026.     m$ = m$ + "....It's a SCREEN resolution?..." + Chr$(13) ' 15
2027.     m$ = m$ + "................................" + Chr$(13) ' 16
2028.     m$ = m$ + "................................" + Chr$(13) ' 17
2029.     m$ = m$ + "................................" + Chr$(13) ' 18
2030.     m$ = m$ + "................................" + Chr$(13) ' 19
2031.     m$ = m$ + "................................" + Chr$(13) ' 20
2032.     m$ = m$ + "................................" + Chr$(13) ' 21
2033.     m$ = m$ + "................................" + Chr$(13) ' 22
2034.     m$ = m$ + "................................" + Chr$(13) ' 23
2035.     m$ = m$ + "................................" + Chr$(13) ' 24
2036.     m$ = m$ + "................................" + Chr$(13) ' 25
2037.     m$ = m$ + "................................" + Chr$(13) ' 26
2038.     m$ = m$ + "................................" + Chr$(13) ' 27
2039.     m$ = m$ + "................................" + Chr$(13) ' 28
2040.     m$ = m$ + "................................" + Chr$(13) ' 29
2041.     m$ = m$ + "................................" + Chr$(13) ' 30
2042.     m$ = m$ + "................................" + Chr$(13) ' 31
2043.     m$ = m$ + "................................" + Chr$(13) ' 32
2044.     PetrText1$ = m$
2045. End Function ' PetrText1$
2046.  
2047. ' /////////////////////////////////////////////////////////////////////////////
2048.  
2049. Function ArrayToString$ (MyArray( 1 To 32 , 1 To 32) As String)
2050.     Dim MyString As String
2051.     Dim iY As Integer
2052.     Dim iX As Integer
2053.     Dim sLine As String
2054.     MyString = ""
2055.     For iY = LBound(MyArray, 1) To UBound(MyArray, 1)
2056.         sLine = ""
2057.         For iX = LBound(MyArray, 2) To UBound(MyArray, 2)
2058.             sLine = sLine + MyArray(iY, iX)
2059.         Next iX
2060.         MyString = MyString + sLine + Chr$(13)
2061.     Next iY
2062.     ArrayToString$ = MyString
2063. End Function ' ArrayToString$
2064.  
2065. ' /////////////////////////////////////////////////////////////////////////////
2066.  
2067. Function ArrayToStringTest$ (MyArray() As String)
2068.     Dim MyString As String
2069.     Dim iY As Integer
2070.     Dim iX As Integer
2071.     Dim sLine As String
2072.     MyString = ""
2073.  
2074.     MyString = MyString + "           11111111112222222222333" + Chr$(13)
2075.     MyString = MyString + "  12345678901234567890123456789012" + Chr$(13)
2076.     For iY = LBound(MyArray, 1) To UBound(MyArray, 1)
2077.         sLine = ""
2078.         sLine = sLine + Right$("  " + cstr$(iY), 2)
2079.         For iX = LBound(MyArray, 2) To UBound(MyArray, 2)
2080.             sLine = sLine + MyArray(iY, iX)
2081.         Next iX
2082.         sLine = sLine + Right$("  " + cstr$(iY), 2)
2083.         MyString = MyString + sLine + Chr$(13)
2084.     Next iY
2085.     MyString = MyString + "  12345678901234567890123456789012" + Chr$(13)
2086.     MyString = MyString + "           11111111112222222222333" + Chr$(13)
2087.     ArrayToStringTest$ = MyString
2088. End Function ' ArrayToStringTest$
2089.  
2090. ' /////////////////////////////////////////////////////////////////////////////
2091.  
2092. Function RotationArrayToStringTest$ (RoArray() As RotationType)
2093.     Dim MyString As String
2094.     Dim iY As Integer
2095.     Dim iX As Integer
2096.     Dim sLine As String
2097.     MyString = ""
2098.     MyString = MyString + "   ---------------- ++++++++++++++++" + Chr$(13)
2099.     MyString = MyString + "   1111111                   1111111" + Chr$(13)
2100.     MyString = MyString + "   654321098765432101234567890123456" + Chr$(13)
2101.     For iY = LBound(RoArray, 1) To UBound(RoArray, 1)
2102.         sLine = ""
2103.         sLine = sLine + Right$("    " + cstr$(iY), 3)
2104.         For iX = LBound(RoArray, 2) To UBound(RoArray, 2)
2105.             sLine = sLine + Chr$(RoArray(iX, iY, 0).c)
2106.         Next iX
2107.         sLine = sLine + Right$("   " + cstr$(iY), 3)
2108.         MyString = MyString + sLine + Chr$(13)
2109.     Next iY
2110.     MyString = MyString + "   654321098765432101234567890123456" + Chr$(13)
2111.     MyString = MyString + "   1111111                   1111111" + Chr$(13)
2112.     MyString = MyString + "   ---------------- ++++++++++++++++" + Chr$(13)
2113.     RotationArrayToStringTest$ = MyString
2114. End Function ' RotationArrayToStringTest$
2115.  
2116. ' /////////////////////////////////////////////////////////////////////////////
2117. ' 1. split string by line breaks CHR$(13)
2118. ' 2. split lines up to 1 column per char
2119. ' 3. count rows, columns
2120. ' 4. DIM array, making sure array has
2121. '    a) an _ODD_ number of rows/columns, with a center point
2122. '    b) index is in cartesian format, where center is (0,0)
2123. ' 5. populate array with contents of string
2124.  
2125. ' dimension #1 = columns
2126. ' dimension #2 = rows
2127.  
2128. Sub StringToRotationArray (RoArray() As RotationType, MyString As String, EmptyChar As String)
2129.     Dim RoutineName As String: RoutineName = "StringToRotationArray"
2130.     ReDim arrLines$(0)
2131.     Dim delim$
2132.     Dim iRow%
2133.     Dim iCol%
2134.     Dim sChar$
2135.     Dim iColCount As Integer
2136.     Dim iRowCount As Integer
2137.     Dim iCount As Integer
2138.     Dim bAddedRow As Integer: bAddedRow = FALSE
2139.     Dim bAddedColumn As Integer: bAddedColumn = FALSE
2140.     Dim iHalf1 As Integer
2141.     Dim iHalf2 As Integer
2142.     Dim iFrom1 As Integer
2143.     Dim iFrom2 As Integer
2144.     Dim iTo1 As Integer
2145.     Dim iTo2 As Integer
2146.     Dim iEmpty As Integer
2147.     Dim iX As Integer
2148.     Dim iY As Integer
2149.  
2150.     delim$ = Chr$(13)
2151.     split MyString, delim$, arrLines$()
2152.  
2153.     iRowCount = UBound(arrLines$) + 1
2154.  
2155.     ' look at all the rows and find the max # of columns used
2156.     iColCount = 0
2157.     For iRow% = LBound(arrLines$) To UBound(arrLines$)
2158.  
2159.         ' count the columns for this row
2160.         iCount = 0
2161.         For iCol% = 1 To Len(arrLines$(iRow%))
2162.             iCount = iCount + 1
2163.         Next iCol%
2164.  
2165.         ' if this row has the most so far, then set that to the max
2166.         If iCount > iColCount Then
2167.             iColCount = iCount
2168.         End If
2169.     Next iRow%
2170.  
2171.     ' adjust columns to be odd
2172.     If IsEven%(iColCount) Then
2173.         iColCount = iColCount + 1
2174.         bAddedColumn = TRUE
2175.     End If
2176.  
2177.     ' calculate array bounds for columns
2178.     iHalf1 = (iColCount - 1) / 2
2179.     iFrom1 = 0 - iHalf1
2180.     iTo1 = iHalf1
2181.  
2182.     ' adjust rows to be odd
2183.     If IsEven%(iRowCount) Then
2184.         iRowCount = iRowCount + 1
2185.         bAddedRow = TRUE
2186.     End If
2187.  
2188.     ' calculate array bounds for rows
2189.     iHalf2 = (iRowCount - 1) / 2
2190.     iFrom2 = 0 - iHalf2
2191.     iTo2 = iHalf2
2192.  
2193.     ' size array to new bounds
2194.     ReDim RoArray(iFrom1 To iTo1, iFrom2 To iTo2, 127) As RotationType
2195.  
2196.     ' get value for empty
2197.     If Len(EmptyChar) > 0 Then
2198.         iEmpty = Asc(EmptyChar)
2199.     Else
2200.         iEmpty = 32 ' (use space as default)
2201.     End If
2202.  
2203.     ' clear array
2204.     For iY = LBound(RoArray, 2) To UBound(RoArray, 2)
2205.         For iX = LBound(RoArray, 1) To UBound(RoArray, 1)
2206.             RoArray(iX, iY, 0).c = iEmpty
2207.             RoArray(iX, iY, 0).origx = iX
2208.             RoArray(iX, iY, 0).origy = iY
2209.         Next iX
2210.     Next iY
2211.  
2212.     ' fill array
2213.     iY = LBound(RoArray, 2) - 1
2214.     For iRow% = LBound(arrLines$) To UBound(arrLines$)
2215.         iY = iY + 1
2216.         iX = LBound(RoArray, 1) - 1
2217.         For iCol% = 1 To Len(arrLines$(iRow%))
2218.             iX = iX + 1
2219.             sChar$ = Mid$(arrLines$(iRow%), iCol%, 1)
2220.             RoArray(iX, iY, 0).c = Asc(sChar$)
2221.         Next iCol%
2222.     Next iRow%
2223.  
2224. End Sub ' StringToRotationArray
2225.  
2226. ' /////////////////////////////////////////////////////////////////////////////
2227.  
2228. Sub StringToArray (MyArray() As String, MyString As String)
2229.     Dim delim$
2230.     ReDim arrLines$(0)
2231.     Dim iRow%
2232.     Dim iCol%
2233.     Dim sChar$
2234.     Dim iDim1 As Integer
2235.     Dim iDim2 As Integer
2236.     iDim1 = LBound(MyArray, 1)
2237.     iDim2 = LBound(MyArray, 2)
2238.     delim$ = Chr$(13)
2239.     split MyString, delim$, arrLines$()
2240.     For iRow% = LBound(arrLines$) To UBound(arrLines$)
2241.         If iRow% <= UBound(MyArray, 2) Then
2242.             For iCol% = 1 To Len(arrLines$(iRow%))
2243.                 If iCol% <= UBound(MyArray, 1) Then
2244.                     sChar$ = Mid$(arrLines$(iRow%), iCol%, 1)
2245.  
2246.                     If Len(sChar$) > 1 Then
2247.                         sChar$ = Left$(sChar$, 1)
2248.                     Else
2249.                         If Len(sChar$) = 0 Then
2250.                             sChar$ = "."
2251.                         End If
2252.                     End If
2253.                     MyArray(iRow% + iDim1, (iCol% - 1) + iDim2) = sChar$
2254.                 Else
2255.                     ' Exit if out of bounds
2256.                     Exit For
2257.                 End If
2258.             Next iCol%
2259.         Else
2260.             ' Exit if out of bounds
2261.             Exit For
2262.         End If
2263.     Next iRow%
2264. End Sub ' StringToArray
2265.  
2266. ' /////////////////////////////////////////////////////////////////////////////
2267.  
2268. 'SUB ClearArray (MyArray(1 To 32, 1 To 32) AS STRING, MyString As String)
2269. Sub ClearArray (MyArray() As String, MyString As String)
2270.     Dim iRow As Integer
2271.     Dim iCol As Integer
2272.     Dim sChar$
2273.     If Len(MyString) = 1 Then
2274.         sChar$ = MyString
2275.     Else
2276.         If Len(MyString) = 0 Then
2277.             sChar$ = " "
2278.         Else
2279.             sChar$ = Left$(MyString, 1)
2280.         End If
2281.     End If
2282.     For iRow = LBound(MyArray, 1) To UBound(MyArray, 1)
2283.         For iCol = LBound(MyArray, 2) To UBound(MyArray, 2)
2284.             MyArray(iRow, iCol) = sChar$
2285.         Next iCol
2286.     Next iRow
2287. End Sub ' ClearArray
2288.  
2289. ' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2290. ' BEGIN GENERAL PURPOSE ROUTINES
2291. ' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2292.  
2293. ' /////////////////////////////////////////////////////////////////////////////
2294.  
2295. Function cstr$ (myValue)
2296.     'cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
2297.     cstr$ = _Trim$(Str$(myValue))
2298. End Function ' cstr$
2299.  
2300. Function cstrl$ (myValue As Long)
2301.     cstrl$ = _Trim$(Str$(myValue))
2302. End Function ' cstrl$
2303.  
2304. ' /////////////////////////////////////////////////////////////////////////////
2305.  
2306. Function IIF (Condition, IfTrue, IfFalse)
2307.     If Condition Then IIF = IfTrue Else IIF = IfFalse
2308. End Function
2309.  
2310. ' /////////////////////////////////////////////////////////////////////////////
2311.  
2312. Function IIFSTR$ (Condition, IfTrue$, IfFalse$)
2313.     If Condition Then IIFSTR$ = IfTrue$ Else IIFSTR$ = IfFalse$
2314. End Function
2315.  
2316. ' /////////////////////////////////////////////////////////////////////////////
2317. ' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
2318.  
2319. Function IsEven% (n)
2320.     If n Mod 2 = 0 Then
2321.         IsEven% = TRUE
2322.     Else
2323.         IsEven% = FALSE
2324.     End If
2325. End Function ' IsEven%
2326.  
2327. ' /////////////////////////////////////////////////////////////////////////////
2328. ' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
2329.  
2330. Function IsOdd% (n)
2331.     If n Mod 2 = 1 Then
2332.         IsOdd% = TRUE
2333.     Else
2334.         IsOdd% = FALSE
2335.     End If
2336. End Function ' IsOdd%
2337.  
2338. ' /////////////////////////////////////////////////////////////////////////////
2339. ' By sMcNeill from https://www.qb64.org/forum/index.php?topic=896.0
2340.  
2341. Function IsNum% (text$)
2342.     Dim a$
2343.     Dim b$
2344.     a$ = _Trim$(text$)
2345.     b$ = _Trim$(Str$(Val(text$)))
2346.     If a$ = b$ Then
2347.         IsNum% = TRUE
2348.     Else
2349.         IsNum% = FALSE
2350.     End If
2351. End Function ' IsNum%
2352.  
2353. ' /////////////////////////////////////////////////////////////////////////////
2354. ' Split and join strings
2355. ' https://www.qb64.org/forum/index.php?topic=1073.0
2356.  
2357. 'Combine all elements of in$() into a single string with delimiter$ separating the elements.
2358.  
2359. Function join$ (in$(), delimiter$)
2360.     result$ = in$(LBound(in$))
2361.     For i = LBound(in$) + 1 To UBound(in$)
2362.         result$ = result$ + delimiter$ + in$(i)
2363.     Next i
2364.     join$ = result$
2365. End Function ' join$
2366.  
2367. ' /////////////////////////////////////////////////////////////////////////////
2368. ' FROM: String Manipulation
2369. ' http://www.[abandoned, outdated and now likely malicious qb64 dot net website - don’t go there]/forum/index_topic_5964-0/
2370. '
2371. 'SUMMARY:
2372. '   Purpose:  A library of custom functions that transform strings.
2373. '   Author:   Dustinian Camburides (dustinian@gmail.com)
2374. '   Platform: QB64 (www.[abandoned, outdated and now likely malicious qb64 dot net website - don’t go there])
2375. '   Revision: 1.6
2376. '   Updated:  5/28/2012
2377.  
2378. 'SUMMARY:
2379. '[Replace$] replaces all instances of the [Find] sub-string with the [Add] sub-string within the [Text] string.
2380. 'INPUT:
2381. 'Text: The input string; the text that's being manipulated.
2382. 'Find: The specified sub-string; the string sought within the [Text] string.
2383. 'Add: The sub-string that's being added to the [Text] string.
2384.  
2385. Function Replace$ (Text1 As String, Find1 As String, Add1 As String)
2386.     ' VARIABLES:
2387.     Dim Text2 As String
2388.     Dim Find2 As String
2389.     Dim Add2 As String
2390.     Dim lngLocation As Long ' The address of the [Find] substring within the [Text] string.
2391.     Dim strBefore As String ' The characters before the string to be replaced.
2392.     Dim strAfter As String ' The characters after the string to be replaced.
2393.  
2394.     ' INITIALIZE:
2395.     ' MAKE COPIESSO THE ORIGINAL IS NOT MODIFIED (LIKE ByVal IN VBA)
2396.     Text2 = Text1
2397.     Find2 = Find1
2398.     Add2 = Add1
2399.  
2400.     lngLocation = InStr(1, Text2, Find2)
2401.  
2402.     ' PROCESSING:
2403.     ' While [Find2] appears in [Text2]...
2404.     While lngLocation
2405.         ' Extract all Text2 before the [Find2] substring:
2406.         strBefore = Left$(Text2, lngLocation - 1)
2407.  
2408.         ' Extract all text after the [Find2] substring:
2409.         strAfter = Right$(Text2, ((Len(Text2) - (lngLocation + Len(Find2) - 1))))
2410.  
2411.         ' Return the substring:
2412.         Text2 = strBefore + Add2 + strAfter
2413.  
2414.         ' Locate the next instance of [Find2]:
2415.         lngLocation = InStr(1, Text2, Find2)
2416.  
2417.         ' Next instance of [Find2]...
2418.     Wend
2419.  
2420.     ' OUTPUT:
2421.     Replace$ = Text2
2422. End Function ' Replace$
2423.  
2424. ' /////////////////////////////////////////////////////////////////////////////
2425. ' Split and join strings
2426. ' https://www.qb64.org/forum/index.php?topic=1073.0
2427. '
2428. ' FROM luke, QB64 Developer
2429. ' Date: February 15, 2019, 04:11:07 AM
2430. '
2431. ' Given a string of words separated by spaces (or any other character),
2432. ' splits it into an array of the words. I've no doubt many people have
2433. ' written a version of this over the years and no doubt there's a million
2434. ' ways to do it, but I thought I'd put mine here so we have at least one
2435. ' version. There's also a join function that does the opposite
2436. ' array -> single string.
2437. '
2438. ' Code is hopefully reasonably self explanatory with comments and a little demo.
2439. ' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.
2440.  
2441. 'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences
2442. 'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$().
2443. '
2444. 'delimiter$ must be one character long.
2445. 'result$() must have been REDIMmed previously.
2446.  
2447. Sub split (in$, delimiter$, result$())
2448.     ReDim result$(-1)
2449.     start = 1
2450.     Do
2451.         While Mid$(in$, start, 1) = delimiter$
2452.             start = start + 1
2453.             If start > Len(in$) Then Exit Sub
2454.         Wend
2455.         finish = InStr(start, in$, delimiter$)
2456.         If finish = 0 Then finish = Len(in$) + 1
2457.         ReDim _Preserve result$(0 To UBound(result$) + 1)
2458.         result$(UBound(result$)) = Mid$(in$, start, finish - start)
2459.         start = finish + 1
2460.     Loop While start <= Len(in$)
2461. End Sub ' split
2462.  
2463. ' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2464. ' END GENERAL PURPOSE ROUTINES
2465. ' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2466.  
2467. ' #END
2468. ' ################################################################################################################################################################
2469.  

[SMcNeill]

Now, let me start off by apologizing and saying that I haven't actually tried any of the code in this topic at all.  Life has had me busy as heck the last few weeks, and all I've did is skim this topic and view the pretty images.  From what I gather, is this the type of effect which you're trying to generate?

Code: QB64: [Select]

1. Width 80, 50
2.  
3. Do
4.     Cls
5.     Print Time$
6.     DrawText 5, 40, "Second Hand on Clock", (Timer Mod 60) * 6
7.     _Limit 60
8. Loop Until _KeyHit
9.  
10.  
11.  
12. Sub DrawText (x, y, Text$, angle)
13.     Dim ScreenArray(_Width, _Height) As _Byte
14.     A = _D2R(angle - 90)
15.     For i = 1 To Len(Text$)
16.         t = Asc(Text$, i)
17.         Do
18.             xPos = x + Sin(A) * radius: If xPos < 1 Or xPos > _Height Then Exit Do
19.             yPos = y + Cos(A) * radius: If yPos < 1 Or yPos > _Width Then Exit Do
20.  
21.             If ScreenArray(yPos, xPos) = 0 Then ScreenArray(yPos, xPos) = t: Exit Do
22.             radius = radius + 1
23.         Loop
24.     Next
25.     For x = 1 To _Width
26.         For y = 1 To _Height
27.             If ScreenArray(x, y) Then
28.                 _PrintString (x, y), Chr$(ScreenArray(x, y))
29.             End If
30.         Next
31.     Next
32. End Sub

It's a pretty little SCREEN 0 clock hand!  ;D

EDIT: Added some error checking for when the text might try to print off screen for us.

[madscijr]

Now, let me start off by apologizing and saying that I haven't actually tried any of the code in this topic at all.  Life has had me busy as heck the last few weeks, and all I've did is skim this topic and view the pretty images.  From what I gather, is this the type of effect which you're trying to generate?

Code: QB64: [Select]

1. Width 80, 50
2.  
3. Do
4.     Cls
5.     Print Time$
6.     DrawText 5, 40, "Second Hand on Clock", (Timer Mod 60) * 6
7.     _Limit 60
8. Loop Until _KeyHit
9.  
10.  
11.  
12. Sub DrawText (x, y, Text$, angle)
13.     Dim ScreenArray(_Width, _Height) As _Byte
14.     A = _D2R(angle - 90)
15.     For i = 1 To Len(Text$)
16.         t = Asc(Text$, i)
17.         Do
18.             xPos = x + Sin(A) * radius: If xPos < 1 Or xPos > _Height Then Exit Do
19.             yPos = y + Cos(A) * radius: If yPos < 1 Or yPos > _Width Then Exit Do
20.  
21.             If ScreenArray(yPos, xPos) = 0 Then ScreenArray(yPos, xPos) = t: Exit Do
22.             radius = radius + 1
23.         Loop
24.     Next
25.     For x = 1 To _Width
26.         For y = 1 To _Height
27.             If ScreenArray(x, y) Then
28.                 _PrintString (x, y), Chr$(ScreenArray(x, y))
29.             End If
30.         Next
31.     Next
32. End Sub

It's a pretty little SCREEN 0 clock hand!  ;D

EDIT: Added some error checking for when the text might try to print off screen for us.

Thanks @SMcNeill  for your reply.
So if I'm understanding the code right, it checks to see if the point we're rotating to is occupied, and if it is, it simply increases the radius by 1 and tries moving the point there?
That's so much easier than what I was trying and discussing with @STxAxTIC.
Very elegant... if I can get it to work!
The problem I'm having is when I try translating it to rotate a 2D array, it just stays stuck at 180 degrees...?
Your code didn't really declare the variables, am I maybe breaking something by declaring something the wrong type?
I'm sure it's due to some dumb error on my part...

Code: QB64: [Select]

1. ' Uses SMcNeill's solution to rotation plotting 2 points to the same coordinates
2. ' https://qb64forum.alephc.xyz/index.php?action=post;quote=139325;topic=4502.0
3.  
4. Const FALSE = 0
5. Const TRUE = Not FALSE
6. Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
7. Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
8. Dim Shared m_bDebug As Integer : m_bDebug = FALSE
9. Dim Shared m_iMapMinX As Integer: m_iMapMinX = 1
10. Dim Shared m_iMapMaxX As Integer: m_iMapMaxX = 32
11. Dim Shared m_iMapMinY As Integer: m_iMapMinY = 1
12. Dim Shared m_iMapMaxY As Integer: m_iMapMaxY = 32
13. Dim Shared m_arrText(m_iMapMinX To m_iMapMaxX, m_iMapMinY To m_iMapMaxY) As String
14. Dim Shared m_arrNew(m_iMapMinX To m_iMapMaxX, m_iMapMinY To m_iMapMaxY) As String
15.  
16. ' ACTIVATE DEBUGGING WINDOW
17. IF m_bDebug = TRUE THEN
18.         $Console
19.         _Delay 4
20.         _Console On
21.         _Echo "Started " + m_ProgramName$
22.         _Echo "Debugging on..."
23. END IF
24.  
25. Dim in$
26. main
27. 'input "PRESS <ENTER> TO EXIT";in$
28.  
29. ' DISABLE DEBUGGING
30. IF m_bDebug = TRUE THEN
31.         _Console Off
32. END IF
33. end
34.  
35. ' /////////////////////////////////////////////////////////////////////////////
36.  
37. sub main
38.         dim iAngle as integer
39.         Width 80, 80
40.         StringToArray m_arrText(), SteveText1$
41.         Do
42.                 for iAngle = 0 to 360
43.                         DrawText iAngle
44.                         input "PRESS <ENTER> TO CONTINUE OR q TO QUIT";in$
45.                         if in$="q" then exit do
46.                 next iAngle
47.                 for iAngle = 360 to 0 step -1
48.                         DrawText iAngle
49.                         input "PRESS <ENTER> TO CONTINUE OR q TO QUIT";in$
50.                         if in$="q" then exit do
51.                 next iAngle
52.                 _Limit 1
53.         Loop Until _KeyHit
54. end sub ' main
55.  
56. ' /////////////////////////////////////////////////////////////////////////////
57.  
58. Sub DrawText (angle)
59.         dim x as integer
60.         dim y as integer
61.     dim A
62.         dim i
63.         dim t as string
64.         dim xPos
65.         dim yPos
66.         dim radius
67.         dim sLine as string
68.         dim iBefore as integer
69.         dim iAfter as integer
70.         dim iMissing as integer
71.         dim in$
72.        
73.         ' init rotated matrix m_arrNew
74.         ' and count characters in original matrix m_arrText
75.         iBefore = 0
76.         for y = m_iMapMinY to m_iMapMaxY
77.                 for x = m_iMapMinX to m_iMapMaxX
78.                         if m_arrText(x, y) <> "." then
79.                                 iBefore = iBefore + 1
80.                         end if
81.                         m_arrNew(x, y) = "."
82.                 next x
83.         next y
84.        
85.         ' rotate all points in matrix m_arrText
86.         ' plotting them to m_arrNew
87.         for y = m_iMapMinY to m_iMapMaxY
88.                 for x = m_iMapMinX to m_iMapMaxX
89.                         A = _D2R(angle - 90) ' The _D2R function converts a degree value into a radian value.
90.                         t = m_arrText(x, y)
91.                        
92.                         IF m_bDebug = TRUE THEN
93.                                 _echo "rotating " + chr$(34) + t + chr$(34) + " from x=" + _Trim$(Str$(x)) + ", " + "y=" + _Trim$(Str$(y))
94.                         END IF
95.                        
96.                         radius = 0
97.                         Do
98.                                 xPos = x + Sin(A) * radius
99.                                 If xPos < m_iMapMinX Or xPos > m_iMapMaxX Then
100.                                         IF m_bDebug = TRUE THEN
101.                                                 _echo "    illegal xPos: " + _Trim$(Str$(xPos))
102.                                         END IF
103.                                         Exit Do
104.                                 end if
105.                                
106.                                 yPos = y + Cos(A) * radius
107.                                 If yPos < m_iMapMinY Or yPos > m_iMapMaxY Then
108.                                         IF m_bDebug = TRUE THEN
109.                                                 _echo "    illegal yPos: " + _Trim$(Str$(yPos))
110.                                         END IF
111.                                         Exit Do
112.                                 end if
113.                                
114.                                 If m_arrNew(xPos, yPos) = "." Then
115.                                         m_arrNew(xPos, yPos) = t
116.                                         IF m_bDebug = TRUE THEN
117.                                                 _echo "    rotated " + chr$(34) + t + chr$(34) + " to x=" + _Trim$(Str$(x)) + ", " + "y=" + _Trim$(Str$(y))
118.                                         END IF
119.                                         Exit Do
120.                                 end if
121.                                
122.                                 radius = radius + 1
123.                                 IF m_bDebug = TRUE THEN
124.                                         _echo "    increasing radius: " + _Trim$(Str$(radius))
125.                                 END IF
126.                         Loop
127.                 next x
128.         next y
129.        
130.         ' show the rotated matrix
131.         cls
132.         print "Angle: " + _Trim$(Str$(angle))
133.         iAfter = 0
134.         For y = m_iMapMinY To m_iMapMaxY
135.                 sLine = ""
136.                 For x = m_iMapMinX To m_iMapMaxX
137.                         sLine = sLine + m_arrNew(x,y)
138.                         ' count the characters in the new rotated matrix
139.                         if m_arrNew(x, y) <> "." then
140.                                 iAfter = iAfter + 1
141.                         end if
142.                 Next x
143.                 print sLine
144.         Next y
145.        
146.         ' if any characters are missing, show how many
147.         iMissing = iBefore - iAfter
148.         if iMissing > 0 then
149.                 print "# points missing: " + _Trim$(Str$(iMissing))
150.         end if
151.        
152. End Sub ' DrawText
153.  
154. ' /////////////////////////////////////////////////////////////////////////////
155.  
156. Function SteveText1$
157.     Dim m$
158.     m$ = ""
159.     '                   11111111112222222222333
160.     '          12345678901234567890123456789012
161.     m$ = m$ + "................................" + Chr$(13) ' 1
162.     m$ = m$ + "................................" + Chr$(13) ' 2
163.     m$ = m$ + "................................" + Chr$(13) ' 3
164.     m$ = m$ + "................................" + Chr$(13) ' 4
165.     m$ = m$ + "................................" + Chr$(13) ' 5
166.     m$ = m$ + "................................" + Chr$(13) ' 6
167.     m$ = m$ + "................................" + Chr$(13) ' 7
168.     m$ = m$ + "................................" + Chr$(13) ' 8
169.     m$ = m$ + "................................" + Chr$(13) ' 9
170.     m$ = m$ + "................................" + Chr$(13) ' 10
171.     m$ = m$ + "................................" + Chr$(13) ' 11
172.     m$ = m$ + "................................" + Chr$(13) ' 12
173.     m$ = m$ + "................................" + Chr$(13) ' 13
174.     m$ = m$ + "................................" + Chr$(13) ' 14
175.     m$ = m$ + "......Second.Hand.on.Clock......" + Chr$(13) ' 15
176.     m$ = m$ + "................................" + Chr$(13) ' 16
177.     m$ = m$ + "................................" + Chr$(13) ' 17
178.     m$ = m$ + "................................" + Chr$(13) ' 18
179.     m$ = m$ + "................................" + Chr$(13) ' 19
180.     m$ = m$ + "................................" + Chr$(13) ' 20
181.     m$ = m$ + "................................" + Chr$(13) ' 21
182.     m$ = m$ + "................................" + Chr$(13) ' 22
183.     m$ = m$ + "................................" + Chr$(13) ' 23
184.     m$ = m$ + "................................" + Chr$(13) ' 24
185.     m$ = m$ + "................................" + Chr$(13) ' 25
186.     m$ = m$ + "................................" + Chr$(13) ' 26
187.     m$ = m$ + "................................" + Chr$(13) ' 27
188.     m$ = m$ + "................................" + Chr$(13) ' 28
189.     m$ = m$ + "................................" + Chr$(13) ' 29
190.     m$ = m$ + "................................" + Chr$(13) ' 30
191.     m$ = m$ + "................................" + Chr$(13) ' 31
192.     m$ = m$ + "................................" + Chr$(13) ' 32
193.     SteveText1$ = m$
194. End Function ' SteveText1$
195.  
196. ' /////////////////////////////////////////////////////////////////////////////
197.  
198. Function PetrText1$
199.     Dim m$
200.     m$ = ""
201.     '                   11111111112222222222333
202.     '          12345678901234567890123456789012
203.     m$ = m$ + "................................" + Chr$(13) ' 1
204.     m$ = m$ + "................................" + Chr$(13) ' 2
205.     m$ = m$ + "................................" + Chr$(13) ' 3
206.     m$ = m$ + "................................" + Chr$(13) ' 4
207.     m$ = m$ + "................................" + Chr$(13) ' 5
208.     m$ = m$ + "................................" + Chr$(13) ' 6
209.     m$ = m$ + "................................" + Chr$(13) ' 7
210.     m$ = m$ + "................................" + Chr$(13) ' 8
211.     m$ = m$ + "................................" + Chr$(13) ' 9
212.     m$ = m$ + "................................" + Chr$(13) ' 10
213.     m$ = m$ + "................................" + Chr$(13) ' 11
214.     m$ = m$ + "................................" + Chr$(13) ' 12
215.     m$ = m$ + "................................" + Chr$(13) ' 13
216.     m$ = m$ + "................................" + Chr$(13) ' 14
217.     m$ = m$ + "....It's a SCREEN resolution?..." + Chr$(13) ' 15
218.     m$ = m$ + "................................" + Chr$(13) ' 16
219.     m$ = m$ + "................................" + Chr$(13) ' 17
220.     m$ = m$ + "................................" + Chr$(13) ' 18
221.     m$ = m$ + "................................" + Chr$(13) ' 19
222.     m$ = m$ + "................................" + Chr$(13) ' 20
223.     m$ = m$ + "................................" + Chr$(13) ' 21
224.     m$ = m$ + "................................" + Chr$(13) ' 22
225.     m$ = m$ + "................................" + Chr$(13) ' 23
226.     m$ = m$ + "................................" + Chr$(13) ' 24
227.     m$ = m$ + "................................" + Chr$(13) ' 25
228.     m$ = m$ + "................................" + Chr$(13) ' 26
229.     m$ = m$ + "................................" + Chr$(13) ' 27
230.     m$ = m$ + "................................" + Chr$(13) ' 28
231.     m$ = m$ + "................................" + Chr$(13) ' 29
232.     m$ = m$ + "................................" + Chr$(13) ' 30
233.     m$ = m$ + "................................" + Chr$(13) ' 31
234.     m$ = m$ + "................................" + Chr$(13) ' 32
235.     PetrText1$ = m$
236. End Function ' PetrText1$
237.  
238. ' /////////////////////////////////////////////////////////////////////////////
239.  
240. Sub StringToArray (MyArray() As String, MyString As String)
241.     Dim delim$
242.     ReDim arrLines$(0)
243.     Dim iRow%
244.     Dim iCol%
245.     Dim sChar$
246.     Dim iDim1 As Integer
247.     Dim iDim2 As Integer
248.     iDim1 = LBound(MyArray, 1)
249.     iDim2 = LBound(MyArray, 2)
250.     delim$ = Chr$(13)
251.     split MyString, delim$, arrLines$()
252.     For iRow% = LBound(arrLines$) To UBound(arrLines$)
253.         If iRow% <= UBound(MyArray, 2) Then
254.             For iCol% = 1 To Len(arrLines$(iRow%))
255.                 If iCol% <= UBound(MyArray, 1) Then
256.                     sChar$ = Mid$(arrLines$(iRow%), iCol%, 1)
257.  
258.                     If Len(sChar$) > 1 Then
259.                         sChar$ = Left$(sChar$, 1)
260.                     Else
261.                         If Len(sChar$) = 0 Then
262.                             sChar$ = "."
263.                         End If
264.                     End If
265.                     MyArray(iRow% + iDim1, (iCol% - 1) + iDim2) = sChar$
266.                 Else
267.                     ' Exit if out of bounds
268.                     Exit For
269.                 End If
270.             Next iCol%
271.         Else
272.             ' Exit if out of bounds
273.             Exit For
274.         End If
275.     Next iRow%
276. End Sub ' StringToArray
277.  
278. ' /////////////////////////////////////////////////////////////////////////////
279.  
280. 'SUB ClearArray (MyArray(1 To 32, 1 To 32) AS STRING, MyString As String)
281. Sub ClearArray (MyArray() As String, MyString As String)
282.     Dim iRow As Integer
283.     Dim iCol As Integer
284.     Dim sChar$
285.     If Len(MyString) = 1 Then
286.         sChar$ = MyString
287.     Else
288.         If Len(MyString) = 0 Then
289.             sChar$ = " "
290.         Else
291.             sChar$ = Left$(MyString, 1)
292.         End If
293.     End If
294.     For iRow = LBound(MyArray, 1) To UBound(MyArray, 1)
295.         For iCol = LBound(MyArray, 2) To UBound(MyArray, 2)
296.             MyArray(iRow, iCol) = sChar$
297.         Next iCol
298.     Next iRow
299. End Sub ' ClearArray
300.  
301. ' /////////////////////////////////////////////////////////////////////////////
302. ' Split and join strings
303. ' https://www.qb64.org/forum/index.php?topic=1073.0
304. '
305. ' FROM luke, QB64 Developer
306. ' Date: February 15, 2019, 04:11:07 AM »
307. '
308. ' Given a string of words separated by spaces (or any other character),
309. ' splits it into an array of the words. I've no doubt many people have
310. ' written a version of this over the years and no doubt there's a million
311. ' ways to do it, but I thought I'd put mine here so we have at least one
312. ' version. There's also a join function that does the opposite
313. ' array -> single string.
314. '
315. ' Code is hopefully reasonably self explanatory with comments and a little demo.
316. ' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.
317.  
318. 'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences
319. 'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$().
320. '
321. 'delimiter$ must be one character long.
322. 'result$() must have been REDIMmed previously.
323.  
324. ' Modified to handle multi-character delimiters
325.  
326. Sub split (in$, delimiter$, result$())
327.     Dim start As Integer
328.     Dim finish As Integer
329.     Dim iDelimLen As Integer
330.     ReDim result$(-1)
331.  
332.     iDelimLen = Len(delimiter$)
333.  
334.     start = 1
335.     Do
336.         'While Mid$(in$, start, 1) = delimiter$
337.         While Mid$(in$, start, iDelimLen) = delimiter$
338.             'start = start + 1
339.             start = start + iDelimLen
340.             If start > Len(in$) Then
341.                 Exit Sub
342.             End If
343.         Wend
344.         finish = InStr(start, in$, delimiter$)
345.         If finish = 0 Then
346.             finish = Len(in$) + 1
347.         End If
348.  
349.         ReDim _Preserve result$(0 To UBound(result$) + 1)
350.  
351.         result$(UBound(result$)) = Mid$(in$, start, finish - start)
352.         start = finish + 1
353.     Loop While start <= Len(in$)
354. End Sub ' split
355.  

[madscijr]

Now, let me start off by apologizing and saying that I haven't actually tried any of the code in this topic at all.  Life has had me busy as heck the last few weeks, and all I've did is skim this topic and view the pretty images.  From what I gather, is this the type of effect which you're trying to generate?

Code: QB64: [Select]

1. Width 80, 50
2.  
3. Do
4.     Cls
5.     Print Time$
6.     DrawText 5, 40, "Second Hand on Clock", (Timer Mod 60) * 6
7.     _Limit 60
8. Loop Until _KeyHit
9.  
10.  
11.  
12. Sub DrawText (x, y, Text$, angle)
13.     Dim ScreenArray(_Width, _Height) As _Byte
14.     A = _D2R(angle - 90)
15.     For i = 1 To Len(Text$)
16.         t = Asc(Text$, i)
17.         Do
18.             xPos = x + Sin(A) * radius: If xPos < 1 Or xPos > _Height Then Exit Do
19.             yPos = y + Cos(A) * radius: If yPos < 1 Or yPos > _Width Then Exit Do
20.  
21.             If ScreenArray(yPos, xPos) = 0 Then ScreenArray(yPos, xPos) = t: Exit Do
22.             radius = radius + 1
23.         Loop
24.     Next
25.     For x = 1 To _Width
26.         For y = 1 To _Height
27.             If ScreenArray(x, y) Then
28.                 _PrintString (x, y), Chr$(ScreenArray(x, y))
29.             End If
30.         Next
31.     Next
32. End Sub

It's a pretty little SCREEN 0 clock hand!  ;D

EDIT: Added some error checking for when the text might try to print off screen for us.

In fact, I'm having trouble just using the formula to calculate any values at all...
What am I doing wrong?

Code: QB64: [Select]

1. dim angle as integer
2. dim x as integer
3. dim y as integer
4. dim A
5. dim radius
6. dim xPos
7. dim yPos
8. dim in$
9.  
10. radius = 0
11. x = 10
12. y = 10
13. For angle = 20 to 40
14.         A = _D2R(angle - 90) ' The _D2R function converts a degree value into a radian value.
15.         yPos = y + Cos(A) * radius
16.         xPos = x + Sin(A) * radius
17.        
18.         print _Trim$(Str$(x)) + "," + _Trim$(Str$(y)) + _
19.                 " rotated to " + _Trim$(Str$(angle)) + " deg = " + _
20.                 _Trim$(Str$(xPos)) + "," + _Trim$(Str$(yPos))
21. Next angle
22.  
23. input "PRESS <ENTER> TO CONTINUE";in$
24. end
25.  

Update: I tried changing everything to the same data type (tried double and single), but still no change.
This is one of those days where I feel like I can't program my way out of a wet paper bag! :-p

Code: QB64: [Select]

1. Width 80, 80
2.  
3. Dim angle As Double
4. Dim x As Double
5. Dim y As Double
6. Dim A As Double
7. Dim radius As Double
8. Dim xPos As Double
9. Dim yPos As Double
10. Dim in$
11.  
12. radius = 0
13. x = 10
14. y = 10
15. For angle = 0 To 45
16.     A = _D2R(angle - 90) ' The _D2R function converts a degree value into a radian value.
17.     yPos = y + Cos(A) * radius
18.     xPos = x + Sin(A) * radius
19.  
20.     print "" + _
21.         "A=" + _Trim$(Str$(A)) + _
22.         "Cos(A) = " + _Trim$(Str$(Cos(A))) + _
23.         _Trim$(Str$(x)) + "," + _Trim$(Str$(y)) + _
24.         " rotated to " + _Trim$(Str$(angle)) + " deg = " + _
25.         _Trim$(Str$(xPos)) + "," + _Trim$(Str$(yPos))
26. Next angle
27.  
28. Input "PRESS <ENTER> TO CONTINUE"; in$
29. End
30.  

[SMcNeill]

Let me just go through what I've got here, and I'll explain the process for you line by line (more or less).

The whole:

Code: [Select]

Sub DrawText (x, y, Text$, angle)
    Dim ScreenArray(_Width, _Height) As _Byte
    A = _D2R(angle - 90)
    For i = 1 To Len(Text$)
        t = Asc(Text$, i)
        Do
            xPos = x + Sin(A) * radius: If xPos < 1 Or xPos > _Height Then Exit Do
            yPos = y + Cos(A) * radius: If yPos < 1 Or yPos > _Width Then Exit Do

            If ScreenArray(yPos, xPos) = 0 Then ScreenArray(yPos, xPos) = t: Exit Do
            radius = radius + 1
        Loop
    Next
    For x = 1 To _Width
        For y = 1 To _Height
            If ScreenArray(x, y) Then
                _PrintString (x, y), Chr$(ScreenArray(x, y))
            End If
        Next
    Next
End Sub
And now to dissect that whole:

Sub DrawText (x, y, Text$, angle) --- X and Y here represent the center point of where we want to place our text.  TEXT$ is what we want to place onto the screen, and ANGLE is the amount of rotation we want that text to have.

    Dim ScreenArray(_Width, _Height) As _Byte  --- This creates an array for us the same size as our text screen.  All the work I[m doing is going to take place within this array, until I'm actually ready to draw onto the screen itself.

    A = _D2R(angle - 90) --- This is our angle conversion from degrees to radians, with a correction to start in the top center of our circle, just as a clock starts with 12 o'clock as being up at the very top.

    For i = 1 To Len(Text$)  ---   This line runs us a loop from the first letter in our text to the last letter of the text, so we can figure out where to place each character correctly.

        t = Asc(Text$, i) --- Here, I'm just getting the character that I want to work with out of that whole length of text.

        Do --- This starts the internal loop for determining proper positioning

            xPos = x + Sin(A) * radius: If xPos < 1 Or xPos > _Height Then Exit Do  --- A two part line.  The first calculates where to put the text on the screen.  x is our original center.  SIN(A) is the angle we're rotating by.  RADIUS is how far from the center we need to go to place this character.   IF this calculated xPOSition is off the screen -- either by being off the top (less than 1) or off the right (greater than our _HEIGHT of the screen), we can now quit calculating as we can't actually plot this character.  It's off the screen, after all!

            yPos = y + Cos(A) * radius: If yPos < 1 Or yPos > _Width Then Exit Do  --- This is basically the same as the line above, except it calculates our y position.  (Remember, in SCREEN 0 x and y are reversed as they actually represent row and column rather than width and height.)

            If ScreenArray(yPos, xPos) = 0 Then ScreenArray(yPos, xPos) = t: Exit Do  ---  Now, this line basically checks to see if we've plotted to this point already.  Sometimes, as you've noticed yourself, characters might try to overlap.  If this character wants to overlap with a previous one, we simply don't draw it yet and move on with the process to actually calculate where to draw it.

            radius = radius + 1  ---  If we haven't plotted our character yet, then we simply increase the radius by one to move it out another point to recalculate the proper spot.

        Loop  ---  And then we repeat the process until we either find the right spot for this character, or we determine it's going to be off the screen.

    Next  --- If we've gotten to this point, we have now decided either where to place our specific character, or else we've decided that the character in question is going to off the screen.   We can now move on to the next character, until we go through the process for the whole string of text.


    For x = 1 To _Width
        For y = 1 To _Height
            If ScreenArray(x, y) Then
                _PrintString (x, y), Chr$(ScreenArray(x, y))
            End If
        Next
    Next
End Sub

And, I think I can more or less explain this whole batch of code here by simply saying, "This is where we actually check our finished array for our text values, and then simply print them to the corresponding spots on our text screen.


The whole process is actually rather simple, and here's the logic behind it:

Make a blank array the same size as the screen.

Since that array is blank, all the values for it default and start at zero.

Calculate the position for each character we want to plot to the screen.

Check that position vs our array.  If the array is zero (blank) in the spot where we want to put our text, let the array hold the character value that we're going to print.  Otherwise, simply move out another point on the radius and check again, until we find an empty spot in that array to put our text, or determine we've went off-screen.

Once we've did this for all our characters, all we have to do is simply run that array through a loop and LOCATE/PRINT to the screen in the corresponding positions to our array.

It's that simple of a process.

Calculate the position of a character centered at X/Y, with a radius of 0, at the desired angle.
Save that character's position
DO
    Calculate the position of a character centered at X/Y, with a radius of 1, at the desired angle.
    IF that position isn't already written to, save it.  Otherwise, increase the radius by 1 and try again.
LOOP until we're done with all our characters.
Finally plot those saved positions to the screen.

[SMcNeill]

Update: I tried changing everything to the same data type (tried double and single), but still no change.
This is one of those days where I feel like I can't program my way out of a wet paper bag! :-p

Code: QB64: [Select]

1. Width 80, 80
2.  
3. Dim angle As Double
4. Dim x As Double
5. Dim y As Double
6. Dim A As Double
7. Dim radius As Double
8. Dim xPos As Double
9. Dim yPos As Double
10. Dim in$
11.  
12. radius = 0
13. x = 10
14. y = 10
15. For angle = 0 To 45
16.     A = _D2R(angle - 90) ' The _D2R function converts a degree value into a radian value.
17.     yPos = y + Cos(A) * radius
18.     xPos = x + Sin(A) * radius
19.  
20.     print "" + _
21.         "A=" + _Trim$(Str$(A)) + _
22.         "Cos(A) = " + _Trim$(Str$(Cos(A))) + _
23.         _Trim$(Str$(x)) + "," + _Trim$(Str$(y)) + _
24.         " rotated to " + _Trim$(Str$(angle)) + " deg = " + _
25.         _Trim$(Str$(xPos)) + "," + _Trim$(Str$(yPos))
26. Next angle
27.  
28. Input "PRESS <ENTER> TO CONTINUE"; in$
29. End
30.  

Itis calculating exactly where you told it to calculate for you:

Centered at X/Y, rotated at ANGLE degrees, with a RADIUS of 0 from that center point.   You're going around in circles at the center point of your circle!!

See how the values change when you increase the radius away from the center:

Code: [Select]

Screen _NewImage(800, 600, 32)

Dim angle As Integer
Dim x As Integer
Dim y As Integer
Dim A
Dim radius
Dim xPos
Dim yPos
Dim in$

For radius = 0 To 10
    Cls
    x = 10
    y = 10
    For angle = 20 To 40
        A = _D2R(angle - 90) ' The _D2R function converts a degree value into a radian value.
        yPos = y + Cos(A) * radius
        xPos = x + Sin(A) * radius
        Print Using "(###/###) rotated to ## degrees with a radius of ## = ###/###"; x, y, angle, radius, xPos, yPos
    Next angle

    Input "PRESS <ENTER> TO CONTINUE"; in$

Next
For a quick illustration of what you're doing, grab a pencil.  Stick it onto the piece of paper with the pencil completely vertical to a single point.  Now, rotate that pencil...   You're turning it, but there's no change in the point where it's located, now is there??

That's why a compass has two points on it -- one with the sharp looking little needle end, and the other with the pencil itself.  The sharp point goes into the center of your circle, you adjust your compass to the desired length (radius), and then rotate from the desired angles to either create your circle, or the arc of a circle. 

Your code is working fine.  Well, it is, as long as you simply want it to rotate that single point which makes the center of a one pixel circle (point) at 10, 10.  ;)

[madscijr]

Itis calculating exactly where you told it to calculate for you:

Centered at X/Y, rotated at ANGLE degrees, with a RADIUS of 0 from that center point.   You're going around in circles at the center point of your circle!!

See how the values change when you increase the radius away from the center:

...

For a quick illustration of what you're doing, grab a pencil.  Stick it onto the piece of paper with the pencil completely vertical to a single point.  Now, rotate that pencil...   You're turning it, but there's no change in the point where it's located, now is there??

That's why a compass has two points on it -- one with the sharp looking little needle end, and the other with the pencil itself.  The sharp point goes into the center of your circle, you adjust your compass to the desired length (radius), and then rotate from the desired angles to either create your circle, or the arc of a circle. 

Your code is working fine.  Well, it is, as long as you simply want it to rotate that single point which makes the center of a one pixel circle (point) at 10, 10.  ;)

OK that makes sense... Silly me!
Thanks for explaining.
I still need to figure out how to translate this to work for a 64x64 (or whatever size) grid, but at least I'm not going around in circles (pun intended).