Now, let's be honest -- How many of you guys think that PRESET is just a longhand version of PSET? Same command, just with more typing! After all, what's the difference between these two programs:
Code: (Select All)
$Color:32
Screen _NewImage(640, 480, 32)
For y = 0 To _Height
For x = 0 To _Width
If x Mod 10 < 5 Then
If y Mod 10 < 5 Then PSet (x, y), Red Else PSet (x, y), Purple
Else
If y Mod 10 < 5 Then PSet (x, y), Gold Else PSet (x, y), Lime
End If
Next
Next
Sleep
And code 2:
Code: (Select All)
$Color:32
Screen _NewImage(640, 480, 32)
For y = 0 To _Height
For x = 0 To _Width
If x Mod 10 < 5 Then
If y Mod 10 < 5 Then PReset (x, y), Red Else PReset (x, y), Purple
Else
If y Mod 10 < 5 Then PReset (x, y), Gold Else PReset (x, y), Lime
End If
Next
Next
Sleep
Stare at both those screens for a while -- try to focus one eye one each of them -- and see how long you can hold out before your brain melts. That's got to be two of the most annoying tiling patterns possible for the human eyes to have to deal with... Just looking at them, I somehow find them jarring and annoying.
Yet, as annoying as those two tiling patterns are, they're exactly the same pattern.
So how the heck did PRESET behave any different at all from PSET?
Quick answer: It didn't. And for most folks, with the way they tend to code explicitly nowadays, it never will.
Most folks? Code nowadays?? WTH is Steve talking about now??
Good question!
Today's modern coding practices have evolved quite a bit from back in the original days of computing. Variable names are now long and descriptive, whereas in the past they were kept as short as possible to reduce memory usage. Gotos are no longer in widespread use, as modern convention says to structure your programs better with DO..LOOPs and such. Line numbers have faded from the wayside of coding practices...
...and so has the practice of writing code that relies implicitly upon previous settings. For example:
Code: (Select All)
$Color:32
Screen _NewImage(640, 480, 32)
Color Pink
For y = 100 To 200
For x = 100 To 200
PSet (x, y)
Next
Next
Sleep
Most modern programmers would set that PSET to become PSET (x, y), Pink, defining it explicitly in their code. Old code used to use the style above, just to save a few bytes of memory when possible (not something we're so obsessed over with modern machines running 32GB+ of ram). Don't specify a color -- just use the default color...
But, now that we have this older style in mind, let's take a look at PRESET:
Code: (Select All)
$Color:32
Screen _NewImage(640, 480, 32)
Cls , White
Color Pink
For y = 100 To 200
For x = 100 To 200
PReset (x, y)
Next
Next
Sleep
If you notice, I cleared the whole screen white. Specified my color to be Pink... and somehow I drew a BLACK box??
WTH?? How'd that happen??
PSET, when no color is specified, defaults to your _DEFAULTCOLOR. PRESET, when no color is specified, defaults to your _BACKGROUNDCOLOR.
Add a simple Print "Hello World" to the last program and see what you get -- pink text on a black background.
Black is the background color, and thus PRESET plots the points specified in black.
And that's the difference in the two commands in a nutshell: PSET defaults to your primary color; PRESET defaults to your background color. As long as you specify the color yourself, they both perform exactly the same. It's only when no color is specified that you'll see the difference in the two commands.
I've been trying to make this work but I'm stumped.
I messed around with a 3d points program by MasterGy and managed to get a sense of the space and coordinates. There's something that I can't seem to grasp though...that's placing an image onto a surface (using _maptriangle).
In this program, I wanted to place an image on the 'floor'. So I started by placing about 600 small tiles in a grid, exactly where I want to place the image. But images always rotate towards the viewer. Even the small tiles do this. The grid of tiles (as a whole) doesn't do this - only each individual tile. How to lay the image flat is what I'm trying to figure out.
So if anyone here knows how this works....
I'll attach the image I'm trying to use but any 750x750 image will do.
'create spectator
Dim Shared sp(6)
sp(0) = 500
sp(1) = 1500
sp(2) = 400
sp(3) = 0 'looking in the direction of the observer XZ
sp(4) = 0 'looking in the direction of the observer YZ
sp(5) = 1 'multiplier X-Y see
sp(6) = 1 'multiplier Z see
'draw floor tiles
For ctx = 1 To 500 Step 20
For cty = 1 To 500 Step 20
ps = 2
x = 0 + ps * ctx
y = 0 + ps * cty
z = 530
rotate_to_maptriangle x, y, z 'position of floor tiles from the point of view of the observer
_MapTriangle (0, 0)-(100, 0)-(0, 100), floor To(x - ps, y - ps, z)-(x + ps, y - ps, z)-(x - ps, y + ps, z)
_MapTriangle (100, 100)-(100, 0)-(0, 100), floor To(x + ps, y + ps, z)-(x + ps, y - ps, z)-(x - ps, y + ps, z)
Next cty
Next ctx
'draw octo floor
ps = 500
x = 500
y = 500
z = 30
rotate_to_maptriangle x, y, z 'octo floor
_MapTriangle (0, 0)-(750, 0)-(0, 750), floor2 To(x - ps, y - ps, z)-(x + ps, y - ps, z)-(x - ps, y + ps, z), , _Smooth
_MapTriangle (750, 750)-(750, 0)-(0, 750), floor2 To(x + ps, y + ps, z)-(x + ps, y - ps, z)-(x - ps, y + ps, z), , _Smooth
_Display
'mouse input axis movement and mousewheel
mousex = mousex * .6
mousey = mousey * .6
mw = 0
While _MouseInput: mousex = mousex + _MouseMovementX: mousey = mousey + _MouseMovementY: mw = mw + _MouseWheel: Wend 'movement data read
Sub rotate_to_maptriangle (x, y, z)
x2 = x - sp(0)
y2 = y - sp(1)
z2 = z - sp(2)
rotate_2d x2, y2, sp(3)
rotate_2d y2, z2, sp(4) + _Pi / 2
x = x2 * sp(5)
y = y2 * sp(5)
z = z2 * sp(6)
End Sub
Sub rotate_2d (x, y, ang)
x1 = x * Cos(ang) - y * Sin(ang)
y1 = x * Sin(ang) + y * Cos(ang)
x = x1: y = y1
End Sub
I'm not sure what the commas do at the end of the line.
The same thing can be found in this example:
Code: (Select All)
Circle (400, 450), 10, _RGB32(100, 100, 100), , , .5
The only wording I've seen so far is on the circle wiki page which seems to suggest this is about "aspect". I believe this changes the circle to an ellipse. But no real mention of using 3 commas in a row as a plan of attack. I'm starting to expect to see more inexplicable multiple commas as I read more program examples.
If anyone can explain this a bit more, please do. Cheers!
EDIT: You'll notice a bit of a mixed bag of choices (like using GOSUB's and SUB's; every BAM program is an opportunity to do sanity checks on as many statements/styles I can squeeze in there without getting too messy.
Is there a fast way to test whether 2 images are exactly the same?
Code: (Select All)
' ?????????????????????????????????????????????????????????????????????????????
' HOW MIGHT WE EFFICIENTLY COMPARE TWO IMAGES?
' ?????????????????????????????????????????????????????????????????????????????
_Dest 0: Cls , cBlack
If image1& < -1 Then _PutImage , image1&, 0
Print "image1 (press any key)"
Sleep
_Dest 0: Cls , cBlack
If image2& < -1 Then _PutImage , image2&, 0
Print "image2 (press any key)"
Sleep
'compare image1& to image2&, the same?
' UPDATE image2 TO MATCH image1
_Dest image2&
Paint (55, 85), cBlue, cRed
'PAINT [STEP] (column%, row%), fillColor[, borderColor%]
_Dest 0: Cls , cBlack
If image2& < -1 Then _PutImage , image2&, 0
Print "image2 after change (press any key)"
Sleep
'compare image1& to image2&, the same?
' WAIT FOR KEYS
Sleep
' CLEAR IMAGES
Screen 0
If image1& < -1 Then _FreeImage image1&
If image2& < -1 Then _FreeImage image2&
System
Sub DrawSquare (img&, x1%, y1%, size%, fgcolor~&, bgcolor~&)
Dim x2%, y2%
If img& < -1 Then
_Dest img& ': Cls , cEmpty
x2% = (x1% + size%) - 1
y2% = (y1% + size%) - 1
Line (x1%, y1%)-(x2%, y1%), fgcolor~&, , 65535
Line (x2%, y1%)-(x2%, y2%), fgcolor~&, , 65535
Line (x2%, y2%)-(x1%, y2%), fgcolor~&, , 65535
Line (x1%, y2%)-(x1%, y1%), fgcolor~&, , 65535
If bgcolor~& <> cEmpty Then
'PAINT [STEP] (column%, row%), fillColor[, borderColor%]
Paint (x1% + 1, y1% + 1), bgcolor~&, fgcolor~&
End If
End If
End Sub ' Draw Square
Function cBlack~& ()
cBlack = _RGB32(0, 0, 0)
End Function ' cBlack~&
Function cGray~& ()
cGray = _RGB32(128, 128, 128)
End Function ' cGray~&
Function cWhite~& ()
cWhite = _RGB32(255, 255, 255)
End Function ' cWhite~&
Function cRed~& ()
cRed = _RGB32(255, 0, 0)
End Function
Function cOrange~& ()
cOrange = _RGB32(255, 165, 0)
End Function ' cOrange~&
Function cYellow~& ()
cYellow = _RGB32(255, 255, 0)
End Function ' cYellow~&
Function cLime~& ()
cLime = _RGB32(0, 255, 0)
End Function ' cLime~&
Function cCyan~& ()
cCyan = _RGB32(0, 255, 255)
End Function ' cCyan~&
Function cBlue~& ()
cBlue = _RGB32(0, 0, 255)
End Function ' cBlue~&
Function cPurple~& ()
cPurple = _RGB32(128, 0, 255)
End Function ' cPurple~&
Function cMagenta~& ()
cMagenta = _RGB32(255, 0, 255)
End Function ' cMagenta~&
Function cEmpty~& ()
cEmpty = _RGB32(0, 0, 0, 0)
End Function ' cEmpty~&
I'm making an animated Christmas card to post next month, having serious crash-outs with it, so I guess I'll have to post it early to get help so I can continue working on the card. It compiles ok, but when the program finishes running, or when you press a key to quit, it hangs up. I have to use task manager to kill it, and it gives the following 2 Alert error messages boxes:
"Alert"
"list_add: failed to allocate new buffer, structure size:"
...and after closing that one, the next box pops up....
"Alert"
"116"
Here's the BAS code so you can try it. Merry Christmas early...
A command that's been around since the beginning of the language -- but also one that has expanded and evolved to make it much more flexible and powerful for modern programmers.
What is it? ASC is a simple little command which lets us to either set/get the ASCII value to/from a string character.
How do we use it?
To get a value, it's a simple function call like: value = ASC(a$, position)
To set a value, it's a simple sub call such as: ASC(a$, position) = 97
A simple example to showcase these methods a little:
Code: (Select All)
Screen _NewImage(800, 600, 32)
a$ = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
'Back in the days of QB45, this is how folks made use of ASC:
For i = 1 To Len(a$)
temp$ = Mid$(a$, i, 1)
Print temp$; " = "; Asc(temp$)
Next
Sleep
'Then, along came QB64 with its first improvement!
'the ability to specify which byte we wanted!
For i = 1 To Len(a$)
Locate i, 20
Print Mid$(a$, i, 1); " = "; Asc(a$, i)
Next
Sleep
'Did you notice that we didn't actually need to use MID$ to get a single character anymore?
'Instead, we just specified which character we wanted to get the ASC value of, out of our string.
'And, as if that improvement wasn't enough, a SUB ASC was written for QB64!
temp$ = a$ 'a perfect match
For i = 1 To Len(a$)
Asc(temp$, i) = Asc(a$, Len(a$) - i + 1)
Next
Print
Print temp$
Sleep
'Notice how we just used ASC to assign characters to our string, based entirely off their ASCII value?
Cls
Print "ASC";
_Delay .5: Print ".";
_Delay .5: Print ".";
_Delay .5: Print "."
Print "Not the same old command that cavemen used to use when programming!"
Print
Print "You can now specify which byte you want the ASCII value of..."
Print "and you can now assign characters to a string with just their ASCII value."
Dim Shared m_sTitle As String: m_sTitle = "2D Vector Shapes v0.20 by madscijr"
_Title m_sTitle ' display in the Window's title bar
' Simple test of vector graphics,
' borrowed graphics objects and format from Widescreen Asteroids by Terry Ritchie.
' DONE
' * We now can draw opaque shapes (still need to get working for shapes with non-contiguous areas)
' * Display looks prettier!
' - Shapes not active are drawn in an animated dashes
' - Text display is color coded to shapes
' * Tried adding twinkling stars (hard to see, need to fix)
' TO DO:
' * fix twinkling stars
' * encapsulate drawing shape in one routine
' * get fill working for shapes with non-contiguous areas)
' - define "fill coordinates" property or array
' - auto find these in shape
' - eliminate duplicates
' - store the remaining values store in shape data
' - use for PAINT when drawing fill color
' HOLDS POSITION AND VELOCITY OF ALL OBJECTS
Type ObjectType
x As Integer
y As Integer
dx As Integer
dy As Integer
cx As Integer
cy As Integer
IsEnabled As Integer
End Type ' ObjectType
' HOLDS DEFINITION OF ALL OBJECTS
Type CoordType
x1 As Integer
y1 As Integer
x2 As Integer
y2 As Integer
color As _Unsigned Long
IsLast As Integer
End Type ' CoordType
' HOLDS LOCATION + COLOR OF EACH STAR
Type StarType
x As Integer
y As Integer
ColorIndex As _Unsigned Long ' the star's current color
TwinkleCounter As Integer ' counter for twinkles
MaxTwinkCount As Integer ' controls how fast the star twinkles
width As Integer
MinWidth As Integer ' smallest width
MaxWidth As Integer ' largest width
WidthCounter As Integer ' counter for width
MaxWidthCount As Integer ' controls how fast the star size fluctuates
BigCounter As Integer ' counter for max width
MaxBigCount As Integer ' controls how long the star stays big
End Type ' StarType
' OBJECT VARIABLES
ReDim Shared m_arrObject(1 To 6) As ObjectType
ReDim Shared m_arrLines(1 To 8, 1 To 32) As CoordType
ReDim Shared m_arrColor(1 To 6) As _Unsigned Long
ReDim Shared m_arrLineStyle(1 To 8) As Long
ReDim Shared m_arrStars(1 To cMaxStars) As StarType
ReDim Shared m_arrGrayColor(-1) As _Unsigned Long
' =============================================================================
' START THE MAIN ROUTINE
DrawVectorObjectTest1
' =============================================================================
' FINISH
Screen 0
System ' return control to the operating system
Sub DrawVectorObjectTest1
' LOCAL VARIABLES
Dim iFPS As Integer: iFPS = cFPS
Dim iLoop As Integer
Dim iObject As Integer
Dim iLine As Integer
Dim imgBack& ' used for drawing background
Dim imgMiddle& ' used for drawing middle layer
Dim imgFront& ' used for drawing top layer
Dim iWhich As Integer: iWhich = 1
Dim bQuit As Integer: bQuit = FALSE
Dim in$
Dim sError As String: sError = ""
Dim iX As Integer
Dim iY As Integer
Dim sKey As String
Dim iMinX As Integer: iMinX = 0
Dim iMaxX As Integer: iMaxX = 800
Dim iMinY As Integer: iMinY = 0
Dim iMaxY As Integer: iMaxY = 640
Dim iStyleCountMax As Integer: iStyleCountMax = iFPS \ 12 ' change 4x a second
Dim iStyleCountNext As Integer: iStyleCountNext = 0
Dim iStyleIndex As Integer
Dim lngStyle ' line style
Dim lngThatStyle ' line style for other objects
Dim lngThisStyle ' selected object's line style
Dim iNumStars As Integer
Dim iValue As Integer
Dim iMinValue As Integer
Dim iMaxValue As Integer
' =============================================================================
' INITIALIZE
InitializeRandom
Screen _NewImage(800, 640, 32) ' 100 text columns x 40 text rows
' USE LATER FOR DRAWING LAYERS:
imgBack& = _NewImage(800, 640, 32) ' background stars
imgMiddle& = _NewImage(800, 640, 32) ' regular objects
imgFront& = _NewImage(800, 640, 32) ' frontmost objects
' =============================================================================
' START NEW GAME
Do
_KeyClear
' CONFIGURE PRINTING FOR _PrintString
_PrintMode _FillBackground
'_PrintMode _KEEPBACKGROUND
' INIT VARS
sKey = ""
iX = 0: iY = 0
For iObject = LBound(m_arrObject) To UBound(m_arrObject)
m_arrObject(iObject).IsEnabled = FALSE
m_arrObject(iObject).x = iX
m_arrObject(iObject).y = iY
m_arrObject(iObject).dx = RandomNumber%(-5, 5)
m_arrObject(iObject).dy = RandomNumber%(-5, 5)
m_arrObject(iObject).cx = 0
m_arrObject(iObject).cy = 0
iX = iX + 200
If iX > 800 Then
iX = 0
iY = iY + 200
If iY > 640 Then
iY = 0
End If
End If
Next iObject
InitVectorObjects
' SAVE COLORS FOR EACH OBJECT (FROM FIRST LINE SEGMENT) TO ARRAY FOR TEXT
For iObject = LBound(m_arrObject) To UBound(m_arrObject)
iLine = LBound(m_arrLines, 2)
m_arrColor(iObject) = m_arrLines(iObject, iLine).color
Next iObject
' SAVE COLORS FOR STARS AND GRAYSCALE OBJECTS
AddGrayscaleColors m_arrGrayColor()
' -----------------------------------------------------------------------------
' PLACE STARS RANDOMLY
iNumStars = RandomNumber%(cMinStars, cMaxStars)
ReDim m_arrStars(1 To iNumStars) As StarType
For iLoop = 1 To iNumStars
m_arrStars(iLoop).x = RandomNumber%(iMinX, iMaxX)
m_arrStars(iLoop).y = RandomNumber%(iMinY, iMaxY)
m_arrStars(iLoop).ColorIndex = RandomNumber%(LBound(m_arrGrayColor), UBound(m_arrGrayColor))
' Assign a width 1-3 (with different probability for each)
iValue = RandomNumber%(1, 100)
If iValue > 98 Then
m_arrStars(iLoop).MinWidth = RandomNumber%(2, 3)
m_arrStars(iLoop).MaxWidth = 3
ElseIf iValue > 85 Then
m_arrStars(iLoop).MinWidth = RandomNumber%(1, 2)
m_arrStars(iLoop).MaxWidth = 2
Else
m_arrStars(iLoop).MinWidth = RandomNumber%(0, 1)
m_arrStars(iLoop).MaxWidth = 1
End If
' Set initial width to normal (MaxWidth)
m_arrStars(iLoop).width = m_arrStars(iLoop).MaxWidth
' Determine how quickly size changes
' Anywhere between 1/30 second and 1 seconds
iMinValue = iFPS \ 30
iMaxValue = iFPS
m_arrStars(iLoop).MaxWidthCount = RandomNumber%(iMinValue, iMaxValue)
m_arrStars(iLoop).WidthCounter = 0
' Determine how long size is changed
' Anywhere between 1/100 second and 1/50 seconds
iMinValue = iFPS \ 100
iMaxValue = iFPS \ 50
m_arrStars(iLoop).MaxBigCount = RandomNumber%(iMinValue, iMaxValue)
m_arrStars(iLoop).BigCounter = 0
' Determine how quickly they twinkle
' Anywhere between 1/120 second and 1/20 seconds
iMinValue = iFPS \ 120
iMaxValue = iFPS \ 20
m_arrStars(iLoop).MaxTwinkCount = RandomNumber%(iMinValue, iMaxValue)
m_arrStars(iLoop).TwinkleCounter = 0
Next iLoop
' MOVE ENABLED OBJECTS
For iObject = LBound(m_arrObject) To UBound(m_arrObject)
' Only enabled objects
If m_arrObject(iObject).IsEnabled = TRUE Then
' Move along X axis
m_arrObject(iObject).cx = m_arrObject(iObject).cx + 1
If m_arrObject(iObject).cx > (10 - Abs(m_arrObject(iObject).dx)) Then
m_arrObject(iObject).cx = 0
If m_arrObject(iObject).dx < 0 Then
m_arrObject(iObject).x = m_arrObject(iObject).x - 1
If m_arrObject(iObject).x < iMinX Then
m_arrObject(iObject).x = iMaxX
End If
ElseIf m_arrObject(iObject).dx > 0 Then
m_arrObject(iObject).x = m_arrObject(iObject).x + 1
If m_arrObject(iObject).x > iMaxX Then
m_arrObject(iObject).x = iMinX
End If
End If
End If
' Move along Y axis
m_arrObject(iObject).cy = m_arrObject(iObject).cy + 1
If m_arrObject(iObject).cy > (10 - Abs(m_arrObject(iObject).dy)) Then
m_arrObject(iObject).cy = 0
If m_arrObject(iObject).dy < 0 Then
m_arrObject(iObject).y = m_arrObject(iObject).y - 1
If m_arrObject(iObject).y < iMinY Then
m_arrObject(iObject).y = iMaxY
End If
ElseIf m_arrObject(iObject).dy > 0 Then
m_arrObject(iObject).y = m_arrObject(iObject).y + 1
If m_arrObject(iObject).y > iMaxY Then
m_arrObject(iObject).y = iMinY
End If
End If
End If
' Draw current object with different line style
If iObject = iWhich Then
' Draw on top layer
_Dest imgFront&
' Draw a solid object
lngStyle = lngThisStyle
Else
' Draw on middle layer
_Dest imgMiddle&
' Draw in other line style
lngStyle = lngThatStyle
End If
' Draw object's line segments
For iLine = LBound(m_arrLines, 2) To UBound(m_arrLines, 2)
'Line (x1%, y1%)-(x2%, y2%), arrColor(arrStars(iLoop).ColorIndex), BF, lngStyle
Line _
(m_arrObject(iObject).x + m_arrLines(iObject, iLine).x1, _
m_arrObject(iObject).y + m_arrLines(iObject, iLine).y1) _
- _
(m_arrObject(iObject).x + m_arrLines(iObject, iLine).x2, _
m_arrObject(iObject).y + m_arrLines(iObject, iLine).y2) _
, _
m_arrLines(iObject, iLine).color, , lngStyle
If m_arrLines(iObject, iLine).IsLast = TRUE Then
Exit For
End If
Next iLine
' Fill in current object with black
If iObject = iWhich Then
'PAINT [STEP] (column%, row%), fillColor[, borderColor%]
Paint (m_arrObject(iObject).x, m_arrObject(iObject).y), cBlack, m_arrColor(iObject)
End If
' PROCESS INPUT
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
sKey = ""
' QUIT?
If _Button(KeyCode_Escape%) Then
bQuit = TRUE
Exit While
End If
' OTHER INPUT 1-6 SELECTS WHICH OBJECT TO CHANGE
If _Button(KeyCode_1%) Then
sKey = sKey + "1,"
iWhich = 1
ElseIf _Button(KeyCode_2%) Then
sKey = sKey + "2,"
iWhich = 2
ElseIf _Button(KeyCode_3%) Then
sKey = sKey + "3,"
iWhich = 3
ElseIf _Button(KeyCode_4%) Then
sKey = sKey + "4,"
iWhich = 4
ElseIf _Button(KeyCode_5%) Then
sKey = sKey + "5,"
iWhich = 5
ElseIf _Button(KeyCode_6%) Then
sKey = sKey + "6,"
iWhich = 6
End If
' GET DIRECTION
If _Button(KeyCode_Left%) Then
sKey = sKey + "LEFT,"
m_arrObject(iWhich).dx = m_arrObject(iWhich).dx - 1
If m_arrObject(iWhich).dx < -10 Then m_arrObject(iWhich).dx = -10
ElseIf _Button(KeyCode_Right%) Then
sKey = sKey + "RIGHT,"
m_arrObject(iWhich).dx = m_arrObject(iWhich).dx + 1
If m_arrObject(iWhich).dx > 10 Then m_arrObject(iWhich).dx = 10
ElseIf _Button(KeyCode_Up%) Then
sKey = sKey + "UP,"
m_arrObject(iWhich).dy = m_arrObject(iWhich).dy - 1
If m_arrObject(iWhich).dy < -10 Then m_arrObject(iWhich).dy = -10
ElseIf _Button(KeyCode_Down%) Then
sKey = sKey + "DOWN,"
m_arrObject(iWhich).dy = m_arrObject(iWhich).dy + 1
If m_arrObject(iWhich).dy > 10 Then m_arrObject(iWhich).dy = 10
End If
' CYCLE LINE STYLE FOR ACTIVE OBJECT
iStyleCountNext = iStyleCountNext + 1 ' increment line style counter
If iStyleCountNext > iStyleCountMax Then
iStyleCountNext = 0
iStyleIndex = iStyleIndex + 1
If iStyleIndex > UBound(m_arrLineStyle) Then
iStyleIndex = LBound(m_arrLineStyle)
End If
lngThatStyle = m_arrLineStyle(iStyleIndex)
End If
' CLEAR KEYBOARD BUFFER
_KeyClear
' CONTROL GAME SPEED
_Limit iFPS
Wend
' UPDATE THE SCREEN
_Display
' CLEAR KEYBOARD BUFFER
_KeyClear: _Delay 2
' PLAY ANOTHER ROUND OR QUIT?
If bQuit = FALSE Then
If bExit = FALSE Then Sleep
Color cWhite, cBlack
Else
Exit Do
End If
Loop
' Receives:
' Long iInput1 = value (0-65535) to conver to binary
' Returns a 16 character string of "1" and "0"
' (a 16-bit binary representation of iInput1)
Function BinaryStringFromLong$ (iInput1 As Long)
Dim sBinary As String
Dim iInput As Long
Dim iLoop As Integer
Dim iNextValue As Long
sBinary = ""
iInput = iInput1
If iInput >= 0 Then
For iLoop = 15 To 0 Step -1
iNextValue = 2 ^ iLoop
If (iInput \ iNextValue) > 0 Then
sBinary = sBinary + "1"
Else
sBinary = sBinary + "0"
End If
iInput = iInput Mod iNextValue
Next iLoop
End If
BinaryStringFromLong$ = sBinary
End Function ' BinaryStringFromLong$
' future versions will pull this data from an editable file
Sub InitVectorObjects
Dim iLoop As Integer
Dim iObject As Integer
Dim iLine As Integer
Dim x1 As Integer
Dim y1 As Integer
Dim x2 As Integer
Dim y2 As Integer
Dim r1 As Integer
Dim g1 As Integer
Dim b1 As Integer
iObject = 1
iLine = 1
Restore VectorData
For iLoop = 1 To 1024
Read x1
Read y1
Read x2
Read y2
Read r1
Read g1
Read b1 ' -255 means no more data, -254 means last set for this object
If b1 = -255 Then
m_arrLines(iObject, iLine).IsLast = TRUE
m_arrObject(iObject).IsEnabled = TRUE
Exit For
ElseIf b1 = -254 Then
m_arrLines(iObject, iLine).IsLast = TRUE
m_arrObject(iObject).IsEnabled = TRUE
iObject = iObject + 1
iLine = 1
If iObject > UBound(m_arrLines, 1) Then Exit For
Else
m_arrLines(iObject, iLine).x1 = x1
m_arrLines(iObject, iLine).y1 = y1
m_arrLines(iObject, iLine).x2 = x2
m_arrLines(iObject, iLine).y2 = y2
m_arrLines(iObject, iLine).color = _RGB32(r1, g1, b1)
m_arrLines(iObject, iLine).IsLast = FALSE
iLine = iLine + 1
If iLine > UBound(m_arrLines, 2) Then Exit For
End If
Next iLoop%
VectorData:
'objaster1 = purple
Data 2,-41,31,-50,128,0,255
Data 31,-50,56,-23,128,0,255
Data 56,-23,37,-10,128,0,255
Data 37,-10,61,13,128,0,255
Data 61,13,32,62,128,0,255
Data 32,62,-22,43,128,0,255
Data -22,43,-40,57,128,0,255
Data -40,57,-62,34,128,0,255
Data -62,34,-47,7,128,0,255
Data -47,7,-62,-26,128,0,255
Data -62,-26,-32,-63,128,0,255
Data -32,-63,2,-41,128,0,255
Data 0,0,0,0,-254,-254,-254
'objaster2 = red
Data -28,-62,22,-62,255,0,0
Data 22,-62,61,-28,255,0,0
Data 61,-28,61,13,255,0,0
Data 61,13,23,57,255,0,0
Data 23,57,-6,62,255,0,0
Data -6,62,-6,15,255,0,0
Data -6,15,-36,47,255,0,0
Data -36,47,-59,14,255,0,0
Data -59,14,-35,1,255,0,0
Data -35,1,-62,-9,255,0,0
Data -62,-9,-28,-62,255,0,0
Data 0,0,0,0,-254,-254,-254
'objaster3 = yellow
Data 9,-62,60,-21,255,255,0
Data 60,-21,62,-3,255,255,0
Data 62,-3,24,13,255,255,0
Data 24,13,53,34,255,255,0
Data 53,34,38,55,255,255,0
Data 38,55,20,40,255,255,0
Data 20,40,-37,61,255,255,0
Data -37,61,-63,15,255,255,0
Data -63,15,-57,-24,255,255,0
Data -57,-24,-24,-24,255,255,0
Data -24,-24,-38,-45,255,255,0
Data -38,-45,9,-62,255,255,0
Data 0,0,0,0,-254,-254,-254
'objmouse = white
Data 0,-10,6,3,255,255,255
Data 6,3,1,2,255,255,255
Data 1,2,1,10,255,255,255
Data 1,10,-1,10,255,255,255
Data -1,10,-1,2,255,255,255
Data -1,2,-6,3,255,255,255
Data -6,3,0,-10,255,255,255
Data 0,0,0,0,-254,-254,-254
'objship = cyan
Data 0,-15,10,15,0,255,255
Data 10,15,6,11,0,255,255
Data 6,11,-6,11,0,255,255
Data -6,11,-10,15,0,255,255
Data -10,15,0,-15,0,255,255
Data 0,0,0,0,-254,-254,-254
'Data 0,18,0,18,0,255,255
'Data 0,0,0,0,-254,-254,-254
'objufo = green
Data -4,-16,4,-16,0,255,0
Data 4,-16,10,-6,0,255,0
Data 10,-6,25,5,0,255,0
Data 25,5,10,16,0,255,0
Data 10,16,-10,16,0,255,0
Data -10,16,-25,5,0,255,0
Data -25,5,-10,-6,0,255,0
Data -10,-6,-4,-16,0,255,0
Data -10,-6,10,-6,0,255,0
Data -25,5,25,5,0,255,0
Data 0,0,0,0,-255,-255,-255
Sub DrawLayers (imgBack&, imgMiddle&, imgFront&)
Dim iLoop As Integer
Dim x1%
Dim x2%
Dim y1%
Dim y2%
'_Dest 0
'Cls , cBlack
' Twinkle twinkle little stars
_Dest imgBack&
For iLoop = LBound(m_arrStars) To UBound(m_arrStars)
' increment twinkle counter
m_arrStars(iLoop).TwinkleCounter = m_arrStars(iLoop).TwinkleCounter + 1
' is it time to twinkle the color?
If m_arrStars(iLoop).TwinkleCounter > m_arrStars(iLoop).MaxTwinkCount Then
m_arrStars(iLoop).TwinkleCounter = 0 ' reset counter
m_arrStars(iLoop).ColorIndex = m_arrStars(iLoop).ColorIndex + 1 ' increment color
If m_arrStars(iLoop).ColorIndex > UBound(m_arrGrayColor) Then
m_arrStars(iLoop).ColorIndex = LBound(m_arrGrayColor) ' reset color
End If
End If
' increment width counter
If m_arrStars(iLoop).BigCounter = 0 Then
m_arrStars(iLoop).WidthCounter = m_arrStars(iLoop).WidthCounter + 1
' is it time to fluctuate the width
If m_arrStars(iLoop).WidthCounter > m_arrStars(iLoop).MaxWidthCount Then
m_arrStars(iLoop).WidthCounter = 0 ' reset counter
m_arrStars(iLoop).BigCounter = 1 ' start big counter
m_arrStars(iLoop).width = m_arrStars(iLoop).MinWidth ' twinkle width
Else
m_arrStars(iLoop).width = m_arrStars(iLoop).MaxWidth ' normal width
End If
Else
' increment big counter
m_arrStars(iLoop).BigCounter = m_arrStars(iLoop).BigCounter + 1
' is it time to return to normal size?
If m_arrStars(iLoop).BigCounter > m_arrStars(iLoop).MaxBigCount Then
m_arrStars(iLoop).BigCounter = 0 ' reset counter
m_arrStars(iLoop).width = m_arrStars(iLoop).MaxWidth ' normal width
End If
End If
' (re)draw it
Line (x1%, y1%)-(x2%, y2%), m_arrGrayColor(m_arrStars(iLoop).ColorIndex), BF
Next iLoop
' COPY LAYERS TO SCREEN
If imgBack& < -1 Then
_PutImage , imgBack&, 0
End If
If imgMiddle& < -1 Then
_PutImage , imgMiddle&, 0
End If
If imgFront& < -1 Then
_PutImage , imgFront&, 0
End If
End Sub ' DrawLayers
' /////////////////////////////////////////////////////////////////////////////
' SHOW INSTRUMENTS + INSTRUCTIONS
' 800x600 = 40 rows x 100 columns
sub DrawText( _
sKey as string, _
iWhich as integer _
)
Dim iObject As Integer
Dim RowNum As Integer
Dim sFlag As String
Dim iNum As Integer
' SHOW OBJECTS
Color cGray, cEmpty
RowNum = RowNum + 1: PrintAt RowNum, 1, "----------------------------------------"
iNum = 0
For iObject = LBound(m_arrObject) To UBound(m_arrObject)
iNum = iNum + 1
If m_arrObject(iObject).IsEnabled = TRUE Then
Color m_arrColor(iObject), cEmpty
If iObject = iWhich Then
'Color cCyan, cEmpty
sFlag = "-> "
Else
'Color cDodgerBlue, cEmpty
sFlag = " "
End If
Else
Color cGray, cEmpty
sFlag = " "
End If
' ################################################################################################################################################################
' BEGIN COLOR ARRAY FUNCTIONS #COLR
' ################################################################################################################################################################
Sub AddColor (ColorValue As _Unsigned Long, arrColor() As _Unsigned Long)
ReDim _Preserve arrColor(0 To UBound(arrColor) + 1) As _Unsigned Long
arrColor(UBound(arrColor)) = ColorValue
End Sub ' AddColor
Sub AddColors (ColorValue As _Unsigned Long, arrColor() As _Unsigned Long, HowMany As Long)
Dim iLoop As Integer
For iLoop = 1 To HowMany
AddColor ColorValue, arrColor()
Next iLoop
End Sub ' AddColors
' ################################################################################################################################################################
' END COLOR ARRAY FUNCTIONS @COLR
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN COLOR FUNCTIONS #COLOR
' ################################################################################################################################################################
Function cRed~& ()
cRed = _RGB32(255, 0, 0)
End Function
Function cOrangeRed~& ()
cOrangeRed = _RGB32(255, 69, 0)
End Function ' cOrangeRed~&
Function cDarkOrange~& ()
cDarkOrange = _RGB32(255, 140, 0)
End Function ' cDarkOrange~&
Function cOrange~& ()
cOrange = _RGB32(255, 165, 0)
End Function ' cOrange~&
Function cGold~& ()
cGold = _RGB32(255, 215, 0)
End Function ' cGold~&
Function cYellow~& ()
cYellow = _RGB32(255, 255, 0)
End Function ' cYellow~&
' LONG-HAIRED FRIENDS OF JESUS OR NOT,
' THIS IS NOT YELLOW ENOUGH (TOO CLOSE TO LIME)
' TO USE FOR OUR COMPLEX RAINBOW SEQUENCE:
Function cChartreuse~& ()
cChartreuse = _RGB32(127, 255, 0)
End Function ' cChartreuse~&
' WE SUBSTITUTE THIS CSS3 COLOR FOR INBETWEEN LIME AND YELLOW:
Function cOliveDrab1~& ()
cOliveDrab1 = _RGB32(192, 255, 62)
End Function ' cOliveDrab1~&
Function cLime~& ()
cLime = _RGB32(0, 255, 0)
End Function ' cLime~&
Function cMediumSpringGreen~& ()
cMediumSpringGreen = _RGB32(0, 250, 154)
End Function ' cMediumSpringGreen~&
' ADDED THIS FOR THE GAUGE COLOR:
Function cSpringGreen~& ()
cSpringGreen = _RGB32(0, 255, 160)
End Function ' cSpringGreen~&
Function cCyan~& ()
cCyan = _RGB32(0, 255, 255)
End Function ' cCyan~&
Function cDeepSkyBlue~& ()
cDeepSkyBlue = _RGB32(0, 191, 255)
End Function ' cDeepSkyBlue~&
Function cDodgerBlue~& ()
cDodgerBlue = _RGB32(30, 144, 255)
End Function ' cDodgerBlue~&
Function cSeaBlue~& ()
cSeaBlue = _RGB32(0, 64, 255)
End Function ' cSeaBlue~&
Function cBlue~& ()
cBlue = _RGB32(0, 0, 255)
End Function ' cBlue~&
Function cBluePurple~& ()
cBluePurple = _RGB32(64, 0, 255)
End Function ' cBluePurple~&
Function cDeepPurple~& ()
cDeepPurple = _RGB32(96, 0, 255)
End Function ' cDeepPurple~&
Function cPurple~& ()
cPurple = _RGB32(128, 0, 255)
End Function ' cPurple~&
Function cPurpleRed~& ()
cPurpleRed = _RGB32(128, 0, 192)
End Function ' cPurpleRed~&
Function cDarkRed~& ()
cDarkRed = _RGB32(160, 0, 64)
End Function ' cDarkRed~&
Function cBrickRed~& ()
cBrickRed = _RGB32(192, 0, 32)
End Function ' cBrickRed~&
Function cDarkGreen~& ()
cDarkGreen = _RGB32(0, 100, 0)
End Function ' cDarkGreen~&
Function cGreen~& ()
cGreen = _RGB32(0, 128, 0)
End Function ' cGreen~&
Function cOliveDrab~& ()
cOliveDrab = _RGB32(107, 142, 35)
End Function ' cOliveDrab~&
Function cLightPink~& ()
cLightPink = _RGB32(255, 182, 193)
End Function ' cLightPink~&
Function cHotPink~& ()
cHotPink = _RGB32(255, 105, 180)
End Function ' cHotPink~&
Function cDeepPink~& ()
cDeepPink = _RGB32(255, 20, 147)
End Function ' cDeepPink~&
Function cMagenta~& ()
cMagenta = _RGB32(255, 0, 255)
End Function ' cMagenta~&
Function cBlack~& ()
cBlack = _RGB32(0, 0, 0)
End Function ' cBlack~&
Function cDimGray~& ()
cDimGray = _RGB32(105, 105, 105)
End Function ' cDimGray~&
Function cGray~& ()
cGray = _RGB32(128, 128, 128)
End Function ' cGray~&
Function cDarkGray~& ()
cDarkGray = _RGB32(169, 169, 169)
End Function ' cDarkGray~&
Function cSilver~& ()
cSilver = _RGB32(192, 192, 192)
End Function ' cSilver~&
Function cLightGray~& ()
cLightGray = _RGB32(211, 211, 211)
End Function ' cLightGray~&
Function cGainsboro~& ()
cGainsboro = _RGB32(220, 220, 220)
End Function ' cGainsboro~&
Function cWhiteSmoke~& ()
cWhiteSmoke = _RGB32(245, 245, 245)
End Function ' cWhiteSmoke~&
Function cWhite~& ()
cWhite = _RGB32(255, 255, 255)
'cWhite = _RGB32(254, 254, 254)
End Function ' cWhite~&
Function cDarkBrown~& ()
cDarkBrown = _RGB32(128, 64, 0)
End Function ' cDarkBrown~&
Function cLightBrown~& ()
cLightBrown = _RGB32(196, 96, 0)
End Function ' cLightBrown~&
Function cKhaki~& ()
cKhaki = _RGB32(240, 230, 140)
End Function ' cKhaki~&
Function cEmpty~& ()
'cEmpty~& = -1
cEmpty = _RGB32(0, 0, 0, 0)
End Function ' cEmpty~&
' ################################################################################################################################################################
' END COLOR FUNCTIONS @COLOR
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN KEYBOARD CODES FUNCTIONS #KEYCODE
'
' ALL CODES ARE FOR _BUTTON, EXCEPT:
' * cF10 (_KEYDOWN)
' * cAltLeft (_KEYHIT)
' * cAltRight (_KEYHIT)
' * cPrintScreen (_KEYHIT) <- may slow down pc?
' * cPauseBreak (_KEYHIT) <- may not work?
' ################################################################################################################################################################
Function KeyCode_Escape% ()
KeyCode_Escape% = 2
End Function
Function KeyCode_F1% ()
KeyCode_F1% = 60
End Function
Function KeyCode_F2% ()
KeyCode_F2% = 61
End Function
Function KeyCode_F3% ()
KeyCode_F3% = 62
End Function
Function KeyCode_F4% ()
KeyCode_F4% = 63
End Function
Function KeyCode_F5% ()
KeyCode_F5% = 64
End Function
Function KeyCode_F6% ()
KeyCode_F6% = 65
End Function
Function KeyCode_F7% ()
KeyCode_F7% = 66
End Function
Function KeyCode_F8% ()
KeyCode_F8% = 67
End Function
Function KeyCode_F9% ()
KeyCode_F9% = 68
End Function
'_KEYDOWN CODE, NOT _BUTTON CODE
Function KeyCode_F10% ()
KeyCode_F10% = 17408
End Function
Function KeyCode_F11% ()
KeyCode_F11% = 88
End Function
Function KeyCode_F12% ()
KeyCode_F12% = 89
End Function
'_KEYHIT CODE, NOT _BUTTON CODE
Function KeyCode_PrintScreen% ()
KeyCode_PrintScreen% = -44
End Function
Function KeyCode_ScrollLock% ()
KeyCode_ScrollLock% = 71
End Function
'_KEYHIT CODE, NOT _BUTTON CODE
Function KeyCode_PauseBreak% ()
KeyCode_PauseBreak% = 31053
End Function
Function KeyCode_Tilde% ()
KeyCode_Tilde% = 42
End Function
Function KeyCode_1% ()
KeyCode_1% = 3
End Function
Function KeyCode_2% ()
KeyCode_2% = 4
End Function
Function KeyCode_3% ()
KeyCode_3% = 5
End Function
Function KeyCode_4% ()
KeyCode_4% = 6
End Function
Function KeyCode_5% ()
KeyCode_5% = 7
End Function
Function KeyCode_6% ()
KeyCode_6% = 8
End Function
Function KeyCode_7% ()
KeyCode_7% = 9
End Function
Function KeyCode_8% ()
KeyCode_8% = 10
End Function
Function KeyCode_9% ()
KeyCode_9% = 11
End Function
Function KeyCode_0% ()
KeyCode_0% = 12
End Function
Function KeyCode_Minus% ()
KeyCode_Minus% = 13
End Function
Function KeyCode_Equal% ()
KeyCode_Equal% = 14
End Function
Function KeyCode_BkSp% ()
KeyCode_BkSp% = 15
End Function
Function KeyCode_Ins% ()
KeyCode_Ins% = 339
End Function
Function KeyCode_Home% ()
KeyCode_Home% = 328
End Function
Function KeyCode_PgUp% ()
KeyCode_PgUp% = 330
End Function
Function KeyCode_Del% ()
KeyCode_Del% = 340
End Function
Function KeyCode_End% ()
KeyCode_End% = 336
End Function
Function KeyCode_PgDn% ()
KeyCode_PgDn% = 338
End Function
Function KeyCode_NumLock% ()
KeyCode_NumLock% = 326
End Function
Function KeyCode_KeypadSlash% ()
KeyCode_KeypadSlash% = 310
End Function
Function KeyCode_KeypadMultiply% ()
KeyCode_KeypadMultiply% = 56
End Function
Function KeyCode_KeypadMinus% ()
KeyCode_KeypadMinus% = 75
End Function
Function KeyCode_Keypad7Home% ()
KeyCode_Keypad7Home% = 72
End Function
Function KeyCode_Keypad8Up% ()
KeyCode_Keypad8Up% = 73
End Function
Function KeyCode_Keypad9PgUp% ()
KeyCode_Keypad9PgUp% = 74
End Function
Function KeyCode_KeypadPlus% ()
KeyCode_KeypadPlus% = 79
End Function
Function KeyCode_Keypad4Left% ()
KeyCode_Keypad4Left% = 76
End Function
Function KeyCode_Keypad5% ()
KeyCode_Keypad5% = 77
End Function
Function KeyCode_Keypad6Right% ()
KeyCode_Keypad6Right% = 78
End Function
Function KeyCode_Keypad1End% ()
KeyCode_Keypad1End% = 80
End Function
Function KeyCode_Keypad2Down% ()
KeyCode_Keypad2Down% = 81
End Function
Function KeyCode_Keypad3PgDn% ()
KeyCode_Keypad3PgDn% = 82
End Function
Function KeyCode_KeypadEnter% ()
KeyCode_KeypadEnter% = 285
End Function
Function KeyCode_Keypad0Ins% ()
KeyCode_Keypad0Ins% = 83
End Function
Function KeyCode_KeypadPeriodDel% ()
KeyCode_KeypadPeriodDel% = 84
End Function
Function KeyCode_Tab% ()
KeyCode_Tab% = 16
End Function
Function KeyCode_Q% ()
KeyCode_Q% = 17
End Function
Function KeyCode_W% ()
KeyCode_W% = 18
End Function
Function KeyCode_E% ()
KeyCode_E% = 19
End Function
Function KeyCode_R% ()
KeyCode_R% = 20
End Function
Function KeyCode_T% ()
KeyCode_T% = 21
End Function
Function KeyCode_Y% ()
KeyCode_Y% = 22
End Function
Function KeyCode_U% ()
KeyCode_U% = 23
End Function
Function KeyCode_I% ()
KeyCode_I% = 24
End Function
Function KeyCode_O% ()
KeyCode_O% = 25
End Function
Function KeyCode_P% ()
KeyCode_P% = 26
End Function
Function KeyCode_BracketLeft% ()
KeyCode_BracketLeft% = 27
End Function
Function KeyCode_BracketRight% ()
KeyCode_BracketRight% = 28
End Function
Function KeyCode_Backslash% ()
KeyCode_Backslash% = 44
End Function
Function KeyCode_CapsLock% ()
KeyCode_CapsLock% = 59
End Function
Function KeyCode_A% ()
KeyCode_A% = 31
End Function
Function KeyCode_S% ()
KeyCode_S% = 32
End Function
Function KeyCode_D% ()
KeyCode_D% = 33
End Function
Function KeyCode_F% ()
KeyCode_F% = 34
End Function
Function KeyCode_G% ()
KeyCode_G% = 35
End Function
Function KeyCode_H% ()
KeyCode_H% = 36
End Function
Function KeyCode_J% ()
KeyCode_J% = 37
End Function
Function KeyCode_K% ()
KeyCode_K% = 38
End Function
Function KeyCode_L% ()
KeyCode_L% = 39
End Function
Function KeyCode_Semicolon% ()
KeyCode_Semicolon% = 40
End Function
Function KeyCode_Apostrophe% ()
KeyCode_Apostrophe% = 41
End Function
Function KeyCode_Enter% ()
KeyCode_Enter% = 29
End Function
Function KeyCode_ShiftLeft% ()
KeyCode_ShiftLeft% = 43
End Function
Function KeyCode_Z% ()
KeyCode_Z% = 45
End Function
Function KeyCode_X% ()
KeyCode_X% = 46
End Function
Function KeyCode_C% ()
KeyCode_C% = 47
End Function
Function KeyCode_V% ()
KeyCode_V% = 48
End Function
Function KeyCode_B% ()
KeyCode_B% = 49
End Function
Function KeyCode_N% ()
KeyCode_N% = 50
End Function
Function KeyCode_M% ()
KeyCode_M% = 51
End Function
Function KeyCode_Comma% ()
KeyCode_Comma% = 52
End Function
Function KeyCode_Period% ()
KeyCode_Period% = 53
End Function
Function KeyCode_Slash% ()
KeyCode_Slash% = 54
End Function
Function KeyCode_ShiftRight% ()
KeyCode_ShiftRight% = 55
End Function
Function KeyCode_Up% ()
KeyCode_Up% = 329
End Function
Function KeyCode_Left% ()
KeyCode_Left% = 332
End Function
Function KeyCode_Down% ()
KeyCode_Down% = 337
End Function
Function KeyCode_Right% ()
KeyCode_Right% = 334
End Function
Function KeyCode_CtrlLeft% ()
KeyCode_CtrlLeft% = 30
End Function
Function KeyCode_WinLeft% ()
KeyCode_WinLeft% = 348
End Function
' _KEYHIT CODE NOT _BUTTON CODE
Function KeyCode_AltLeft% ()
KeyCode_AltLeft% = -30764
End Function
Function KeyCode_Spacebar% ()
KeyCode_Spacebar% = 58
End Function
' _KEYHIT CODE NOT _BUTTON CODE
Function KeyCode_AltRight% ()
KeyCode_AltRight% = -30765
End Function
Function KeyCode_WinRight% ()
KeyCode_WinRight% = 349
End Function
Function KeyCode_Menu% ()
KeyCode_Menu% = 350
End Function
Function KeyCode_CtrlRight% ()
KeyCode_CtrlRight% = 286
End Function
' ################################################################################################################################################################
' END KEYBOARD CODES FUNCTIONS @KEYCODE
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN GENERAL PURPOSE ROUTINES #GEN
' ################################################################################################################################################################
Function AppendString$ (MyString As String, NewString As String, MyDelimiter As String)
Dim sResult As String: sResult = MyString
If Len(MyString) > 0 Then
sResult = sResult + MyDelimiter
End If
sResult = sResult + NewString
AppendString$ = sResult
End Function ' AppendString$
Sub AppendToStringArray (MyStringArray$(), MyString$)
ReDim _Preserve MyStringArray$(LBound(MyStringArray$) To UBound(MyStringArray$) + 1)
MyStringArray$(UBound(MyStringArray$)) = MyString$
End Sub ' AppendToStringArray
' /////////////////////////////////////////////////////////////////////////////
' See also StringTo2dArray
Function Array2dToString$ (MyArray() As String)
Dim MyString As String
Dim iY As Integer
Dim iX As Integer
Dim sLine As String
MyString = ""
For iY = LBound(MyArray, 1) To UBound(MyArray, 1)
sLine = ""
For iX = LBound(MyArray, 2) To UBound(MyArray, 2)
sLine = sLine + MyArray(iY, iX)
Next iX
MyString = MyString + sLine + Chr$(13)
Next iY
Array2dToString$ = MyString
End Function ' Array2dToString$
$If Then
Function Array2dToStringTest$ (MyArray() As String)
Dim MyString As String
Dim iY As Integer
Dim iX As Integer
Dim sLine As String
MyString = ""
MyString = MyString + " 11111111112222222222333" + Chr$(13)
MyString = MyString + " 12345678901234567890123456789012" + Chr$(13)
For iY = LBound(MyArray, 1) To UBound(MyArray, 1)
sLine = ""
sLine = sLine + Right$(" " + cstr$(iY), 2)
For iX = LBound(MyArray, 2) To UBound(MyArray, 2)
sLine = sLine + MyArray(iY, iX)
Next iX
sLine = sLine + Right$(" " + cstr$(iY), 2)
MyString = MyString + sLine + Chr$(13)
Next iY
MyString = MyString + " 12345678901234567890123456789012" + Chr$(13)
MyString = MyString + " 11111111112222222222333" + Chr$(13)
Array2dToStringTest$ = MyString
End Function ' Array2dToStringTest$
$End If
' /////////////////////////////////////////////////////////////////////////////
' use angles in degrees units instead of radians (converted inside sub)
' Note this function uses whatever the default type is, better not be some Integer Type.
Function CosD (degrees)
CosD = Cos(_D2R(degrees))
End Function ' CosD
' /////////////////////////////////////////////////////////////////////////////
' Integer to string
Function cstr$ (myValue)
'cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
cstr$ = _Trim$(Str$(myValue))
End Function ' cstr$
' /////////////////////////////////////////////////////////////////////////////
' Long to string
Function cstrl$ (myValue As Long)
cstrl$ = _Trim$(Str$(myValue))
End Function ' cstrl$
' /////////////////////////////////////////////////////////////////////////////
' Single to string
Function cstrs$ (myValue As Single)
''cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
cstrs$ = _Trim$(Str$(myValue))
End Function ' cstrs$
' /////////////////////////////////////////////////////////////////////////////
' Unsigned Long to string
Function cstrul$ (myValue As _Unsigned Long)
cstrul$ = _Trim$(Str$(myValue))
End Function ' cstrul$
' /////////////////////////////////////////////////////////////////////////////
' Simple timestamp function
Function CurrentDateTime$
CurrentDateTime$ = Mid$(Date$, 7, 4) + "-" + _
Mid$(Date$, 1, 5) + " " + _
Time$
End Function ' CurrentDateTime$
' /////////////////////////////////////////////////////////////////////////////
' use angles in degrees units instead of radians (converted inside sub)
' Note this function uses whatever the default type is, better not be some Integer Type.
Function DAtan2 (x1, y1, x2, y2) ' The angle in degrees a 2nd point (x2, y2) makes to a first point (x1, y1)
' Delta means change between 1 measure and another for example x2 - x1
deltaX = x2 - x1
deltaY = y2 - y1
' To find the angle point(x2, y2) makes to (x1, y1) in Degrees
' Take DegreeAngle = DAtan2(y2 - y1, x2 - x1)
rtn = _R2D(_Atan2(deltaY, deltaX))
If rtn < 0 Then
DAtan2 = rtn + 360
Else
DAtan2 = rtn
End If
End Function ' DAtan2
' /////////////////////////////////////////////////////////////////////////////
' Hack function, to be replaced with something better
Function DblToInt% (dblOld As Double)
Dim dblNew As Double
Dim sValue As String
Dim iPos As Integer
' /////////////////////////////////////////////////////////////////////////////
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
Function DblToStr$ (n#)
Dim result$: result$ = ""
Dim value$
Dim Xpos%
Dim expo%
Dim sign$
Dim valu$
Dim dot%
Dim L%
Dim add$
Dim min$
Dim DP$
Dim n%
value$ = UCase$(LTrim$(Str$(n#)))
Xpos% = InStr(value$, "D") + InStr(value$, "E") ' only D or E can be present
If Xpos% Then
expo% = Val(Mid$(value$, Xpos% + 1))
If Val(value$) < 0 Then
sign$ = "-"
valu$ = Mid$(value$, 2, Xpos% - 2)
Else
valu$ = Mid$(value$, 1, Xpos% - 1)
End If
dot% = InStr(valu$, ".")
L% = Len(valu$)
If expo% > 0 Then
add$ = String$(expo% - (L% - dot%), "0")
End If
If expo% < 0 Then
min$ = String$(Abs(expo%) - (dot% - 1), "0")
DP$ = "."
End If
For n% = 1 To L%
If Mid$(valu$, n%, 1) <> "." Then
num$ = num$ + Mid$(valu$, n%, 1)
End If
Next n%
result$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
Else
result$ = value$
End If
Function DblRoundedToStr$ (dblValue As Double, intNumPlaces As Integer)
Dim dblNew As Double
dblNew = RoundDouble#(dblValue, intNumPlaces)
DblRoundedToStr$ = DblToStr$(dblNew)
End Function ' DblRoundedToStr$
' /////////////////////////////////////////////////////////////////////////////
' Receives an {sDelim} delimited list {sInput}
' returns the list with all duplicate entries removed.
Function DedupeDelimList$ (sInput As String, sDelim As String)
ReDim arrLines(-1) As String
Dim sOutput As String
Dim iLoop As Integer
split sInput, sDelim, arrLines()
sOutput = sDelim
For iLoop = LBound(arrLines) To UBound(arrLines)
If InStr(1, sOutput, sDelim + arrLines(iLoop) + sDelim) = 0 Then
sOutput = sOutput + arrLines(iLoop) + sDelim
End If
Next iLoop
DedupeDelimList$ = sOutput
End Function ' DedupeDelimList$
Function DoubleABS# (dblValue As Double)
If Sgn(dblValue) = -1 Then
DoubleABS# = 0 - dblValue
Else
DoubleABS# = dblValue
End If
End Function ' DoubleABS#
' /////////////////////////////////////////////////////////////////////////////
' bplus: The Gold Standard is even better than THE QB64 CIRCLE sub in this respect!
' https://forum.qb64.org/index.php?topic=1044.135
' from Steve Gold standard
' Renamed fcirc to DrawCircleSolid
' Not as fast as DrawCircleTopLeft but pretty fast.
' Example:
' Screen _NewImage(800, 600, 32)
' _ScreenMove 250, 60
' For r = 250 To 0 Step -60
' DrawCircleSolid 400, 300, r, _RGBA(255, 255, 255, 100)
' Next r
Sub DrawCircleSolid (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R)
RadiusError = -Radius
X = Radius
Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
' 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
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub ' DrawCircleSolid
' /////////////////////////////////////////////////////////////////////////////
' Draws scaled + rotated text to screen
' by BPlus
' Scale rotate font text strings by B+
' https://qb64phoenix.com/forum/showthread.php?tid=414&highlight=rotate+text
' INPUT:
' S$ is the string to display
' c is the color (will have a transparent background)
' midX and midY is the center of where you want to display the string
' xScale would multiply 8 pixel width of default font
' yScale would multiply the 16 pixel height of the default font
' Rotation is in Radian units, use _D2R to convert Degree units to Radian units
' DEPENDENCIES:
' drwString needs sub RotoZoom2, intended for graphics screens using the default font.
Sub drwString (S$, c As _Unsigned Long, midX, midY, xScale, yScale, Rotation As Single)
I& = _NewImage(_PrintWidth(S$), _FontHeight, 32)
_Dest I&
Color c, _RGBA32(0, 0, 0, 0)
_PrintString (0, 0), S$
_Dest storeDest&
RotoZoom2 midX, midY, I&, xScale, yScale, Rotation
_FreeImage I&
End Sub ' drwString
' /////////////////////////////////////////////////////////////////////////////
' SMcNeill
' More efficient version of ExtendedTimer.
' This stores our day values and only updates them when necessary.
' We really don't need to figure out how many seconds are in today over and over endlessly
' -- just count them once, and when the clock swaps back to 0:0:0, add 24*60*60 seconds to the count.
' Re: how to time something (ie do loop for n seconds)
' https://forum.qb64.org/index.php?topic=4682.0
Function ExtendedTimer##
'modified extendedtimer to store the old day's count, and not have to recalculate it every time the routine is called.
Static olds As _Float, old_day As _Float
Dim m As Integer, d As Integer, y As Integer
Dim s As _Float, day As String
If olds = 0 Then 'calculate the day the first time the extended timer runs
day = Date$
m = Val(Left$(day, 2))
d = Val(Mid$(day, 4, 2))
y = Val(Right$(day, 4)) - 1970
Select Case m 'Add the number of days for each previous month passed
Case 2: d = d + 31
Case 3: d = d + 59
Case 4: d = d + 90
Case 5: d = d + 120
Case 6: d = d + 151
Case 7: d = d + 181
Case 8: d = d + 212
Case 9: d = d + 243
Case 10: d = d + 273
Case 11: d = d + 304
Case 12: d = d + 334
End Select
If (y Mod 4) = 2 And m > 2 Then d = d + 1 'add a day if this is leap year and we're past february
d = (d - 1) + 365 * y 'current month days passed + 365 days per each standard year
d = d + (y + 2) \ 4 'add in days for leap years passed
s = d * 24 * 60 * 60 'Seconds are days * 24 hours * 60 minutes * 60 seconds
old_day = s
End If
If Timer < oldt Then 'we went from 23:59:59 (a second before midnight) to 0:0:0 (midnight)
old_day = s + 83400 'add another worth of seconds to our counter
End If
oldt = Timer
olds = old_day + oldt
ExtendedTimer## = olds
End Function ' ExtendedTimer##
Function FloatRoundedToStr$ (fValue As _Float, intNumPlaces As Integer)
Dim fNew As _Float
fNew = Round##(fValue, intNumPlaces)
FloatRoundedToStr$ = FloatToStr$(fNew)
End Function ' DblRoundedToStr$
' /////////////////////////////////////////////////////////////////////////////
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
Function FloatToStr$ (n##)
value$ = UCase$(LTrim$(Str$(n##)))
Xpos% = InStr(value$, "D") + InStr(value$, "E") 'only D or E can be present
If Xpos% Then
expo% = Val(Mid$(value$, Xpos% + 1))
If Val(value$) < 0 Then
sign$ = "-"
valu$ = Mid$(value$, 2, Xpos% - 2)
Else
valu$ = Mid$(value$, 1, Xpos% - 1)
End If
dot% = InStr(valu$, ".")
L% = Len(valu$)
If expo% > 0 Then
add$ = String$(expo% - (L% - dot%), "0")
End If
If expo% < 0 Then
min$ = String$(Abs(expo%) - (dot% - 1), "0")
DP$ = "."
End If
For n = 1 To L%
If Mid$(valu$, n, 1) <> "." Then
num$ = num$ + Mid$(valu$, n, 1)
End If
Next n
Else
FloatToStr$ = value$
Exit Function
End If
FloatToStr$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
End Function ' FloatToStr$
' /////////////////////////////////////////////////////////////////////////////
' TODO: find the newer formatting function?
Function FormatNumber$ (myValue, iDigits As Integer)
Dim strValue As String
strValue = DblToStr$(myValue) + String$(iDigits, " ")
If myValue < 1 Then
If myValue < 0 Then
strValue = Replace$(strValue, "-.", "-0.")
ElseIf myValue > 0 Then
strValue = "0" + strValue
End If
End If
FormatNumber$ = Left$(strValue, iDigits)
End Function ' FormatNumber$
' /////////////////////////////////////////////////////////////////////////////
' From: Bitwise Manipulations By Steven Roman
' http://www.romanpress.com/Articles/Bitwise_R/Bitwise.htm
' Returns the 8-bit binary representation
' of an integer iInput where 0 <= iInput <= 255
Function GetBinary$ (iInput1 As Integer)
Dim sResult As String
Dim iLoop As Integer
Dim iInput As Integer: iInput = iInput1
sResult = ""
If iInput >= 0 And iInput <= 255 Then
For iLoop = 1 To 8
sResult = LTrim$(RTrim$(Str$(iInput Mod 2))) + sResult
iInput = iInput \ 2
'If iLoop = 4 Then sResult = " " + sResult
Next iLoop
End If
GetBinary$ = sResult
End Function ' GetBinary$
' /////////////////////////////////////////////////////////////////////////////
' wonderfully inefficient way to read if a bit is set
' ival = GetBit256%(int we are comparing, int containing the bits we want to read)
' See also: GetBit256%, SetBit256%
Function GetBit256% (iNum1 As Integer, iBit1 As Integer)
Dim iResult As Integer
Dim sNum As String
Dim sBit As String
Dim iLoop As Integer
Dim bContinue As Integer
'DIM iTemp AS INTEGER
Dim iNum As Integer: iNum = iNum1
Dim iBit As Integer: iBit = iBit1
iResult = FALSE
bContinue = TRUE
If iNum < 256 And iBit <= 128 Then
sNum = GetBinary$(iNum)
sBit = GetBinary$(iBit)
For iLoop = 1 To 8
If Mid$(sBit, iLoop, 1) = "1" Then
'if any of the bits in iBit are false, return false
If Mid$(sNum, iLoop, 1) = "0" Then
iResult = FALSE
bContinue = FALSE
Exit For
End If
End If
Next iLoop
If bContinue = TRUE Then
iResult = TRUE
End If
End If
GetBit256% = iResult
End Function ' GetBit256%
' /////////////////////////////////////////////////////////////////////////////
' Returns the text character at positon x%, y%
' Does the same as:
' Locate y%, x%
' GetCharXY% = Screen(CsrLin, Pos(0))
' See also: GetColorXY&
Function GetCharXY% (x%, y%)
GetCharXY% = Screen(y%, x%, 0) ' when 3rd parameter = 0 returns character code
End Function ' GetCharXY%
' /////////////////////////////////////////////////////////////////////////////
' Returns the text color at positon x%, y%
' See also: GetCharXY%
Function GetColorXY& (x%, y%)
GetColorXY& = Screen(y%, x%, 1) ' when 3rd parameter = 1 returns character color
End Function ' GetColorXY
' /////////////////////////////////////////////////////////////////////////////
' Simple timestamp function
' Format: {YYYY}-{MM}-{DD} {hh}:[mm}:{ss}
' Uses:
' TIME$
' The TIME$ Function returns a STRING representation
' of the current computer time in a 24 hour format.
' https://qb64phoenix.com/qb64wiki/index.php/TIME$
' DATE$
' The DATE$ function returns the current computer date
' as a string in the format "mm-dd-yyyy".
' https://qb64phoenix.com/qb64wiki/index.php/DATE$
'
' TODO: support template where
' {yyyy} = 4 digit year
' {mm} = 2 digit month
' {dd} = 2 digit day
' {hh} = 2 digit hour (12-hour)
' {rr} = 2 digit hour (24-hour)
' {nn} = 2 digit minute
' {ss} = 2 digit second
' {ampm} = AM/PM
' We got the nn for minute from Microsoft > Office VBA Reference > DateDiff function
' https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/datediff-function
Function GetCurrentDateTime$ (sTemplate$)
Dim sDate$: sDate$ = Date$
Dim sTime$: sTime$ = Time$
Dim sYYYY$: sYYYY$ = Mid$(sDate$, 7, 4)
Dim sMM$: sMM$ = Mid$(sDate$, 1, 2)
Dim sDD$: sDD$ = Mid$(sDate$, 4, 2)
Dim sHH24$: sHH24$ = Mid$(sTime$, 1, 2)
Dim sHH$: sHH$ = ""
Dim sMI$: sMI$ = Mid$(sTime$, 4, 2)
Dim sSS$: sSS$ = Mid$(sTime$, 7, 2)
Dim iHour%: iHour% = Val(sHH24$)
Dim sAMPM$: sAMPM$ = ""
Dim result$: result$ = ""
' FIGURE OUT AM/PM
If InStr(sTemplate$, "{ampm}") > 0 Then
If iHour% = 0 Then
sAMPM$ = "AM"
iHour% = 12
ElseIf iHour% > 0 And iHour% < 12 Then
sAMPM$ = "AM"
ElseIf iHour% = 12 Then
sAMPM$ = "PM"
Else
sAMPM$ = "PM"
iHour% = iHour% - 12
End If
sHH$ = Right$("00" + _Trim$(Str$(iHour%)), 2)
End If
' RETURN RESULT
GetCurrentDateTime$ = result$
End Function ' GetCurrentDateTime$
' /////////////////////////////////////////////////////////////////////////////
' From: Bitwise Manipulations By Steven Roman
' http://www.romanpress.com/Articles/Bitwise_R/Bitwise.htm
' Returns the integer that corresponds to a binary string of length 8
Function GetIntegerFromBinary% (sBinary1 As String)
Dim iResult As Integer
Dim iLoop As Integer
Dim strBinary As String
Dim sBinary As String: sBinary = sBinary1
iResult = 0
strBinary = Replace$(sBinary, " ", "") ' Remove any spaces
For iLoop = 0 To Len(strBinary) - 1
iResult = iResult + 2 ^ iLoop * Val(Mid$(strBinary, Len(strBinary) - iLoop, 1))
Next iLoop
GetIntegerFromBinary% = iResult
End Function ' GetIntegerFromBinary%
' /////////////////////////////////////////////////////////////////////////////
' Receives a {sDelimeter} delimited list of numbers {MyString}
' and splits it up into an integer array arrInteger()
' beginning at index {iMinIndex}.
Sub GetIntegerArrayFromDelimList (MyString As String, sDelimiter As String, iMinIndex As Integer, arrInteger() As Integer)
ReDim arrString(-1) As String
Dim CleanString As String
Dim iLoop As Integer
Dim iCount As Integer: iCount = iMinIndex - 1
If Len(sDelimiter) > 0 Then
CleanString = MyString
If sDelimiter <> " " Then
CleanString = Replace$(CleanString, " ", "")
End If
split CleanString, sDelimiter, arrString()
iCount = iMinIndex - 1
For iLoop = LBound(arrString) To UBound(arrString)
If IsNum%(arrString(iLoop)) = TRUE Then
iCount = iCount + 1
ReDim _Preserve arrInteger(iMinIndex To iCount) As Integer
arrInteger(iCount) = Val(arrString(iLoop))
'DebugPrint "5633 arrInteger(" + cstr$(iCount) + ") = VAL(arrString(" + cstr$(iLoop) + ")) = " + cstr$(arrInteger(iCount))
End If
Next iLoop
Else
If IsNum%(MyString) = TRUE Then
ReDim _Preserve arrInteger(iMinIndex To iMinIndex) As Integer
arrInteger(iMinIndex) = Val(MyString)
End If
End If
'CleanString=""
'for iLoop=lbound(arrInteger) to ubound(arrInteger)
'CleanString = CleanString + iifstr$(iLoop=lbound(arrInteger), "", ",") + cstr$(arrInteger(iLoop))
'next iLoop
'DebugPrint "arrInteger=(" + CleanString + ")"
End Sub ' GetIntegerArrayFromDelimList
' /////////////////////////////////////////////////////////////////////////////
' Gets the # of seconds so far today
Function GetTimeSeconds& ()
Dim result&: result& = 0
Dim sTime$: sTime$ = Time$
Dim sHH24$: sHH24$ = Mid$(sTime$, 1, 2)
Dim sMI$: sMI$ = Mid$(sTime$, 4, 2)
Dim sSS$: sSS$ = Mid$(sTime$, 7, 2)
Function IntPadLeft$ (iValue As Integer, iWidth As Integer)
IntPadLeft$ = Right$(String$(iWidth, " ") + _Trim$(Str$(iValue)), iWidth)
End Function ' IntPadLeft$
Function IntPadRight$ (iValue As Integer, iWidth As Integer)
IntPadRight$ = Left$(_Trim$(Str$(iValue)) + String$(iWidth, " "), iWidth)
End Function ' IntPadRight$
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if number n is even
' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
' see also: IsOdd%
Function IsEven% (n)
If n Mod 2 = 0 Then
IsEven% = TRUE
Else
IsEven% = FALSE
End If
End Function ' IsEven%
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if value text$ is numeric.
Function IsNum% (text$)
IsNum% = IsNumber%(text$)
End Function ' IsNum%
'' NOTE: THIS FAILS FOR NUMBERS LIKE "002" AND "2.000":
'' from https://www.qb64.org/forum/index.php?topic=896.0
'Function IsNum% (text$)
' Dim a$
' Dim b$
' a$ = _Trim$(text$)
' b$ = _Trim$(Str$(Val(text$)))
' If a$ = b$ Then
' IsNum% = TRUE
' Else
' IsNum% = FALSE
' End If
'End Function ' IsNum%
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if value OriginalString$ is numeric.
' Re: Does a Is Number function exist in QB64?
' https://www.qb64.org/forum/index.php?topic=896.15
' Version 2 by madscijr
' Returns TRUE (-1) if string is an integer, FALSE (0) if not
' Version 1 by MWheatley
' Reply #18 on: January 01, 2019, 11:24:30 AM
' returns 1 if string is an integer, 0 if not
Function IsNumber% (OriginalString$)
Dim bResult%: bResult% = FALSE
Dim iLoop%
Dim TestString$
'Dim bNegative%
Dim iDecimalCount%
Dim sNextChar$
'THEY SHOULD TRIM OUTSIDE THE FUNCTION!
'TestString$ = _TRIM$(OriginalString$)
If Len(OriginalString$) > 0 Then
TestString$ = ""
If Left$(OriginalString$, 1) = "+" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
'bNegative% = FALSE
ElseIf Left$(OriginalString$, 1) = "-" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
'bNegative% = TRUE
Else
TestString$ = OriginalString$
'bNegative% = FALSE
End If
If Len(TestString$) > 0 Then
bResult% = TRUE
iDecimalCount% = 0
For iLoop% = 1 To Len(TestString$)
sNextChar$ = Mid$(TestString$, iLoop%, 1)
If sNextChar$ = "." Then
iDecimalCount% = iDecimalCount% + 1
If iDecimalCount% > 1 Then
' TOO MANY DECIMAL POINTS, INVALID!
bResult% = FALSE
Exit For
End If
ElseIf Asc(sNextChar$) < 48 Or Asc(sNextChar$) > 57 Then
' NOT A NUMERAL OR A DECIMAL, INVALID!
bResult% = FALSE
Exit For
End If
Next iLoop%
End If
End If
IsNumber% = bResult%
End Function ' IsNumber%
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if number n is odd
' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
' see also: IsEven%
Function IsOdd% (n)
If n Mod 2 = 1 Then
IsOdd% = TRUE
Else
IsOdd% = FALSE
End If
End Function ' IsOdd%
' /////////////////////////////////////////////////////////////////////////////
' 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.
Function join$ (in$(), delimiter$)
Dim result$
Dim i As Long
result$ = in$(LBound(in$))
For i = LBound(in$) + 1 To UBound(in$)
result$ = result$ + delimiter$ + in$(i)
Next i
join$ = result$
End Function ' join$
Function LeftPadString$ (myString$, toWidth%, padChar$)
LeftPadString$ = Right$(String$(toWidth%, padChar$) + myString$, toWidth%)
End Function ' LeftPadString$
' /////////////////////////////////////////////////////////////////////////////
' ABS was returning strange values with type LONG
' so I created this which does not.
Function LongABS& (lngValue As Long)
If Sgn(lngValue) = -1 Then
LongABS& = 0 - lngValue
Else
LongABS& = lngValue
End If
End Function ' LongABS&
' /////////////////////////////////////////////////////////////////////////////
' remove scientific Notation to String (~40 LOC)
' SMcNeill Jan 7, 2020
' https://www.qb64.org/forum/index.php?topic=1555.msg112989#msg112989
' Last Function in code marked Best Answer (removed debug comments and
' blank lines added these 2 lines.)
Function N2S$ (EXP$)
ReDim t$, sign$, l$, r$, r&&
ReDim dp As Long, dm As Long, ep As Long, em As Long, check1 As Long, l As Long, i As Long
t$ = LTrim$(RTrim$(EXP$))
If Left$(t$, 1) = "-" Or Left$(t$, 1) = "N" Then sign$ = "-": t$ = Mid$(t$, 2)
dp = InStr(t$, "D+"): dm = InStr(t$, "D-")
ep = InStr(t$, "E+"): em = InStr(t$, "E-")
check1 = Sgn(dp) + Sgn(dm) + Sgn(ep) + Sgn(em)
If check1 < 1 Or check1 > 1 Then N2S = _Trim$(EXP$): Exit Function ' If no scientic notation is found, or if we find more than 1 type, it's not SN!
Select Case l ' l now tells us where the SN starts at.
Case Is < dp: l = dp
Case Is < dm: l = dm
Case Is < ep: l = ep
Case Is < em: l = em
End Select
l$ = Left$(t$, l - 1) ' The left of the SN
r$ = Mid$(t$, l + 1): r&& = Val(r$) ' The right of the SN, turned into a workable long
If InStr(l$, ".") Then ' Location of the decimal, if any
If r&& > 0 Then
r&& = r&& - Len(l$) + 2
Else
r&& = r&& + 1
End If
l$ = Left$(l$, 1) + Mid$(l$, 3)
End If
Select Case r&&
Case 0 ' what the heck? We solved it already?
' l$ = l$
Case Is < 0
For i = 1 To -r&&
l$ = "0" + l$
Next
l$ = "." + l$
Case Else
For i = 1 To r&&
l$ = l$ + "0"
Next
l$ = l$
End Select
N2S$ = sign$ + l$
End Function ' N2S$
Sub PauseDecisecond (iDS As Integer)
Dim iCount As Integer
iCount = 0
Do
iCount = iCount + 1
_Limit 10 ' run 10x every second
Loop Until iCount = iDS
End Sub ' PauseDecisecond
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if point (x1%, y1%) is adjacent to point (x2%, y2%)
Function PointsAreAdjacent% (x1%, y1%, x2%, y2%)
Dim bResult%: bResult% = FALSE
' x or y can be the same, but not both
If (x1% <> x2%) Or (y1% <> y2%) Then
If (x1% = x2%) Or ((x1% = (x2% + 1)) Or (x2% = (x1% + 1))) Then
If (y1% = y2%) Or ((y1% = (y2% + 1)) Or (y2% = (y1% + 1))) Then
bResult% = TRUE
End If
End If
End If
PointsAreAdjacent% = bResult%
End Function ' PointsAreAdjacent%
' /////////////////////////////////////////////////////////////////////////////
' Does a _PrintString at the specified row+column.
'
' iRow% and iCol% are 0-based in this version
'
' See also: PrintString, PrintString1, PutCharXY
Sub PrintAt (iRow%, iCol%, sText$)
'_PrintString (iCol% * 8, iRow% * 16), sText$
_PrintString (iCol% * 8, iRow% * 16), sText$
'_PrintString (iCol%, iRow%), sText$
End Sub ' PrintAt
' /////////////////////////////////////////////////////////////////////////////
' Writes sText to file sFileName.
' If bAppend=TRUE appends to file, else overwrites it.
' Returns blank if successful else returns error message.
Function PrintFile$ (sFileName As String, sText As String, bAppend As Integer)
Dim sError As String: sError = ""
If Len(sError) = 0 Then
If (bAppend = TRUE) Then
If _FileExists(sFileName) Then
Open sFileName For Append As #1 ' opens an existing file for appending
Else
sError = "Error in PrintFile$ : File not found. Cannot append."
End If
Else
Open sFileName For Output As #1 ' opens and clears an existing file or creates new empty file
End If
End If
If Len(sError) = 0 Then
' NOTE: WRITE places text in quotes in the file
'WRITE #1, x, y, z$
'WRITE #1, sText
' PRINT does not put text inside quotes
Print #1, sText
Close #1
End If
PrintFile$ = sError
End Function ' PrintFile$
' /////////////////////////////////////////////////////////////////////////////
' Does a _PrintString at the specified row+column.
' iRow and iCol are 0-based.
' See also: PrintString1
Sub PrintString (iRow As Integer, iCol As Integer, MyString As String)
Dim iX As Integer
Dim iY As Integer
iX = _FontWidth * iCol
iY = _FontHeight * iRow ' (iRow + 1)
_PrintString (iX, iY), MyString
End Sub ' PrintString
' /////////////////////////////////////////////////////////////////////////////
' Does a _PrintString at the specified row+column.
' iRow and iCol are 1-based.
' See also: PrintString
Sub PrintString1 (iRow As Integer, iCol As Integer, MyString As String)
Dim iX As Integer
Dim iY As Integer
iX = _FontWidth * (iCol - 1)
iY = _FontHeight * (iRow - 1)
_PrintString (iX, iY), MyString
End Sub ' PrintString1
' /////////////////////////////////////////////////////////////////////////////
' iNum% = PromptForIntegerInRange%("Please type a number between {min} and {max} (or blank to quit).", 1, 4, 0) ' prompt, min, max, default
Function PromptForIntegerInRange% (sPrompt$, iMin%, iMax%, iDefault%)
Dim iValue%
Dim bFinished%
Dim sPrompt1$
Dim in$
If Len(sPrompt$) > 0 Then
sPrompt1$ = sPrompt$
Else
sPrompt1$ = "Please type a number between {min} and {max} (or blank to quit)."
End If
Input in$
in$ = _Trim$(in$)
If Len(in$) > 0 Then
If IsNumber(in$) Then
iValue% = Val(in$)
If iValue% >= iMin% And iValue% <= iMax% Then
'bFinished% = TRUE
Exit Do
Else
Print "Number out of range."
Print
End If
Else
Print "Not a valid number."
Print
End If
Else
iValue% = iDefault%
Exit Do
'bFinished% = TRUE
End If
Loop Until bFinished% = TRUE
PromptForIntegerInRange% = iValue%
End Function ' PromptForIntegerInRange%
' /////////////////////////////////////////////////////////////////////////////
' Prints text character char$ at positoin x%,y% in color myColor&.
Sub PutCharXY (x%, y%, char$, myColor&)
Color myColor&
Locate y%, x%
Print char$;
End Sub ' PutCharXY
' /////////////////////////////////////////////////////////////////////////////
' Initializes random number generator seed
' NOTE:
' using # of seconds so far in the day
' may be slightly more random than Randomize Timer
' unless user runs program at exact same time every day
Sub InitializeRandom
Dim iSeed As Integer
'iSeed = GetTimeSeconds& MOD 32767
t9# = (Timer * 1000000) Mod 32767
Randomize iSeed
'print "Randomize " + cstr$(iSeed)
'Sleep
End Sub ' InitializeRandom
' /////////////////////////////////////////////////////////////////////////////
' Generate random value between Min and Max inclusive.
' Note: random-number generator should be initialized with
' InitializeRandom or Randomize Timer
Function RandomNumber% (Min%, Max%)
Dim NumSpread%
NumSpread% = (Max% - Min%) + 1
RandomNumber% = Int(Rnd * NumSpread%) + Min% ' GET RANDOM # BETWEEN Max% AND Min%
End Function ' RandomNumber%
$If Then
Sub RandomNumberTest
Dim iCols As Integer: iCols = 10
Dim iRows As Integer: iRows = 20
Dim iLoop As Integer
Dim iX As Integer
Dim iY As Integer
Dim sError As String
Dim sFileName As String
Dim sText As String
Dim bAppend As Integer
Dim iMin As Integer
Dim iMax As Integer
Dim iNum As Integer
Dim iErrorCount As Integer
Dim sInput$
Input "Press <ENTER> to continue", sInput$
End Sub ' RandomNumberTest
$End If
' /////////////////////////////////////////////////////////////////////////////
' FROM: String Manipulation
' found at abandoned, outdated and now likely malicious qb64 dot net website
' http://www.qb64.[net]/forum/index_topic_5964-0/
'
'SUMMARY:
' Purpose: A library of custom functions that transform strings.
' Author: Dustinian Camburides (dustinian@gmail.com)
' Platform: QB64 (www.qb64.org)
' 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.
Function Replace$ (Text1 As String, Find1 As String, Add1 As String)
' VARIABLES:
Dim Text2 As String
Dim Find2 As String
Dim Add2 As String
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]...
While lngLocation
' 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))))
Function RightPadString$ (myString$, toWidth%, padChar$)
RightPadString$ = Left$(myString$ + String$(toWidth%, padChar$), toWidth%)
End Function ' RightPadString$
' /////////////////////////////////////////////////////////////////////////////
' This sub gives really nice control over displaying an Image.
' by BPlus
' Scale rotate font text strings by B+
' https://qb64phoenix.com/forum/showthread.php?tid=414&highlight=rotate+text
' USED BY: drwString
Sub RotoZoom2 (centerX As Long, centerY As Long, Image As Long, xScale As Single, yScale As Single, Rotation As Single)
Dim px(3) As Single: Dim py(3) As Single
W& = _Width(Image&): H& = _Height(Image&)
px(0) = -W& / 2: py(0) = -H& / 2: px(1) = -W& / 2: py(1) = H& / 2
px(2) = W& / 2: py(2) = H& / 2: px(3) = W& / 2: py(3) = -H& / 2
sinr! = Sin(-Rotation): cosr! = Cos(-Rotation)
For i& = 0 To 3
x2& = (px(i&) * cosr! + sinr! * py(i&)) * xScale + centerX: y2& = (py(i&) * cosr! - px(i&) * sinr!) * yScale + centerY
px(i&) = x2&: py(i&) = y2&
Next
_MapTriangle (0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
_MapTriangle (0, 0)-(W& - 1, 0)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
End Sub ' RotoZoom2
'' /////////////////////////////////////////////////////////////////////////////
'' https://qb64phoenix.com/forum/showthread.php?tid=644
'' From: bplus
'' Date: 07-18-2022, 03:16 PM
'' Here is a Round$ that acts the way you'd expect in under 100 LOC
'' b = b + ...
'
'Function Round$ (anyNumber, dp As Long)
' ' 5 and up at decimal place dp+1 > +1 at decimal place 4 and down > +0 at dp
' ' 2 1 0.-1 -2 -3 -4 ... pick dp like this for this Round$ Function
' sn$ = N2S$(Str$(anyNumber + .5 * 10 ^ dp)) ' get rid of sci notation, steve trims it so next find dot
' dot = InStr(sn$, ".")
' If dot Then
' predot = dot - 1
' postdot = Len(sn$) - (dot + 1)
' Else
' predot = Len(sn$)
' postdot = 0
' End If
' ' xxx.yyyyyy dp = -2
' ' ^ dp
' If dp >= 0 Then
' Rtn$ = Mid$(sn$, 1, predot - dp) + String$(dp, "0")
' Else
' Rtn$ = Mid$(sn$, 1, predot) + "." + Mid$(sn$, dot + 1, -dp)
' End If
' If Rtn$ = "" Then
' Round$ = "0"
' Else
' Round$ = Rtn$
' End If
'End Function ' Round$
'
'' /////////////////////////////////////////////////////////////////////////////
''
''Sub RoundTest
'' Print Round$(.15, 0) ' 0
'' Print Round$(.15, -1) ' .2
'' Print Round$(.15, -2) ' .15
'' Print Round$(.15, -3) ' .150
'' Print
'' Print Round$(3555, 0) ' 3555
'' Print Round$(3555, 1) ' 3560
'' Print Round$(3555, 2) ' 3600 'good
'' Print Round$(3555, 3) ' 4000
'' Print
'' Print Round$(23.149999, -1) ' 23.1
'' Print Round$(23.149999, -2) ' 23.15
'' Print Round$(23.149999, -3) ' 23.150
'' Print Round$(23.149999, -4) ' 23.1500
'' Print
'' Print Round$(23.143335, -1) ' 23.1 OK?
'' Print Round$(23.143335, -2) ' 23.14
'' Print Round$(23.143335, -3) ' 23.143
'' Print Round$(23.143335, -4) ' 23.1433
'' Print Round$(23.143335, -5) ' 23.14334
'' Print
'' Dim float31 As _Float
'' float31 = .310000000000009
'' Print Round$(.31, -2) ' .31
'' Print Round$(.31##, -2)
'' Print Round$(float31, -2)
''End Sub ' RoundTest
' /////////////////////////////////////////////////////////////////////////////
' https://www.qb64.org/forum/index.php?topic=3605.0
' Quote from: SMcNeill on Today at 03:53:48 PM
'
' Sometimes, you guys make things entirely too complicated.
' There ya go! Three functions to either round naturally,
' always round down, or always round up, to whatever number of digits you desire.
' EDIT: Modified to add another option to round scientific,
' since you had it's description included in your example.
' Receives + returns _FLOAT myVar## (-1.18E-4932 to +1.18E+4932)
' =============================================================================
' ROUNDING FUNCTIONS FOR TYPE _FLOAT
' old name: RoundNatural##
Function Round## (num##, digits%)
Round## = Int(num## * 10 ^ digits% + .5) / 10 ^ digits%
End Function
Function RoundUp## (num##, digits%)
RoundUp## = _Ceil(num## * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundDown## (num##, digits%)
RoundDown## = Int(num## * 10 ^ digits%) / 10 ^ digits%
End Function
' old name: Round_Scientific##
Function RoundScientific## (num##, digits%)
RoundScientific## = _Round(num## * 10 ^ digits%) / 10 ^ digits%
End Function
' =============================================================================
' ROUNDING FUNCTIONS FOR TYPE DOUBLE
Function RoundDouble# (num#, digits%)
RoundDouble# = Int(num# * 10 ^ digits% + .5) / 10 ^ digits%
End Function
Function RoundUpDouble# (num#, digits%)
RoundUpDouble# = _Ceil(num# * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundDownDouble# (num#, digits%)
RoundDownDouble# = Int(num# * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundScientificDouble# (num#, digits%)
RoundScientificDouble# = _Round(num# * 10 ^ digits%) / 10 ^ digits%
End Function
' =============================================================================
' ROUNDING FUNCTIONS FOR TYPE SINGLE
Function RoundSingle! (num!, digits%)
RoundSingle! = Int(num! * 10 ^ digits% + .5) / 10 ^ digits%
End Function
' NOTE: not sure this one works: when digits%=3, it rounds .31 to .32
Function RoundUpSingle! (num!, digits%)
RoundUpSingle! = _Ceil(num! * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundDownSingle! (num!, digits%)
RoundDownSingle! = Int(num! * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundScientificSingle! (num!, digits%)
RoundScientificSingle! = _Round(num! * 10 ^ digits%) / 10 ^ digits%
End Function
' /////////////////////////////////////////////////////////////////////////////
' fantastically inefficient way to set a bit
' example use: arrMaze(iX, iY) = SetBit256%(arrMaze(iX, iY), cS, FALSE)
' See also: GetBit256%, SetBit256%
' newint=SetBit256%(oldint, int containing the bits we want to set, value to set them to)
Function SetBit256% (iNum1 As Integer, iBit1 As Integer, bVal1 As Integer)
Dim sNum As String
Dim sBit As String
Dim sVal As String
Dim iLoop As Integer
Dim strResult As String
Dim iResult As Integer
Dim iNum As Integer: iNum = iNum1
Dim iBit As Integer: iBit = iBit1
Dim bVal As Integer: bVal = bVal1
If iNum < 256 And iBit <= 128 Then
sNum = GetBinary$(iNum)
sBit = GetBinary$(iBit)
If bVal = TRUE Then
sVal = "1"
Else
sVal = "0"
End If
strResult = ""
For iLoop = 1 To 8
If Mid$(sBit, iLoop, 1) = "1" Then
strResult = strResult + sVal
Else
strResult = strResult + Mid$(sNum, iLoop, 1)
End If
Next iLoop
iResult = GetIntegerFromBinary%(strResult)
Else
iResult = iNum
End If
Next iDegree
End Sub ' ShowDegreesAndRadians
$End If
' /////////////////////////////////////////////////////////////////////////////
' use angles in degrees units instead of radians (converted inside sub)
' Note this function uses whatever the default type is, better not be some Integer Type.
Function SinD (degrees)
SinD = Sin(_D2R(degrees))
End Function ' SinD
Function SmallestOf3% (i1%, i2%, i3%)
Dim iMin%
iMin% = i1%
If i2% < iMin% Then iMin% = i2%
If i3% < iMin% Then iMin% = i3%
SmallestOf3% = iMin%
End Function ' SmallestOf3
Function SngRoundedToStr$ (sngValue As Single, intNumPlaces As Integer)
Dim sngNew As Single
sngNew = RoundSingle!(sngValue, intNumPlaces)
SngRoundedToStr$ = SngToStr$(sngNew)
End Function ' SngRoundedToStr$
' /////////////////////////////////////////////////////////////////////////////
' Hack function, to be replaced with something better
Function SngToInt% (sngOld As Single)
Dim sngNew As Single
Dim sValue As String
Dim iPos As Integer
' /////////////////////////////////////////////////////////////////////////////
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
Function SngToStr$ (n!)
Dim result$: result$ = ""
Dim value$
Dim Xpos%
Dim expo%
Dim sign$
Dim valu$
Dim dot%
Dim L%
Dim add$
Dim min$
Dim DP$
Dim n%
value$ = UCase$(LTrim$(Str$(n!)))
Xpos% = InStr(value$, "D") + InStr(value$, "E") ' only D or E can be present
If Xpos% Then
expo% = Val(Mid$(value$, Xpos% + 1))
If Val(value$) < 0 Then
sign$ = "-"
valu$ = Mid$(value$, 2, Xpos% - 2)
Else
valu$ = Mid$(value$, 1, Xpos% - 1)
End If
dot% = InStr(valu$, ".")
L% = Len(valu$)
If expo% > 0 Then
add$ = String$(expo% - (L% - dot%), "0")
End If
If expo% < 0 Then
min$ = String$(Abs(expo%) - (dot% - 1), "0")
DP$ = "."
End If
For n% = 1 To L%
If Mid$(valu$, n%, 1) <> "." Then
num$ = num$ + Mid$(valu$, n%, 1)
End If
Next n%
result$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
Else
result$ = value$
End If
SngToStr$ = result$
End Function ' SngToStr$
' /////////////////////////////////////////////////////////////////////////////
' 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.
' Modified to handle multi-character delimiters
Sub split (in$, delimiter$, result$())
Dim start As Integer
Dim finish As Integer
Dim iDelimLen As Integer
ReDim result$(-1)
iDelimLen = Len(delimiter$)
start = 1
Do
'While Mid$(in$, start, 1) = delimiter$
While Mid$(in$, start, iDelimLen) = delimiter$
'start = start + 1
start = start + iDelimLen
If start > Len(in$) Then
Exit Sub
End If
Wend
finish = InStr(start, in$, delimiter$)
If finish = 0 Then
finish = Len(in$) + 1
End If
ReDim _Preserve result$(0 To UBound(result$) + 1)
result$(UBound(result$)) = Mid$(in$, start, finish - start)
start = finish + 1
Loop While start <= Len(in$)
End Sub ' split
For iLoop% = LBound(arrTest$) To UBound(arrTest$)
Print "arrTest$(" + LTrim$(RTrim$(Str$(iLoop%))) + ") = " + Chr$(34) + arrTest$(iLoop%) + Chr$(34)
Next iLoop%
Print
Print "Split test finished."
End Sub ' SplitTest
$End If
Print "SplitAndReplaceTest finished."
End Sub ' SplitAndReplaceTest
$End If
' /////////////////////////////////////////////////////////////////////////////
' Converts a chr$(13) delimited string
' into a 2-dimensional array.
' Usage:
' Dim StringArray(1 To 48, 1 To 128) As String
' StringTo2dArray StringArray(), GetMap$
' Version 2 with indexed array(row, columm)
' Renamed StringToArray to StringTo2dArray.
' See also: Array2dToString$
Sub StringTo2dArray (MyArray() As String, MyString As String)
Dim sDelim As String
ReDim arrLines(0) As String
Dim iRow As Integer
Dim iCol As Integer
Dim sChar As String
Dim iDim1 As Integer
Dim iDim2 As Integer
Dim iIndex1 As Integer
Dim iIndex2 As Integer
iDim1 = LBound(MyArray, 1)
iDim2 = LBound(MyArray, 2)
sDelim = Chr$(13)
split MyString, sDelim, arrLines()
For iRow = LBound(arrLines) To UBound(arrLines)
If iRow <= UBound(MyArray, 1) Then
For iCol = 1 To Len(arrLines(iRow))
If iCol <= UBound(MyArray, 2) Then
sChar = Mid$(arrLines(iRow), iCol, 1)
If Len(sChar) > 1 Then
sChar = Left$(sChar, 1)
Else
If Len(sChar) = 0 Then
sChar = "."
End If
End If
iIndex1 = iRow + iDim1
iIndex2 = (iCol - 1) + iDim2
MyArray(iIndex1, iIndex2) = sChar
'DebugPrint "MyArray(" + cstr$(iIndex1) + ", " + cstr$(iIndex2) + " = " + chr$(34) + sChar + chr$(34)
Else
' Exit if out of bounds
Exit For
End If
Next iCol
Else
' Exit if out of bounds
Exit For
End If
Next iRow
End Sub ' StringTo2dArray
Function StrJustifyRight$ (sValue As String, iWidth As Integer)
StrJustifyRight$ = Right$(String$(iWidth, " ") + sValue, iWidth)
End Function ' StrJustifyRight$
Function StrJustifyLeft$ (sValue As String, iWidth As Integer)
StrJustifyLeft$ = Left$(sValue + String$(iWidth, " "), iWidth)
End Function ' StrJustifyLeft$
Function StrJustifyCenter$ (sValue As String, iWidth As Integer)
Dim iLen0 As Integer
Dim iLen1 As Integer
Dim iLen2 As Integer
Dim iExtra As Integer
iLen0 = Len(sValue)
If iWidth = iLen0 Then
' no extra space: return unchanged
StrJustifyCenter$ = sValue
ElseIf iWidth > iLen0 Then
If IsOdd%(iWidth) Then
iWidth = iWidth - 1
End If
' center
iExtra = iWidth - iLen0
iLen1 = iExtra \ 2
iLen2 = iLen1 + (iExtra Mod 2)
StrJustifyCenter$ = String$(iLen1, " ") + sValue + String$(iLen2, " ")
Else
' string is too long: truncate
StrJustifyCenter$ = Left$(sValue, iWidth)
End If
End Function ' StrJustifyCenter$
' /////////////////////////////////////////////////////////////////////////////
' Use to pretty print TRUE and FALSE values.
Function TrueFalse$ (myValue)
If myValue = TRUE Then
TrueFalse$ = "TRUE"
Else
TrueFalse$ = "FALSE"
End If
End Function ' TrueFalse$
' ################################################################################################################################################################
' END GENERAL PURPOSE ROUTINES @GEN
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN REFERENCE #REF
' ################################################################################################################################################################
' =============================================================================
' SOME USEFUL STUFF FOR REFERENCE:
' Type Name Type suffix symbol Minimum value Maximum value Size in Bytes
' --------------------- ------------------ ---------------------------- -------------------------- -------------
' _BIT ` -1 0 1/8
' _BIT * n `n -128 127 n/8
' _UNSIGNED _BIT ~` 0 1 1/8
' _BYTE %% -128 127 1
' _UNSIGNED _BYTE ~%% 0 255 1
' INTEGER % -32,768 32,767 2
' _UNSIGNED INTEGER ~% 0 65,535 2
' LONG & -2,147,483,648 2,147,483,647 4
' _UNSIGNED LONG ~& 0 4,294,967,295 4
' _INTEGER64 && -9,223,372,036,854,775,808 9,223,372,036,854,775,807 8
' _UNSIGNED _INTEGER64 ~&& 0 18,446,744,073,709,551,615 8
' SINGLE ! or none -2.802597E-45 +3.402823E+38 4
' DOUBLE # -4.490656458412465E-324 +1.797693134862310E+308 8
' _FLOAT ## -1.18E-4932 +1.18E+4932 32(10 used)
' _OFFSET %& -9,223,372,036,854,775,808 9,223,372,036,854,775,807 Use LEN
' _UNSIGNED _OFFSET ~%& 0 18,446,744,073,709,551,615 Use LEN
' _MEM none combined memory variable type N/A Use LEN
$If Then
'Pete:
'Oh, does anyone else like how using $IF/THEN works as a block REM statement?
'I mean I'd rather we had a QB64 block remark statement like the one used for JavaScript, but thi hack will do.
$End If
' ################################################################################################################################################################
' END REFERENCE @REF
' ################################################################################################################################################################
Mini-Monster-Mixer v0.1 generates a sprites sheet of 40 monster sprites at 64x64 pixels.
A source image of parts (included in the program code) has pieces that are randomly selected and recolored to generate the final images.
Press c or s to save the currently displayed sprites sheet to the clipboard if you wish. (to be pasted into any paint program afterward).
Code: (Select All)
'Mini-Monster-Mixer v0.1
'By James D. Jarvis November 2022
'This program uses BASIMAGE coded by Dav for QB64GL 1.4, MAY/2020
'
'generate a sprite sheet of monsters
'each is 64 by 64 pixels but code here can be modified to change that
'
'press c or s to save a sprite sheet to the clipboard so you can paste it into a paint program
'and save is whatever format you desire
'pres <esc> to quit
'
'License: Share sprite sheets as long as they include generated credit bar in image
'any programs using original code or graphics from source or generated by program
' please include the following (or equivalent) line somwhere in comments and documentation:
'Includes Art and/or Code from Mini-Monster-Mixer v0.1 created by James D. Jarvis
'
Randomize Timer
Dim Shared ms&
ms& = _NewImage(512, 360, 32)
Screen ms&
_Title "Mini-Monster-Mixer V0.1"
Dim Shared part&
Dim Shared kk1 As _Unsigned Long
Dim Shared kk2 As _Unsigned Long
Dim Shared kk3 As _Unsigned Long
Dim Shared kk4 As _Unsigned Long
Dim Shared clr~&
part& = BASIMAGE1&
Type critterbody_type
head As Integer
arm As Integer
torso As Integer
leg As Integer
k1 As _Unsigned Long
k2 As _Unsigned Long
k3 As _Unsigned Long
k4 As _Unsigned Long
End Type
monster_limit = 40
Dim Shared mlook(monster_limit) As critterbody_type
_Source part&
'read the colors from the color reference bar whichever color is in the top left corner will be transparent
clr~& = Point(0, 0) 'find background color of image
kk1 = Point(0, 1): kk2 = Point(0, 2): kk3 = Point(0, 3): kk4 = Point(0, 4)
_Dest part&
Line (0, 0)-(0, 4), clr~& 'erase the color reference bar from the bit map
_ClearColor clr~&, ms& 'set background color as transparent
_ClearColor clr~&, part&
_Source ms&
_Dest ms&
Do
Cls
mmx = 0: mmy = 0
For m = 1 To monster_limit
'create a new set of monster sprites
'included image source has 16 options for head,arms,torso, and legs
mlook(m).head = Int(1 + Rnd * 16)
mlook(m).arm = Int(1 + Rnd * 16)
mlook(m).torso = Int(1 + Rnd * 16)
mlook(m).leg = Int(1 + Rnd * 16)
'generating new colors for this specific monstewr sprite
kr = Int(Rnd * 150 + 105): kg = Int(Rnd * 150 + 105): kb = Int(Rnd * 150 + 105)
kr2 = Int(kr / 2): kg2 = Int(kg / 2): kb2 = Int(kb / 2)
kr3 = Int(kr2 / (1.2 + Rnd * 3)): kg3 = Int(kg2 / (1.2 + Rnd * 3)): kb3 = Int(kb2 / (1.2 + Rnd * 3))
mlook(m).k1 = _RGB32(kr, kg, kb)
mlook(m).k2 = _RGB32(kr2, kg2, kb2)
mlook(m).k3 = _RGB32(kr3, kg3, kb3)
mlook(m).k4 = _RGB32(Int(Rnd * 220 + 33), Int(Rnd * 210 + 33), Int(Rnd * 200 + 33))
draw_monster mmx, mmy, m, 3
mmx = mmx + 64
If mmx >= _Width Then
mmx = 0
mmy = mmy + 64
End If
Next m
md$ = "Monster Sprite Sheet generated " + Date$ + " at " + Time$
md2$ = "Using Mini-Monster-Mixer V0.1 by James D. Jarvis"
_PrintString (0, 321), md$
_PrintString (0, 337), md2$
Do
_Limit 60
kk$ = InKey$
Loop Until kk$ <> ""
If kk$ = "C" Or kk$ = "c" Or kk$ = "S" Or kk$ = "s" Then
_ClipboardImage = ms&
_Delay 0.3
Locate 1, 1: Print "Sprite Sheet Saved to Clipboard"
Sleep 3
End If
Loop Until kk$ = Chr$(27)
_FreeImage part&
System
Sub draw_monster (Mx, my, mid, scale)
'generate a monster image from source sprite sheet part& and render to the programs main screen ms&
tempi& = _NewImage(32, 32, 32)
'tempi& creates a temporary one sprite image for rendering
_ClearColor clr~&, tempi&
_Dest tempi&
Cls
hs = Int(Rnd * (scale * 2))
_PutImage (0, 0)-(31, 31), part&, tempi&, ((mlook(mid).leg - 1) * 32, 96)-((mlook(mid).leg - 1) * 32 + 31, 96 + 31)
_PutImage (0, 0)-(31, 31), part&, tempi&, ((mlook(mid).arm - 1) * 32, 32)-((mlook(mid).arm - 1) * 32 + 31, 32 + 31)
_PutImage (0 - Int(hs * .8), 0)-(31 + Int(hs * .8), 31), part&, tempi&, ((mlook(mid).torso - 1) * 32, 64)-((mlook(mid).torso - 1) * 32 + 31, 64 + 31)
_PutImage (0 - hs, 0)-(31 + hs, 31), part&, tempi&, ((mlook(mid).head - 1) * 32, 0)-((mlook(mid).head - 1) * 32 + 31, 31)
_Source tempi&
'repaint source image with generate color values for new monster sprite
For y = 0 To 31
For x = 0 To 31
Select Case Point(x, y)
Case kk1
PSet (x, y), mlook(mid).k1
Case kk2
PSet (x, y), mlook(mid).k2
Case kk3
PSet (x, y), mlook(mid).k3
Case kk4
PSet (x, y), mlook(mid).k4
End Select
Next x
Next y
'generated image in tempi& is rendered to ms& as a 64 by 64 sprite
_PutImage (Mx, my)-(Mx + 63, my + 63), tempi&, ms&
_Source ms&
_Dest ms&
_FreeImage tempi&
End Sub
