' ################################################################################################################################################################
' #TOP
' Basic 2D plotting functions
' Version 1.00 by madscijr
' with help from various (sources cited below).
' ################################################################################################################################################################
' =============================================================================
' GLOBAL DECLARATIONS
' =============================================================================
' boolean constants
' rotational constants
Const cCounterClockwise
= -1
' -----------------------------------------------------------------------------
' USER DEFINED TYPES
' -----------------------------------------------------------------------------
z
As Integer ' which zone screen is in, 1 = top right, 2 = bottom right, 3 = bottom left, 4 = top left
' -----------------------------------------------------------------------------
' GLOBAL VARIABLES
' -----------------------------------------------------------------------------
' =============================================================================
' BEGIN MAIN PROGRAM
' =============================================================================
' ****************************************************************************************************************************************************************
' ACTIVATE DEBUGGING WINDOW
_Echo "Started " + m_ProgramName$
' ****************************************************************************************************************************************************************
' -----------------------------------------------------------------------------
' START THE MENU
main
' -----------------------------------------------------------------------------
' DONE
Print m_ProgramName$
+ " finished." 'Screen 0
Input "Press <ENTER> to continue", in$
' ****************************************************************************************************************************************************************
' DEACTIVATE DEBUGGING WINDOW
' ****************************************************************************************************************************************************************
' -----------------------------------------------------------------------------
' EXIT
System ' return control to the operating system
' =============================================================================
' END MAIN PROGRAM
' =============================================================================
' /////////////////////////////////////////////////////////////////////////////
' MAIN MENU
Print "Some basic 2D plotting" Print " 1. PlotPointTest" Print " 2. PlotSquareTest" Print " 3. PlotCircleTest" Print " 4. PlotCircleTopLeftTest" Print " 5. PlotSemicircleTest" Print " 6. CircleFillTest" Print " 7. CircleFillTopLeftTest" Print " 8. SemiCircleFillTest" Print "10. EllipseFillTest" Print "12. ShearRotate1Test1" Print "13. ShearRotate1Test2 (auto advances 0-360 degrees)" Print "14. ShearRotate1Test2 (auto advances 0-360 degrees) (uses Petr's text)" Print "15. ShearRotate2Test1 (correct for missing points logic v1)" Print "16. ShearRotate2Test1 (correct for missing points logic v1) (uses Petr's text)" Print "17. ShearRotate3Test1 (correct for missing points logic v2)" Print "18. ShearRotate3Test1 (correct for missing points logic v2) (uses Petr's text)" Print "19. ShearRotate4Test1 (correct for missing points logic v3)" Print "20. ShearRotate4Test1 (correct for missing points logic v3) (uses Petr's text)" Print "21. ShearRotate5Test1 (correct for missing points, STxAxTIC logic)" Print "22. ShearRotate5Test1 (correct for missing points, STxAxTIC logic) (uses Petr's text)" Print "23. GetRotationMaskTest" Print "24. ShearRotate6Test1 (corrects for missing points using precalculated v1)" Print "25. ShearRotate6Test1 (corrects for missing points using precalculated v1) (uses Petr's text)"
Print "What to do? ('q' to exit)"
PlotPointTest
PlotSquareTest
PlotCircleTest
PlotCircleTopLeftTest
PlotSemicircleTest
CircleFillTest
CircleFillTopLeftTest
SemiCircleFillTest
EllipseTest
EllipseFillTest
PlotLineTest
ShearRotate1Test1
ShearRotate1Test2 TestSprite1$
ShearRotate1Test2 PetrText1$
ShearRotate2Test1 TestSprite1$
ShearRotate2Test1 PetrText1$
ShearRotate3Test1 TestSprite1$
ShearRotate3Test1 PetrText1$
ShearRotate4Test1 TestSprite1$
ShearRotate4Test1 PetrText1$
ShearRotate5Test1 TestSprite1$
ShearRotate5Test1 PetrText1$
GetRotationMaskTest
ShearRotate6Test1 TestSprite1$
ShearRotate6Test1 PetrText1$
' /////////////////////////////////////////////////////////////////////////////
' MyArray(1 To 32, 1 To 32) AS STRING
' where index is MyArray(Y, X)
_Echo "PlotPoint X=" + cstr$
(X
) + ", Y=" + cstr$
(Y
) + ", S=" + Chr$(34) + S
+ Chr$(34) + ", MyArray()" MyArray(Y, X) = S
MyArray
(Y
, X
) = Left$(S
, 1)
' /////////////////////////////////////////////////////////////////////////////
ClearArray MyArray(), "."
iChar = 64
Print ArrayToStringTest
(MyArray
())
Print "Type x,y (1-32, 1-32) coordinate to plot point at." Input "X,Y OR 0 TO QUIT? "; X
, Y
iChar = iChar + 1
Print "X=" + cstr$
(X
) + ", Y=" + cstr$
(Y
) PlotPoint X
, Y
, Chr$(iChar
), MyArray
()
Print ArrayToStringTest
(MyArray
())
' /////////////////////////////////////////////////////////////////////////////
sChar$ = S
sChar$ = " "
X2 = (X1 + L) - 1
Y2 = (Y1 + L) - 1
PlotPoint X, Y, sChar$, MyArray()
' /////////////////////////////////////////////////////////////////////////////
ClearArray MyArray(), "."
iChar = 64
Print "Enter parameters to draw a square." Print ArrayToStringTest
(MyArray
()) Print "Type top left x,y (1-32, 1-32) coordinate to plot square," Print "and size (1-32) of square." Input "X,Y,L OR 0 TO QUIT? "; X
, Y
, L
iChar = iChar + 1
PlotSquare X
, Y
, L
, Chr$(iChar
), MyArray
()
Print ArrayToStringTest
(MyArray
())
' /////////////////////////////////////////////////////////////////////////////
' Fast circle drawing in pure Atari BASIC#
' https://atariwiki.org/wiki/Wiki.jsp?page=Super%20fast%20circle%20routine
' * Magazine: Moj Mikro, 1989/3
' * Author : Zlatko Bleha
' * Page : 27 - 31
' * Atari BASIC listing on disk (tokenized): M8903282.BAS
' * Atari BASIC listing (listed): M8903282.LST
' Next example is demonstration of implementing mentioned circle algorithm
' in pure Atari BASIC. This program shows how much faster it is compared to
' classic program using sine and cosine functions from Atari BASIC
' (shown in last example).
' Basic Listing M8903282.LST#
'1 REM *******************************
'2 REM PROGRAM : FAST CIRCLE DRAWING
'3 REM AUTHOR : ZLATKO BLEHA
'4 REM PUBLISHER: MOJ MIKRO MAGAZINE
'5 REM ISSUE NO.: 1989, NO.3, PAGE 29
'6 REM *******************************
'7 REM
'10 GRAPHICS 8:SETCOLOR 2,0,0:COLOR 3
'20 PRINT "ENTER X, Y AND R"
'30 INPUT X,Y,R
'40 IF R=0 THEN PLOT X,Y:END
'50 B=R:C=0:A=R-1
'60 PLOT X+C,Y+B
'70 PLOT X+C,Y-B
'80 PLOT X-C,Y-B
'90 PLOT X-C,Y+B
'100 PLOT X+B,Y+C
'110 PLOT X+B,Y-C
'120 PLOT X-B,Y-C
'130 PLOT X-B,Y+C
'140 C=C+1
'150 A=A+1-C-C
'160 IF A>=0 THEN 190
'170 B=B-1
'180 A=A+B+B
'190 IF B>=C THEN 60
' Use some valid values for coordinates and radius, for example:
' X=40, Y=40, R=30
' X=130, Y=90, R=60
' Slow circle drawing in Atari BASIC#
' * Magazine: Moj Mikro, 1989/3
' * Author : Zlatko Bleha
' * Page : 27 - 31
' * Atari BASIC listing on disk (tokenized): M8903281.BAS
' * Atari BASIC listing (listed): M8903281.LST
' This is classic example for drawing circles from Atari BASIC
' using sine and cosine functions. Unfortunatelly, this is very slow
' way of doing it and not recommended.
' Just use routine shown above and everybody will be happy
' Basic Listing M8903281.LST#
'1 REM *******************************
'2 REM PROGRAM : SLOW CIRCLE DRAWING
'3 REM AUTHOR : ZLATKO BLEHA
'4 REM PUBLISHER: MOJ MIKRO MAGAZINE
'5 REM ISSUE NO.: 1989, NO.3, PAGE 29
'6 REM *******************************
'7 REM
'10 GRAPHICS 8:SETCOLOR 2,0,0:COLOR 3
'20 FOR A=0 TO 6.28 STEP 0.02
'30 X=SIN(A)*50+150
'40 Y=COS(A)*50+80
'50 PLOT X,Y
'60 NEXT A
' Conclusion#
' Returning back to first program with the fastest way of drawing circles...
' There is one more thing to note. In case you want to use PLOT subroutine,
' which is part of the main circle routine, then read following explanation.
' PLOT routine is written so it can be used easily from Atari BASIC program
' independently from main circle routine, by using like this:
' A=USR(30179,POK,X,Y)
'
' POK 1 (drawing a pixel), 0 (erasing a pixel)
' X X coordinate of the pixel
' Y Y coordinate of the pixel
'
' The routine alone is not any faster than normal PLOT command
' from Atari BASIC, because USR command takes approximately 75%
' of whole execution. But, used as part of the main circle routine
' it does not matter anymore, because it is integrated in one larger
' entity. There the execution is very fast, with no overhead.
' PLOT routine is here for you to examine anyway.
' You never know if you will maybe need it in the future.
' More on plotting circles:
' Drawing a circle in BASIC - fast
' https://www.cpcwiki.eu/forum/programming/drawing-a-circle-in-basic-fast/
' X,Y = center point of circle
' R = radius
' S = char to draw
' MyArray = 2D string array to plot circle in
S2 = S
S2 = " "
B = R
C = 0
A = R - 1
PlotPoint X + C, Y + B, S2, MyArray()
PlotPoint X + C, Y - B, S2, MyArray()
PlotPoint X - C, Y - B, S2, MyArray()
PlotPoint X - C, Y + B, S2, MyArray()
PlotPoint X + B, Y + C, S2, MyArray()
PlotPoint X + B, Y - C, S2, MyArray()
PlotPoint X - B, Y - C, S2, MyArray()
PlotPoint X - B, Y + C, S2, MyArray()
C = C + 1
A = A + 1 - C - C
If A
< 0 Then ' IF A>=0 THEN 190 B = B - 1
A = A + B + B
' /////////////////////////////////////////////////////////////////////////////
ClearArray MyArray(), "."
iChar = 64
Print "Plot a raster circle" Print "Based on Fast circle drawing in pure Atari BASIC by Zlatko Bleha." Print "Enter parameters to draw a circle." Print ArrayToStringTest
(MyArray
())
Print "Type center point x,y (1-32, 1-32) coordinate to plot circle," Print "and radius (1-32) of circle." Input "X,Y,R OR 0 TO QUIT: "; X
, Y
, R
iChar = iChar + 1
PlotCircle X
, Y
, R
, Chr$(iChar
), MyArray
()
Print ArrayToStringTest
(MyArray
())
' /////////////////////////////////////////////////////////////////////////////
' X,Y = top left point of circle
' R = radius
' S = char to draw
' MyArray = 2D string array to plot circle in
Dim RoutineName
As String: RoutineName
= "PlotCircleTopLeft"
' Get total width
W = (R * 2) + 1
' Define a temp array
' Get minimum X, Y of target array
S2 = S
S2 = " "
' Draw circle to temporary array
B = R
C = 0
A = R - 1
' PORTIONS OF CIRCLE:
' .......3333222.......
' .....33.......22.....
' ....3...........2....
' ...7.............6...
' ..7...............6..
' .7.................6.
' .7.................6.
' 7...................6
' 7...................6
' 7...................6
' 8...................6
' 8...................5
' 8...................5
' 8...................5
' .8.................5.
' .8.................5.
' ..8...............5..
' ...8.............5...
' ....4...........1....
' .....44.......11.....
' .......4444111.......
PlotPoint R + C, R + B, S2, arrTemp() ' 1
PlotPoint R + C, R - B, S2, arrTemp() ' 2
PlotPoint R - C, R - B, S2, arrTemp() ' 3
PlotPoint R - C, R + B, S2, arrTemp() ' 4
PlotPoint R + B, R + C, S2, arrTemp() ' 5
PlotPoint R + B, R - C, S2, arrTemp() ' 6
PlotPoint R - B, R - C, S2, arrTemp() ' 7
PlotPoint R - B, R + C, S2, arrTemp() ' 8
C = C + 1
A = A + 1 - C - C
B = B - 1
A = A + B + B
' Copy circle to destination Y,X
TY = Y + DY
TX = X + DX
MyArray(TY, TX) = arrTemp(DY, DX)
' /////////////////////////////////////////////////////////////////////////////
Sub PlotCircleTopLeftTest
ClearArray MyArray(), "."
iChar = 64
Print "Plot a raster circle, specifying top left x,y position" Print "Based on Fast circle drawing in pure Atari BASIC by Zlatko Bleha." Print "Enter parameters to draw a circle." Print ArrayToStringTest
(MyArray
())
Print "Type top left point x,y (1-32, 1-32) coordinate to plot circle," Print "and radius (1-32) of circle." Input "X,Y,R OR 0 TO QUIT: "; X
, Y
, R
iChar = iChar + 1
PlotCircleTopLeft X
, Y
, R
, Chr$(iChar
), MyArray
()
Print "Circle plotted (from top left), drawn with " + Chr$(34) + Chr$(iChar
) + Chr$(34) + ":" Print ArrayToStringTest
(MyArray
())
End Sub ' PlotCircleTopLeftTest
' /////////////////////////////////////////////////////////////////////////////
' Based on PlotCircleTopLeft.
' X,Y = top left point of circle
' R = radius
' Q = which quarter of the circle to return
' where 1=top right, 2=bottom right, 3=bottom left, 4=top left
' like this:
' .......4444111.......
' .....44.......11.....
' ....4...........1....
' ...4.............1...
' ..4...............1..
' .4.................1.
' .4.................1.
' 4...................1
' 4...................1
' 4...................1
' 3...................1
' 3...................2
' 3...................2
' 3...................2
' .3.................2.
' .3.................2.
' ..3...............2..
' ...3.............2...
' ....3...........2....
' .....33.......22.....
' .......3333222.......
' S = char to draw
' MyArray = 2D string array to plot circle in
Dim RoutineName
As String: RoutineName
= "PlotCircleTopLeft"
' Get total width
W = (R * 2) + 1
' Define a temp array
' Get minimum X, Y of target array
S2 = S
S2 = " "
' Draw circle to temporary array
B = R
C = 0
A = R - 1
' PORTIONS OF CIRCLE:
' .......3333222.......
' .....33.......22.....
' ....3...........2....
' ...7.............6...
' ..7...............6..
' .7.................6.
' .7.................6.
' 7...................6
' 7...................6
' 7...................6
' 8...................6
' 8...................5
' 8...................5
' 8...................5
' .8.................5.
' .8.................5.
' ..8...............5..
' ...8.............5...
' ....4...........1....
' .....44.......11.....
' .......4444111.......
' JUST PLOT SELECTED QUADRANT:
' quadrant #1
PlotPoint C, R - B, S2, arrTemp() ' 2
PlotPoint B, R - C, S2, arrTemp() ' 6
' quadrant #2
PlotPoint B, C, S2, arrTemp() ' 5
PlotPoint C, B, S2, arrTemp() ' 1
' quadrant #3
PlotPoint R - C, B, S2, arrTemp() ' 4
PlotPoint R - B, C, S2, arrTemp() ' 8
' quadrant #4
PlotPoint R - B, R - C, S2, arrTemp() ' 7
PlotPoint R - C, R - B, S2, arrTemp() ' 3
' (DO NOTHING)
'' PLOT CIRCLE:
'' quadrant #1
'PlotPoint R + C, R - B, S2, arrTemp() ' 2
'PlotPoint R + B, R - C, S2, arrTemp() ' 6
'
'' quadrant #2
'PlotPoint R + B, R + C, S2, arrTemp() ' 5
'PlotPoint R + C, R + B, S2, arrTemp() ' 1
'
'' quadrant #3
'PlotPoint R - C, R + B, S2, arrTemp() ' 4
'PlotPoint R - B, R + C, S2, arrTemp() ' 8
'
'' quadrant #4
'PlotPoint R - B, R - C, S2, arrTemp() ' 7
'PlotPoint R - C, R - B, S2, arrTemp() ' 3
C = C + 1
A = A + 1 - C - C
B = B - 1
A = A + B + B
' Copy semicircle to destination Y,X
TY = Y + DY
TX = X + DX
MyArray(TY, TX) = arrTemp(DY, DX)
' /////////////////////////////////////////////////////////////////////////////
ClearArray MyArray(), "."
iChar = 64
Print "Plot a semicircle" Print "Based on Fast circle drawing in pure Atari BASIC by Zlatko Bleha." Print "Enter parameters to draw a semicircle." Print ArrayToStringTest
(MyArray
())
Print "Type top left point x,y (1-32, 1-32) coordinate to plot semicircle," Print "radius (1-32) of semicircle, and quadrant of circle to use:" Input "X,Y,R,Q OR 0 TO QUIT: "; X
, Y
, R
, Q
iChar = iChar + 1
PlotSemicircle X
, Y
, R
, Q
, Chr$(iChar
), MyArray
()
Print "Semicircle plotted (from top left), drawn with " + Chr$(34) + Chr$(iChar
) + Chr$(34) + ":" Print ArrayToStringTest
(MyArray
())
' /////////////////////////////////////////////////////////////////////////////
' Re: Is this fast enough as general circle fill?
' https://qb64forum.alephc.xyz/index.php?topic=298.msg1913#msg1913
' From: SMcNeill
' Date: « Reply #30 on: June 26, 2018, 03:34:18 pm »
'
' Sometimes, computers do things that are completely counter-intuitive to us, and
' we find ourselves having to step back as programmers and simply say, "WOW!!"
' Here's a perfect example of that:
' Here we look at two different circle fill routines -- one, which I'd assume to
' be faster, which precalculates the offset needed to find the endpoints for each
' line which composes a circle, and another, which is the same old CircleFill
' program which I've shared countless times over the years with people on various
' QB64 forums.
'
' When all is said and done though, CircleFill is STILL even faster than
' CircleFillFast, which pregenerates those end-points for us!
' CX,CY = center point of circle
' R = radius
' S = char to draw
' MyArray = 2D string array to plot circle in
RadiusError = -Radius
X = Radius
Y = 0
'PSET (CX, CY), C
'PlotPoint CX, CY, S, MyArray()
' Draw the middle span here so we don't draw it twice in the main loop,
' which would be a problem with blending turned on.
'LINE (CX - X, CY)-(CX + X, CY), C, BF
For iLoopX
= CX
- X
To CX
+ X
PlotPoint iLoopX, CY, S, MyArray()
RadiusError = RadiusError + Y * 2 + 1
'LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
iLoopY = CY - X
For iLoopX
= CX
- Y
To CX
+ Y
PlotPoint iLoopX, iLoopY, S, MyArray()
'LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
iLoopY = CY + X
For iLoopX
= CX
- Y
To CX
+ Y
PlotPoint iLoopX, iLoopY, S, MyArray()
X = X - 1
RadiusError = RadiusError - X * 2
Y = Y + 1
'LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
iLoopY = CY - Y
For iLoopX
= CX
- X
To CX
+ X
PlotPoint iLoopX, iLoopY, S, MyArray()
'LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
iLoopY = CY + Y
For iLoopX
= CX
- X
To CX
+ X
PlotPoint iLoopX, iLoopY, S, MyArray()
' /////////////////////////////////////////////////////////////////////////////
ClearArray MyArray(), "."
iChar = 64
Print "Plot a filled circle" Print "Based on CircleFill by SMcNeill." Print "Enter parameters to draw a circle." Print ArrayToStringTest
(MyArray
())
Print "Type center point x,y (1-32, 1-32) coordinate to plot circle," Print "and radius (1-32) of circle." Input "X,Y,R OR 0 TO QUIT: "; X
, Y
, R
iChar = iChar + 1
'PlotCircle X, Y, R, Chr$(iChar), MyArray()
CircleFill X
, Y
, R
, Chr$(iChar
), MyArray
()
Print ArrayToStringTest
(MyArray
())
' /////////////////////////////////////////////////////////////////////////////
' Based on CircleFill and PlotCircleTopLeft.
' CX,CY = top left point of circle
' R = radius
' S = char to draw
' MyArray = 2D string array to plot circle in
RadiusError = -Radius
X = Radius
Y = 0
'PSET (CX, CY), C
'PlotPoint CX, CY, S, MyArray()
' Get total width
W = (Radius * 2) + 1
' Define a temp array
' Get minimum X, Y of target array
' Draw the middle span here so we don't draw it twice in the main loop,
' which would be a problem with blending turned on.
'LINE (CX - X, CY)-(CX + X, CY), C, BF
'FOR iLoopX = CX - X TO CX + X
For iLoopX
= R
- X
To R
+ X
'PlotPoint iLoopX, CY, S, MyArray()
'PlotPoint iLoopX, CY, S, arrTemp()
PlotPoint iLoopX, R, S, arrTemp()
RadiusError = RadiusError + Y * 2 + 1
'LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
'iLoopY = CY - X
iLoopY = R - X
'FOR iLoopX = CX - Y TO CX + Y
For iLoopX
= R
- Y
To R
+ Y
'PlotPoint iLoopX, iLoopY, S, MyArray()
PlotPoint iLoopX, iLoopY, S, arrTemp()
'LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
'iLoopY = CY + X
iLoopY = R + X
'FOR iLoopX = CX - Y TO CX + Y
For iLoopX
= R
- Y
To R
+ Y
'PlotPoint iLoopX, iLoopY, S, MyArray()
PlotPoint iLoopX, iLoopY, S, arrTemp()
X = X - 1
RadiusError = RadiusError - X * 2
Y = Y + 1
'LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
'iLoopY = CY - Y
iLoopY = R - Y
'FOR iLoopX = CX - X TO CX + X
For iLoopX
= R
- X
To R
+ X
'PlotPoint iLoopX, iLoopY, S, MyArray()
PlotPoint iLoopX, iLoopY, S, arrTemp()
'LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
'iLoopY = CY + Y
iLoopY = R + Y
'FOR iLoopX = CX - X TO CX + X
For iLoopX
= R
- X
To R
+ X
'PlotPoint iLoopX, iLoopY, S, MyArray()
PlotPoint iLoopX, iLoopY, S, arrTemp()
' Copy circle to destination Y,X
TY = DY + CY
TX = DX + CX
MyArray(TY, TX) = arrTemp(DY, DX)
' /////////////////////////////////////////////////////////////////////////////
Sub CircleFillTopLeftTest
ClearArray MyArray(), "."
iChar = 64
Print "Plot a solid circle, specifying top left x,y position" Print "Based on CircleFill by SMcNeill." Print "Enter parameters to draw a circle." Print ArrayToStringTest
(MyArray
())
Print "Type top left point x,y (1-32, 1-32) coordinate to plot circle," Print "and radius (1-32) of circle." Input "X,Y,R OR 0 TO QUIT: "; X
, Y
, R
iChar = iChar + 1
CircleFillTopLeft X
, Y
, R
, Chr$(iChar
), MyArray
()
Print "Circle plotted (from top left), drawn with " + Chr$(34) + Chr$(iChar
) + Chr$(34) + ":" Print ArrayToStringTest
(MyArray
())
End Sub ' CircleFillTopLeftTest
' /////////////////////////////////////////////////////////////////////////////
' Based on CircleFill and PlotSemiCircle
' CX,CY = top left point of circle
' R = radius
' Q = which quarter of the circle to return semicircle from
' where 1=top right, 2=bottom right, 3=bottom left, 4=top left
' like this:
' .......4444111.......
' .....44444411111.....
' ....4444444111111....
' ...444444441111111...
' ..44444444411111111..
' .4444444444111111111.
' .4444444444111111111.
' 444444444441111111111
' 444444444441111111111
' 444444444441111111111
' 333333333331111111111
' 333333333332222222222
' 333333333332222222222
' 333333333332222222222
' .3333333333222222222.
' .3333333333222222222.
' ..33333333322222222..
' ...333333332222222...
' ....3333333222222....
' .....33333322222.....
' .......3333222.......
' S = char to draw
' MyArray = 2D string array to plot semicircle in
RadiusError = -Radius
X = Radius
Y = 0
'PSET (CX, CY), C
'PlotPoint CX, CY, S, MyArray()
' Get total width
W = (Radius * 2) + 1
' Define a temp array
' Get minimum X, Y of target array
' Temp array's lbound is 0
' Calculate difference from MyArray the indices of arrTemp are
AY = 0 - MinY
AX = 0 - MinX
' Draw the middle span here so we don't draw it twice in the main loop,
' which would be a problem with blending turned on.
'LINE (CX - X, CY)-(CX + X, CY), C, BF
'FOR iLoopX = CX - X TO CX + X
For iLoopX
= R
- X
To R
+ X
'PlotPoint iLoopX, CY, S, MyArray()
'PlotPoint iLoopX, CY, S, arrTemp()
PlotPoint iLoopX, R, S, arrTemp()
RadiusError = RadiusError + Y * 2 + 1
'LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
'iLoopY = CY - X
iLoopY = R - X
'FOR iLoopX = CX - Y TO CX + Y
For iLoopX
= R
- Y
To R
+ Y
'PlotPoint iLoopX, iLoopY, S, MyArray()
PlotPoint iLoopX, iLoopY, S, arrTemp()
'LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
'iLoopY = CY + X
iLoopY = R + X
'FOR iLoopX = CX - Y TO CX + Y
For iLoopX
= R
- Y
To R
+ Y
'PlotPoint iLoopX, iLoopY, S, MyArray()
PlotPoint iLoopX, iLoopY, S, arrTemp()
X = X - 1
RadiusError = RadiusError - X * 2
Y = Y + 1
'LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
'iLoopY = CY - Y
iLoopY = R - Y
'FOR iLoopX = CX - X TO CX + X
For iLoopX
= R
- X
To R
+ X
'PlotPoint iLoopX, iLoopY, S, MyArray()
PlotPoint iLoopX, iLoopY, S, arrTemp()
'LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
'iLoopY = CY + Y
iLoopY = R + Y
'FOR iLoopX = CX - X TO CX + X
For iLoopX
= R
- X
To R
+ X
'PlotPoint iLoopX, iLoopY, S, MyArray()
PlotPoint iLoopX, iLoopY, S, arrTemp()
'_echo "MyArray(" + _Trim$(Str$(lbound(MyArray,1))) + " To " + _Trim$(Str$(ubound(MyArray,1))) + ", " + _Trim$(Str$(lbound(MyArray,2))) + " To " + _Trim$(Str$(ubound(MyArray,2))) + ")"
' Copy semicircle to destination Y,X
' JUST COPY SELECTED QUADRANT:
' quadrant #1
'_echo "DY=" + cstr$(DY) + ", DX=" + cstr$(DX)
TY = (DY + CY) - (AY + 1)
TX = (DX - Radius) - AX
MyArray(TY, TX) = arrTemp(DY, DX)
' quadrant #2
TY = (DY - Radius) - AY
TX = (DX - Radius) - AX
MyArray(TY, TX) = arrTemp(DY, DX)
' quadrant #3
TY = (DY - Radius) - AY
TX = (DX + CX) - (AX + 1)
MyArray(TY, TX) = arrTemp(DY, DX)
' quadrant #4
TY = (DY + CY) - (AY + 1)
TX = (DX + CX) - (AX + 1)
MyArray(TY, TX) = arrTemp(DY, DX)
' (DO NOTHING)
'' Copy circle to destination:
'For DY = lbound(arrTemp, 1) to ubound(arrTemp, 1)
' For DX = lbound(arrTemp, 2) to ubound(arrTemp, 2)
' IF LEN(arrTemp(DY, DX)) > 0 THEN
' MyArray(DY + CY, DX + CX) = arrTemp(DY, DX)
' END IF
' Next DX
'Next DY
' /////////////////////////////////////////////////////////////////////////////
ClearArray MyArray(), "."
iChar = 64
Print "Plot a solid semicircle" Print "Based on CircleFill by SMcNeill." Print "Enter parameters to draw a semicircle." Print ArrayToStringTest
(MyArray
())
Print "Type top left point x,y (1-32, 1-32) coordinate to plot semicircle," Print "radius (1-32) of semicircle, and quadrant of circle to use:" Input "X,Y,R,Q OR 0 TO QUIT: "; X
, Y
, R
, Q
iChar = iChar + 1
SemiCircleFill X
, Y
, R
, Q
, Chr$(iChar
), MyArray
()
Print "Semicircle plotted (from top left), drawn with " + Chr$(34) + Chr$(iChar
) + Chr$(34) + ":" Print ArrayToStringTest
(MyArray
())
' /////////////////////////////////////////////////////////////////////////////
' Re: Is this fast enough as general circle fill?
' https://qb64forum.alephc.xyz/index.php?topic=298.msg3588#msg3588
' From: bplus
' Date: « Reply #59 on: August 30, 2018, 09:18:34 am »
scale = yRadius / xRadius
xs = xRadius * xRadius
'PSET (CX, CY - yRadius)
PlotPoint CX, CY - yRadius, S, MyArray()
'PSET (CX, CY + yRadius)
PlotPoint CX, CY + yRadius, S, MyArray()
lastx = 0: lasty = yRadius
y
= scale
* Sqr(xs
- x
* x
) 'LINE (CX + lastx, CY - lasty)-(CX + x, CY - y)
PlotLine CX + lastx, CY - lasty, CX + x, CY - y, S, MyArray()
'LINE (CX + lastx, CY + lasty)-(CX + x, CY + y)
PlotLine CX + lastx, CY + lasty, CX + x, CY + y, S, MyArray()
'LINE (CX - lastx, CY - lasty)-(CX - x, CY - y)
PlotLine CX - lastx, CY - lasty, CX - x, CY - y, S, MyArray()
'LINE (CX - lastx, CY + lasty)-(CX - x, CY + y)
PlotLine CX - lastx, CY + lasty, CX - x, CY + y, S, MyArray()
lastx = x
lasty = y
' /////////////////////////////////////////////////////////////////////////////
ClearArray MyArray(), "."
iChar = 64
Print "Based on ellipse by bplus." Print "Enter parameters to draw an ellipse." Print ArrayToStringTest
(MyArray
())
Print "Type center point x,y (1-32, 1-32) coordinate to plot ellipse," Print "and x radius (1-32) and y radius (1-32) of ellipse." Input "X,Y,RX,RY OR 0 TO QUIT: "; X
, Y
, RX
, RY
iChar = iChar + 1
Ellipse X
, Y
, RX
, RY
, Chr$(iChar
), MyArray
()
Print ArrayToStringTest
(MyArray
())
' /////////////////////////////////////////////////////////////////////////////
' Re: Is this fast enough as general circle fill?
' https://qb64forum.alephc.xyz/index.php?topic=298.msg3588#msg3588
' From: bplus
' Date: « Reply #59 on: August 30, 2018, 09:18:34 am »
'
' Here is my ellipse and filled ellipse routines, no where near
' Steve's level of performance. The speed is cut in half at
' least because you probably have to do a whole quadrants worth
' of calculations (ellipse not as symmetric as circle).
'
' But I am sure this code can be optimized more than it is:
scale = yRadius / xRadius
'LINE (CX, CY - yRadius)-(CX, CY + yRadius), , BF
For iLoopY
= CY
- yRadius
To CY
+ yRadius
PlotPoint CX, iLoopY, S, MyArray()
y
= scale
* Sqr(xRadius
* xRadius
- x
* x
)
'LINE (CX + x, CY - y)-(CX + x, CY + y), , BF
iLoopX = CX + x
For iLoopY
= CY
- y
To CY
+ y
PlotPoint iLoopX, iLoopY, S, MyArray()
'LINE (CX - x, CY - y)-(CX - x, CY + y), , BF
iLoopX = CX - x
For iLoopY
= CY
- y
To CY
+ y
PlotPoint iLoopX, iLoopY, S, MyArray()
' /////////////////////////////////////////////////////////////////////////////
ClearArray MyArray(), "."
iChar = 64
Print "Plot a filled ellipse" Print "Based on fellipse by bplus." Print "Enter parameters to draw an ellipse." Print ArrayToStringTest
(MyArray
())
Print "Type center point x,y (1-32, 1-32) coordinate to plot ellipse," Print "and x radius (1-32) and y radius (1-32) of ellipse." Input "X,Y,RX,RY OR 0 TO QUIT: "; X
, Y
, RX
, RY
iChar = iChar + 1
EllipseFill X
, Y
, RX
, RY
, Chr$(iChar
), MyArray
()
Print ArrayToStringTest
(MyArray
())
' /////////////////////////////////////////////////////////////////////////////
' Based on "BRESNHAM.BAS" by Kurt Kuzba. (4/16/96)
' From: http://www.thedubber.altervista.org/qbsrc.htm
Sub PlotLine
(x1%
, y1%
, x2%
, y2%
, c$
, MyArray
() As String)
sx% = 1
sx% = -1
sy% = 1
sy% = -1
steep% = 1
ev% = 2 * dy% - dx%
For iLoop%
= 0 To dx%
- 1 ''PSET (y1%, x1%), c%:
'LOCATE y1%, x1%
'PRINT c$;
PlotPoint y1%, x1%, c$, MyArray()
''PSET (x1%, y1%), c%
'LOCATE x1%, y1%
'PRINT c$;
PlotPoint x1%, y1%, c$, MyArray()
y1% = y1% + sy%
ev% = ev% - 2 * dx%
x1% = x1% + sx%
ev% = ev% + 2 * dy%
''PSET (x2%, y2%), c%
'LOCATE x2%, y2%
'PRINT c$;
PlotPoint x2%, y2%, c$, MyArray()
' /////////////////////////////////////////////////////////////////////////////
ClearArray MyArray(), "."
iChar = 64
Print "Plot line with Bresenham Algorithm" Print "based on BRESNHAM.BAS by Kurt Kuzba (4/16/96)." Print ArrayToStringTest
(MyArray
()) Print "Enter coordinate values for " Print "line start point x1, y1 (1-32, 1-32)" Print "line end point x2, y2 (1-32, 1-32)" Input "ENTER X1,Y1,X2,Y2 OR 0 TO QUIT: "; X1
, Y1
, X2
, Y2
iChar = iChar + 1
PlotLine X1
, Y1
, X2
, Y2
, Chr$(iChar
), MyArray
()
Print ArrayToStringTest
(MyArray
())
' /////////////////////////////////////////////////////////////////////////////
' 3 shear method testing
' _PUT Rotation Help
' https://www.qb64.org/forum/index.php?topic=1959.0
' 3 Shear Rotation - rotates without any aliasing(holes)
' https://www.freebasic.net/forum/viewtopic.php?t=24557
' From: leopardpm
' Date: Apr 02, 2016 1:21
' Last edited by leopardpm on Apr 02, 2016 17:18, edited 1 time in total.
'
' This is just a little 3-shear rotation routine
' (I am using 3-shear because it leaves no gaps/aliasing)
' that I was wondering if anyone sees how to make it faster.
' Obviously, I am just thinking about inside the double loop.
' Thanks again to BasicCoder2 for linking me to this little routine, it is wonderful so far!
''' roto-zooming algorithm
''' coded by Michael S. Nissen
''' jernmager@yahoo.dk
'
''' ===============================================================
''' Recoded to run on FBC 32/64 bit WIN, Version 1.05.0, 2016, by MrSwiss
''' Heavy flickering before going Full-Screen on 64 Bit !!!
''' This seems NOT to be the Case on 32 Bit ...
''' ===============================================================
'
'Type Pixel
' As Single X, Y
' As ULong C
'End Type
'
''' dim vars
'Dim shared as Any Ptr Img_Buffer
''' write the name of the .bmp image you want to rotozoom here:
''' (it has to be sqare ie. 100x100 pixels, 760x760 pixels or whatever)
'Dim As String Img_Name = "phobos.bmp"
'Dim shared as Integer X_Mid, Y_Mid, scrn_wid, scrn_hgt, P1, P2, P3, P4, C
'Dim shared as Short Img_Hgt, Img_Wid, Img_Lft, Img_Rgt, Img_Top, Img_Btm, X, Y
'Dim Shared As Single Cos_Ang, Sin_Ang, Rot_Fac_X, Rot_Fac_Y, Angle = 0, Scale = 1
'
''' changed Function to Sub (+ recoded arguments list)
'Sub Calc_rotozoom ( ByRef Cos_Ang As Single, _
' ByRef Sin_Ang As Single, _
' ByVal S_Fact As Single, _
' ByVal NewAng As Single )
' Cos_Ang = Cos(NewAng)*S_Fact
' Sin_Ang = Sin(NewAng)*S_Fact
'End Sub
'
''' full screen
'ScreenInfo scrn_wid, scrn_hgt
'screenRes scrn_wid, scrn_hgt, 32,,1
'
''' dim screenpointer (has to be done after screenres)
'Dim As ULong Ptr Scrn_Ptr = Screenptr
'
''' place image in center of screen
'X_Mid = scrn_wid\2
'Y_Mid = scrn_hgt\2
'Calc_rotozoom(Cos_Ang, Sin_Ang, Scale, Angle)
'
''' find image dimensions
'Open Img_Name For Binary As #1
'Get #1, 19, Img_Wid
'Get #1, 23, Img_Hgt
'Close #1
'
''' prepare to dim the array that will hold the image.
'Img_Rgt = (Img_Wid-1)\2
'Img_Lft = -Img_Rgt
'Img_Btm = (Img_Hgt-1)\2
'Img_Top = -Img_Btm
'
''' dim array to hold image. Note: pixel (0, 0) is in the center.
'Dim As Pixel Pixel(Img_Lft to Img_Rgt, Img_Top to Img_Btm)
'
''' imagecreate sprite and load image to sprite
'Img_Buffer = ImageCreate (Img_Wid, Img_Hgt)
'Bload (Img_Name, Img_Buffer)
'
''' load image from sprite to array with point command
'For Y = Img_Top to Img_Btm
' For X = Img_Lft to Img_Rgt
' With Pixel(X, Y)
' .X = X_Mid+X
' .Y = Y_Mid+Y
' C = Point (X-Img_Top, Y-Img_Lft, Img_buffer)
' If C <> RGB(255, 0, 255) Then
' .C = C
' Else
' .C = RGB(0, 0, 0)
' End If
' End With
' Next X
'Next Y
'
''' we don't need the sprite anymore, kill it
'ImageDestroy Img_Buffer
'Img_Buffer = 0
'
''' main program loop
'Do
'
' '' scale in/out with uparrow/downarrow
' If Multikey(80) Then
' Scale *= 1.03
' Calc_rotozoom(Cos_Ang, Sin_Ang, Scale, Angle)
' ElseIf Multikey(72) Then
' Scale *= 0.97
' Calc_rotozoom(Cos_Ang, Sin_Ang, Scale, Angle)
' End If
'
' '' rotate left/right with leftarrow/rightarrow
' If Multikey(77) Then
' Angle -= 0.03
' Calc_rotozoom(Cos_Ang, Sin_Ang, Scale, Angle)
' ElseIf Multikey(75) Then
' Angle += 0.03
' Calc_rotozoom(Cos_Ang, Sin_Ang, Scale, Angle)
' End If
'
' '' lock screen in order to use screen pointers
' ScreenLock
'
' '' draw pixel in center of image
' Scrn_Ptr[ X_Mid + Y_Mid * scrn_wid ] = Pixel(0, 0).C
' '' draw all other pixels - 4 at a time
' For Y = Img_Top to 0
' For X = Img_Lft to -1
' '' find pixel positions
' P1 = (X_Mid+X) + (Y_Mid+Y) * scrn_wid
' P2 = (X_Mid-X) + (Y_Mid-Y) * scrn_wid
' P3 = (X_Mid+Y) + (Y_Mid-X) * scrn_wid
' P4 = (X_Mid-Y) + (Y_Mid+X) * scrn_wid
' '' erase old pixels (paint them black)
' Scrn_Ptr[P1] = 0
' Scrn_Ptr[P2] = 0
' Scrn_Ptr[P3] = 0
' Scrn_Ptr[P4] = 0
' '' rotate and zoom
' Rot_Fac_X = X*Cos_Ang - Y*Sin_Ang
' Rot_Fac_Y = X*Sin_Ang + Y*Cos_Ang
' If Rot_Fac_X < Img_Lft Or Rot_Fac_X > Img_Rgt Then Continue For
' If Rot_Fac_Y < Img_Top Or Rot_Fac_Y > Img_Btm Then Continue For
' '' draw new pixels
' Scrn_Ptr[P1] = Pixel(Rot_Fac_X, Rot_Fac_Y).C
' Scrn_Ptr[P2] = Pixel(-Rot_Fac_X, -Rot_Fac_Y).C
' Scrn_Ptr[P3] = Pixel(Rot_Fac_Y, -Rot_Fac_X).C
' Scrn_Ptr[P4] = Pixel(-Rot_Fac_Y, Rot_Fac_X).C
' Next X
' Next Y
'
' ScreenUnLock
'
' Sleep 10, 1
'Loop Until InKey() = Chr(27)
' UPDATES:
' Fixed bug where values 135, 224, and 314 all resolve to -45 degrees.
' Fixed bug where an angle of 46-135 degrees caused the image to be flipped wrong.
' TODO:
' Fix issue where image looks bad at 30, 60, 120, 150, 210, 240, 300, 330 degrees
Dim RtoD
As Double: RtoD
= 180 / Pi
' radians * RtoD = degrees Dim DtoR
As Double: DtoR
= Pi
/ 180 ' degrees * DtoR = radians
' initialize new with empty
NewArray(x, y, 0).origx = x
NewArray(x, y, 0).origy = y
NewArray(x, y, 0).c = iEmpty
' angle is reversed
angle = 360 - angle1
' Shearing each element 3 times in one shot
nangle = angle
' this pre-processing portion basically rotates by 90 to get
' between -45 and 45 degrees, where the 3-shear routine works correctly...
nangle = angle - 90
nangle = angle - 180
nangle = angle - 180
nangle = angle - 270
nangle = nangle + 360
nangle = nangle - 360
rotr = nangle * DtoR
shear1
= Tan(rotr
/ 2) ' correct way
' *** NOTE: this had a bug where the values 135, 224, and 314
' *** all resolve to -45 degrees.
' *** Fixed by changing < to <=
'if angle > 45 and angle < 134 then
flipper = 1
flipper = 2
' *** NOTE: this had a bug where this flipper was wrong
' Fixed by adding case 7
'flipper = 3
flipper = 7
flipper = 0
' Here is where it needs some optimizing possibly... kinda slow...
nx = -y
ny = x
nx = -x
ny = -y
nx = -y
ny = -x
nx = -x
ny = y
nx = x
ny = -y
nx = y
ny = x
nx = y
ny = -x
nx = x
ny = y
clr = OldArray(nx, ny, 0).c
y1 = y * shear1
xy1 = x + y1
fy = (y - xy1 * shear2)
fx = xy1 + fy * shear1
NewArray(fx, fy, 0).c = clr
NewArray(fx, fy, 0).origx = fx
NewArray(fx, fy, 0).origy = fy
' /////////////////////////////////////////////////////////////////////////////
' Same as ShearRotate, except adds iOverwriteCount parameter,
' and counts how many points are overwriting existing points,
' and return that value byref in parameter iOverwriteCount.
Dim RtoD
As Double: RtoD
= 180 / Pi
' radians * RtoD = degrees Dim DtoR
As Double: DtoR
= Pi
/ 180 ' degrees * DtoR = radians
' initialize new with empty
NewArray(x, y, 0).origx = x
NewArray(x, y, 0).origy = y
NewArray(x, y, 0).c = iEmpty
' angle is reversed
angle = 360 - angle1
' Shearing each element 3 times in one shot
nangle = angle
' this pre-processing portion basically rotates by 90 to get
' between -45 and 45 degrees, where the 3-shear routine works correctly...
nangle = angle - 90
nangle = angle - 180
nangle = angle - 180
nangle = angle - 270
nangle = nangle + 360
nangle = nangle - 360
rotr = nangle * DtoR
shear1
= Tan(rotr
/ 2) ' correct way
' *** NOTE: this had a bug where the values 135, 224, and 314
' *** all resolve to -45 degrees.
' *** Fixed by changing < to <=
'if angle > 45 and angle < 134 then
flipper = 1
flipper = 2
' *** NOTE: this had a bug where this flipper was wrong
' Fixed by adding case 7
'flipper = 3
flipper = 7
flipper = 0
' Here is where it needs some optimizing possibly... kinda slow...
iOverwriteCount = 0
nx = -y
ny = x
nx = -x
ny = -y
nx = -y
ny = -x
nx = -x
ny = y
nx = x
ny = -y
nx = y
ny = x
nx = y
ny = -x
nx = x
ny = y
clr = OldArray(nx, ny, 0).c
y1 = y * shear1
xy1 = x + y1
fy = (y - xy1 * shear2)
fx = xy1 + fy * shear1
' count points that will be overwritten
If NewArray
(fx
, fy
, 0).c
<> iEmpty
Then iOverwriteCount = iOverwriteCount + 1
NewArray(fx, fy, 0).c = clr
NewArray(fx, fy, 0).origx = fx
NewArray(fx, fy, 0).origy = fy
' /////////////////////////////////////////////////////////////////////////////
Dim RoArray1
(-16 To 16, -16 To 16, 127) As RotationType
Dim RoArray2
(-16 To 16, -16 To 16, 127) As RotationType
' GET A SHAPE TO BE ROTATED
Print "3 shear rotation based on code by leopardpm"
sMap = TestSprite1$
' CONVERT SHAPE TO ARRAY
StringToRotationArray RoArray1(), sMap, "."
Print "Initial contents of Rotation Array:" Print RotationArrayToStringTest
(RoArray1
())
' ROTATE THE SHAPE
Print "Type degrees to rotate (0 TO 360) or non-numeric value to quit." Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)."
Input "Degrees to rotate (q to quit)? "; in$
ShearRotate RoArray1
(), RoArray2
(), D
, Asc(".") Print "Rotated by " + cstr$
(D
) + " degrees:" Print RotationArrayToStringTest
(RoArray2
())
' /////////////////////////////////////////////////////////////////////////////
' Now receives parameter sMap
' which comes from TestSprite1$, TestSprite2$, TestSprite3$, etc.
' e.g. ShearRotate1Test2 TestSprite1$
Dim RoArray1
(-16 To 16, -16 To 16, 127) As RotationType
Dim RoArray2
(-16 To 16, -16 To 16, 127) As RotationType
'Dim sMap As String
' GET A SHAPE TO BE ROTATED
Print "3 shear rotation based on code by leopardpm" 'sMap = TestSprite1$
' CONVERT SHAPE TO ARRAY
StringToRotationArray RoArray1(), sMap, "."
' GET START ANGLE
D = 0
Print "Rotated by " + cstr$
(D
) + " degrees:" Print RotationArrayToStringTest
(RoArray1
()) Print "Type an angle (-360 to 360) to rotate to, " Print "or blank to increase by 1 degree, or q to quit." Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)." Print "Hold down <ENTER> to rotate continually." Input "Angle (q to quit)? ", in$
D1 = -500
D1 = 1
' ROTATE TO EACH ANGLE
bFinished = FALSE
' ROTATE CLOCKWISE
ShearRotate1 RoArray1
(), RoArray2
(), D
, Asc("."), iOverwriteCount
'Print "Rotated by " + cstr$(D) + " degrees:"
Print "Rotated by " + cstr$
(D
) + " degrees" + IIFSTR$
(iOverwriteCount
= 0, "", " (" + cstr$
(iOverwriteCount
) + " points overwritten)") + ":"
Print RotationArrayToStringTest
(RoArray2
())
Print "Type an angle (-360 to 360) to rotate to, " Print "or blank to increase by 1 degree, or q to quit." Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)." Print "Hold down <ENTER> to rotate continually." Input "Angle (q to quit)? ", in$
D = D - 1
bFinished = TRUE
bFinished = TRUE
' ROTATE COUNTER-CLOCKWISE
ShearRotate1 RoArray1
(), RoArray2
(), D
, Asc("."), iOverwriteCount
'Print "Rotated by " + cstr$(D) + " degrees:"
Print "Rotated by " + cstr$
(D
) + " degrees" + IIFSTR$
(iOverwriteCount
= 0, "", " (" + cstr$
(iOverwriteCount
) + " points overwritten)") + ":"
Print RotationArrayToStringTest
(RoArray2
())
Print "Type an angle (0 to 360) to rotate to, " Print "or blank to increase by 1 degree, or q to quit." Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)." Print "Hold down <ENTER> to rotate continually." Input "Angle (q to quit)? ", in$
D = D + 1
bFinished = TRUE
bFinished = TRUE
' /////////////////////////////////////////////////////////////////////////////
' ShearRotate v2
' Tries to fix the problem of 2 points resolving to the same coordinate
' (one overwrites the other, which becomes "lost")
' Returns # points missing (that could not be corrected) in iMissing parameter.
Dim RtoD
As Double: RtoD
= 180 / Pi
' radians * RtoD = degrees Dim DtoR
As Double: DtoR
= Pi
/ 180 ' degrees * DtoR = radians
' initialize new with empty
NewArray(x, y, 0).origx = x
NewArray(x, y, 0).origy = y
NewArray(x, y, 0).c = iEmpty
' angle is reversed
angle = 360 - angle1
' Shearing each element 3 times in one shot
nangle = angle
' this pre-processing portion basically rotates by 90 to get
' between -45 and 45 degrees, where the 3-shear routine works correctly...
nangle = angle - 90
nangle = angle - 180
nangle = angle - 180
nangle = angle - 270
nangle = nangle + 360
nangle = nangle - 360
rotr = nangle * DtoR
shear1
= Tan(rotr
/ 2) ' correct way
' *** NOTE: this had a bug where the values 135, 224, and 314
' *** all resolve to -45 degrees.
' *** Fixed by changing < to <=
'if angle > 45 and angle < 134 then
flipper = 1
flipper = 2
' *** NOTE: this had a bug where this flipper was wrong
' Fixed by adding case 7
'flipper = 3
flipper = 7
flipper = 0
' Here is where it needs some optimizing possibly... kinda slow...
nx = -y
ny = x
nx = -x
ny = -y
nx = -y
ny = -x
nx = -x
ny = y
nx = x
ny = -y
nx = y
ny = x
nx = y
ny = -x
nx = x
ny = y
clr = OldArray(nx, ny, 0).c
y1 = y * shear1
xy1 = x + y1
fy = (y - xy1 * shear2)
fx = xy1 + fy * shear1
' only draw here if this spot is empty
If NewArray
(fx
, fy
, 0).c
= iEmpty
Then NewArray(fx, fy, 0).c = clr
NewArray(fx, fy, 0).origx = fx
NewArray(fx, fy, 0).origy = fy
' don't draw, but save it to a list to handle later
arrLost
(UBound(arrLost
)).c
= clr
arrLost
(UBound(arrLost
)).origx
= fx
arrLost
(UBound(arrLost
)).origy
= fy
' try to place any points that would have overwritten to a spot nearby
' can nearby be determined by the angle of rotation?
' perhaps if we divide the screen up into 4 zones:
'
' --------------------------------------
'| | |
'| zone 4 | zone 1 |
'| 271-359 degrees) | (1-89 degrees) |
'|--------------------------------------|
'| | |
'| zone 3 | zone 2 |
'| (181-269 degrees) | (91-179 degrees) |
'| | |
' --------------------------------------
' in zone search direction (y,x)
' ------- ----------------------
' 1 up + right
' 2 down + right
' 3 down + left
' 4 up + left
iMissing = 0
bFound = FindEmptyShearRotationPoint2%(arrLost(iLoop), angle1, iEmpty, x, y, NewArray())
_Echo "Plotted missing point " + Chr$(34) + Chr$(arrLost
(iLoop
).c
) + Chr$(34) + " to (x=" + cstr$
(x
) + ", y=" + cstr$
(y
) + ")" iMissing = iMissing + 1
_Echo "Detected missing point " + Chr$(34) + Chr$(arrLost
(iLoop
).c
) + Chr$(34) + " at (x=" + cstr$
(x
) + ", y=" + cstr$
(y
) + ")"
' /////////////////////////////////////////////////////////////////////////////
' Receives
' FindMe (RotationType) = contains the starting location (.origx, .origy) to start looking from, and the value (.c) to write
' angle1 (Integer) = angle we were rotating to, to determine direction to look in
' iEmpty (Integer) = value to test against for empty
' destX (Integer) = if an empty spot is found, returns the x location here byref
' destY (Integer) = if an empty spot is found, returns the y location here byref
' NewArray() (RotationType array (x,y,127) ) = array representing the screen to search in and plot to
' Returns
' FALSE if no empty spot was found
' TRUE if an empty spot was found, and x,y location returned byref in destX,destY parameters
destX = 0
destY = 0
' Choose search direction depending on the angle
dirX = 1
dirY = -1
dirX = 1
dirY = 1
dirX = -1
dirY = 1
dirX = -1
dirY = -1
dirX = 0
dirY = 0
x = FindMe.origx
y = FindMe.origy
' quit if we're out of bounds
' =============================================================================
' BEGIN SEARCH
' =============================================================================
' look along y axis for a blank spot
destX = x
destY = y + dirY
If NewArray
(destX
, destY
, 0).c
= iEmpty
Then NewArray(destX, destY, 0).c = FindMe.c
bResult = TRUE
' look along x axis for a blank spot
destX = x + dirX
destY = y
If NewArray
(x
+ dirX
, y
, 0).c
= iEmpty
Then NewArray(destX, destY, 0).c = FindMe.c
bResult = TRUE
' look diagonally for a blank spot
destX = x + dirX
destY = y + dirY
If NewArray
(x
+ dirX
, y
+ dirY
, 0).c
= iEmpty
Then NewArray(destX, destY, 0).c = FindMe.c
bResult = TRUE
' =============================================================================
' END SEARCH
' =============================================================================
' Keep looking
x = x + dirX
y = y + dirY
' Return result
FindEmptyShearRotationPoint2% = bResult
' /////////////////////////////////////////////////////////////////////////////
' Tries to correct for missing points.
' Receives parameter sMap
' which comes from TestSprite1$, TestSprite2$, TestSprite3$, etc.
' e.g. ShearRotate2Test1 TestSprite1$
Dim RoArray1
(-16 To 16, -16 To 16, 127) As RotationType
Dim RoArray2
(-16 To 16, -16 To 16, 127) As RotationType
'Dim sMap As String
' GET A SHAPE TO BE ROTATED
Print "3 shear rotation based on code by leopardpm" 'sMap = TestSprite1$
' CONVERT SHAPE TO ARRAY
StringToRotationArray RoArray1(), sMap, "."
' GET START ANGLE
D = 0
Print "Rotated by " + cstr$
(D
) + " degrees:" Print RotationArrayToStringTest
(RoArray1
()) Print "Type an angle (-360 to 360) to rotate to, " Print "or blank to increase by 1 degree, or q to quit." Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)." Print "Hold down <ENTER> to rotate continually." Input "Angle (q to quit)? ", in$
D1 = -500
D1 = 1
' ROTATE TO EACH ANGLE
bFinished = FALSE
' ROTATE CLOCKWISE
ShearRotate2 RoArray1
(), RoArray2
(), D
, Asc("."), iMissing
'Print "Rotated by " + cstr$(D) + " degrees:"
Print "Rotated by " + cstr$
(D
) + " degrees" + IIFSTR$
(iMissing
= 0, "", " (" + cstr$
(iMissing
) + " points missing)") + ":"
Print RotationArrayToStringTest
(RoArray2
())
Print "Type an angle (-360 to 360) to rotate to, " Print "or blank to increase by 1 degree, or q to quit." Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)." Print "Hold down <ENTER> to rotate continually." Input "Angle (q to quit)? ", in$
D = D - 1
bFinished = TRUE
bFinished = TRUE
' ROTATE COUNTER-CLOCKWISE
ShearRotate2 RoArray1
(), RoArray2
(), D
, Asc("."), iMissing
'Print "Rotated by " + cstr$(D) + " degrees:"
Print "Rotated by " + cstr$
(D
) + " degrees" + IIFSTR$
(iMissing
= 0, "", " (" + cstr$
(iMissing
) + " points missing)") + ":"
Print RotationArrayToStringTest
(RoArray2
())
Print "Type an angle (0 to 360) to rotate to, " Print "or blank to increase by 1 degree, or q to quit." Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)." Print "Hold down <ENTER> to rotate continually." Input "Angle (q to quit)? ", in$
D = D + 1
bFinished = TRUE
bFinished = TRUE
' /////////////////////////////////////////////////////////////////////////////
' ShearRotate v3
' Tries to fix the problem of 2 points resolving to the same coordinate
' (one overwrites the other, which becomes "lost")
' a little more accurately, using iDirection parameter
' (which can be cClockwise or cCounterClockwise)
' together with which quarter of the screen the point is in,
' Note: cClockwise and cCounterClockwise constants must be declared globally.
' Returns # points missing (that could not be corrected) in iMissing parameter.
OldArray
() As RotationType
, _
NewArray
() As RotationType
, _
Dim RtoD
As Double: RtoD
= 180 / Pi
' radians * RtoD = degrees Dim DtoR
As Double: DtoR
= Pi
/ 180 ' degrees * DtoR = radians
' initialize new with empty
NewArray(x, y, 0).origx = x
NewArray(x, y, 0).origy = y
NewArray(x, y, 0).c = iEmpty
' find midpoints
' angle is reversed
angle = 360 - angle1
' Shearing each element 3 times in one shot
nangle = angle
' this pre-processing portion basically rotates by 90 to get
' between -45 and 45 degrees, where the 3-shear routine works correctly...
nangle = angle - 90
nangle = angle - 180
nangle = angle - 180
nangle = angle - 270
nangle = nangle + 360
nangle = nangle - 360
rotr = nangle * DtoR
shear1
= Tan(rotr
/ 2) ' correct way
' *** NOTE: this had a bug where the values 135, 224, and 314
' *** all resolve to -45 degrees.
' *** Fixed by changing < to <=
'if angle > 45 and angle < 134 then
flipper = 1
flipper = 2
' *** NOTE: this had a bug where this flipper was wrong
' Fixed by adding case 7
'flipper = 3
flipper = 7
flipper = 0
' Here is where it needs some optimizing possibly... kinda slow...
' find which part of screen the current point is in
' bottom half of screen
' right half of screen
iScreenZone = 2
' left half of screen
iScreenZone = 3
' top half of screen
' right half of screen
iScreenZone = 1
' left half of screen
iScreenZone = 4
' calculate directions
nx = -y
ny = x
nx = -x
ny = -y
nx = -y
ny = -x
nx = -x
ny = y
nx = x
ny = -y
nx = y
ny = x
nx = y
ny = -x
nx = x
ny = y
clr = OldArray(nx, ny, 0).c
y1 = y * shear1
xy1 = x + y1
fy = (y - xy1 * shear2)
fx = xy1 + fy * shear1
' only draw here if this spot is empty
If NewArray
(fx
, fy
, 0).c
= iEmpty
Then NewArray(fx, fy, 0).c = clr
NewArray(fx, fy, 0).origx = fx
NewArray(fx, fy, 0).origy = fy
' don't draw, but save it to a list to handle later
arrLost
(UBound(arrLost
)).c
= clr
arrLost
(UBound(arrLost
)).origx
= fx
arrLost
(UBound(arrLost
)).origy
= fy
' preserve which zone screen is in, 1 = top right, 2 = bottom right, 3 = bottom left, 4 = top left
arrLost
(UBound(arrLost
)).z
= iScreenZone
' try to place any points that would have overwritten to a spot nearby
' can nearby be determined by the direction of rotation (iDirection)
' together with which quarter of the screen the point is in (iScreenZone)
' where we divide the screen up into 4 zones:
' --------------------------------------
'| | |
'| zone 4 | zone 1 |
'| | |
'|--------------------------------------|
'| | |
'| zone 3 | zone 2 |
'| | |
'| | |
' --------------------------------------
' in zone rotation direction search direction (y,x)
' ------- ------------------ ----------------------
' 1 clockwise down + right
' 1 counter-clockwise up + left
' 2 clockwise down + left
' 2 counter-clockwise up + right
' 3 clockwise up + left
' 3 counter-clockwise down + right
' 4 clockwise up + right
' 4 counter-clockwise down + left
iMissing = 0
bFound = FindEmptyShearRotationPoint3%(arrLost(iLoop), iDirection, iEmpty, x, y, NewArray())
_Echo "Plotted missing point " + Chr$(34) + Chr$(arrLost
(iLoop
).c
) + Chr$(34) + " to (x=" + cstr$
(x
) + ", y=" + cstr$
(y
) + ")" iMissing = iMissing + 1
_Echo "Detected missing point " + Chr$(34) + Chr$(arrLost
(iLoop
).c
) + Chr$(34) + " at (x=" + cstr$
(x
) + ", y=" + cstr$
(y
) + ")"
' /////////////////////////////////////////////////////////////////////////////
' Looks for a new point
' a little more accurately, using iDirection parameter
' which can be cClockwise or cCounterClockwise.
' Note: cClockwise and cCounterClockwise constants must be declared globally.
' Receives
' FindMe (RotationType) = contains
' .origx, .origy = the starting location to start looking from,
' .z = which area of the screen the point is in
' (1=top right, 2=bottom right, 3=bottom left, 4=top left)
' to determine direction to look in
' .c = the value to write
' iDirection (Integer) = direction of rotation, can be cClockwise or cCounterClockwise (constants must be declared globally)
' iEmpty (Integer) = value to test against for empty
' destX (Integer) = if an empty spot is found, returns the x location here byref
' destY (Integer) = if an empty spot is found, returns the y location here byref
' NewArray() (RotationType array (x,y,127) ) = array representing the screen to search in and plot to
' Returns
' FALSE if no empty spot was found
' TRUE if an empty spot was found, and x,y location returned byref in destX,destY parameters
' Initialize
destX = 0
destY = 0
bContinue = TRUE
' Choose search direction based on the quadrant of the screen
' and the direction of rotation:
' iScreenZone iDirection search direction (y,x)
' ----------- ------------------ ----------------------
' 1 cClockwise down + right ( 1, 1)
' 1 cCounterClockwise up + left (-1,-1)
' 2 cClockwise down + left ( 1,-1)
' 2 cCounterClockwise up + right (-1, 1)
' 3 cClockwise up + left (-1,-1)
' 3 cCounterClockwise down + right ( 1, 1)
' 4 cClockwise up + right (-1, 1)
' 4 cCounterClockwise down + left ( 1,-1)
If FindMe.z
= 1 And iDirection
= cClockwise
Then dirY = 1
dirX = 1
dirY = -1
dirX = -1
dirY = 1
dirX = -1
dirY = -1
dirX = 1
dirY = -1
dirX = -1
dirY = 1
dirX = 1
dirY = -1
dirX = 1
dirY = 1
dirX = -1
bContinue = FALSE
' Quit if we're out of bounds
bContinue = FALSE
x = FindMe.origx
y = FindMe.origy
bContinue = TRUE
' look along y axis for an available adjacent point
destX = x
destY = y + dirY
If NewArray
(destX
, destY
, 0).c
= iEmpty
Then NewArray(destX, destY, 0).c = FindMe.c
bResult = TRUE
bContinue = FALSE
' look along x axis for an available adjacent point
destX = x + dirX
destY = y
If NewArray
(x
+ dirX
, y
, 0).c
= iEmpty
Then NewArray(destX, destY, 0).c = FindMe.c
bResult = TRUE
bContinue = FALSE
' look diagonally for an available adjacent point
destX = x + dirX
destY = y + dirY
If NewArray
(x
+ dirX
, y
+ dirY
, 0).c
= iEmpty
Then NewArray(destX, destY, 0).c = FindMe.c
bResult = TRUE
bContinue = FALSE
' Return result
FindEmptyShearRotationPoint3% = bResult
' /////////////////////////////////////////////////////////////////////////////
' Receives parameter sMap
' which comes from TestSprite1$, TestSprite2$, TestSprite3$, etc.
' e.g. ShearRotate3Test1 TestSprite1$
Dim RoArray1
(-16 To 16, -16 To 16, 127) As RotationType
Dim RoArray2
(-16 To 16, -16 To 16, 127) As RotationType
'Dim sMap As String
' GET A SHAPE TO BE ROTATED
Print "3 shear rotation based on code by leopardpm" 'sMap = TestSprite1$
' CONVERT SHAPE TO ARRAY
StringToRotationArray RoArray1(), sMap, "."
' GET START ANGLE
D = 0
Print "Rotated by " + cstr$
(D
) + " degrees:" Print RotationArrayToStringTest
(RoArray1
()) Print "Type an angle (-360 to 360) to rotate to, " Print "or blank to increase by 1 degree, or q to quit." Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)." Print "Hold down <ENTER> to rotate continually." Input "Angle (q to quit)? ", in$
D1 = -500
D1 = 1
' ROTATE TO EACH ANGLE
bFinished = FALSE
' ROTATE CLOCKWISE
ShearRotate3 RoArray1
(), RoArray2
(), D
, cClockwise
, Asc("."), iMissing
'Print "Rotated by " + cstr$(D) + " degrees:"
Print "Rotated by " + cstr$
(D
) + " degrees" + IIFSTR$
(iMissing
= 0, "", " (" + cstr$
(iMissing
) + " points missing)") + ":"
Print RotationArrayToStringTest
(RoArray2
())
Print "Type an angle (-360 to 360) to rotate to, " Print "or blank to increase by 1 degree, or q to quit." Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)." Print "Hold down <ENTER> to rotate continually." Input "Angle (q to quit)? ", in$
D = D - 1
bFinished = TRUE
bFinished = TRUE
' ROTATE COUNTER-CLOCKWISE
ShearRotate3 RoArray1
(), RoArray2
(), D
, cCounterClockwise
, Asc("."), iMissing
'Print "Rotated by " + cstr$(D) + " degrees:"
Print "Rotated by " + cstr$
(D
) + " degrees" + IIFSTR$
(iMissing
= 0, "", " (" + cstr$
(iMissing
) + " points missing)") + ":"
Print RotationArrayToStringTest
(RoArray2
())
Print "Type an angle (0 to 360) to rotate to, " Print "or blank to increase by 1 degree, or q to quit." Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)." Print "Hold down <ENTER> to rotate continually." Input "Angle (q to quit)? ", in$
D = D + 1
bFinished = TRUE
bFinished = TRUE
' /////////////////////////////////////////////////////////////////////////////
' ShearRotate v4
' Tries to fix the problem of 2 points resolving to the same coordinate
' (one overwrites the other, which becomes "lost")
' using a different approach, by just looking at the problem angles:
' 30, 60, 120, 150, 210, 240, 300, 330 degrees
' (which can be cClockwise or cCounterClockwise)
' together with which quarter of the screen the point is in,
' Note: cClockwise and cCounterClockwise constants must be declared globally.
' Returns # points missing (that could not be corrected) in iMissing parameter.
OldArray
() As RotationType
, _
NewArray
() As RotationType
, _
Dim RtoD
As Double: RtoD
= 180 / Pi
' radians * RtoD = degrees Dim DtoR
As Double: DtoR
= Pi
/ 180 ' degrees * DtoR = radians
' initialize new with empty
NewArray(x, y, 0).origx = x
NewArray(x, y, 0).origy = y
NewArray(x, y, 0).c = iEmpty
' find midpoints
' angle is reversed
angle = 360 - angle1
' Shearing each element 3 times in one shot
nangle = angle
' this pre-processing portion basically rotates by 90 to get
' between -45 and 45 degrees, where the 3-shear routine works correctly...
nangle = angle - 90
nangle = angle - 180
nangle = angle - 180
nangle = angle - 270
nangle = nangle + 360
nangle = nangle - 360
rotr = nangle * DtoR
shear1
= Tan(rotr
/ 2) ' correct way
' *** NOTE: this had a bug where the values 135, 224, and 314
' *** all resolve to -45 degrees.
' *** Fixed by changing < to <=
'if angle > 45 and angle < 134 then
flipper = 1
flipper = 2
' *** NOTE: this had a bug where this flipper was wrong
' Fixed by adding case 7
'flipper = 3
flipper = 7
flipper = 0
' Here is where it needs some optimizing possibly... kinda slow...
' find which part of screen the current point is in
' bottom half of screen
' right half of screen
iScreenZone = 2
' left half of screen
iScreenZone = 3
' top half of screen
' right half of screen
iScreenZone = 1
' left half of screen
iScreenZone = 4
' calculate directions
nx = -y
ny = x
nx = -x
ny = -y
nx = -y
ny = -x
nx = -x
ny = y
nx = x
ny = -y
nx = y
ny = x
nx = y
ny = -x
nx = x
ny = y
clr = OldArray(nx, ny, 0).c
y1 = y * shear1
xy1 = x + y1
fy = (y - xy1 * shear2)
fx = xy1 + fy * shear1
' only draw here if this spot is empty
If NewArray
(fx
, fy
, 0).c
= iEmpty
Then NewArray(fx, fy, 0).c = clr
NewArray(fx, fy, 0).origx = fx
NewArray(fx, fy, 0).origy = fy
' don't draw, but save it to a list to handle later
arrLost
(UBound(arrLost
)).c
= clr
arrLost
(UBound(arrLost
)).origx
= fx
arrLost
(UBound(arrLost
)).origy
= fy
' preserve which zone screen is in, 1 = top right, 2 = bottom right, 3 = bottom left, 4 = top left
arrLost
(UBound(arrLost
)).z
= iScreenZone
' try to place any points that would have overwritten to a spot nearby
' can nearby be determined by the direction of rotation (iDirection)
' together with which quarter of the screen the point is in (iScreenZone)
' where we divide the screen up into 4 zones:
' --------------------------------------
'| | |
'| zone 4 | zone 1 |
'| | |
'|--------------------------------------|
'| | |
'| zone 3 | zone 2 |
'| | |
'| | |
' --------------------------------------
' in zone rotation direction search direction (y,x)
' ------- ------------------ ----------------------
' 1 clockwise down + right
' 1 counter-clockwise up + left
' 2 clockwise down + left
' 2 counter-clockwise up + right
' 3 clockwise up + left
' 3 counter-clockwise down + right
' 4 clockwise up + right
' 4 counter-clockwise down + left
If IsProblemAngle%
(angle1
) Then iMissing = 0
bFound = FindEmptyShearRotationPoint4%(arrLost(iLoop), iDirection, iEmpty, x, y, NewArray())
_Echo "Plotted missing point " + Chr$(34) + Chr$(arrLost
(iLoop
).c
) + Chr$(34) + " to (x=" + cstr$
(x
) + ", y=" + cstr$
(y
) + ")" iMissing = iMissing + 1
_Echo "Detected missing point " + Chr$(34) + Chr$(arrLost
(iLoop
).c
) + Chr$(34) + " at (x=" + cstr$
(x
) + ", y=" + cstr$
(y
) + ")"
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if angle is any of
' 30, 60, 120, 150, 210, 240, 300, 330
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%
bResult = TRUE
IsProblemAngle% = bResult
' /////////////////////////////////////////////////////////////////////////////
' Looks for a new point
' a little more accurately, using iDirection parameter
' which can be cClockwise or cCounterClockwise.
' Note: cClockwise and cCounterClockwise constants must be declared globally.
' Receives
' FindMe (RotationType) = contains
' .origx, .origy = the starting location to start looking from,
' .z = which area of the screen the point is in
' (1=top right, 2=bottom right, 3=bottom left, 4=top left)
' to determine direction to look in
' .c = the value to write
' iDirection (Integer) = direction of rotation, can be cClockwise or cCounterClockwise (constants must be declared globally)
' iEmpty (Integer) = value to test against for empty
' destX (Integer) = if an empty spot is found, returns the x location here byref
' destY (Integer) = if an empty spot is found, returns the y location here byref
' NewArray() (RotationType array (x,y,127) ) = array representing the screen to search in and plot to
' Returns
' FALSE if no empty spot was found
' TRUE if an empty spot was found, and x,y location returned byref in destX,destY parameters
' Initialize
destX = 0
destY = 0
bContinue = TRUE
' Choose search direction based on the quadrant of the screen
' and the direction of rotation:
' iScreenZone iDirection search direction (y,x)
' ----------- ------------------ ----------------------
' 1 cClockwise down + right ( 1, 1)
' 1 cCounterClockwise up + left (-1,-1)
' 2 cClockwise down + left ( 1,-1)
' 2 cCounterClockwise up + right (-1, 1)
' 3 cClockwise up + left (-1,-1)
' 3 cCounterClockwise down + right ( 1, 1)
' 4 cClockwise up + right (-1, 1)
' 4 cCounterClockwise down + left ( 1,-1)
If FindMe.z
= 1 And iDirection
= cClockwise
Then dirY = 1
dirX = 1
dirY = -1
dirX = -1
dirY = 1
dirX = -1
dirY = -1
dirX = 1
dirY = -1
dirX = -1
dirY = 1
dirX = 1
dirY = -1
dirX = 1
dirY = 1
dirX = -1
bContinue = FALSE
' Quit if we're out of bounds
bContinue = FALSE
x = FindMe.origx
y = FindMe.origy
bContinue = TRUE
' look along y axis for an available adjacent point
destX = x
destY = y + dirY
If NewArray
(destX
, destY
, 0).c
= iEmpty
Then NewArray(destX, destY, 0).c = FindMe.c
bResult = TRUE
bContinue = FALSE
' look along x axis for an available adjacent point
destX = x + dirX
destY = y
If NewArray
(x
+ dirX
, y
, 0).c
= iEmpty
Then NewArray(destX, destY, 0).c = FindMe.c
bResult = TRUE
bContinue = FALSE
' look diagonally for an available adjacent point
destX = x + dirX
destY = y + dirY
If NewArray
(x
+ dirX
, y
+ dirY
, 0).c
= iEmpty
Then NewArray(destX, destY, 0).c = FindMe.c
bResult = TRUE
bContinue = FALSE
' ' look (in the opposite direction) along y axis for an available adjacent point
' If bContinue = TRUE Then
' destX = x
' destY = y - dirY
' if destX >= LBound(NewArray, 1) then
' if destX <= UBound(NewArray, 1) then
' if destY >= LBound(NewArray, 2) then
' if destY <= UBound(NewArray, 2) then
' if NewArray(destX, destY, 0).c = iEmpty then
' NewArray(destX, destY, 0).c = FindMe.c
' bResult = TRUE
' bContinue = FALSE
' end if
' end if
' end if
' end if
' end if
' end if
'
' ' look (in the opposite direction) along x axis for an available adjacent point
' If bContinue = TRUE Then
' destX = x - dirX
' destY = y
' if destX >= LBound(NewArray, 1) then
' if destX <= UBound(NewArray, 1) then
' if destY >= LBound(NewArray, 2) then
' if destY <= UBound(NewArray, 2) then
' if NewArray(x + dirX, y, 0).c = iEmpty then
' NewArray(destX, destY, 0).c = FindMe.c
' bResult = TRUE
' bContinue = FALSE
' end if
' end if
' end if
' end if
' end if
' end if
'
' ' look (in the opposite direction) diagonally for an available adjacent point
' If bContinue = TRUE Then
' destX = x - dirX
' destY = y - dirY
' if destX >= LBound(NewArray, 1) then
' if destX <= UBound(NewArray, 1) then
' if destY >= LBound(NewArray, 2) then
' if destY <= UBound(NewArray, 2) then
' if NewArray(x + dirX, y + dirY, 0).c = iEmpty then
' NewArray(destX, destY, 0).c = FindMe.c
' bResult = TRUE
' bContinue = FALSE
' end if
' end if
' end if
' end if
' end if
' End If
' Return result
FindEmptyShearRotationPoint4% = bResult
' /////////////////////////////////////////////////////////////////////////////
' Tries to correct for missing points with improved logic v3
' Receives parameter sMap
' which comes from TestSprite1$, TestSprite2$, TestSprite3$, etc.
' e.g. ShearRotate4Test1 TestSprite1$
Dim RoArray1
(-16 To 16, -16 To 16, 127) As RotationType
Dim RoArray2
(-16 To 16, -16 To 16, 127) As RotationType
'Dim sMap As String
' GET A SHAPE TO BE ROTATED
Print "3 shear rotation based on code by leopardpm" 'sMap = TestSprite1$
' CONVERT SHAPE TO ARRAY
StringToRotationArray RoArray1(), sMap, "."
' GET START ANGLE
D = 0
Print "Rotated by " + cstr$
(D
) + " degrees:" Print RotationArrayToStringTest
(RoArray1
()) Print "Type an angle (-360 to 360) to rotate to, " Print "or blank to increase by 1 degree, or q to quit." Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)." Print "Hold down <ENTER> to rotate continually." Input "Angle (q to quit)? ", in$
D1 = -500
D1 = 1
' ROTATE TO EACH ANGLE
bFinished = FALSE
' ROTATE CLOCKWISE
ShearRotate4 RoArray1
(), RoArray2
(), D
, cClockwise
, Asc("."), iMissing
'Print "Rotated by " + cstr$(D) + " degrees:"
Print "Rotated by " + cstr$
(D
) + " degrees" + IIFSTR$
(iMissing
= 0, "", " (" + cstr$
(iMissing
) + " points missing)") + ":"
Print RotationArrayToStringTest
(RoArray2
())
Print "Type an angle (-360 to 360) to rotate to, " Print "or blank to increase by 1 degree, or q to quit." Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)." Print "Hold down <ENTER> to rotate continually." Input "Angle (q to quit)? ", in$
D = D - 1
bFinished = TRUE
bFinished = TRUE
' ROTATE COUNTER-CLOCKWISE
ShearRotate4 RoArray1
(), RoArray2
(), D
, cCounterClockwise
, Asc("."), iMissing
'Print "Rotated by " + cstr$(D) + " degrees:"
Print "Rotated by " + cstr$
(D
) + " degrees" + IIFSTR$
(iMissing
= 0, "", " (" + cstr$
(iMissing
) + " points missing)") + ":"
Print RotationArrayToStringTest
(RoArray2
())
Print "Type an angle (0 to 360) to rotate to, " Print "or blank to increase by 1 degree, or q to quit." Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)." Print "Hold down <ENTER> to rotate continually." Input "Angle (q to quit)? ", in$
D = D + 1
bFinished = TRUE
bFinished = TRUE
' /////////////////////////////////////////////////////////////////////////////
' Correct for overwriting points issue
' (happens at 30, 60, 120, 150, 210, 240, 300, 330 degrees)
' using STxAxTIC's method of merging array rotated to angle-1 and angle+1
' If rotation is 30, 60, 120, 150, 210, 240, 300, 330 degrees
' then try correcting for overwriting.
If IsProblemAngle%
(angle1
) Then ' get array rotated to angle-1
ShearRotate OldArray(), arrCW(), angle1 - 1, iEmpty
' get array rotated to angle
ShearRotate OldArray(), NewArray(), angle1 - 1, iEmpty
' get array rotated to angle=1
ShearRotate OldArray(), arrCCW(), angle1 + 1, iEmpty
' merge the results
' is point empty?
If NewArray
(x
, y
, 0).c
= iEmpty
Then ' see if point is occupied 1 deg. counter-clockwise
If arrCCW
(x
, y
, 0).c
<> iEmpty
Then NewArray(x, y, 0).c = arrCCW(x, y, 0).c
' see if point is occupied 1 deg. clockwise
NewArray(x, y, 0).c = arrCW(x, y, 0).c
' Otherwise rotate without correcting.
ShearRotate OldArray(), NewArray(), angle1, iEmpty
' /////////////////////////////////////////////////////////////////////////////
' Tries to correct for missing (overwritten) points
' using STxAxTIC's method to correct for overwritten points
' Receives parameter sMap
' which comes from TestSprite1$, TestSprite2$, TestSprite3$, etc.
' e.g. ShearRotate5Test1 TestSprite1$
Dim RoArray1
(-16 To 16, -16 To 16, 127) As RotationType
Dim RoArray2
(-16 To 16, -16 To 16, 127) As RotationType
'Dim sMap As String
'Dim iMissing As Integer
' GET A SHAPE TO BE ROTATED
Print "3 shear rotation based on code by leopardpm" Print "using STxAxTIC's method to correct for overwritten points" 'sMap = TestSprite1$
' CONVERT SHAPE TO ARRAY
StringToRotationArray RoArray1(), sMap, "."
' GET START ANGLE
D = 0
Print "Rotated by " + cstr$
(D
) + " degrees:" Print RotationArrayToStringTest
(RoArray1
()) Print "Type an angle (-360 to 360) to rotate to, " Print "or blank to increase by 1 degree, or q to quit." Print "Note: Tries to fix for 30,60,120,150,210,240,300,330 degrees (looks bad)." Print "Hold down <ENTER> to rotate continually." Input "Angle (q to quit)? ", in$
D1 = -500
D1 = 1
' ROTATE TO EACH ANGLE
bFinished = FALSE
' ROTATE CLOCKWISE
'ShearRotate4 RoArray1(), RoArray2(), D, cClockwise, Asc("."), iMissing
ShearRotate5 RoArray1
(), RoArray2
(), D
, Asc(".") Print "Rotated by " + cstr$
(D
) + " degrees:" 'Print "Rotated by " + cstr$(D) + " degrees" + IIFSTR$ (iMissing = 0, "", " (" + cstr$(iMissing) + " points missing)") + ":"
Print RotationArrayToStringTest
(RoArray2
())
Print "Type an angle (-360 to 360) to rotate to, " Print "or blank to increase by 1 degree, or q to quit." Print "Note: Tries to fix for 30,60,120,150,210,240,300,330 degrees (looks bad)." Print "Hold down <ENTER> to rotate continually." Input "Angle (q to quit)? ", in$
D = D - 1
bFinished = TRUE
bFinished = TRUE
' ROTATE COUNTER-CLOCKWISE
'ShearRotate4 RoArray1(), RoArray2(), D, cCounterClockwise, Asc("."), iMissing
ShearRotate5 RoArray1
(), RoArray2
(), D
, Asc(".") Print "Rotated by " + cstr$
(D
) + " degrees:" 'Print "Rotated by " + cstr$(D) + " degrees" + IIFSTR$ (iMissing = 0, "", " (" + cstr$(iMissing) + " points missing)") + ":"
Print RotationArrayToStringTest
(RoArray2
())
Print "Type an angle (0 to 360) to rotate to, " Print "or blank to increase by 1 degree, or q to quit." Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)." Print "Hold down <ENTER> to rotate continually." Input "Angle (q to quit)? ", in$
D = D + 1
bFinished = TRUE
bFinished = TRUE
' /////////////////////////////////////////////////////////////////////////////
' Correct for overwriting points issue
' (happens at 30, 60, 120, 150, 210, 240, 300, 330 degrees)
' using STxAxTIC's method of merging array rotated to angle-1 and angle+1
' updated with using precalculated arrays to find the exact location
' a given point should rotate to.
' Receives:
' OldArray = array to rotate
' NewArray = rotated array returned here
' angle = angle to rotate to
' iDirection = cClockwise or cCounterClockwise (cClockwise and cCounterClockwise constants must be declared globally)
' iEmpty = value for empty
' iMissing = return value (byref), number of points not found
Dim oSearch
As RotationType
' *****************************************************************************
' NOTE: THESE WOULD BE SHARED ARRAYS, PRE-POPULATED AHEAD OF TIME
ReDim arrMasks
(-1, -1, -1) As RotationType
' Initialize
iMissing = 0
' Get index
GetMaskIndex arrMaskIndex()
' Get rotation masks
GetRotationMasks OldArray(), arrMasks(), iMaxValue
' *****************************************************************************
' If rotation is 30, 60, 120, 150, 210, 240, 300, 330 degrees
' then try correcting for overwriting.
If IsProblemAngle%
(angle
) Then
' do we have a mask index for this angle?
If arrMaskIndex
(angle
) > 0 Then
' initialize new with empty
NewArray(x, y, 0).origx = x
NewArray(x, y, 0).origy = y
NewArray(x, y, 0).c = iEmpty
' first do basic rotate
' get the mask value from unrotated
iValue = arrMasks(arrMaskIndex(0), x, y).c
' is mask value in the rotated?
FindValueInMask arrMasks(), arrMaskIndex(angle), iValue, oSearch
' found, copy point
NewArray(oSearch.origx, oSearch.origy, 0).c = OldArray(x, y, 0).c
' not found, try get from adjacent angles
If iDirection
= cCounterClockwise
Then ' is mask value in the rotated -1 ?
FindValueInMask arrMasks(), arrMaskIndex(angle - 1), iValue, oSearch
' found, copy point
NewArray(oSearch.origx, oSearch.origy, 0).c = OldArray(x, y, 0).c
' not found, try to get from rotated +1
FindValueInMask arrMasks(), arrMaskIndex(angle + 1), iValue, oSearch
' found, copy point
NewArray(oSearch.origx, oSearch.origy, 0).c = OldArray(x, y, 0).c
' not found, oh well
iMissing = iMissing + 1
Else ' assume iDirection = cClockwise ' is mask value in the rotated +1 ?
FindValueInMask arrMasks(), arrMaskIndex(angle + 1), iValue, oSearch
' found, copy point
NewArray(oSearch.origx, oSearch.origy, 0).c = OldArray(x, y, 0).c
' not found, try to get from rotated -1
FindValueInMask arrMasks(), arrMaskIndex(angle - 1), iValue, oSearch
' found, copy point
NewArray(oSearch.origx, oSearch.origy, 0).c = OldArray(x, y, 0).c
' not found, oh well
iMissing = iMissing + 1
' Otherwise rotate without correcting.
ShearRotate OldArray(), NewArray(), angle, iEmpty
' /////////////////////////////////////////////////////////////////////////////
' looks for value iValue in arrMasks(iIndex, [x], [y])
' and returns results in oResult (RotationType):
' * if found, returns oResult.c = TRUE, and x,y found at in oResult.origx, oResult.origy
' * if not found, returns oResult.c = FALSE
' FindValueInMask arrMasks(), arrMaskIndex(angle), iValue, c
oResult.c = FALSE
bFound = FALSE
If arrMasks
(iIndex
, iLoopX
, iLoopY
).c
= iValue
Then oResult.c = TRUE
oResult.origx = iLoopX
oResult.origy = iLoopY
'iLoopY = ubound(arrMasks, 3)+1
bFound = TRUE
' /////////////////////////////////////////////////////////////////////////////
' Tries to correct for missing (overwritten) points
' using STxAxTIC's method to correct for overwritten points
' updated with using precalculated arrays to find the exact location
' a given point should rotate to.
' Receives parameter sMap
' which comes from TestSprite1$, TestSprite2$, TestSprite3$, etc.
' e.g. ShearRotate6Test1 TestSprite1$
Dim RoArray1
(-16 To 16, -16 To 16, 127) As RotationType
Dim RoArray2
(-16 To 16, -16 To 16, 127) As RotationType
'Dim sMap As String
' GET A SHAPE TO BE ROTATED
Print "3 shear rotation based on code by leopardpm" Print "using STxAxTIC's method to correct for overwritten points" Print "updated with using precalculated arrays to find the exact location" Print "a given point should rotate to."
'sMap = TestSprite1$
' CONVERT SHAPE TO ARRAY
StringToRotationArray RoArray1(), sMap, "."
' GET START ANGLE
D = 0
Print "Rotated by " + cstr$
(D
) + " degrees:" Print RotationArrayToStringTest
(RoArray1
()) Print "Type an angle (-360 to 360) to rotate to, " Print "or blank to increase by 1 degree, or q to quit." Print "Note: Tries to fix for 30,60,120,150,210,240,300,330 degrees (looks bad)." Print "Hold down <ENTER> to rotate continually." Input "Angle (q to quit)? ", in$
D1 = -500
D1 = 1
' ROTATE TO EACH ANGLE
bFinished = FALSE
' ROTATE CLOCKWISE
iDirection = cClockwise
'ShearRotate4 RoArray1(), RoArray2(), D, cClockwise, Asc("."), iMissing
ShearRotate6 RoArray1
(), RoArray2
(), D
, iDirection
, Asc("."), iMissing
'Print "Rotated by " + cstr$(D) + " degrees:"
Print "Rotated by " + cstr$
(D
) + " degrees" + IIFSTR$
(iMissing
= 0, "", " (" + cstr$
(iMissing
) + " points missing)") + ":"
Print RotationArrayToStringTest
(RoArray2
())
Print "Type an angle (-360 to 360) to rotate to, " Print "or blank to increase by 1 degree, or q to quit." Print "Note: Tries to fix for 30,60,120,150,210,240,300,330 degrees (looks bad)." Print "Hold down <ENTER> to rotate continually." Input "Angle (q to quit)? ", in$
D = D - 1
bFinished = TRUE
bFinished = TRUE
' ROTATE COUNTER-CLOCKWISE
iDirection = cCounterClockwise
'ShearRotate4 RoArray1(), RoArray2(), D, cCounterClockwise, Asc("."), iMissing
ShearRotate6 RoArray1
(), RoArray2
(), D
, iDirection
, Asc("."), iMissing
'Print "Rotated by " + cstr$(D) + " degrees:"
Print "Rotated by " + cstr$
(D
) + " degrees" + IIFSTR$
(iMissing
= 0, "", " (" + cstr$
(iMissing
) + " points missing)") + ":"
Print RotationArrayToStringTest
(RoArray2
())
Print "Type an angle (0 to 360) to rotate to, " Print "or blank to increase by 1 degree, or q to quit." Print "Note: Need to fix code for 30,60,120,150,210,240,300,330 degrees (looks bad)." Print "Hold down <ENTER> to rotate continually." Input "Angle (q to quit)? ", in$
D = D + 1
bFinished = TRUE
bFinished = TRUE
' /////////////////////////////////////////////////////////////////////////////
Dim RoutineName
As String: RoutineName
= "GetRotationMaskTest" ReDim RoArray1
(-16 To 16, -16 To 16, 127) As RotationType
'ReDim RoArray2(-16 To 16, -16 To 16, 127) As RotationType
ReDim arrMasks
(-1, -1, -1) As RotationType
' Get index
GetMaskIndex arrMaskIndex()
Print "Contents of arrMaskIndex:" If arrMaskIndex
(iLoop%
) > 0 Then Print "arrMaskIndex(" + cstr$
(iLoop%
) + ") = " + cstr$
(arrMaskIndex
(iLoop%
)) Input "PRESS <ENTER> TO CONTINUE OR q TO QUIT"; in$
' Get rotation masks
GetRotationMasks RoArray1(), arrMasks(), iMaxValue%
' Show unrotated mask
Print "Unrotated mask, containing unique values 1-" + cstr$
(iMaxValue%
) + ":" iIndex% = 0
sLine = ""
sLine
= sLine
+ IIFSTR$
(Len(sLine
) = 0, "", ",") + Right$(" " + cstr$
(arrMasks
(iIndex%
, x
, y
).c
), 4) Input "PRESS <ENTER> TO CONTINUE OR q TO QUIT"; in$
' Show what we have
iIndex% = arrMaskIndex(iLoop%)
'print "arrMaskIndex(" + cstr$(iLoop%) + ") = " + cstr$(iIndex%)
Print "arrMaskIndex(" + cstr$
(iLoop%
) + ") = " + cstr$
(iIndex%
) sLine = ""
sLine
= sLine
+ IIFSTR$
(Len(sLine
) = 0, "", ",") + Right$(" " + cstr$
(arrMasks
(iIndex%
, x
, y
).c
), 4) Input "PRESS <ENTER> TO CONTINUE OR q TO QUIT"; in$
Print RoutineName
+ " finished." Input "PRESS <ENTER> TO CONTINUE"; in$
CleanupAndExit:
'Screen 0
' /////////////////////////////////////////////////////////////////////////////
' Returns array with rotation masks
' NewArray(index, x, y) of RotationType
' and maximum unique value iValue.
' (Values range from 1 to iValue.)
Sub GetRotationMasks
(OldArray
() As RotationType
, NewArray
() As RotationType
, iValue
As Integer)
' Get index
GetMaskIndex arrMaskIndex()
' Size array
' create the original mask
iValue = 0
iValue = iValue + 1
arrMask(x, y, 0).c = iValue
arrMask(x, y, 0).origx = x
arrMask(x, y, 0).origy = y
NewArray(0, x, y).c = iValue
NewArray(0, x, y).origx = x
NewArray(0, x, y).origy = y
' create rotated masks
' If angle is 30, 60, 120, 150, 210, 240, 300, 330 degrees
' then precalculate rotation masks for angle-1, angle, angle+1
' and store in NewArray
If IsProblemAngle%
(angle
) Then ' get array rotated to angle-1
ShearRotate arrMask(), arrNext(), angle - 1, iEmpty
' copy to mask array
iIndex = arrMaskIndex(angle - 1)
NewArray(iIndex, x, y).c = arrNext(x, y, 0).c
NewArray(iIndex, x, y).origx = arrNext(x, y, 0).origx
NewArray(iIndex, x, y).origy = arrNext(x, y, 0).origy
' get array rotated to angle
ShearRotate arrMask(), arrNext(), angle, iEmpty
' copy to mask array
iIndex = arrMaskIndex(angle)
NewArray(iIndex, x, y).c = arrNext(x, y, 0).c
NewArray(iIndex, x, y).origx = arrNext(x, y, 0).origx
NewArray(iIndex, x, y).origy = arrNext(x, y, 0).origy
' get array rotated to angle+1
ShearRotate arrMask(), arrNext(), angle + 1, iEmpty
' copy to mask array
iIndex = arrMaskIndex(angle + 1)
NewArray(iIndex, x, y).c = arrNext(x, y, 0).c
NewArray(iIndex, x, y).origx = arrNext(x, y, 0).origx
NewArray(iIndex, x, y).origy = arrNext(x, y, 0).origy
' /////////////////////////////////////////////////////////////////////////////
' Returns an array 0 to 360
' that returns the index of the mask array for the given angle
' for looking up the mask for a given angle in the mask array
' (a value 0 means no entry exists in the mask array)
' The values that matter are:
' arrMaskIndex( 29) = 1
' arrMaskIndex( 30) = 2
' arrMaskIndex( 31) = 3
' arrMaskIndex( 59) = 4
' arrMaskIndex( 60) = 5
' arrMaskIndex( 61) = 6
' arrMaskIndex(119) = 7
' arrMaskIndex(120) = 8
' arrMaskIndex(121) = 9
' arrMaskIndex(149) = 10
' arrMaskIndex(150) = 11
' arrMaskIndex(151) = 12
' arrMaskIndex(209) = 13
' arrMaskIndex(210) = 14
' arrMaskIndex(211) = 15
' arrMaskIndex(239) = 16
' arrMaskIndex(240) = 17
' arrMaskIndex(241) = 18
' arrMaskIndex(299) = 19
' arrMaskIndex(300) = 20
' arrMaskIndex(301) = 21
' arrMaskIndex(329) = 22
' arrMaskIndex(330) = 23
' arrMaskIndex(331) = 24
iCount% = -1
arrMaskIndex(iLoop%) = 0
iCount% = iCount% + 3
arrMaskIndex(iLoop% - 1) = iCount% - 1
arrMaskIndex(iLoop% + 0) = iCount% + 0
arrMaskIndex(iLoop% + 1) = iCount% + 1
' /////////////////////////////////////////////////////////////////////////////
'Screen _NewImage(1280, 1024, 32): _ScreenMove 0, 0
'Width 80, 80
Print "Testing GetMaskIndex" GetMaskIndex arrMaskIndex()
Print "GetMaskIndex arrMaskIndex()" Print " LBound(arrMaskIndex) = " + cstr$
(LBound(arrmaskindex
)) Print " UBound(arrMaskIndex) = " + cstr$
(UBound(arrmaskindex
))
Print "Testing problem angles:"
If IsProblemAngle%
(iLoop%
) Then Print " angle-1, arrMaskIndex(" + cstr$
(iLoop%
- 1) + ") = " + cstr$
(arrMaskIndex
(iLoop%
- 1)) Print " angle , arrMaskIndex(" + cstr$
(iLoop%
+ 0) + ") = " + cstr$
(arrMaskIndex
(iLoop%
+ 0)) Print " angle+1, arrMaskIndex(" + cstr$
(iLoop%
+ 1) + ") = " + cstr$
(arrMaskIndex
(iLoop%
+ 1)) Print " angle " + cstr$
(iLoop%
) + "is out of range."
Input "PRESS <ENTER> TO CONTINUE"; in$
' /////////////////////////////////////////////////////////////////////////////
m$ = ""
' 11111111112222222222333
' 12345678901234567890123456789012
m$
= m$
+ "11111111111111111111111111111111" + Chr$(13) ' 1 m$
= m$
+ "4..............................2" + Chr$(13) ' 2 m$
= m$
+ "4....##.....#######.....####...2" + Chr$(13) ' 3 m$
= m$
+ "4...####....##...###...######..2" + Chr$(13) ' 4 m$
= m$
+ "4..##..##...##...###..##....##.2" + Chr$(13) ' 5 m$
= m$
+ "4.##....##..#######...##.......2" + Chr$(13) ' 6 m$
= m$
+ "4.########..#######...##.......2" + Chr$(13) ' 7 m$
= m$
+ "4.########..##...###..##....##.2" + Chr$(13) ' 8 m$
= m$
+ "4.##....##..##...###...######..2" + Chr$(13) ' 9 m$
= m$
+ "4.##....##..#######.....####...2" + Chr$(13) ' 10 m$
= m$
+ "4..............................2" + Chr$(13) ' 11 m$
= m$
+ "4..............................2" + Chr$(13) ' 12 m$
= m$
+ "4..ABBBBBBBBBBBBBBBBBBBBBBBBC..2" + Chr$(13) ' 13 m$
= m$
+ "4..A...........EE...........C..2" + Chr$(13) ' 14 m$
= m$
+ "4..A..........FFFF..........C..2" + Chr$(13) ' 15 m$
= m$
+ "4..A.........GGGGGG.........C..2" + Chr$(13) ' 16 m$
= m$
+ "4..A........HHHHHHHH........C..2" + Chr$(13) ' 17 m$
= m$
+ "4..A.......IIIIIIIIII.......C..2" + Chr$(13) ' 18 m$
= m$
+ "4..A......JJJJJJJJJJJJ......C..2" + Chr$(13) ' 19 m$
= m$
+ "4..DDDDDDDDDDDDDDDDDDDDDDDDDC..2" + Chr$(13) ' 20 m$
= m$
+ "4..............................2" + Chr$(13) ' 21 m$
= m$
+ "4..............................2" + Chr$(13) ' 22 m$
= m$
+ "4.######....########..########.2" + Chr$(13) ' 23 m$
= m$
+ "4.#######...########..########.2" + Chr$(13) ' 24 m$
= m$
+ "4.##...###..##........##.......2" + Chr$(13) ' 25 m$
= m$
+ "4.##....##..########..#######..2" + Chr$(13) ' 26 m$
= m$
+ "4.##....##..########..#######..2" + Chr$(13) ' 27 m$
= m$
+ "4.##...###..##........##.......2" + Chr$(13) ' 28 m$
= m$
+ "4.#######...##........##.......2" + Chr$(13) ' 29 m$
= m$
+ "4.######....########..##.......2" + Chr$(13) ' 30 m$
= m$
+ "4..............................2" + Chr$(13) ' 31 m$
= m$
+ "33333333333333333333333333333332" + Chr$(13) ' 32 TestSprite1$ = m$
' /////////////////////////////////////////////////////////////////////////////
m$ = ""
' 11111111112222222222333
' 12345678901234567890123456789012
m$
= m$
+ "...............AA..............." + Chr$(13) ' 1 m$
= m$
+ "..............//BB.............." + Chr$(13) ' 2 m$
= m$
+ ".............??..CC............." + Chr$(13) ' 3 m$
= m$
+ "............==....DD............" + Chr$(13) ' 4 m$
= m$
+ "...........++......EE..........." + Chr$(13) ' 5 m$
= m$
+ "..........&&........FF.........." + Chr$(13) ' 6 m$
= m$
+ ".........zz..........GG........." + Chr$(13) ' 7 m$
= m$
+ "........yy............HH........" + Chr$(13) ' 8 m$
= m$
+ ".......xx..............II......." + Chr$(13) ' 9 m$
= m$
+ "......ww................JJ......" + Chr$(13) ' 10 m$
= m$
+ ".....vv..................KK....." + Chr$(13) ' 11 m$
= m$
+ "....uu....................LL...." + Chr$(13) ' 12 m$
= m$
+ "...tt......DDAAAAAAA.......MM..." + Chr$(13) ' 13 m$
= m$
+ "..ss.......DDAAAAAAA........NN.." + Chr$(13) ' 14 m$
= m$
+ ".rr........DD.....BB.........OO." + Chr$(13) ' 15 m$
= m$
+ "qq.........DD.....BB..........PP" + Chr$(13) ' 16 m$
= m$
+ "pp.........DD.....BB..........QQ" + Chr$(13) ' 17 m$
= m$
+ ".oo........DD.....BB.........RR." + Chr$(13) ' 18 m$
= m$
+ "..nn.......CCCCCCCBB........SS.." + Chr$(13) ' 19 m$
= m$
+ "...mm......CCCCCCCBB.......TT..." + Chr$(13) ' 20 m$
= m$
+ "....ll....................UU...." + Chr$(13) ' 21 m$
= m$
+ ".....kk..................VV....." + Chr$(13) ' 22 m$
= m$
+ "......jj................WW......" + Chr$(13) ' 23 m$
= m$
+ ".......ii..............XX......." + Chr$(13) ' 24 m$
= m$
+ "........hh............YY........" + Chr$(13) ' 25 m$
= m$
+ ".........gg..........ZZ........." + Chr$(13) ' 26 m$
= m$
+ "..........ff........@@.........." + Chr$(13) ' 27 m$
= m$
+ "...........ee......##..........." + Chr$(13) ' 28 m$
= m$
+ "............dd....$$............" + Chr$(13) ' 29 m$
= m$
+ ".............cc..%%............." + Chr$(13) ' 30 m$
= m$
+ "..............bb\\.............." + Chr$(13) ' 31 m$
= m$
+ "...............aa..............." + Chr$(13) ' 32 TestSprite2$ = m$
' /////////////////////////////////////////////////////////////////////////////
m$ = ""
' 11111111112222222222333
' 12345678901234567890123456789012
m$
= m$
+ "................................" + Chr$(13) ' 1 m$
= m$
+ "................................" + Chr$(13) ' 2 m$
= m$
+ "................................" + Chr$(13) ' 3 m$
= m$
+ "................................" + Chr$(13) ' 4 m$
= m$
+ "................................" + Chr$(13) ' 5 m$
= m$
+ "................................" + Chr$(13) ' 6 m$
= m$
+ "................................" + Chr$(13) ' 7 m$
= m$
+ "................................" + Chr$(13) ' 8 m$
= m$
+ "................................" + Chr$(13) ' 9 m$
= m$
+ "................................" + Chr$(13) ' 10 m$
= m$
+ "................................" + Chr$(13) ' 11 m$
= m$
+ "................................" + Chr$(13) ' 12 m$
= m$
+ "................................" + Chr$(13) ' 13 m$
= m$
+ "................................" + Chr$(13) ' 14 m$
= m$
+ "....It's a SCREEN resolution?..." + Chr$(13) ' 15 m$
= m$
+ "................................" + Chr$(13) ' 16 m$
= m$
+ "................................" + Chr$(13) ' 17 m$
= m$
+ "................................" + Chr$(13) ' 18 m$
= m$
+ "................................" + Chr$(13) ' 19 m$
= m$
+ "................................" + Chr$(13) ' 20 m$
= m$
+ "................................" + Chr$(13) ' 21 m$
= m$
+ "................................" + Chr$(13) ' 22 m$
= m$
+ "................................" + Chr$(13) ' 23 m$
= m$
+ "................................" + Chr$(13) ' 24 m$
= m$
+ "................................" + Chr$(13) ' 25 m$
= m$
+ "................................" + Chr$(13) ' 26 m$
= m$
+ "................................" + Chr$(13) ' 27 m$
= m$
+ "................................" + Chr$(13) ' 28 m$
= m$
+ "................................" + Chr$(13) ' 29 m$
= m$
+ "................................" + Chr$(13) ' 30 m$
= m$
+ "................................" + Chr$(13) ' 31 m$
= m$
+ "................................" + Chr$(13) ' 32 PetrText1$ = m$
' /////////////////////////////////////////////////////////////////////////////
MyString = ""
sLine = ""
sLine = sLine + MyArray(iY, iX)
MyString
= MyString
+ sLine
+ Chr$(13) ArrayToString$ = MyString
' /////////////////////////////////////////////////////////////////////////////
MyString = ""
MyString
= MyString
+ " 11111111112222222222333" + Chr$(13) MyString
= MyString
+ " 12345678901234567890123456789012" + Chr$(13) sLine = ""
sLine
= sLine
+ Right$(" " + cstr$
(iY
), 2) sLine = sLine + MyArray(iY, iX)
sLine
= sLine
+ Right$(" " + cstr$
(iY
), 2) MyString
= MyString
+ sLine
+ Chr$(13) MyString
= MyString
+ " 12345678901234567890123456789012" + Chr$(13) MyString
= MyString
+ " 11111111112222222222333" + Chr$(13) ArrayToStringTest$ = MyString
' /////////////////////////////////////////////////////////////////////////////
Function RotationArrayToStringTest$
(RoArray
() As RotationType
) MyString = ""
MyString
= MyString
+ " ---------------- ++++++++++++++++" + Chr$(13) MyString
= MyString
+ " 1111111 1111111" + Chr$(13) MyString
= MyString
+ " 654321098765432101234567890123456" + Chr$(13) sLine = ""
sLine
= sLine
+ Right$(" " + cstr$
(iY
), 3) sLine
= sLine
+ Chr$(RoArray
(iX
, iY
, 0).c
) sLine
= sLine
+ Right$(" " + cstr$
(iY
), 3) MyString
= MyString
+ sLine
+ Chr$(13) MyString
= MyString
+ " 654321098765432101234567890123456" + Chr$(13) MyString
= MyString
+ " 1111111 1111111" + Chr$(13) MyString
= MyString
+ " ---------------- ++++++++++++++++" + Chr$(13) RotationArrayToStringTest$ = MyString
' /////////////////////////////////////////////////////////////////////////////
' 1. split string by line breaks CHR$(13)
' 2. split lines up to 1 column per char
' 3. count rows, columns
' 4. DIM array, making sure array has
' a) an _ODD_ number of rows/columns, with a center point
' b) index is in cartesian format, where center is (0,0)
' 5. populate array with contents of string
' dimension #1 = columns
' dimension #2 = rows
Dim RoutineName
As String: RoutineName
= "StringToRotationArray"
split MyString, delim$, arrLines$()
iRowCount
= UBound(arrLines$
) + 1
' look at all the rows and find the max # of columns used
iColCount = 0
' count the columns for this row
iCount = 0
iCount = iCount + 1
' if this row has the most so far, then set that to the max
iColCount = iCount
' adjust columns to be odd
iColCount = iColCount + 1
bAddedColumn = TRUE
' calculate array bounds for columns
iHalf1 = (iColCount - 1) / 2
iFrom1 = 0 - iHalf1
iTo1 = iHalf1
' adjust rows to be odd
iRowCount = iRowCount + 1
bAddedRow = TRUE
' calculate array bounds for rows
iHalf2 = (iRowCount - 1) / 2
iFrom2 = 0 - iHalf2
iTo2 = iHalf2
' size array to new bounds
ReDim RoArray
(iFrom1
To iTo1
, iFrom2
To iTo2
, 127) As RotationType
' get value for empty
iEmpty = 32 ' (use space as default)
' clear array
RoArray(iX, iY, 0).c = iEmpty
RoArray(iX, iY, 0).origx = iX
RoArray(iX, iY, 0).origy = iY
' fill array
iY = iY + 1
iX = iX + 1
sChar$
= Mid$(arrLines$
(iRow%
), iCol%
, 1) RoArray
(iX
, iY
, 0).c
= Asc(sChar$
)
End Sub ' StringToRotationArray
' /////////////////////////////////////////////////////////////////////////////
split MyString, delim$, arrLines$()
sChar$
= Mid$(arrLines$
(iRow%
), iCol%
, 1)
sChar$
= Left$(sChar$
, 1) sChar$ = "."
MyArray(iRow% + iDim1, (iCol% - 1) + iDim2) = sChar$
' Exit if out of bounds
' Exit if out of bounds
' /////////////////////////////////////////////////////////////////////////////
'SUB ClearArray (MyArray(1 To 32, 1 To 32) AS STRING, MyString As String)
sChar$ = MyString
sChar$ = " "
sChar$
= Left$(MyString
, 1) MyArray(iRow, iCol) = sChar$
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GENERAL PURPOSE ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
'cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
' /////////////////////////////////////////////////////////////////////////////
' /////////////////////////////////////////////////////////////////////////////
TrueFalse$ = "TRUE"
TrueFalse$ = "FALSE"
' /////////////////////////////////////////////////////////////////////////////
Function IIF
(Condition
, IfTrue
, IfFalse
)
' /////////////////////////////////////////////////////////////////////////////
Function IIFSTR$
(Condition
, IfTrue$
, IfFalse$
) If Condition
Then IIFSTR$
= IfTrue$
Else IIFSTR$
= IfFalse$
' /////////////////////////////////////////////////////////////////////////////
' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
IsEven% = TRUE
IsEven% = FALSE
' /////////////////////////////////////////////////////////////////////////////
' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
IsOdd% = TRUE
IsOdd% = FALSE
' /////////////////////////////////////////////////////////////////////////////
' By sMcNeill from https://www.qb64.org/forum/index.php?topic=896.0
IsNum% = TRUE
IsNum% = FALSE
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'Combine all elements of in$() into a single string with delimiter$ separating the elements.
result$ = result$ + delimiter$ + in$(i)
join$ = result$
' /////////////////////////////////////////////////////////////////////////////
' FROM: String Manipulation
' http://www.[abandoned, outdated and now likely malicious qb64 dot net website - don’t go there]/forum/index_topic_5964-0/
'
'SUMMARY:
' Purpose: A library of custom functions that transform strings.
' Author: Dustinian Camburides (dustinian@gmail.com)
' Platform: QB64 (www.[abandoned, outdated and now likely malicious qb64 dot net website - don’t go there])
' Revision: 1.6
' Updated: 5/28/2012
'SUMMARY:
'[Replace$] replaces all instances of the [Find] sub-string with the [Add] sub-string within the [Text] string.
'INPUT:
'Text: The input string; the text that's being manipulated.
'Find: The specified sub-string; the string sought within the [Text] string.
'Add: The sub-string that's being added to the [Text] string.
' VARIABLES:
Dim lngLocation
As Long ' The address of the [Find] substring within the [Text] string. Dim strBefore
As String ' The characters before the string to be replaced. Dim strAfter
As String ' The characters after the string to be replaced.
' INITIALIZE:
' MAKE COPIESSO THE ORIGINAL IS NOT MODIFIED (LIKE ByVal IN VBA)
Text2 = Text1
Find2 = Find1
Add2 = Add1
lngLocation
= InStr(1, Text2
, Find2
)
' PROCESSING:
' While [Find2] appears in [Text2]...
' Extract all Text2 before the [Find2] substring:
strBefore
= Left$(Text2
, lngLocation
- 1)
' Extract all text after the [Find2] substring:
strAfter
= Right$(Text2
, ((Len(Text2
) - (lngLocation
+ Len(Find2
) - 1))))
' Return the substring:
Text2 = strBefore + Add2 + strAfter
' Locate the next instance of [Find2]:
lngLocation
= InStr(1, Text2
, Find2
)
' Next instance of [Find2]...
' OUTPUT:
Replace$ = Text2
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'
' FROM luke, QB64 Developer
' Date: February 15, 2019, 04:11:07 AM
'
' Given a string of words separated by spaces (or any other character),
' splits it into an array of the words. I've no doubt many people have
' written a version of this over the years and no doubt there's a million
' ways to do it, but I thought I'd put mine here so we have at least one
' version. There's also a join function that does the opposite
' array -> single string.
'
' Code is hopefully reasonably self explanatory with comments and a little demo.
' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.
'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences
'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$().
'
'delimiter$ must be one character long.
'result$() must have been REDIMmed previously.
Sub split
(in$
, delimiter$
, result$
()) start = 1
start = start + 1
finish
= InStr(start
, in$
, delimiter$
) result$
(UBound(result$
)) = Mid$(in$
, start
, finish
- start
) start = finish + 1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GENERAL PURPOSE ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' #END
' ################################################################################################################################################################
