Seeing @NakedApe's Rock Jockey 2.0 game has inspired me to dig out the Spacewar! game I was working on but stalled on a couple years back, and see if I can finish it.
The part I got bogged down on was a vector polygon shape editor to let players edit what their ship looks like using the mouse, where they click on a grid to add / remove / change start/end points for various line segments. It kinda sorta works but I have to finish the code that keeps track of whether they're adding/deleting/changing an anchor point. I might still have to finish the part where it loads/saves the shape definitions from/to a file.
Anyway here is all the code if anyone wants to play with it. I must have introduced a bug into the game in the last version, because it crashes when the player destroys all the enemies and the round is supposed to end. I'll fix it when I get a chance, I just wanted to share what I have so folks can play around with it in the meantime.
The game "multispaceware72.bas":
The vector polygon shape editor "VectorEditor59.bas":
Simple polygon test/demo "polygon33.bas":
Newer polygon test, I think introduced a bug? "polygon35.bas" :
The part I got bogged down on was a vector polygon shape editor to let players edit what their ship looks like using the mouse, where they click on a grid to add / remove / change start/end points for various line segments. It kinda sorta works but I have to finish the code that keeps track of whether they're adding/deleting/changing an anchor point. I might still have to finish the part where it loads/saves the shape definitions from/to a file.
Anyway here is all the code if anyone wants to play with it. I must have introduced a bug into the game in the last version, because it crashes when the player destroys all the enemies and the round is supposed to end. I'll fix it when I get a chance, I just wanted to share what I have so folks can play around with it in the meantime.
The game "multispaceware72.bas":
Code: (Select All)
Dim Shared m_sTitle As String: m_sTitle = "Fast Zap 'Em : Multispacewar! by Softintheheadware v0.72"
_Title m_sTitle ' display in the Window's title bar
' DATE WHO-DONE-IT DID-WHAT
' 2001-06-10 Tassadar created "Collisions" program in VB6
' 2022-11-01 madscijr Converted "Collisions" to QB64, added some tweaks
' 2022-11-04 madscijr Version 0.44 is now playable with up to 16 players
' 2022-11-06 madscijr Version 0.57, one player can control more than one ship.
' 2022-11-24 madscijr Version 0.69, added constants/parameters/types to be more flexible
' 2022-12-01 madscijr Version 0.71 (last version before project stalled!)
' 2025-01-05 madscijr Version 0.72 added line intersection routines by MasterGy and bplus, to be used later
' DONE:
' * get it working in QB64 + tweak various calculations
' * random enemy radius (wider range with each level)
' * added variables for bullet lifespan, bullet radius
' * bullets can wrap around screen
' * bullet-bullet collisions
' * bonus shields at end of round
' * are you lookin' at me??
' * track x/y velocity differently (movement is jerky)
' * vector engine: define vector objects line by line and draw to screen
' * vector engine: translate rotation angle into dx,dy to move in direction of angle
' * local multiplayer Spacewar! (upto 16 players)
' * finish collisions
' - player hit player
' - player shoot player
' - enemy shoot enemy
' * 2-players control 16 ships (button #2 changes which ship)
' * fix jerky ship movement (ships should move & respond like Asteroids) = fixed by using Single instead of Integer!
' TODO:
' * fix "out of memory" error that happens when all enemies destroyed & round ends
' * get VectorEditor program working (allows player to edit what their ship looks like)
' - uses graphics objects format borrowed from Widescreen Asteroids by Terry Ritchie
' * make sure game works with new code from "VectorEditor" program
' - update collision checking to use IsIntersection function by MasterGy
' and/or LineIntersectLine & TwoSegmentsIntersect by bplus
' at https://qb64phoenix.com/forum/showthread.php?tid=2134&pid=29992
' * factor ship's heading into bullet's speed
' * move scores + player status to top or edges of screen
' * fix player placement
' * sun and gravity
' * explosions and stuff
' * sound effects
' * cleanup/fix menu (breaks if we remove test items)
' * show player # or name on or near ship
' * limited fuel/ammo
' * option: fire button auto-repeat
' * define ships with polygons + improve collision detection accuracy
' * polygon editor
' (lots more plans for phase 2 and beyond)
' OTHER TODO:
' * fix DrawVectorObjectTest1 demo where program crashes on exit (press ESC)
' ORIGINAL CREDITS FROM "Collisions" VB6 game by Tassadar
' downloaded from PlanetSourceCode.com in 2001:
' ********************************************************************************
' * This is My Program, I made it to show some trig stuff *
' * and got a little carried away, but it shows how to do trigonometry anyways *
' * *
' * You are permitted to do whatever you want with this code *
' * eg. Feel free to modify this code, steal it, etc. *
' * I don't really give a crap! *
' * *
' * Programmed by Tassadar *
' ********************************************************************************
' BOOLEAN CONSTANTS
Const FALSE = 0
Const TRUE = Not FALSE
' OTHER SETTINGS
Const cFPS = 120
Const cMinStars = 50
Const cMaxStars = 150
Const cSpeed = 2
Const MIN_PLAYERS = 1
Const MAX_PLAYERS = 16
Const MAX_ROUNDS = 255 ' HOW MANY ROUNDS DOES THE GAME LAST?
Const TURN_SPEED = 36 ' 72=normal, 36=faster, 18=superfast
Const SHIP_ACCEL = 0.1 ' how fast does it accelerate: 0.025, 0.1, 0.05
Const MAX_SPEED = 12 ' what is the ships max speed: 6, 12
Const SHIP_RADIUS = 10 ' What is the radius of the players ship
Const BULLET_RADIUS = 2 ' What is the radius of the bullets
Const SHOOT_DELAY = 200 ' Delay between shots for the ship
Const BULLET_SPEED = 9 ' Bullet speed - Ship speed + bullet speed = overall bulletspeed: 6, 9
Const BULLET_LIFESPAN = 1 ' # seconds bullet is alive
Const BULLETS_STOP_BULLETS = TRUE
Const MIN_ENEMY_RADIUS = 6 ' What is the initial minimum radius of the enemy ships
Const MAX_ENEMY_RADIUS = 99 ' What is the initial maximum radius of the enemy ships
Const WRAP_BULLET = TRUE
Const NUM_SHIELDS = 2 ' 100
Const MAX_SHIELDS = 10
Const BONUS_SHIELDS = 2 ' 50
Const BULLET_DAMAGE = 1
' UDT TO HOLD MENU OPTIONS
Type MenuType
Choice As String
Info As String
End Type ' MenuType
Type ShipType
PlayerNum As Integer
name As String
score As Integer
level As Integer
shields As Integer ' how much shields does the ship have
fuel As Integer
ammo As Integer
radius As Integer
xPos As Single 'Integer ' X co-ordinate of the ship
yPos As Single 'Integer ' Y co-ordinate of the ship
dx As Single ' x multiplier
dy As Single ' y multiplier
vx As Single ' x velocity
vy As Single ' y velocity
heading As Single ' which direction is the ship heading
facing As Single ' which direction is the ship facing
speed As Single ' how fast is the ship going
ShootTime As Long
ShootCount As Long
Left_IsPressed As Integer ' Is the LeftKey depressed
Right_IsPressed As Integer ' Is the RightKey depressed
Up_IsPressed As Integer ' Is the UpKey depressed
Down_IsPressed As Integer ' Is the DownKey depressed
Button1_IsPressed As Integer ' Is Button #1 depressed
Button2_IsPressed As Integer ' Is Button #2 depressed
BodyColor As _Unsigned Long
EngineColor As _Unsigned Long
FlameColor As _Unsigned Long
End Type ' ShipType
Type PlayerType
WhichShip As Integer ' stores what is being controlled (1-16 = ship #, 0 = all)
FirstShip As Integer
LastShip As Integer
'Button2_IsPressed As Integer ' Is Button #2 depressed
Button2_IsReady As Integer ' TRACKS WHETHER BUTTON HAS BEEN RELEASED SINCE LAST PRESSED (TRUE/FALSE)
Left_KeyCode As Integer ' stores key code for Left
Right_KeyCode As Integer ' stores key code for Right
Up_KeyCode As Integer ' stores key code for Up
Down_KeyCode As Integer ' stores key code for Down
Button1_KeyCode As Integer ' stores key code for Button #1 (shoot)
Button2_KeyCode As Integer ' stores key code for Button #2 (option)
instructMoveUp As String
instructMoveDown As String
instructMoveLeft As String
instructMoveRight As String
instructButton1 As String
instructButton2 As String
'instructButton3 As String
'instructButton4 As String
End Type ' PlayerType
Type EnemyType
xPos As Single 'Integer ' X position of this enemy
yPos As Single 'Integer ' Y position of this enemy
life As Integer ' How much life does this enemy have
maxlife As Integer ' Total life this enemy begins with
alive As Integer ' Is this enemy alive
radius As Integer ' size of enemy ship
End Type ' EnemyType
Type BulletType
xPos As Single 'Integer ' X co-ordinate of this bullet
yPos As Single 'Integer ' Y co-ordinate of this bullet
heading As Single ' Direction this bullet is heading
speed As Single ' Speed of this bullet
alive As Integer ' Is this bullet alive
kind As String ' What type of bullet is this (Players or enemies)
owner As Integer ' player # who fired shot (if kind = player)
lifespan As Long
lifetime As Long
End Type ' BulletType
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN SIMPLE VECTOR ENGINE TYPES
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' 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
z As Integer ' zorder in which object is stacked (in front of or behind other objects)
FillColor As _Unsigned Long ' color to fill in object with (use cEmpty for transparent)
PreviewColor As _Unsigned Long '
End Type ' ObjectType
' HOLDS DEFINITION OF ALL OBJECTS
Type LineType
x1 As Integer
y1 As Integer
x2 As Integer
y2 As Integer
color As _Unsigned Long
IsLast As Integer
IsEnabled As Integer
End Type ' LineType
' HOLDS AN X,Y COORDINATE
Type CoordType
x As Integer
y As Integer
End Type ' CoordType
' HOLDS COORDINATES FOR TEST ROTATION
Type PointsType
x As Integer
y As Integer
color As _Unsigned Long
angle As Integer
rx As Integer
ry As Integer
dx As Integer
dy As Integer
End Type ' PointsType
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END SIMPLE VECTOR ENGINE TYPES
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN CHEAPO PLANETARIUM TYPES
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' 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
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END CHEAPO PLANETARIUM TYPES
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ENABLE / DISABLE DEBUG CONSOLE
Dim Shared m_bDebug As Integer: m_bDebug = TRUE
' BASIC PROGRAM METADATA
Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
Dim Shared m_VersionInfo$: m_VersionInfo$ = "0.57"
' GAME CONTROLLER MAPPING
ReDim Shared m_arrButtonCode(1 To 99) As Integer
ReDim Shared m_arrButtonKey(1 To 99) As String
ReDim Shared m_arrButtonKeyDesc(0 To 512) As String
Dim Shared m_bInitialized As Integer: m_bInitialized = FALSE
' FOR MENU
ReDim Shared m_arrMenu(-1) As MenuType
' DISPLAY MODE
Dim Shared m_bCocktailMode As Integer: m_bCocktailMode = TRUE
' OTHER USEFUL VARIABLES
Dim Shared PI As Single: PI = 4 * Atn(1)
Dim Shared ENGINE_RADIUS As Integer: ENGINE_RADIUS = SHIP_RADIUS * 0.6
Dim Shared FLAME_RADIUS As Integer: FLAME_RADIUS = SHIP_RADIUS * 2
Dim Shared m_arrDX(0 To 143) As Single
Dim Shared m_arrDY(0 To 143) As Single
Dim Shared iFPS As Integer: iFPS = 60 ' Delay between frames (frames per second)
Dim Shared iMinX As Integer: iMinX = 1
Dim Shared iMaxX As Integer: iMaxX = 1024
Dim Shared iMinY As Integer: iMinY = 1
Dim Shared iMaxY As Integer: iMaxY = 768
' GAME STATE
Dim Shared m_iPlayers As Integer ' How many players
Dim Shared m_iNumShips As Integer ' How many ships
Dim Shared m_iShipsPerPlayer As Integer ' How many ships does each player control
Dim Shared m_bSimpleEnemies As Integer ' enable/disable enemy type #1
Dim Shared m_iRoundsPerGame As Integer ' how many rounds per game (0 = infinite)
Dim Shared m_bGameOver As Integer ' Is the game over
Dim Shared m_iLevel As Integer ' Track the level
'Dim Shared m_iScore As Integer ' Keeps track of player score
Dim Shared m_iMinEnemyRadius As Integer ' current minimum enemy radius
Dim Shared m_iMaxEnemyRadius As Integer ' current maximum enemy radius
' INPUT VARIABLES
Dim Shared m_bEscKey As Integer
' GAME OBJECTS
ReDim Shared m_arrPlayer(-1) As PlayerType ' A nice array of players
ReDim Shared m_arrShip(-1) As ShipType ' A nice array of ships
ReDim Shared m_arrBullet(-1) As BulletType ' A nice array of bullets
ReDim Shared m_arrEnemy(-1) As EnemyType ' A nice array of enemies
' OBJECT VARIABLES
ReDim Shared m_arrObject(1 To 32) As ObjectType ' m_arrObject(ObjectIndex)
ReDim Shared m_arrOrder(1 To 32) As Integer ' TBD
ReDim Shared m_arrLines(1 To 32, 1 To 32) As LineType ' m_arrLines(ObjectIndex, LineIndex)
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
ReDim Shared m_arrEditGrid(0 To 126, 0 To 126) As CoordType ' CONVERTS EDITOR GRID TO POLAR COORDINATES
' ****************************************************************************************************************************************************************
' ACTIVATE DEBUGGING WINDOW
If m_bDebug = TRUE Then
$Console
_Delay 4
_Console On
_Echo "Started " + m_ProgramName$
_Echo "Debugging on..."
End If
' ****************************************************************************************************************************************************************
' =============================================================================
' START THE MAIN ROUTINE
main
' =============================================================================
' FINISH
'Screen 0
'Print m_ProgramName$ + " finished."
'Sleep
' ****************************************************************************************************************************************************************
' DEACTIVATE DEBUGGING WINDOW
If m_bDebug = TRUE Then
_Console Off
End If
' ****************************************************************************************************************************************************************
' FINISHED
System ' return control to the operating system
' ################################################################################################################################################################
' BEGIN ADD YOUR CUSTOM MENU ITEMS HERE #CUSTOMENU
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
Sub InitializeMenu
' *****************************************************************************
' *** BEGIN ADD YOUR MENU CHOICES HERE ****************************************
AddNextMenuItem "Start game", ""
AddNextMenuItem "Game options", "Change # players, ships, etc."
AddNextMenuItem "DrawVectorObjectTest1", "Test simple vector graphics engine."
'AddNextMenuItem "Choice A", "Option A uses code 65 to do its thing."
'AddNextMenuItem "Choice B", "Option B uses code 66 to do its thing."
'AddNextMenuItem "Choice C", "Option C uses code 67 to do its thing."
AddNextMenuItem "Choice D", "Option D uses code 68 to do its thing."
AddNextMenuItem "Choice E", "Option E uses code 69 to do its thing."
AddNextMenuItem "Choice F", "Option F uses code 70 to do its thing."
AddNextMenuItem "Choice G", "Option G uses code 71 to do its thing."
AddNextMenuItem "Choice H", "Option H uses code 72 to do its thing."
AddNextMenuItem "Choice I", "Option I uses code 73 to do its thing."
AddNextMenuItem "Choice J", "Option J uses code 74 to do its thing."
AddNextMenuItem "Choice K", "Option K uses code 75 to do its thing."
AddNextMenuItem "Choice L", "Option L uses code 76 to do its thing."
AddNextMenuItem "Choice M", "Option M uses code 77 to do its thing."
AddNextMenuItem "Choice N", "Option N uses code 78 to do its thing."
AddNextMenuItem "Choice O", "Option O uses code 79 to do its thing."
AddNextMenuItem "Choice P", "Option P uses code 80 to do its thing."
AddNextMenuItem "Choice Q", "Option Q uses code 81 to do its thing."
AddNextMenuItem "Choice R", "Option R uses code 82 to do its thing."
AddNextMenuItem "Choice S", "Option S uses code 83 to do its thing."
AddNextMenuItem "Choice T", "Option T uses code 84 to do its thing."
AddNextMenuItem "Choice U", "Option U uses code 85 to do its thing."
AddNextMenuItem "Choice V", "Option V uses code 86 to do its thing."
AddNextMenuItem "Choice W", "Option W uses code 87 to do its thing."
AddNextMenuItem "Choice X", "Option X uses code 88 to do its thing."
AddNextMenuItem "Choice Y", "Option Y uses code 89 to do its thing."
AddNextMenuItem "Choice Z", "Option Z uses code 90 to do its thing."
' *** END ADD YOUR MENU CHOICES HERE ******************************************
' *****************************************************************************
End Sub ' InitializeMenu
' /////////////////////////////////////////////////////////////////////////////
Sub DoMenuItem (iMenuPos As Integer)
Dim in$
ClearKeyboard 3
in$ = m_arrMenu(iMenuPos).Choice
If in$ = "" Then ' (DO NOTHING)
' *****************************************************************************
' *** BEGIN ADD YOUR MENU CHOICES AND WHAT CODE RUNS HERE *********************
ElseIf in$ = "Start game" Then game: ClearKeyboard 3
ElseIf in$ = "Game options" Then OptionsMenu
ElseIf in$ = "DrawVectorObjectTest1" Then DrawVectorObjectTest1: ClearKeyboard 3
ElseIf in$ = "Choice A" Then TestRoutineChoiceA: ClearKeyboard 3
ElseIf in$ = "Choice B" Then TestRoutineChoiceB: ClearKeyboard 3
ElseIf in$ = "Choice C" Then TestRoutineChoiceC: ClearKeyboard 3
ElseIf in$ = "Choice D" Then TestRoutineChoiceD: ClearKeyboard 3
ElseIf in$ = "Choice E" Then TestRoutineChoiceE: ClearKeyboard 3
ElseIf in$ = "Choice F" Then TestRoutineChoiceF: ClearKeyboard 3
ElseIf in$ = "Choice G" Then TestRoutineChoiceG: ClearKeyboard 3
ElseIf in$ = "Choice H" Then TestRoutineChoiceH: ClearKeyboard 3
ElseIf in$ = "Choice I" Then TestRoutineChoiceI: ClearKeyboard 3
ElseIf in$ = "Choice J" Then TestRoutineChoiceJ: ClearKeyboard 3
ElseIf in$ = "Choice K" Then TestRoutineChoiceK: ClearKeyboard 3
ElseIf in$ = "Choice L" Then TestRoutineChoiceL: ClearKeyboard 3
ElseIf in$ = "Choice M" Then TestRoutineChoiceM: ClearKeyboard 3
ElseIf in$ = "Choice N" Then TestRoutineChoiceN: ClearKeyboard 3
ElseIf in$ = "Choice O" Then TestRoutineChoiceO: ClearKeyboard 3
ElseIf in$ = "Choice P" Then TestRoutineChoiceP: ClearKeyboard 3
ElseIf in$ = "Choice Q" Then TestRoutineChoiceQ: ClearKeyboard 3
ElseIf in$ = "Choice R" Then TestRoutineChoiceR: ClearKeyboard 3
ElseIf in$ = "Choice S" Then TestRoutineChoiceS: ClearKeyboard 3
ElseIf in$ = "Choice T" Then TestRoutineChoiceT: ClearKeyboard 3
ElseIf in$ = "Choice U" Then TestRoutineChoiceU: ClearKeyboard 3
ElseIf in$ = "Choice V" Then TestRoutineChoiceV: ClearKeyboard 3
ElseIf in$ = "Choice W" Then TestRoutineChoiceW: ClearKeyboard 3
ElseIf in$ = "Choice X" Then TestRoutineChoiceX: ClearKeyboard 3
ElseIf in$ = "Choice Y" Then TestRoutineChoiceY: ClearKeyboard 3
ElseIf in$ = "Choice Z" Then TestRoutineChoiceZ: ClearKeyboard 3
' *** END ADD YOUR MENU CHOICES AND WHAT CODE RUNS HERE ***********************
' *****************************************************************************
Else
' (DO NOTHING)
End If
End Sub ' DoMenuItem
' /////////////////////////////////////////////////////////////////////////////
Sub InitializeMenu1
' *****************************************************************************
' *** BEGIN ADD YOUR MENU CHOICES HERE ****************************************
AddNextMenuItem "Choice A", "Option A uses code 65 to do its thing."
AddNextMenuItem "Choice B", "Option B uses code 66 to do its thing."
AddNextMenuItem "Choice C", "Option C uses code 67 to do its thing."
AddNextMenuItem "Choice D", "Option D uses code 68 to do its thing."
AddNextMenuItem "Choice E", "Option E uses code 69 to do its thing."
AddNextMenuItem "Choice F", "Option F uses code 70 to do its thing."
AddNextMenuItem "Choice G", "Option G uses code 71 to do its thing."
AddNextMenuItem "Choice H", "Option H uses code 72 to do its thing."
AddNextMenuItem "Choice I", "Option I uses code 73 to do its thing."
AddNextMenuItem "Choice J", "Option J uses code 74 to do its thing."
AddNextMenuItem "Choice K", "Option K uses code 75 to do its thing."
AddNextMenuItem "Choice L", "Option L uses code 76 to do its thing."
AddNextMenuItem "Choice M", "Option M uses code 77 to do its thing."
AddNextMenuItem "Choice N", "Option N uses code 78 to do its thing."
AddNextMenuItem "Choice O", "Option O uses code 79 to do its thing."
AddNextMenuItem "Choice P", "Option P uses code 80 to do its thing."
AddNextMenuItem "Choice Q", "Option Q uses code 81 to do its thing."
AddNextMenuItem "Choice R", "Option R uses code 82 to do its thing."
AddNextMenuItem "Choice S", "Option S uses code 83 to do its thing."
AddNextMenuItem "Choice T", "Option T uses code 84 to do its thing."
AddNextMenuItem "Choice U", "Option U uses code 85 to do its thing."
AddNextMenuItem "Choice V", "Option V uses code 86 to do its thing."
AddNextMenuItem "Choice W", "Option W uses code 87 to do its thing."
AddNextMenuItem "Choice X", "Option X uses code 88 to do its thing."
AddNextMenuItem "Choice Y", "Option Y uses code 89 to do its thing."
AddNextMenuItem "Choice Z", "Option Z uses code 90 to do its thing."
' *** END ADD YOUR MENU CHOICES HERE ******************************************
' *****************************************************************************
End Sub ' InitializeMenu
' /////////////////////////////////////////////////////////////////////////////
Sub DoMenuItem1 (iMenuPos As Integer)
Dim in$
ClearKeyboard 3
in$ = m_arrMenu(iMenuPos).Choice
If in$ = "" Then ' (DO NOTHING)
' *****************************************************************************
' *** BEGIN ADD YOUR MENU CHOICES AND WHAT CODE RUNS HERE *********************
ElseIf in$ = "Choice A" Then TestRoutineChoiceA: ClearKeyboard 3
ElseIf in$ = "Choice B" Then TestRoutineChoiceB: ClearKeyboard 3
ElseIf in$ = "Choice C" Then TestRoutineChoiceC: ClearKeyboard 3
ElseIf in$ = "Choice D" Then TestRoutineChoiceD: ClearKeyboard 3
ElseIf in$ = "Choice E" Then TestRoutineChoiceE: ClearKeyboard 3
ElseIf in$ = "Choice F" Then TestRoutineChoiceF: ClearKeyboard 3
ElseIf in$ = "Choice G" Then TestRoutineChoiceG: ClearKeyboard 3
ElseIf in$ = "Choice H" Then TestRoutineChoiceH: ClearKeyboard 3
ElseIf in$ = "Choice I" Then TestRoutineChoiceI: ClearKeyboard 3
ElseIf in$ = "Choice J" Then TestRoutineChoiceJ: ClearKeyboard 3
ElseIf in$ = "Choice K" Then TestRoutineChoiceK: ClearKeyboard 3
ElseIf in$ = "Choice L" Then TestRoutineChoiceL: ClearKeyboard 3
ElseIf in$ = "Choice M" Then TestRoutineChoiceM: ClearKeyboard 3
ElseIf in$ = "Choice N" Then TestRoutineChoiceN: ClearKeyboard 3
ElseIf in$ = "Choice O" Then TestRoutineChoiceO: ClearKeyboard 3
ElseIf in$ = "Choice P" Then TestRoutineChoiceP: ClearKeyboard 3
ElseIf in$ = "Choice Q" Then TestRoutineChoiceQ: ClearKeyboard 3
ElseIf in$ = "Choice R" Then TestRoutineChoiceR: ClearKeyboard 3
ElseIf in$ = "Choice S" Then TestRoutineChoiceS: ClearKeyboard 3
ElseIf in$ = "Choice T" Then TestRoutineChoiceT: ClearKeyboard 3
ElseIf in$ = "Choice U" Then TestRoutineChoiceU: ClearKeyboard 3
ElseIf in$ = "Choice V" Then TestRoutineChoiceV: ClearKeyboard 3
ElseIf in$ = "Choice W" Then TestRoutineChoiceW: ClearKeyboard 3
ElseIf in$ = "Choice X" Then TestRoutineChoiceX: ClearKeyboard 3
ElseIf in$ = "Choice Y" Then TestRoutineChoiceY: ClearKeyboard 3
ElseIf in$ = "Choice Z" Then TestRoutineChoiceZ: ClearKeyboard 3
' *** END ADD YOUR MENU CHOICES AND WHAT CODE RUNS HERE ***********************
' *****************************************************************************
Else
' (DO NOTHING)
End If
End Sub ' DoMenuItem
' ################################################################################################################################################################
' END ADD YOUR CUSTOM MENU ITEMS HERE @MENU2
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN YOUR CODE THAT THE MENU RUNS GOES HERE
' ################################################################################################################################################################
Sub TestRoutineChoiceA
Dim in$
Cls
Print "This is TestRoutineChoiceA"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceA
Sub TestRoutineChoiceB
Dim in$
Cls
Print "This is TestRoutineChoiceB"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceB
Sub TestRoutineChoiceC
Dim in$
Cls
Print "This is TestRoutineChoiceC"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceC
Sub TestRoutineChoiceD
Dim in$
Cls
Print "This is TestRoutineChoiceD"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceD
Sub TestRoutineChoiceE
Dim in$
Cls
Print "This is TestRoutineChoiceE"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceE
Sub TestRoutineChoiceF
Dim in$
Cls
Print "This is TestRoutineChoiceF"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceF
Sub TestRoutineChoiceG
Dim in$
Cls
Print "This is TestRoutineChoiceG"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceG
Sub TestRoutineChoiceH
Dim in$
Cls
Print "This is TestRoutineChoiceH"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceH
Sub TestRoutineChoiceI
Dim in$
Cls
Print "This is TestRoutineChoiceI"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceI
Sub TestRoutineChoiceJ
Dim in$
Cls
Print "This is TestRoutineChoiceJ"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceJ
Sub TestRoutineChoiceK
Dim in$
Cls
Print "This is TestRoutineChoiceK"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceK
Sub TestRoutineChoiceL
Dim in$
Cls
Print "This is TestRoutineChoiceL"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceL
Sub TestRoutineChoiceM
Dim in$
Cls
Print "This is TestRoutineChoiceM"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceM
Sub TestRoutineChoiceN
Dim in$
Cls
Print "This is TestRoutineChoiceN"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceN
Sub TestRoutineChoiceO
Dim in$
Cls
Print "This is TestRoutineChoiceO"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceO
Sub TestRoutineChoiceP
Dim in$
Cls
Print "This is TestRoutineChoiceP"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceP
Sub TestRoutineChoiceQ
Dim in$
Cls
Print "This is TestRoutineChoiceQ"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceQ
Sub TestRoutineChoiceR
Dim in$
Cls
Print "This is TestRoutineChoiceR"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceR
Sub TestRoutineChoiceS
Dim in$
Cls
Print "This is TestRoutineChoiceS"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceS
Sub TestRoutineChoiceT
Dim in$
Cls
Print "This is TestRoutineChoiceT"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceT
Sub TestRoutineChoiceU
Dim in$
Cls
Print "This is TestRoutineChoiceU"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceU
Sub TestRoutineChoiceV
Dim in$
Cls
Print "This is TestRoutineChoiceV"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceV
Sub TestRoutineChoiceW
Dim in$
Cls
Print "This is TestRoutineChoiceW"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceW
Sub TestRoutineChoiceX
Dim in$
Cls
Print "This is TestRoutineChoiceX"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceX
Sub TestRoutineChoiceY
Dim in$
Cls
Print "This is TestRoutineChoiceY"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceY
Sub TestRoutineChoiceZ
Dim in$
Cls
Print "This is TestRoutineChoiceZ"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceZ
' ################################################################################################################################################################
' END YOUR CODE THAT THE MENU RUNS GOES HERE
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN GENERIC MENU CODE #MENU1
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' TODO: fix bug where it blows up when less menu items are used
' TODO: remove unused variables
' TODO: use _Height(0) to automatically set height iMenuSize and iInfoSize
' TODO: use variables to make it easy to change placement and layout of title/instructions/description
' DONE: use _Width(0) to automatically limit # of text columns
Sub main
Dim RoutineName As String: RoutineName = "main"
Dim sResult As String
Dim sFileName As String
Dim vbCrLf As String: vbCrLf = Chr$(10) + Chr$(13)
Dim vbCr As String: vbCr = Chr$(13)
Dim vbLf As String: vbLf = Chr$(10)
Dim vbTab As String: vbTab = Chr$(9)
Dim quot As String: quot = Chr$(34)
Dim sTemp As String
Dim sTempHR As String: sTempHR = "++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++"
Dim sOut As String
Dim sComment As String
Dim sError As String
Dim bFinished As Integer
Dim bAppend As Integer
Dim iMenuSize As Integer ' how many items to display on screen
Dim iMenuPos As Integer ' where in the list we are
Dim iMenuStart As Integer ' first item to display on the list
Dim iMenuEnd As Integer ' last item to display on the list
Dim iMenuLoop As Integer
Dim iStartRow As Integer
Dim iRow As Integer
Dim iCol As Integer
Dim iColCount As Integer
Dim iRowCount As Integer
Dim iLastKey As Integer
Dim iPageSize As Integer
Dim iNudgeSize As Integer ' when cursor reaches bottom or top, how many lines to scroll
Dim bMoved As Integer
Dim bInitPage As Integer
Dim bInitInfo As Integer
Dim in$
ReDim arrInfo(-1) As String
Dim sInfoDelim As String: sInfoDelim = "\n"
Dim iInfoRow As Integer
Dim iInfoSize As Integer
Dim iNextRow As Integer
'Dim iLastInfoRow As Integer
Dim iBackColor~&: iBackColor~& = cBlack
Dim iTitleFgColor~&: iTitleFgColor~& = cBlack
Dim iTitleBgColor~&: iTitleBgColor~& = cDodgerBlue
Dim iLabelColor~&: iLabelColor~& = cGold
Dim iValueColor~&: iValueColor~& = cOrange
Dim iInstructColor~&: iInstructColor~& = cCyan
Dim iMenuColor~&: iMenuColor~& = cWhite
Dim iRunColor~&: iRunColor~& = cYellow
Dim iInfoColor~&: iInfoColor~& = cSilver
Dim iMaxColumns As Integer
Dim iIndex As Integer
Dim bValue As Integer
' SET UP SCREEN
' MAKE SCREEN BIG TO FIT A LOT OF TEXT: 1024x768=128cols,48rows and 1280x1024=160cols,64rows
Screen _NewImage(1024, 768, 32): _ScreenMove 0, 0
' INITIALIZE OPTIONS
m_iPlayers = 2
m_iShipsPerPlayer = 3
m_iNumShips = 1
' INITIALIZE MENU
Cls
Print "Initializing..."
InitializeMenu
iRowCount = _Height(0) \ _FontHeight
iColCount = _Width(0) \ _FontWidth
iMenuSize = 20
iNudgeSize = iMenuSize \ 2
iPageSize = iMenuSize - iNudgeSize
iMenuPos = LBound(m_arrMenu)
iMenuStart = iMenuPos
iMaxColumns = iColCount - 1
'sFileName = m_ProgramPath$ + Left$(m_ProgramName$, Len(m_ProgramName$) - 4) + ".txt"
'iStartRow = 7
iStartRow = 14
iInfoRow = iMenuSize + 10
iInfoSize = 10
' MAIN MENU
bInitPage = TRUE
bChangedOptions = TRUE
bInitInfo = TRUE
iLastKey = 0
bMoved = TRUE
bFinished = FALSE
Do
' INITIALIZE PAGE
If bInitPage = TRUE Then
_Dest 0: Cls , iBackColor~& ' makes the background opaque black
Color iTitleFgColor~&, iTitleBgColor~&
' SHOW TITLE
'PrintString 0, 0, "SimpleMenu"
PrintString 0, 0, "Fast Zap 'Em : Multispacewar! by Softintheheadware, 2022"
' SHOW INSTRUCTIONS
Color iInstructColor~&, iBackColor~&
PrintString 2, 0, "KEY(S) ACTION"
PrintString 3, 0, "----------------------------------- --------------------------------"
PrintString 4, 0, "Crsr Up/Down, PgUp/PgDown, Home/End Navigate/select item"
'PrintString 5, 0, "Crsr Left See description of current item"
PrintString 6, 0, "Crsr Right Run current item"
' SHOW OPTIONS
Color iLabelColor~&, iBackColor~&
PrintString 8, 0, "Players :"
PrintString 9, 0, "Ships per player:"
PrintString 10, 0, "Rounds per game :"
PrintString 11, 0, "Simple enemies :"
Color iValueColor~&, iBackColor~&
PrintString 8, 18, cstr$(m_iPlayers) + " "
PrintString 9, 18, cstr$(m_iShipsPerPlayer) + " "
bValue = IIF(m_iRoundsPerGame = 0, TRUE, FALSE)
PrintString 10, 18, IIFSTR$(bValue, "Infinite", cstr$(m_iRoundsPerGame))
PrintString 11, 18, IIFSTR$(m_bSimpleEnemies, "Yes", "No ")
' CLEAR KEYBOARD BUFFER
ClearKeyboard 1
' INITIALIZE DONE
bInitPage = FALSE
End If
' (RE)DRAW MENU
If bInitInfo = TRUE Or bMoved = TRUE Then
' Clear old description
For iNextRow = iInfoRow To (iInfoRow + iInfoSize)
Locate iNextRow, 1
Color iBackColor~&, iBackColor~&
Print String$(iMaxColumns, " ");
Next iNextRow
' Show current item's description
If Len(m_arrMenu(iMenuPos).Choice) > 0 Then
If Len(m_arrMenu(iMenuPos).Info) > 0 Then
split m_arrMenu(iMenuPos).Info, sInfoDelim, arrInfo()
iRowCount = 0
iNextRow = iInfoRow
For iIndex = 0 To UBound(arrInfo)
iRowCount = iRowCount + 1
If iRowCount > iInfoSize Then Exit For
Locate iNextRow, 1
Color iInfoColor~&, iBackColor~&
Print Left$(arrInfo(iIndex), iMaxColumns);
iNextRow = iNextRow + 1
Next iIndex
End If
End If ' If Len(m_arrMenu(iMenuPos).Choice) > 0 Then
bInitInfo = FALSE
End If
' (RE)DISPLAY CURRENT SLICE OF THE MENU
If bMoved = TRUE Then
iRow = iStartRow
iCol = 0
If iMenuStart < LBound(m_arrMenu) Then
iMenuStart = LBound(m_arrMenu)
End If
iMenuEnd = (iMenuStart + iMenuSize) - 1
If iMenuEnd > UBound(m_arrMenu) Then
If iMenuSize >= UBound(m_arrMenu) Then
iMenuStart = UBound(m_arrMenu) - (iMenuSize - 1)
Else
iMenuStart = LBound(m_arrMenu)
iMenuEnd = UBound(m_arrMenu)
End If
End If
For iMenuLoop = iMenuStart To iMenuEnd
iRow = iRow + 1
If iMenuLoop = iMenuPos Then
Color iBackColor~&, iMenuColor~&
Else
Color iMenuColor~&, iBackColor~&
End If
PrintString iRow, iCol, right$(" " + cstr$(iMenuLoop), 3) + ". " + _
left$(m_arrMenu(iMenuLoop).Choice + string$(iColCount, " "), iColCount)
Next iMenuLoop
bMoved = FALSE
End If
' GET USER INPUT
While _DeviceInput(1): Wend ' Clear and update the keyboard buffer
' DON'T ACCEPT ANY MORE INPUT UNTIL THE LAST PRESSED KEY IS RELEASED
If iLastKey <> 0 Then
If _Button(iLastKey) = FALSE Then
iLastKey = 0
End If
End If
' READY TO ACCEPT MORE INPUT?
If iLastKey = 0 Or bInitInfo = TRUE Then
' DID PLAYER PRESS ANY KEYS WE KNOW?
If _Button(KeyCode_Home%) Then
in$ = "home"
iLastKey = KeyCode_Home%
ElseIf _Button(KeyCode_End%) Then
in$ = "end"
iLastKey = KeyCode_End%
ElseIf _Button(KeyCode_PgUp%) Then
in$ = "pgup"
iLastKey = KeyCode_PgUp%
ElseIf _Button(KeyCode_PgDn%) Then
in$ = "pgdn"
iLastKey = KeyCode_PgDn%
ElseIf _Button(KeyCode_Up%) Then
in$ = "up"
iLastKey = KeyCode_Up%
ElseIf _Button(KeyCode_Down%) Then
in$ = "down"
iLastKey = KeyCode_Down%
'ElseIf _Button(KeyCode_Left%) Then
' in$ = "info"
' iLastKey = KeyCode_Left%
ElseIf _Button(KeyCode_Right%) Then
in$ = "run"
iLastKey = KeyCode_Right%
'ElseIf _Button(KeyCode_Enter%) Then '<-- for some reason clearing the keyboard buffer doesn't stop the Enter key from being detected later, oh well
' in$ = "run"
' iLastKey = KeyCode_Enter%
ElseIf _Button(KeyCode_Escape%) Then
in$ = "esc"
iLastKey = KeyCode_Escape%
Else
in$ = ""
End If
' IF USER DID PRESS A KEY WE KNOW, PROCESS INPUT
If iLastKey <> 0 Or bInitInfo = TRUE Then
ClearKeyboard 0
If in$ = "" Then
' (DO NOTHING)
ElseIf in$ = "home" Then
iMenuPos = LBound(m_arrMenu)
bMoved = TRUE
ElseIf in$ = "end" Then
iMenuPos = UBound(m_arrMenu)
bMoved = TRUE
ElseIf in$ = "pgup" Then
iMenuPos = iMenuPos - iPageSize
bMoved = TRUE
ElseIf in$ = "pgdn" Then
iMenuPos = iMenuPos + iPageSize
bMoved = TRUE
ElseIf in$ = "up" Then
iMenuPos = iMenuPos - 1
bMoved = TRUE
ElseIf in$ = "down" Then
iMenuPos = iMenuPos + 1
bMoved = TRUE
ElseIf in$ = "run" Then
' DO WHAT THE USER SELECTED
DoMenuItem iMenuPos
bMoved = TRUE
' FLAG TO REDRAW MENU
bInitPage = TRUE
bInitInfo = TRUE
ElseIf in$ = "esc" Then
bFinished = TRUE
Exit Do
End If
' HANDLE MOVE
If bMoved = TRUE Then
' MAKE SURE NOT OUT OF BOUNDS
If iMenuPos < LBound(m_arrMenu) Then
iMenuPos = LBound(m_arrMenu)
ElseIf iMenuPos > UBound(m_arrMenu) Then
iMenuPos = UBound(m_arrMenu)
End If
' DETERMINE WHAT RANGE TO DISPLAY
If iMenuPos < iMenuStart Then
iMenuStart = iMenuPos - iNudgeSize
If iMenuStart < LBound(m_arrMenu) Then
iMenuStart = LBound(m_arrMenu)
End If
iMenuEnd = iMenuStart + (iMenuSize - 1)
If iMenuEnd > UBound(m_arrMenu) Then
iMenuEnd = UBound(m_arrMenu)
End If
ElseIf iMenuPos > iMenuEnd Then
iMenuEnd = iMenuPos + iNudgeSize
If iMenuEnd > UBound(m_arrMenu) Then
iMenuEnd = UBound(m_arrMenu)
End If
iMenuStart = iMenuEnd - (iMenuSize - 1)
If iMenuStart < LBound(m_arrMenu) Then
iMenuStart = LBound(m_arrMenu)
End If
End If
End If ' HANDLE MOVE
End If ' iLastKey <> 0
End If ' IF iLastKey = 0
Loop Until bFinished = TRUE
While _DeviceInput(1): Wend ' Clear and update the keyboard buffer
ClearKeyboard 3
' RETURN TO TEXT SCREEN
Screen 0
End Sub ' main
' /////////////////////////////////////////////////////////////////////////////
Sub AddNextMenuItem (sName As String, sInfo As String)
ReDim _Preserve m_arrMenu(1 To UBound(m_arrMenu) + 1) As MenuType
m_arrMenu(UBound(m_arrMenu)).Choice = sName
m_arrMenu(UBound(m_arrMenu)).Info = sInfo
End Sub ' AddNextMenuItem
' /////////////////////////////////////////////////////////////////////////////
' Tries to clear the keyboard buffer.
' In some places _KeyClear seems to work
' but in other situations While_DeviceInput(1):Wend works
' And in other situations k = _KeyHit works.
' So this handy dandy sub does it all:
' iDelay% VALUE FOR
' ------------- ---
' (any) _KeyClear
' 1 _Delay 1
' 2 While _DeviceInput(1): Wend
' 3 k = _KeyHit and the above methods
Sub ClearKeyboard (iDelay%)
Dim k As Integer
_KeyClear
If iDelay% = 1 Then
_Delay iDelay%
End If
If iDelay% > 1 Then
While _DeviceInput(1): Wend ' Clear and update the keyboard buffer
End If
If iDelay% > 2 Then
k = _KeyHit
End If
End Sub ' ClearKeyboard
' ################################################################################################################################################################
' END GENERIC MENU CODE @MENU1
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN BOX DRAWING ROUTINES
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D BOX (OUTLINE)
' https://www.qb64.org/wiki/LINE
Sub DrawBoxOutline (iX As Integer, iY As Integer, iSize As Integer, fgColor As _Unsigned Long)
Line (iX, iY)-(iX + (iSize - 1), iY + (iSize - 1)), fgColor, B ' Draw box outline
End Sub ' DrawBoxOutline
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D BOX (SOLID)
' https://www.qb64.org/wiki/LINE
' Renamed DrawBox/DrawBoxLine to DrawSolidBox
Sub DrawBoxSolid (iX As Integer, iY As Integer, iSize As Integer, fgColor As _Unsigned Long)
Line (iX, iY)-(iX + (iSize - 1), iY + (iSize - 1)), fgColor, BF ' Draw a solid box
End Sub ' DrawBoxSolid
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D RECTANGLE
'DrawRect 0, iX, iY, iSizeW, iSizeH, fgColor, bgColor
Sub DrawRect (img&, iX As Integer, iY As Integer, iSizeW As Integer, iSizeH As Integer, fgColor As _Unsigned Long, bgColor As _Unsigned Long)
'If img& < -1 Then
If img& <= 0 Then
' Select target image
_Dest img& ': Cls , cEmpty
' Draw fill (bgColor)
If bgColor <> cEmpty Then
Line (iX, iY)-(iX + (iSizeW - 1), iY + (iSizeH - 1)), bgColor, BF ' Draw a solid rectangle
End If
' Draw outline (fgColor)
If fgColor <> cEmpty Then
Line (iX, iY)-(iX + (iSizeW - 1), iY + (iSizeH - 1)), fgColor, B ' Draw rectangle outline
End If
End If
End Sub ' DrawRect
' /////////////////////////////////////////////////////////////////////////////
' 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
'DrawCircle 0, iX, iY, iRadius, iThickness, fgColor, bgColor
Sub DrawCircle (img&, iX As Integer, iY As Integer, iRadius As Integer, iThickness As Integer, fgColor As _Unsigned Long, bgColor As _Unsigned Long)
Dim iLoop As Integer
Dim iNextRadius As Integer
Dim iRadiusError As Integer
Dim iNextX As Integer
Dim iNextY As Integer
If (img& <= 0) And (iThickness > 0) And (fgColor <> cEmpty) Then
' Select target image
_Dest img& ': Cls , cEmpty
' Draw circle fill
If bgColor <> cEmpty Then
iNextRadius = Abs(iRadius)
iRadiusError = -iNextRadius
iNextX = iNextRadius
iNextY = 0
If iNextRadius = 0 Then
PSet (iX, iY), bgColor
Else
' 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 (iX - iNextX, iY)-(iX + iNextX, iY), bgColor, BF
While iNextX > iNextY
iRadiusError = iRadiusError + iNextY * 2 + 1
If iRadiusError >= 0 Then
If iNextX <> iNextY + 1 Then
Line (iX - iNextY, iY - iNextX)-(iX + iNextY, iY - iNextX), bgColor, BF
Line (iX - iNextY, iY + iNextX)-(iX + iNextY, iY + iNextX), bgColor, BF
End If
iNextX = iNextX - 1
iRadiusError = iRadiusError - iNextX * 2
End If
iNextY = iNextY + 1
Line (iX - iNextX, iY - iNextY)-(iX + iNextX, iY - iNextY), bgColor, BF
Line (iX - iNextX, iY + iNextY)-(iX + iNextX, iY + iNextY), bgColor, BF
Wend
End If
End If
' Draw circle outline
If fgColor <> cEmpty Then
If iRadius = 0 Then
PSet (iX, iY), fgColor
Else
iNextRadius = iRadius
For iLoop = 1 To iThickness
' DRAW CIRCLE
' CIRCLE (x, y), radius, color
'CIRCLE [[[STEP]]](column, row), radius%, [drawColor%][, startRadian!, stopRadian!] [, aspect!]
Circle (iX, iY), iNextRadius, fgColor
'Line (iLoop * 8, iHeight * 16)-(iLoop * 8 + 8, _Height), cGray, BF
'Circle (iX, iY), 4, cRed
iNextRadius = iNextRadius - 1
If iNextRadius = 0 Then
PSet (iX, iY), fgColor
Exit For
End If
Next iLoop
End If
End If
End If
End Sub ' DrawCircle
' /////////////////////////////////////////////////////////////////////////////
'DrawCircleOutline 0, iX, iY, iRadius, iThickness, fgColor
Sub DrawCircleOutline (img&, iX As Integer, iY As Integer, iRadius As Integer, iThickness As Integer, fgColor As _Unsigned Long)
Dim iNextRadius As Integer
Dim iLoop As Integer
If (img& <= 0) And (iThickness > 0) And (fgColor <> cEmpty) Then
' Select target image
_Dest img& ': Cls , cEmpty
' Initialize
iNextRadius = iRadius
' Draw circle
If Radius = 0 Then
PSet (iX, iY), fgColor
Else
For iLoop = 1 To iThickness
' DRAW CIRCLE
' CIRCLE (x, y), radius, color
'CIRCLE [[[STEP]]](column, row), radius%, [drawColor%][, startRadian!, stopRadian!] [, aspect!]
Circle (iX, iY), iNextRadius, fgColor
'Line (iLoop * 8, iHeight * 16)-(iLoop * 8 + 8, _Height), cGray, BF
'Circle (iX, iY), 4, cRed
iNextRadius = iNextRadius - 1
If iNextRadius = 0 Then
PSet (iX, iY), fgColor
Exit For
End If
Next iLoop
End If
End If
End Sub ' DrawCircleOutline
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D RECTANGLE (OUTLINE)
'DrawRectOutline iX, iY, iSizeW, iSizeH, fgColor
Sub DrawRectOutline (iX As Integer, iY As Integer, iSizeW As Integer, iSizeH As Integer, fgColor As _Unsigned Long)
Line (iX, iY)-(iX + (iSizeW - 1), iY + (iSizeH - 1)), fgColor, B ' Draw rectangle outline
End Sub ' DrawRectOutline
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D RECTANGLE (SOLID)
'DrawRectSolid iX, iY, iSizeW, iSizeH, fgColor
Sub DrawRectSolid (iX As Integer, iY As Integer, iSizeW As Integer, iSizeH As Integer, fgColor As _Unsigned Long)
Line (iX, iY)-(iX + (iSizeW - 1), iY + (iSizeH - 1)), fgColor, BF ' Draw a solid rectangle
End Sub ' DrawRectSolid
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D BOX (OUTLINE)
' https://www.qb64.org/wiki/LINE
' The style parameter 0-255 doesn't seem to have a solid line?
' For that, use DrawOutlineBox.
' LINE [STEP] [(column1, row1)]-[STEP] (column2, row2), color[, [{B|BF}], style%]
' B creates a box outline with each side parallel to the program screen sides. BF creates a filled box.
' The style% signed INTEGER value sets a dotted pattern to draw the line or rectangle outline.
Sub DrawStyledOutlineBox (iX%, iY%, iSize%, iColor~&, iStyle%)
Line (iX%, iY%)-(iX% + (iSize% - 1), iY% + (iSize% - 1)), iColor~&, B , iStyle%
End Sub ' DrawStyledOutlineBox
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D BOX (OUTLINE) WITH A SOLID LINE
Sub DrawOutlineBox (iX%, iY%, iSize2%, iColor~&, iWeight2%)
Dim iFromX%
Dim iFromY%
Dim iToX%
Dim iToY%
iSize% = iSize2% - 1
iWeight% = iWeight2% - 1
If iWeight% = 0 Then
' TOP LINE
iFromX% = iX%
iFromY% = iY%
iToX% = iX% + iSize%
iToY% = iY%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
' BOTTOM LINE
iFromX% = iX%
iFromY% = iY% + iSize%
iToX% = iX% + iSize%
iToY% = iY% + iSize%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
' LEFT LINE
iFromX% = iX%
iFromY% = iY%
iToX% = iX%
iToY% = iY% + iSize%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
' RIGHT LINE
iFromX% = iX% + iSize%
iFromY% = iY%
iToX% = iX% + iSize%
iToY% = iY% + iSize%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
ElseIf iWeight% > 0 Then
' TOP LINE
For iFromY% = iY% To (iY% + iWeight%)
iFromX% = iX%
'iFromY% = iY%
iToX% = iX% + iSize%
iToY% = iFromY%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
Next iFromY%
' BOTTOM LINE
For iFromY% = ((iY% + iSize%) - iWeight%) To (iY% + iSize%)
iFromX% = iX%
'iFromY% = iY% + iSize%
iToX% = iX% + iSize%
iToY% = iFromY%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
Next iFromY%
' LEFT LINE
For iFromX% = iX% To (iX% + iWeight%)
'iFromX% = iX%
iFromY% = iY%
iToX% = iFromX%
iToY% = iY% + iSize%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
Next iFromX%
' RIGHT LINE
For iFromX% = ((iX% + iSize%) - iWeight%) To (iX% + iSize%)
'iFromX% = iX% + iSize%
iFromY% = iY%
iToX% = iFromX%
iToY% = iY% + iSize%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
Next iFromX%
End If
End Sub ' DrawOutlineBox
' /////////////////////////////////////////////////////////////////////////////
'DrawSquare 0, x1, y1, size, fgcolor, bgcolor
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
' ################################################################################################################################################################
' END BOX DRAWING ROUTINES
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN SIMPLE VECTOR ENGINE #VEC
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
Sub DrawVectorObjectTest1
Dim RoutineName As String: RoutineName = "DrawVectorObjectTest1"
Dim iFPS As Integer: iFPS = cFPS
Dim iLoop As Integer
Dim iObject As Integer
Dim iLayer As Integer
Dim iLine As Integer
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 iLineStyleIndex As Integer
Dim lngLineStyle ' line style
Dim lngDashedLineStyle ' line style for other objects
Dim lngSolidLineStyle ' selected object's line style
Dim iNumStars As Integer
Dim iValue As Integer
Dim iMinValue As Integer
Dim iMaxValue As Integer
Dim iStarLoop As Integer
Dim x1%
Dim x2%
Dim y1%
Dim y2%
Dim imgStars& ' used for drawing background
Dim imgText& ' used for drawing text
Dim imgObjects& ' used for drawing objects
Dim imgTemp& ' temporary drawing area
' =============================================================================
' INITIALIZE
InitializeRandom
Screen _NewImage(iMaxX, iMaxY, 32) ' 100 text columns x 40 text rows
' USE LATER FOR DRAWING LAYERS:
imgStars& = _NewImage(iMaxX, iMaxY, 32) ' background stars
imgText& = _NewImage(iMaxX, iMaxY, 32) ' text
imgObjects& = _NewImage(iMaxX, iMaxY, 32) ' frontground objects
imgTemp& = _NewImage(iMaxX, iMaxY, 32) ' temporary
' =============================================================================
' START NEW GAME
Do
_KeyClear
' CONFIGURE PRINTING FOR _PrintString
_PrintMode _FillBackground
'_PrintMode _KEEPBACKGROUND
' INIT OBJECT DEFINITIONS
InitVectorObjects
' INIT VARS
sKey = ""
' PLACE OBJECTS
iX = 0: iY = 0
iValue = UBound(m_arrObject)
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
m_arrObject(iObject).z = iValue
m_arrObject(iObject).FillColor = cBlack
iX = iX + 200
If iX > 800 Then
iX = 0
iY = iY + 200
If iY > 640 Then
iY = 0
End If
End If
iValue = iValue - 1
Next iObject
' INIT OBJECT Z-ORDER ARRAY
ReDim m_arrOrder(LBound(m_arrObject) To UBound(m_arrObject)) As Integer
For iObject = LBound(m_arrObject) To UBound(m_arrObject)
m_arrOrder(m_arrObject(iObject).z) = iObject
Next iObject
' SAVE LINE STYLE SEQUENCE
iLoop = 0
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 61680 ' 1111000011110000
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 30840 ' 0111100001111000
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 15420 ' 0011110000111100
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 7710 ' 0001111000011110
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 3855 ' 0000111100001111
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 34695 ' 1000011110000111
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 50115 ' 1100001111000011
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 57825 ' 1110000111100001
iLineStyleIndex = LBound(m_arrLineStyle)
lngDashedLineStyle = m_arrLineStyle(iLineStyleIndex)
lngSolidLineStyle = 65535
' 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_arrObject(iObject).PreviewColor = 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
' ================================================================================================================================================================
' BEGIN MAIN LOOP
While TRUE = TRUE
' CLEAR OBJECTS LAYER
_Dest imgObjects&: Cls , cEmpty
' MOVE AND ADD ENABLED OBJECTS (IN STACKING ORDER)
For iLayer = UBound(m_arrOrder) To LBound(m_arrOrder) Step -1
' Get next object
iObject = m_arrOrder(iLayer)
' 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 - cSpeed
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 + cSpeed
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 - cSpeed
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 + cSpeed
If m_arrObject(iObject).y > iMaxY Then
m_arrObject(iObject).y = iMinY
End If
End If
End If
' Clear temporary (layer and draw on it
_Dest imgTemp&: Cls , cEmpty
' Draw object's line segments
For iLine = LBound(m_arrLines, 2) To UBound(m_arrLines, 2)
If m_arrLines(iObject, iLine).IsEnabled = TRUE Then
If m_arrLines(iObject, iLine).IsLast = FALSE Then
'Line (x1%, y1%)-(x2%, y2%), arrColor(arrStars(iLoop).ColorIndex), BF, lngLineStyle
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, , lngSolidLineStyle
Else
Exit For
End If
End If
Next iLine
' Draw fill color if not transparent
If m_arrObject(iObject).FillColor <> cEmpty Then
' Fill in current object with its fill color...
'PAINT [STEP] (column%, row%), fillColor[, borderColor%]
Paint (m_arrObject(iObject).x, m_arrObject(iObject).y), _
m_arrObject(iObject).FillColor, m_arrObject(iObject).PreviewColor
End If
' Make other objects appear drawn with a dashed line
If iObject <> iWhich Then
' Outline with a dashed line
For iLine = LBound(m_arrLines, 2) To UBound(m_arrLines, 2)
If m_arrLines(iObject, iLine).IsEnabled = TRUE Then
If m_arrLines(iObject, iLine).IsLast = FALSE Then
'Line (x1%, y1%)-(x2%, y2%), arrColor(arrStars(iLoop).ColorIndex), BF, lngLineStyle
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) _
, _
cBlack, , lngDashedLineStyle
Else
Exit For
End If
End If
Next iLine
End If
' Add new object to objects layer
'_PUTIMAGE , sourceHandle&, destHandle& 'size full source to fit full destination area
_PutImage , imgTemp&, imgObjects&
End If
Next iLayer
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN STARS
' Twinkle twinkle little stars
_Dest imgStars&: Cls , cEmpty
For iStarLoop = LBound(m_arrStars) To UBound(m_arrStars)
' increment twinkle counter
m_arrStars(iStarLoop).TwinkleCounter = m_arrStars(iStarLoop).TwinkleCounter + 1
' is it time to twinkle the color?
If m_arrStars(iStarLoop).TwinkleCounter > m_arrStars(iStarLoop).MaxTwinkCount Then
m_arrStars(iStarLoop).TwinkleCounter = 0 ' reset counter
m_arrStars(iStarLoop).ColorIndex = m_arrStars(iStarLoop).ColorIndex + 1 ' increment color
If m_arrStars(iStarLoop).ColorIndex > UBound(m_arrGrayColor) Then
m_arrStars(iStarLoop).ColorIndex = LBound(m_arrGrayColor) ' reset color
End If
End If
' increment width counter
If m_arrStars(iStarLoop).BigCounter = 0 Then
m_arrStars(iStarLoop).WidthCounter = m_arrStars(iStarLoop).WidthCounter + 1
' is it time to fluctuate the width
If m_arrStars(iStarLoop).WidthCounter > m_arrStars(iStarLoop).MaxWidthCount Then
m_arrStars(iStarLoop).WidthCounter = 0 ' reset counter
m_arrStars(iStarLoop).BigCounter = 1 ' start big counter
m_arrStars(iStarLoop).width = m_arrStars(iStarLoop).MinWidth ' twinkle width
Else
m_arrStars(iStarLoop).width = m_arrStars(iStarLoop).MaxWidth ' normal width
End If
Else
' increment big counter
m_arrStars(iStarLoop).BigCounter = m_arrStars(iStarLoop).BigCounter + 1
' is it time to return to normal size?
If m_arrStars(iStarLoop).BigCounter > m_arrStars(iStarLoop).MaxBigCount Then
m_arrStars(iStarLoop).BigCounter = 0 ' reset counter
m_arrStars(iStarLoop).width = m_arrStars(iStarLoop).MaxWidth ' normal width
End If
End If
' get size
x1% = m_arrStars(iStarLoop).x: x2% = x1% + m_arrStars(iStarLoop).width
y1% = m_arrStars(iStarLoop).y: y2% = y1% + m_arrStars(iStarLoop).width
' (re)draw it
Line (x1%, y1%)-(x2%, y2%), m_arrGrayColor(m_arrStars(iStarLoop).ColorIndex), BF
Next iStarLoop
' END STARS
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' SHOW TEXT
_Dest imgText&: Cls , cEmpty
DrawText sKey, iWhich
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN UPDATE SCREEN
' COPY LAYERS TO SCREEN
_Dest 0: Cls , cBlack
If imgStars& < -1 Then
_PutImage , imgStars&, 0
End If
If imgText& < -1 Then
_PutImage , imgText&, 0
End If
If imgObjects& < -1 Then
_PutImage , imgObjects&, 0
End If
' UPDATE THE SCREEN
_Display
' END UPDATE SCREEN
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' 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
iLineStyleIndex = iLineStyleIndex + 1
If iLineStyleIndex > UBound(m_arrLineStyle) Then
iLineStyleIndex = LBound(m_arrLineStyle)
End If
lngDashedLineStyle = m_arrLineStyle(iLineStyleIndex)
End If
' CLEAR KEYBOARD BUFFER
_KeyClear
' CONTROL GAME SPEED
_Limit iFPS
Wend
' END MAIN LOOP
' ================================================================================================================================================================
' 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
' CLEAR IMAGES
_Dest 0: Cls , cBlack
Screen 0
If imgStars& < -1 Then _FreeImage imgStars&
If imgText& < -1 Then _FreeImage imgText&
If imgObjects& < -1 Then _FreeImage imgObjects&
If imgTemp& < -1 Then _FreeImage imgTemp&
' RETURN TO AUTODISPLAY
_AutoDisplay
End Sub ' DrawVectorObjectTest1
' /////////////////////////////////////////////////////////////////////////////
' 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
RowNum = 0
Color cWhite, cEmpty
RowNum = RowNum + 1: PrintAt RowNum, 1, m_sTitle
RowNum = RowNum + 1
Color cYellow, cEmpty
RowNum = RowNum + 1: PrintAt RowNum, 1, "----------------------------------------"
RowNum = RowNum + 1: PrintAt RowNum, 1, "Press 1-6 to select active object."
RowNum = RowNum + 1: PrintAt RowNum, 1, "Arrow keys move active object."
RowNum = RowNum + 1: PrintAt RowNum, 1, "Press ESC to quit"
RowNum = RowNum + 1: PrintAt RowNum, 1, "----------------------------------------"
RowNum = RowNum + 1
' 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_arrObject(iObject).PreviewColor, cEmpty
If iObject = iWhich Then
'Color cCyan, cEmpty
sFlag = "-> "
Else
'Color cDodgerBlue, cEmpty
sFlag = " "
End If
Else
Color cGray, cEmpty
sFlag = " "
End If
RowNum = RowNum + 1: PrintAt RowNum, 1, "" + _
sFlag + _
cstr$(iNum) + ". " + _
"obj #" + cstr$(iObject) + _
"(" + cstr$(m_arrObject(iObject).x) + "," + cstr$(m_arrObject(iObject).y) + ")" + _
"(" + cstr$(m_arrObject(iObject).dx) + "," + cstr$(m_arrObject(iObject).dy) + ")" + _
"(" + cstr$(m_arrObject(iObject).cx) + "," + cstr$(m_arrObject(iObject).cy) + ")" + _
""
Next iObject
Color cGray, cEmpty
RowNum = RowNum + 1: PrintAt RowNum, 1, "----------------------------------------"
RowNum = RowNum + 2
'' SHOW ACTIVE OBJECT
'Color cWhite
'RowNum = RowNum + 1: PrintAt RowNum, 1, "Object # : " + cstr$(iWhich)
' SHOW INPUT
Color cLime, cEmpty
RowNum = RowNum + 1: PrintAt RowNum, 1, "Controls : " + RightPadString$(sKey, 10, " ") + " "
End Sub ' DrawText
' /////////////////////////////////////////////////////////////////////////////
' 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$
' /////////////////////////////////////////////////////////////////////////////
' Receives:
' String sBitPattern = 16 character string of "1" and "0"
' (a 16-bit binary representation)
' Returns the bit pattern converted to a long integer.
Function LongFromBinaryString& (sBitPattern As String)
Dim sInput As String: sInput = sBitPattern
Dim iLoop As Integer
Dim MyLong As Long
MyLong = 0
If Len(sInput) >= 16 Then
For iLoop = 0 To 15
If Mid$(sInput, 16 - iLoop, 1) = "1" Then
MyLong = MyLong + (2 ^ iLoop)
End If
Next iLoop
End If
LongFromBinaryString& = MyLong
End Function ' LongFromBinaryString&
' /////////////////////////////////////////////////////////////////////////////
' VECTOR OBJECT DEFINITIONS
' future versions will pull this data from an editable file
Sub InitVectorObjects
Dim RoutineName As String: RoutineName = "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
' CLEAR OUT EXISTING
For iObject = LBound(m_arrObject) To UBound(m_arrObject)
m_arrObject(iObject).IsEnabled = FALSE
Next iObject
For iObject = LBound(m_arrLines, 1) To UBound(m_arrLines, 1)
For iLine = LBound(m_arrLines, 2) To UBound(m_arrLines, 2)
m_arrLines(iObject, iLine).x1 = 0
m_arrLines(iObject, iLine).y1 = 0
m_arrLines(iObject, iLine).x2 = 0
m_arrLines(iObject, iLine).y2 = 0
m_arrLines(iObject, iLine).color = cEmpty
m_arrLines(iObject, iLine).IsLast = TRUE
m_arrLines(iObject, iLine).IsEnabled = FALSE
Next iLine
Next iObject
' INITIALIZE FROM SAVED
Restore VectorData
iObject = 1
iLine = 1
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 ' NO MORE DATA AT ALL
m_arrLines(iObject, iLine).IsEnabled = FALSE
m_arrLines(iObject, iLine).IsLast = TRUE
m_arrObject(iObject).IsEnabled = TRUE
Exit For
ElseIf b1 = -254 Then ' NO MORE DATA FOR THIS OBJECT
m_arrLines(iObject, iLine).IsEnabled = FALSE
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).IsEnabled = TRUE
m_arrLines(iObject, iLine).IsLast = FALSE
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)
iLine = iLine + 1
If iLine > UBound(m_arrLines, 2) Then Exit For
End If
Next iLoop%
VectorData:
' Objects are defined as a collection of line segments, in the form:
' Data {x1},{y1},{x2},{y2},{red},{green},{blue}
' where
' * {x1},{y1} are the starting point of the line
' * {x2},{y2} are the ending point of the line
' * {red},{green},{blue} are the RGB color of the line segment
' * 0,0 is the origin,
' * negative numbers mean to the left or above the origin
' * positive numbers mean to the right or below the origin
' * if the {blue} value is -254 like
' Data 0,0,0,0,-254,-254,-254
' then that line is not used,
' it just exists to tell the parser that object's definition is done,
' * if the {blue} value is -255 like
' Data 0,0,0,0,-255,-255,-255
' then that line is not used
' it just exists to tell the parser no more data, stop parsing.
' For now we're using data statements, but later might store
' these definitions in a separate file that an editor can read/write.
'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,-254,-254,-254
'Data 0,0,0,0,-255,-255,-255
'test object
Data -31,-31,-31,31,255,0,0
Data -31,31,31,31,255,0,0
Data 31,31,31,-31,255,0,0
Data 31,-31,-31,-31,255,0,0
Data 0,0,0,0,-254,-254,-254
'test object
Data -31,-31,-31,31,0,0,255
Data -31,31,31,31,0,0,255
Data 31,31,31,-31,0,0,255
Data 31,-31,-31,-31,0,0,255
Data 0,0,0,0,-254,-254,-254
'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,-254,-254,-254
'Data 0,0,0,0,-255,-255,-255
'test object
Data -31,-31,-31,31,255,0,0
Data -31,31,31,31,255,0,0
Data 31,31,31,-31,255,0,0
Data 31,-31,-31,-31,255,0,0
Data 0,0,0,0,-254,-254,-254
'test object
Data -31,-31,-31,31,0,0,255
Data -31,31,31,31,0,0,255
Data 31,31,31,-31,0,0,255
Data 31,-31,-31,-31,0,0,255
Data 0,0,0,0,-254,-254,-254
'test object
Data -31,-31,-31,31,255,0,0
Data -31,31,31,31,255,0,0
Data 31,31,31,-31,255,0,0
Data 31,-31,-31,-31,255,0,0
Data 0,0,0,0,-254,-254,-254
'objaster0 = deep purple square
Data -63,-63,-63,63,96,0,255
Data -63,63,63,63,96,0,255
Data 63,63,63,-63,96,0,255
Data 63,-63,-63,-63,96,0,255
Data 0,0,0,0,-254,-254,-254
'test object
Data -31,-31,-31,31,0,0,255
Data -31,31,31,31,0,0,255
Data 31,31,31,-31,0,0,255
Data 31,-31,-31,-31,0,0,255
Data 0,0,0,0,-254,-254,-254
'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,-254,-254,-254
'Data 0,0,0,0,-255,-255,-255
'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,-254,-254,-254
'Data 0,0,0,0,-255,-255,-255
''test object
'Data -31,-31,-31,31,255, 0, 0
'Data -31,31,31,31,255, 0, 0
'Data 31,31,31,-31,255, 0, 0
'Data 31,-31,-31,-31,255, 0, 0
'Data 0,0,0,0,-254,-254,-254
'FINAL test object
Data -31,-31,-31,31,255,255,255
Data -31,31,31,31,255,255,255
Data 31,31,31,-31,255,255,255
Data 31,-31,-31,-31,255,255,255
Data -16,-16,-16,16,255,0,0
Data -16,16,16,16,0,255,0
Data 16,16,16,-16,0,0,255
Data 16,-16,-16,-16,255,255,0
' Data 0,0,0,0,-254,-254,-254
Data 0,0,0,0,-255,-255,-255
End Sub ' InitVectorObjects
' ################################################################################################################################################################
' END SIMPLE VECTOR ENGINE @VEC
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN TEST CODE #TEST
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
'Sub TestDivideAndRound1
' Dim mySingle As Single
' Dim myDouble As Double
' Dim myFloat1 As _Float
' Dim in$
' ' Excel 1/360 = 0.002778
' mySingle = 1 / 360
' myDouble = 1 / 360
' myFloat1 = 1 / 360
' Print "Single 1/360 = " + _Trim$(Str$(mySingle)) + " or " + SngToStr$(mySingle) + " or " + SngRoundedToStr$(mySingle, 6)
' Print "Double 1/360 = " + _Trim$(Str$(myDouble)) + " or " + DblToStr$(myDouble) + " or " + DblRoundedToStr$(myDouble, 6)
' Print "_FLOAT 1/360 = " + _Trim$(Str$(myFloat1)) + " or " + FloatToStr$(myFloat1) + " or " + FloatRoundedToStr$(myFloat1, 6)
'
' Input "Press <ENTER> to continue", in$
'End Sub ' TestDivideAndRound1
' ################################################################################################################################################################
' END TEST CODE @TEST
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN GAME CODE #GAME
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
Sub game ()
Dim RoutineName As String: RoutineName = "game"
DebugPrintTS "started " + RoutineName
Screen _NewImage(iMaxX, iMaxY, 32)
_KeyClear
DebugPrintTS "InitDxDyTables"
InitDxDyTables
DebugPrintTS "InitVariables"
InitVariables ' Initialize variables
_KeyClear
Do ' main game loop
Cls ' Clear the form
GetInput
If m_bEscKey = FALSE Then
DebugPrintTS "MoveBullets"
MoveBullets ' Activates the MoveBullets sub
DebugPrintTS "MoveAllShips"
MoveAllShips ' Activates the MoveAllShips sub
DebugPrintTS "MoveEnemy"
MoveEnemy ' (doesn't do much yet)
DebugPrintTS "Collisions"
Collisions ' Activates the Collisions sub
DebugPrintTS "CheckForEnd"
CheckForEnd
Else
' game cancelled
m_bGameOver = TRUE
Exit Do
End If
If m_bGameOver = FALSE Then
DebugPrintTS "Shooting"
Shooting ' Activates the Shooting sub
DebugPrintTS "DrawEnemy"
DrawEnemy ' Activates the DrawEnemy sub
DebugPrintTS "DrawBullets"
DrawBullets ' Activates the DrawBullets sub
DebugPrintTS "ShowScore"
ShowScore ' Display the score, etc.
DebugPrintTS "DrawAllShips"
DrawAllShips ' Activates the DrawAllShips sub
'if m_bSimpleEnemies=TRUE then
' Respawn ' Activates the Respawn sub
'end if
Else
If AskPlayAgain% = TRUE Then
DebugPrintTS "AskPlayAgain% = TRUE: InitVariables"
InitVariables
Else
Exit Do
End If
End If
' UPDATE THE SCREEN
_Display
' CONTROL GAME SPEED
_Limit iFPS
Loop
' RETURN TO AUTODISPLAY
_AutoDisplay
End Sub ' game
' /////////////////////////////////////////////////////////////////////////////
Sub OptionsMenu ()
Dim RoutineName As String: RoutineName = "OptionsMenu"
Dim bFinished%
Dim bChanged As Integer
Dim iLastKey As Integer
' INITIALIZE
iLastKey = 0
bChanged = TRUE
bFinished% = FALSE
Do
If bChanged = TRUE Then
Cls
Print "Key Change Current"
Print "- + Option Value"
Print "--- ---------------- -------"
Print "1 2 How many players " + cstr$(m_iPlayers)
Print "3 4 Ships per player " + cstr$(m_iShipsPerPlayer)
Print "5 6 Rounds per game " + IIFSTR$(m_iRoundsPerGame = 0, "Infinite", cstr$(m_iRoundsPerGame))
Print "7 8 Simple enemies " + IIFSTR$(m_bSimpleEnemies, "yes", "No")
Print
Print "Press ESC to exit."
'ClearKeyboard 1
_KeyClear
bChanged = FALSE
End If
' GET USER INPUT
While _DeviceInput(1): Wend ' Clear and update the keyboard buffer
' DON'T ACCEPT ANY MORE INPUT UNTIL THE LAST PRESSED KEY IS RELEASED
If iLastKey <> 0 Then
If _Button(iLastKey) = FALSE Then
iLastKey = 0
End If
End If
' READY TO ACCEPT MORE INPUT?
If iLastKey = 0 Then
' DID PLAYER PRESS ANY KEYS WE KNOW?
If _Button(KeyCode_1%) Then
If m_iPlayers > MIN_PLAYERS Then
m_iPlayers = m_iPlayers - 1
bChanged = TRUE
End If
iLastKey = KeyCode_1%
ElseIf _Button(KeyCode_2%) Then
If m_iPlayers < MAX_PLAYERS Then
If ((m_iPlayers + 1) * m_iShipsPerPlayer) <= MAX_PLAYERS Then
m_iPlayers = m_iPlayers + 1
bChanged = TRUE
End If
End If
iLastKey = KeyCode_2%
ElseIf _Button(KeyCode_3%) Then
If m_iShipsPerPlayer > 1 Then
m_iShipsPerPlayer = m_iShipsPerPlayer - 1
bChanged = TRUE
End If
iLastKey = KeyCode_3%
ElseIf _Button(KeyCode_4%) Then
If (m_iPlayers * (m_iShipsPerPlayer + 1)) <= MAX_PLAYERS Then
m_iShipsPerPlayer = m_iShipsPerPlayer + 1
bChanged = TRUE
End If
iLastKey = KeyCode_4%
ElseIf _Button(KeyCode_5%) Then
If m_iRoundsPerGame > 0 Then
m_iRoundsPerGame = m_iRoundsPerGame - 1
Else
m_iRoundsPerGame = MAX_ROUNDS
End If
bChanged = TRUE
iLastKey = KeyCode_5%
ElseIf _Button(KeyCode_6%) Then
If m_iRoundsPerGame < MAX_ROUNDS Then
m_iRoundsPerGame = m_iRoundsPerGame + 1
Else
m_iRoundsPerGame = 0
End If
bChanged = TRUE
iLastKey = KeyCode_6%
ElseIf _Button(KeyCode_7%) Then
If m_bSimpleEnemies = TRUE Then
m_bSimpleEnemies = FALSE
bChanged = TRUE
End If
iLastKey = KeyCode_7%
ElseIf _Button(KeyCode_8%) Then
If m_bSimpleEnemies = FALSE Then
m_bSimpleEnemies = TRUE
bChanged = TRUE
End If
iLastKey = KeyCode_8%
ElseIf _Button(KeyCode_Escape%) Then
bFinished = TRUE
iLastKey = KeyCode_Escape%
End If
End If ' IF iLastKey = 0
_Limit 30
Loop Until bFinished = TRUE
End Sub ' OptionsMenu
' /////////////////////////////////////////////////////////////////////////////
Function AskPlayAgain%
Dim bResult As Integer: bResult = FALSE
Dim iColCount As Integer
Dim iRowCount As Integer
Dim iRow As Integer
Dim iCol As Integer
Dim iLoopRow As Integer
Dim iWidth As Integer
' Get # text columns + rows
iRowCount = _Height(0) \ _FontHeight
iColCount = _Width(0) \ _FontWidth
iWidth = 18
' Draw background
iRow = (iRowCount \ 2)
iCol = (iColCount \ 2) - (iWidth / 2)
Color cRed, cRed
For iLoopRow = (iRow - 2) To (iRow + 2)
PrintString iLoopRow, iCol, String$(iWidth, " ")
Next iLoopRow
' Write prompt
Color cWhite, cEmpty
PrintString iRow - 1, iCol, LeftPadString$("GAME OVER", iWidth, " ")
PrintString iRow + 1, iCol, LeftPadString$("Play again? (y/n)", iWidth, " ")
' GET USER INPUT
_KeyClear
Do
While _DeviceInput(1): Wend ' Clear and update the keyboard buffer
If _Button(KeyCode_Y%) Then
bResult = TRUE
Exit Do
ElseIf _Button(KeyCode_N%) Then
bResult = FALSE
Exit Do
End If
_Limit 30
Loop
' RETURN RESULT
AskPlayAgain% = bResult
End Function ' AskPlayAgain%
' /////////////////////////////////////////////////////////////////////////////
Function AskPlayAgain1%
Dim bResult As Integer
Dim in$
Cls
Print "GAME OVER"
Print
Print "Level: " + cstr$(m_iLevel)
'TODO: show scores for all players
'Print "Score: " + cstr$(m_iScore)
Print
Do
Input "Do you wish to try again (y/n) "; in$
If LCase$(_Trim$(in$)) = "y" Then
bResult = TRUE
Exit Do
ElseIf LCase$(_Trim$(in$)) = "n" Then
bResult = FALSE
Exit Do
Else
Print
Print "Please type 'y' or 'n'"
Print
End If
Loop
AskPlayAgain1% = bResult
End Function ' AskPlayAgain1%
' /////////////////////////////////////////////////////////////////////////////
' Set the initial state for variables
Sub InitVariables ()
Dim iShip1 As Integer
Dim iShip2 As Integer
Dim iPlayer As Integer
Dim iEnemy As Integer
Dim iLoop1 As Integer
Dim iMinShip As Integer
Dim iMaxShip As Integer
Dim iTurn As Integer
Dim iSpread As Integer
Dim iHalf As Integer
Dim iDivisor As Integer
Dim bDone As Integer
Dim in$
' Initialize game
If m_iPlayers > 0 Then
' Score
m_iLevel = 1
' Game status
m_bGameOver = FALSE
' Enemy min/max radius
iSpread = MAX_ENEMY_RADIUS - MIN_ENEMY_RADIUS
iHalf = iSpread / 2
iDivisor = iSpread / 10
m_iMinEnemyRadius = iHalf - iDivisor
If m_iMinEnemyRadius < MIN_ENEMY_RADIUS Then m_iMinEnemyRadius = MIN_ENEMY_RADIUS
m_iMaxEnemyRadius = iHalf + iDivisor
If m_iMaxEnemyRadius > MAX_ENEMY_RADIUS Then m_iMaxEnemyRadius = MAX_ENEMY_RADIUS
' SIZE ARRAY FOR PLAYERS (who is controlling the ships)
ReDim m_arrPlayer(1 To 16) As PlayerType
' SIZE ARRAY FOR SHIPS
ReDim m_arrShip(1 To 16) As ShipType
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN WHO CONTROLS WHAT
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' RESET SHIP TO PLAYER MAPPING:
For iShip1 = 1 To 16
m_arrShip(iShip1).PlayerNum = 0
m_arrShip(iShip1).shields = 0
Next iShip1
' MAP PLAYERS TO SHIPS AND COUNT TOTAL # OF SHIPS
m_iNumShips = 0
For iPlayer = 1 To m_iPlayers
iMinShip = 0
iMaxShip = 0
For iShip1 = 1 To m_iShipsPerPlayer
' GET SHIP #
m_iNumShips = m_iNumShips + 1
' ASSIGN SHIP TO PLAYER
m_arrShip(m_iNumShips).PlayerNum = iPlayer
' SAVE FIRST & LAST SHIP INDEX FOR CURRENT PLAYER
If iMinShip = 0 Then
iMinShip = m_iNumShips
End If
If m_iNumShips > iMaxShip Then
iMaxShip = m_iNumShips
End If
Next iShip1
' INITIALIZE PLAYER FIRST/LAST/CURRENT SHIP
m_arrPlayer(iPlayer).FirstShip = iMinShip
m_arrPlayer(iPlayer).LastShip = iMaxShip
m_arrPlayer(iPlayer).WhichShip = iMinShip
' RESET BUTTON #2 CONTROL STATUS
m_arrPlayer(iPlayer).Button2_IsReady = TRUE
Next iPlayer
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END WHO CONTROLS WHAT
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' CLEAR CONTROL BUFFER FOR SHIPS
For iShip1 = 1 To 16
' Clear input flags
m_arrShip(iShip1).Left_IsPressed = FALSE
m_arrShip(iShip1).Right_IsPressed = FALSE
m_arrShip(iShip1).Up_IsPressed = FALSE
m_arrShip(iShip1).Down_IsPressed = FALSE
m_arrShip(iShip1).Button1_IsPressed = FALSE
m_arrShip(iShip1).Button2_IsPressed = FALSE
Next iShip1
InitColors
MapControls
' Set the starting positions of the ships
For iShip1 = 1 To m_iNumShips
' FOR NOW JUST NAME EACH PLAYER A LETTER OF THE ALPHABET
m_arrShip(iShip1).name = Chr$(iShip1 + 64)
' RESET SCORE
m_arrShip(iShip1).score = 0
m_arrShip(iShip1).level = 0
' EVERYONE STARTS WITH SAME SHIELDS
' TODO: GET THIS VALUE FROM OPTIONS
m_arrShip(iShip1).shields = NUM_SHIELDS
' INITIALIZE SHIP SIZE
' TODO: let player pick different shape ships, and calculate radius
' TODO: eventually we won't use radius for collision checking (e.g. odd-shaped vessels)
m_arrShip(iShip1).radius = SHIP_RADIUS
' TODO: ADD OPTIONS FOR FUEL AND AMMO, FOR NOW NOT USED...
m_arrShip(iShip1).fuel = 100
If m_iNumShips > 1 Then
m_arrShip(iShip1).ammo = m_iNumShips * 2 ' 2 shots per opponent
Else
m_arrShip(iShip1).ammo = 10
End If
' PLACE SHIP
' TODO: PLACE SHIPS AROUND EDGES OF SCREEN, ON A BASE, ETC.
bDone = FALSE
Do
m_arrShip(iShip1).xPos = RandomNumber%(iMinX, iMaxX) 'Int(Rnd * ScaleWidth + 1)
m_arrShip(iShip1).yPos = RandomNumber%(iMinY, iMaxY) 'Int(Rnd * ScaleHeight + 1)
For iShip2 = 1 To m_iNumShips
If iShip2 <> iShip1 Then
' Is ship too close to another ship?
If GetDist(m_arrShip(iShip1).xPos, m_arrShip(iShip1).yPos, m_arrShip(iShip2).xPos, m_arrShip(iShip2).yPos) > (m_arrShip(iShip1).radius * 4) Then
bDone = TRUE
Exit For
End If
End If
Next iShip2
If bDone = TRUE Then Exit Do
Loop
' POINT SHIP
iTurn = RandomNumber%(0, 143)
If iTurn = 0 Then
m_arrShip(iShip1).facing = 0
m_arrShip(iShip1).dx = 0
m_arrShip(iShip1).dy = 0
Else
For iLoop1 = 1 To iTurn
m_arrShip(iShip1).facing = m_arrShip(iShip1).facing + PI / TURN_SPEED
m_arrShip(iShip1).dx = m_arrShip(iShip1).dx + 1
If m_arrShip(iShip1).dx > 143 Then m_arrShip(iShip1).dx = 0
m_arrShip(iShip1).dy = m_arrShip(iShip1).dy + 1
If m_arrShip(iShip1).dy > 143 Then m_arrShip(iShip1).dy = 0
Next iLoop1
End If
' SHOP NOT MOVING
' TODO: MAYBE ADD OPTION TO START PLAYERS DRIFTING IN A RANDOM DIRECTION?
m_arrShip(iShip1).dx = 0
m_arrShip(iShip1).dy = 0
m_arrShip(iShip1).vx = 0
m_arrShip(iShip1).vy = 0
' VARIABLES THAT LIMIT HOW FAST PLAYER CAN SHOOT
' TODO: add option too limit how many shots player can have at a time
m_arrShip(iShip1).ShootTime = iFPS \ 4
m_arrShip(iShip1).ShootCount = m_arrShip(iShip1).ShootTime + 1
' TODO: REMOVE UNUSED VARIABLES
m_arrShip(iShip1).heading = 0
m_arrShip(iShip1).facing = 0
m_arrShip(iShip1).speed = 0
Next iShip1
' Spawn enemy
' TODO: start enemies off screen and let them move in on their own
If m_bSimpleEnemies = TRUE Then
ReDim _Preserve m_arrEnemy(0) As EnemyType
For iEnemy = 0 To UBound(m_arrEnemy)
' choose a random size
m_arrEnemy(iEnemy).radius = RandomNumber%(m_iMinEnemyRadius, m_iMaxEnemyRadius)
' give enemy life
m_arrEnemy(iEnemy).alive = TRUE
'm_arrEnemy(iEnemy).life = 30
'm_arrEnemy(iEnemy).maxlife = 30
m_arrEnemy(iEnemy).life = m_arrEnemy(iEnemy).radius
m_arrEnemy(iEnemy).maxlife = m_arrEnemy(iEnemy).radius
' Stops the enemy starting on top of any players
Do
' Place enemy randomly
m_arrEnemy(iEnemy).xPos = RandomNumber%(iMinX, iMaxX) 'Int(Rnd * ScaleWidth + 1)
m_arrEnemy(iEnemy).yPos = RandomNumber%(iMinY, iMaxY) 'Int(Rnd * ScaleHeight + 1)
' Make sure enemy is not too close to any players
bDone = TRUE
For iShip1 = 1 To m_iNumShips
If GetDist(m_arrEnemy(iEnemy).xPos, m_arrEnemy(iEnemy).yPos, m_arrShip(iShip1).xPos, m_arrShip(iShip1).yPos) <= (m_arrShip(iShip1).radius * 4) Then
bDone = FALSE
Exit For
End If
Next iShip1
' Have we found a place for this enemy?
If bDone Then Exit Do
Loop
Next iEnemy
Else
ReDim _Preserve m_arrEnemy(-1) As EnemyType
End If
' RESET BULLETS
ReDim _Preserve m_arrBullet(-1) As BulletType
End If
End Sub ' InitVariables
' /////////////////////////////////////////////////////////////////////////////
' TODO: allow players to select colors as part of ship editor
' and store it in a settings file
Sub InitColors
m_arrShip(1).BodyColor = cWhite: m_arrShip(1).EngineColor = cWhite: m_arrShip(1).FlameColor = cRed
m_arrShip(2).BodyColor = cGray: m_arrShip(2).EngineColor = cGray: m_arrShip(2).FlameColor = cOrangeRed
m_arrShip(3).BodyColor = cDarkOrange: m_arrShip(3).EngineColor = cDarkOrange: m_arrShip(3).FlameColor = cOrange
m_arrShip(4).BodyColor = cGold: m_arrShip(4).EngineColor = cGold: m_arrShip(4).FlameColor = cWhiteSmoke
m_arrShip(5).BodyColor = cOliveDrab1: m_arrShip(5).EngineColor = cOliveDrab1: m_arrShip(5).FlameColor = cChartreuse
m_arrShip(6).BodyColor = cMediumSpringGreen: m_arrShip(6).EngineColor = cMediumSpringGreen: m_arrShip(6).FlameColor = cLime
m_arrShip(7).BodyColor = cCyan: m_arrShip(7).EngineColor = cCyan: m_arrShip(7).FlameColor = cSpringGreen
m_arrShip(8).BodyColor = cDodgerBlue: m_arrShip(8).EngineColor = cDodgerBlue: m_arrShip(8).FlameColor = cDeepSkyBlue
m_arrShip(9).BodyColor = cSeaBlue: m_arrShip(9).EngineColor = cSeaBlue: m_arrShip(9).FlameColor = cBlue
m_arrShip(10).BodyColor = cDeepPink: m_arrShip(10).EngineColor = cDeepPink: m_arrShip(10).FlameColor = cLightPink
m_arrShip(11).BodyColor = cMagenta: m_arrShip(11).EngineColor = cMagenta: m_arrShip(11).FlameColor = cHotPink
m_arrShip(12).BodyColor = cOliveDrab: m_arrShip(12).EngineColor = cOliveDrab: m_arrShip(12).FlameColor = cPurpleRed
m_arrShip(13).BodyColor = cBluePurple: m_arrShip(13).EngineColor = cBluePurple: m_arrShip(13).FlameColor = cPurple
m_arrShip(14).BodyColor = cGreen: m_arrShip(14).EngineColor = cGreen: m_arrShip(14).FlameColor = cDeepPurple
m_arrShip(15).BodyColor = cBrickRed: m_arrShip(15).EngineColor = cBrickRed: m_arrShip(15).FlameColor = cLightGray
m_arrShip(16).BodyColor = cYellow: m_arrShip(16).EngineColor = cYellow: m_arrShip(16).FlameColor = cSilver
End Sub ' InitColors
' /////////////////////////////////////////////////////////////////////////////
' Initialize control mapping
' TODO: allow players to map their own controls (keyboard, gamepad, mouse, etc.)
' and store it in a settings file
Sub MapControls
m_arrPlayer(1).Left_KeyCode = KeyCode_Left%
m_arrPlayer(1).Right_KeyCode = KeyCode_Right%
m_arrPlayer(1).Up_KeyCode = KeyCode_Up%
m_arrPlayer(1).Down_KeyCode = KeyCode_Down%
m_arrPlayer(1).Button1_KeyCode = KeyCode_CtrlRight%
m_arrPlayer(1).Button2_KeyCode = KeyCode_ShiftRight%
m_arrPlayer(2).Left_KeyCode = KeyCode_Keypad4Left%
m_arrPlayer(2).Right_KeyCode = KeyCode_Keypad6Right%
m_arrPlayer(2).Up_KeyCode = KeyCode_Keypad8Up%
m_arrPlayer(2).Down_KeyCode = KeyCode_Keypad2Down%
m_arrPlayer(2).Button1_KeyCode = KeyCode_Keypad7Home%
m_arrPlayer(2).Button2_KeyCode = KeyCode_Keypad9PgUp%
m_arrPlayer(3).Left_KeyCode = KeyCode_Keypad1End%
m_arrPlayer(3).Right_KeyCode = KeyCode_Keypad3PgDn%
m_arrPlayer(3).Up_KeyCode = KeyCode_Keypad5%
m_arrPlayer(3).Down_KeyCode = KeyCode_Keypad0Ins%
m_arrPlayer(3).Button1_KeyCode = KeyCode_KeypadEnter%
m_arrPlayer(3).Button2_KeyCode = KeyCode_KeypadPeriodDel%
m_arrPlayer(4).Left_KeyCode = KeyCode_1%
m_arrPlayer(4).Right_KeyCode = KeyCode_2%
m_arrPlayer(4).Up_KeyCode = KeyCode_3%
m_arrPlayer(4).Down_KeyCode = KeyCode_4%
m_arrPlayer(4).Button1_KeyCode = KeyCode_5%
m_arrPlayer(4).Button2_KeyCode = KeyCode_Tilde%
m_arrPlayer(5).Left_KeyCode = KeyCode_6%
m_arrPlayer(5).Right_KeyCode = KeyCode_7%
m_arrPlayer(5).Up_KeyCode = KeyCode_8%
m_arrPlayer(5).Down_KeyCode = KeyCode_9%
m_arrPlayer(5).Button1_KeyCode = KeyCode_0%
m_arrPlayer(5).Button2_KeyCode = KeyCode_Minus%
m_arrPlayer(6).Left_KeyCode = KeyCode_BracketLeft%
m_arrPlayer(6).Right_KeyCode = KeyCode_BracketRight%
m_arrPlayer(6).Up_KeyCode = KeyCode_BkSp%
m_arrPlayer(6).Down_KeyCode = KeyCode_Enter%
m_arrPlayer(6).Button1_KeyCode = KeyCode_Backslash%
m_arrPlayer(6).Button2_KeyCode = KeyCode_Equal%
m_arrPlayer(7).Left_KeyCode = KeyCode_Ins%
m_arrPlayer(7).Right_KeyCode = KeyCode_Home%
m_arrPlayer(7).Up_KeyCode = KeyCode_PgDn%
m_arrPlayer(7).Down_KeyCode = KeyCode_PgUp%
m_arrPlayer(7).Button1_KeyCode = KeyCode_End%
m_arrPlayer(7).Button2_KeyCode = KeyCode_Del%
m_arrPlayer(8).Left_KeyCode = KeyCode_Q%
m_arrPlayer(8).Right_KeyCode = KeyCode_W%
m_arrPlayer(8).Up_KeyCode = KeyCode_E%
m_arrPlayer(8).Down_KeyCode = KeyCode_R%
m_arrPlayer(8).Button1_KeyCode = KeyCode_T%
m_arrPlayer(8).Button2_KeyCode = KeyCode_KeypadSlash%
m_arrPlayer(9).Left_KeyCode = KeyCode_Y%
m_arrPlayer(9).Right_KeyCode = KeyCode_U%
m_arrPlayer(9).Up_KeyCode = KeyCode_I%
m_arrPlayer(9).Down_KeyCode = KeyCode_O%
m_arrPlayer(9).Button1_KeyCode = KeyCode_P%
m_arrPlayer(9).Button2_KeyCode = KeyCode_KeypadMultiply%
m_arrPlayer(10).Left_KeyCode = KeyCode_A%
m_arrPlayer(10).Right_KeyCode = KeyCode_S%
m_arrPlayer(10).Up_KeyCode = KeyCode_D%
m_arrPlayer(10).Down_KeyCode = KeyCode_F%
m_arrPlayer(10).Button1_KeyCode = KeyCode_G%
m_arrPlayer(10).Button2_KeyCode = KeyCode_KeypadMinus%
m_arrPlayer(11).Left_KeyCode = KeyCode_Z%
m_arrPlayer(11).Right_KeyCode = KeyCode_X%
m_arrPlayer(11).Up_KeyCode = KeyCode_C%
m_arrPlayer(11).Down_KeyCode = KeyCode_V%
m_arrPlayer(11).Button1_KeyCode = KeyCode_B%
m_arrPlayer(11).Button2_KeyCode = KeyCode_F12%
m_arrPlayer(12).Left_KeyCode = KeyCode_N%
m_arrPlayer(12).Right_KeyCode = KeyCode_M%
m_arrPlayer(12).Up_KeyCode = KeyCode_Comma%
m_arrPlayer(12).Down_KeyCode = KeyCode_Period%
m_arrPlayer(12).Button1_KeyCode = KeyCode_Slash%
m_arrPlayer(12).Button2_KeyCode = KeyCode_Menu%
m_arrPlayer(13).Left_KeyCode = KeyCode_H%
m_arrPlayer(13).Right_KeyCode = KeyCode_J%
m_arrPlayer(13).Up_KeyCode = KeyCode_K%
m_arrPlayer(13).Down_KeyCode = KeyCode_L%
m_arrPlayer(13).Button1_KeyCode = KeyCode_Semicolon%
m_arrPlayer(13).Button2_KeyCode = KeyCode_Apostrophe%
m_arrPlayer(14).Left_KeyCode = KeyCode_F1%
m_arrPlayer(14).Right_KeyCode = KeyCode_F2%
m_arrPlayer(14).Up_KeyCode = KeyCode_F3%
m_arrPlayer(14).Down_KeyCode = KeyCode_F4%
m_arrPlayer(14).Button1_KeyCode = KeyCode_F5%
m_arrPlayer(14).Button2_KeyCode = KeyCode_ScrollLock%
m_arrPlayer(15).Left_KeyCode = KeyCode_F6%
m_arrPlayer(15).Right_KeyCode = KeyCode_F7%
m_arrPlayer(15).Up_KeyCode = KeyCode_F8%
m_arrPlayer(15).Down_KeyCode = KeyCode_F9%
m_arrPlayer(15).Button1_KeyCode = KeyCode_F11%
m_arrPlayer(15).Button2_KeyCode = KeyCode_NumLock%
m_arrPlayer(16).Left_KeyCode = KeyCode_CtrlLeft%
m_arrPlayer(16).Right_KeyCode = KeyCode_Spacebar%
m_arrPlayer(16).Up_KeyCode = KeyCode_Tab%
m_arrPlayer(16).Down_KeyCode = KeyCode_CapsLock%
m_arrPlayer(16).Button1_KeyCode = KeyCode_ShiftLeft%
m_arrPlayer(16).Button2_KeyCode = KeyCode_KeypadPlus%
End Sub ' MapControls
' /////////////////////////////////////////////////////////////////////////////
' Detect which keys are pressed
Sub GetInput ()
Dim iPlayer As Integer
Dim iShip1 As Integer
Dim iFirstShip As Integer
Dim iLastShip As Integer
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
' DID THEY PRESS ESCAPE?
If _Button(KeyCode_Escape%) Then
m_bEscKey = TRUE
Else
m_bEscKey = FALSE
End If
' DETECT KEYS FOR EACH SHIP
For iPlayer = 1 To m_iPlayers
' IF PLAYER HAS SHIPS, DETECT KEYS
If m_arrPlayer(iPlayer).WhichShip > -1 Then
' IF PLAYER PRESSES BUTTON #2, CYCLE WHICH SHIP THEY CONTROL
If _Button(m_arrPlayer(iPlayer).Button2_KeyCode) Then
' IS BUTTON ENABLED?
If m_arrPlayer(iPlayer).Button2_IsReady = TRUE Then
' DISABLE ALL EXISTING BUTTONS FOR THIS PLAYER'S SHIPS
For iShip1 = m_arrPlayer(iPlayer).FirstShip To m_arrPlayer(iPlayer).LastShip
ClearInputBuffer iShip1
Next iShip1
' CHANGE WHICH SHIP PLAYER CONTROLS
If m_arrPlayer(iPlayer).WhichShip = 0 Then
' SWITCH CONTROL TO FIRST SHIP
m_arrPlayer(iPlayer).WhichShip = m_arrPlayer(iPlayer).FirstShip
Else
If m_arrPlayer(iPlayer).WhichShip = m_arrPlayer(iPlayer).LastShip Then
' SWITCH CONTROL TO ALL SHIPS
m_arrPlayer(iPlayer).WhichShip = 0
Else
' SWITCH CONTROL TO NEXT WORKING SHIP
iShip1 = m_arrPlayer(iPlayer).WhichShip
Do
iShip1 = iShip1 + 1
If iShip1 > m_arrPlayer(iPlayer).LastShip Then
iShip1 = m_arrPlayer(iPlayer).FirstShip
End If
If m_arrShip(iShip1).shields > 0 Then
Exit Do
ElseIf iShip1 = m_arrPlayer(iPlayer).WhichShip Then
Exit Do
End If
Loop
m_arrPlayer(iPlayer).WhichShip = iShip1
End If
End If
' DISABLE BUTTON UNTIL IT IS RELEASED
m_arrPlayer(iPlayer).Button2_IsReady = FALSE
End If
Else
' BUTTON HAS BEEN RELEASED, RE-ENABLE IT
m_arrPlayer(iPlayer).Button2_IsReady = TRUE
End If
' WHICH SHIPS TO GET INPUT FOR?
If m_arrPlayer(iPlayer).WhichShip = 0 Then
' ALL SHIPS
iFirstShip = m_arrPlayer(iPlayer).FirstShip
iLastShip = m_arrPlayer(iPlayer).LastShip
Else
' JUST THE CURRENT ONE
iFirstShip = m_arrPlayer(iPlayer).WhichShip
iLastShip = m_arrPlayer(iPlayer).WhichShip
End If
' GET INPUT FOR SHIP(S)
For iShip1 = iFirstShip To iLastShip
' IGNORE DESTROYED SHIPS
If m_arrShip(iShip1).shields > 0 Then
If _Button(m_arrPlayer(iPlayer).Left_KeyCode) Then
m_arrShip(iShip1).Left_IsPressed = TRUE
m_arrShip(iShip1).Right_IsPressed = FALSE
ElseIf _Button(m_arrPlayer(iPlayer).Right_KeyCode) Then
m_arrShip(iShip1).Left_IsPressed = FALSE
m_arrShip(iShip1).Right_IsPressed = TRUE
Else
m_arrShip(iShip1).Left_IsPressed = FALSE
m_arrShip(iShip1).Right_IsPressed = FALSE
End If
If _Button(m_arrPlayer(iPlayer).Up_KeyCode) Then
m_arrShip(iShip1).Up_IsPressed = TRUE
m_arrShip(iShip1).Down_IsPressed = FALSE
ElseIf _Button(m_arrPlayer(iPlayer).Down_KeyCode) Then
m_arrShip(iShip1).Up_IsPressed = FALSE
m_arrShip(iShip1).Down_IsPressed = TRUE
Else
m_arrShip(iShip1).Up_IsPressed = FALSE
m_arrShip(iShip1).Down_IsPressed = FALSE
End If
If _Button(m_arrPlayer(iPlayer).Button1_KeyCode) Then
m_arrShip(iShip1).Button1_IsPressed = TRUE
Else
m_arrShip(iShip1).Button1_IsPressed = FALSE
End If
'If _Button(m_arrPlayer(iPlayer).Button2_KeyCode) Then
' m_arrShip(iShip1).Button2_IsPressed = TRUE
'Else
' m_arrShip(iShip1).Button2_IsPressed = FALSE
'End If
End If
Next iShip1
End If
Next iPlayer
' CLEAR KEYBOARD BUFFER
_KeyClear
End Sub ' GetInput
' /////////////////////////////////////////////////////////////////////////////
' DISABLE ALL EXISTING BUTTONS FOR THIS SHIP
' Clear input flags
Sub ClearInputBuffer (iShip1 As Integer)
m_arrShip(iShip1).Left_IsPressed = FALSE
m_arrShip(iShip1).Right_IsPressed = FALSE
m_arrShip(iShip1).Up_IsPressed = FALSE
m_arrShip(iShip1).Down_IsPressed = FALSE
m_arrShip(iShip1).Button1_IsPressed = FALSE
m_arrShip(iShip1).Button2_IsPressed = FALSE
End Sub ' ClearInputBuffer
' /////////////////////////////////////////////////////////////////////////////
' Check for collisions
' TODO: improve collision checking to handle different shape polygons, etc.
' using IsIntersection function by MasterGy
Sub Collisions ()
Dim iShip1 As Integer
Dim iShip2 As Integer
Dim iEnemy1 As Integer
Dim iBullet1 As Integer
Dim iBullet2 As Integer
' ================================================================================================================================================================
' BEGIN check for bullet collisions
' ================================================================================================================================================================
' CHECK ALL BULLETS
For iBullet1 = 0 To UBound(m_arrBullet)
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN bullet hits bullet
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' IS BULLET ALIVE?
If m_arrBullet(iBullet1).alive = TRUE Then
' CHECK ALL (OTHER) BULLETS
For iBullet2 = 0 To UBound(m_arrBullet)
' NOT ITSELF!
If iBullet2 <> iBullet1 Then
' CAN BULLETS STOP BULLETS?
If BULLETS_STOP_BULLETS = TRUE Then
' BULLET HIT BULLET?
If GetDist(m_arrBullet(iBullet2).xPos, m_arrBullet(iBullet2).yPos, m_arrBullet(iBullet1).xPos, m_arrBullet(iBullet1).yPos) <= BULLET_RADIUS Then
' BOTH SHOTS DESTROYED
m_arrBullet(iBullet1).alive = FALSE ' Destroy the bullet
m_arrBullet(iBullet2).alive = FALSE ' Destroy the other bullet
' QUIT CHECKING BULLETS
Exit For
End If
End If
End If
Next iBullet2
End If
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END bullet hits bullet
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN bullet hits ship
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' IS BULLET ALIVE?
If m_arrBullet(iBullet1).alive = TRUE Then
' CHECK ALL SHIPS
For iShip1 = 1 To m_iNumShips
' IS SHIP ALIVE?
If m_arrShip(iShip1).shields > 0 Then
' BULLET HITS SHIP?
If GetDist(m_arrShip(iShip1).xPos, m_arrShip(iShip1).yPos, m_arrBullet(iBullet1).xPos, m_arrBullet(iBullet1).yPos) <= m_arrShip(iShip1).radius Then
' STOP BULLET
m_arrBullet(iBullet1).alive = FALSE ' Destroy the bullet
' DO DAMAGE
' TODO: DIFFERENT DAMAGE DEPENDING ON WHETHER IT'S A PLAYER OR ENEMY BULLET, WEAPON TYPE, ETC.
m_arrShip(iShip1).shields = m_arrShip(iShip1).shields - BULLET_DAMAGE ' Take Damage
' IS SHIP DEAD?
If m_arrShip(iShip1).shields < 1 Then
' CLEAR INPUT FOR THIS SHIP
ClearInputBuffer iShip1
' ADJUST ROSTER FOR THIS PLAYER
AdjustRoster m_arrShip(iShip1).PlayerNum
' PLAYER SCORES IF OPPONENT KILLED
If m_arrBullet(iBullet1).kind = "SHIP" Then
m_arrShip(m_arrBullet(iBullet1).owner).score = m_arrShip(m_arrBullet(iBullet1).owner).score + 100
End If
Else
' TODO: award points for hit but not kill?
End If
' QUIT CHECKING SHIPS
Exit For
End If
End If
Next iShip1
End If
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END bullet hits ship
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN bullet hits enemy
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' IS THIS BULLET STILL ALIVE?
If m_arrBullet(iBullet1).alive = TRUE Then
' CHECK ENEMIES
For iEnemy1 = 0 To UBound(m_arrEnemy)
' IS ENEMY ALIVE?
If m_arrEnemy(iEnemy1).alive = TRUE Then
' BULLET HITS ENEMY?
If GetDist(m_arrEnemy(iEnemy1).xPos, m_arrEnemy(iEnemy1).yPos, m_arrBullet(iBullet1).xPos, m_arrBullet(iBullet1).yPos) <= m_arrEnemy(iEnemy1).radius Then
' STOP BULLET
m_arrBullet(iBullet1).alive = FALSE ' Destroy the bullet
' DO DAMAGE
' TODO: DIFFERENT DAMAGE DEPENDING ON WHETHER IT'S A PLAYER OR ENEMY BULLET, WEAPON TYPE, ETC.
m_arrEnemy(iEnemy1).life = m_arrEnemy(iEnemy1).life - BULLET_DAMAGE ' Enemy take damage
' IS ENEMY DEAD?
If m_arrEnemy(iEnemy1).life <= 0 Then
' DESTROY IT
m_arrEnemy(iEnemy1).alive = FALSE
' PLAYER SCORES IF ENEMY KILLED
If m_arrBullet(iBullet1).kind = "SHIP" Then
m_arrShip(m_arrBullet(iBullet1).owner).score = m_arrShip(m_arrBullet(iBullet1).owner).score + 10
'm_iScore = m_iScore + 10
End If
End If
' QUIT CHECKING ENEMIES
Exit For
End If
End If
Next iEnemy1
End If
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END bullet hits enemy
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
Next iBullet1
' ================================================================================================================================================================
' END check for bullet collisions
' ================================================================================================================================================================
' ================================================================================================================================================================
' BEGIN check for ship hit enemy
' ================================================================================================================================================================
' CHECK ENEMIES
For iEnemy1 = 0 To UBound(m_arrEnemy)
' IS ENEMY ALIVE?
If m_arrEnemy(iEnemy1).alive = TRUE Then
' CHECK EACH SHIP
For iShip1 = 1 To m_iNumShips
' IS SHIP ALIVE?
If m_arrShip(iShip1).shields > 0 Then
' SHIP HITS ENEMY?
If GetDist(m_arrShip(iShip1).xPos, m_arrShip(iShip1).yPos, m_arrEnemy(iEnemy1).xPos, m_arrEnemy(iEnemy1).yPos) <= m_arrEnemy(iEnemy1).radius Then
' KILL SHIP
m_arrShip(iShip1).shields = 0 ' The ship has no shields/Dead
' KILL ENEMY
m_arrEnemy(iEnemy1).life = 0 ' The enemy has no life/Dead
m_arrEnemy(iEnemy1).alive = FALSE
' CLEAR CONTROL BUFFER FOR SHIP
ClearInputBuffer iShip1
' ADJUST ROSTER
AdjustRoster m_arrShip(iShip1).PlayerNum
' PLAYER SCORES
'm_iScore = m_iScore + 10
m_arrShip(iShip1).score = m_arrShip(iShip1).score + 10
' QUIT CHECKING SHIPS
Exit For
End If
End If
Next iShip1
End If
Next iEnemy1
' ================================================================================================================================================================
' END check for ship hit enemy
' ================================================================================================================================================================
' ================================================================================================================================================================
' BEGIN check for ship colliding with ship
' ================================================================================================================================================================
' CHECK SHIPS
For iShip1 = 1 To m_iNumShips
' IS SHIP ALIVE?
If m_arrShip(iShip1).shields > 0 Then
' CHECK EACH SHIP
For iShip2 = 1 To m_iNumShips
' NOT THIS SHIP
If iShip1 <> iShip2 Then
' IS SHIP ALIVE?
If m_arrShip(iShip2).shields > 0 Then
' SHIP HIT SHIP?
If GetDist(m_arrShip(iShip1).xPos, m_arrShip(iShip1).yPos, m_arrShip(iShip2).xPos, m_arrShip(iShip2).yPos) <= m_arrShip(iShip1).radius Then
' KILL BOTH SHIPS
' TODO: MAYBE SHIPS DON'T JUST BLOW UP WHEN THEY COLLIDE, ADD OPTIONS FOR DAMAGE, BOUNCE OFF EACH OTHER, ETC.
m_arrShip(iShip1).shields = 0
m_arrShip(iShip2).shields = 0
' CLEAR CONTROL BUFFER FOR BOTH SHIPS
ClearInputBuffer iShip1
ClearInputBuffer iShip2
' ADJUST ROSTER
AdjustRoster m_arrShip(iShip1).PlayerNum
AdjustRoster m_arrShip(iShip2).PlayerNum
' SCORE ONE LAST TIME!
m_arrShip(iShip1).score = m_arrShip(iShip1).score + 100
m_arrShip(iShip2).score = m_arrShip(iShip2).score + 100
End If
End If
End If
Next iShip2
End If
Next iShip1
' ================================================================================================================================================================
' END check for ship colliding with ship
' ================================================================================================================================================================
End Sub ' Collisions
' /////////////////////////////////////////////////////////////////////////////
' When a ship is destroyed, updates that player's first, last & current ship
' to next available ship, else sets to -1 meaning none left.
' example: AdjustRoster m_arrShip(iShip1).PlayerNum
Sub AdjustRoster (iPlayer As Integer)
Dim iShip2 As Integer
Dim iFirstShip As Integer: iFirstShip = 0
Dim iLastShip As Integer: iLastShip = 0
' Only worry about this if >1 ships per player in the current game
If m_iShipsPerPlayer > 1 Then
' Make sure there are ships
If m_arrPlayer(iPlayer).FirstShip > 0 And m_arrPlayer(iPlayer).LastShip > 0 Then
' Find first working ship in roster
For iShip2 = m_arrPlayer(iPlayer).FirstShip To m_arrPlayer(iPlayer).LastShip
If m_arrShip(iShip2).shields > 0 Then
iFirstShip = iShip2
Exit For
End If
Next iShip2
' Any ships left?
If iFirstShip > 0 Then
' Find last working ship in roster
For iShip2 = m_arrPlayer(iPlayer).LastShip To m_arrPlayer(iPlayer).FirstShip Step -1
If m_arrShip(iShip2).shields > 0 Then
iLastShip = iShip2
Exit For
End If
Next iShip2
' Update first & last
m_arrPlayer(iPlayer).FirstShip = iFirstShip
m_arrPlayer(iPlayer).LastShip = iLastShip
' If current is a single ship, move to next available
If m_arrPlayer(iPlayer).WhichShip > 0 Then
m_arrPlayer(iPlayer).WhichShip = iFirstShip
End If
Else
' All dead, all dead
m_arrPlayer(iPlayer).FirstShip = 0
m_arrPlayer(iPlayer).LastShip = 0
m_arrPlayer(iPlayer).WhichShip = -1
End If
Else
' Already all dead!
m_arrPlayer(iPlayer).FirstShip = 0
m_arrPlayer(iPlayer).LastShip = 0
m_arrPlayer(iPlayer).WhichShip = -1
End If
End If
End Sub ' AdjustRoster
' /////////////////////////////////////////////////////////////////////////////
Sub Shooting ()
Dim iShip1 As Integer
Dim iShip2 As Integer
Dim iEnemy1 As Integer
Dim iBullet1 As Integer
Dim iBullet2 As Integer
Dim iFreeSpot As Integer
Dim sngXComp As Single
Dim sngYComp As Single
Dim sngCheckDistance As Single
Dim sngShortestDistance As Single
Dim iClosestPlayer As Integer
' DID PLAYER SHOOT?
For iShip1 = 1 To m_iNumShips
If m_arrShip(iShip1).Button1_IsPressed = TRUE Then
' Has the gun cooled down yet (prevent bullet being created every 25 milliseconds)
If m_arrShip(iShip1).ShootCount > m_arrShip(iShip1).ShootTime Then
m_arrShip(iShip1).ShootCount = 0
iFreeSpot = -1
For iBullet1 = 0 To UBound(m_arrBullet)
' Check whether it can use another bullet or not
If m_arrBullet(iBullet1).alive = FALSE Then
' if so use the dead bullet
iFreeSpot = iBullet1
Exit For
End If
Next iBullet1
' if there were no already dead bullets
If iFreeSpot = -1 Then
' create another one
ReDim _Preserve m_arrBullet(UBound(m_arrBullet) + 1) As BulletType
' iFreeSpot is this new bullet
iFreeSpot = UBound(m_arrBullet)
End If
' Set the properties of this bullet
m_arrBullet(iFreeSpot).owner = iShip1 ' identify player that fired shot
m_arrBullet(iFreeSpot).alive = TRUE ' The bullet is alive
m_arrBullet(iFreeSpot).xPos = m_arrShip(iShip1).xPos ' the bullet is created where the ship is
m_arrBullet(iFreeSpot).yPos = m_arrShip(iShip1).yPos ' the bullet is created where the ship is
m_arrBullet(iFreeSpot).kind = "SHIP" ' This is a Ship Bullet
m_arrBullet(iFreeSpot).lifespan = BULLET_LIFESPAN * iFPS ' # seconds bullet is alive
m_arrBullet(iFreeSpot).lifetime = 0 ' bullet is brand new
' Determine the X and Y components of the resultant vector
sngXComp = m_arrShip(iShip1).speed * Sin(m_arrShip(iShip1).heading) + BULLET_SPEED * Sin(m_arrShip(iShip1).facing)
sngYComp = m_arrShip(iShip1).speed * Cos(m_arrShip(iShip1).heading) + BULLET_SPEED * Cos(m_arrShip(iShip1).facing)
' Determine the resultant speed
m_arrBullet(iFreeSpot).speed = Sqr(sngXComp ^ 2 + sngYComp ^ 2)
'Calculate the resultant heading, and adjust for arctangent by adding Pi if necessary
If Sgn(sngYComp) > 0 Then
m_arrBullet(iFreeSpot).heading = Atn(sngXComp / sngYComp)
End If
If Sgn(sngYComp) < 0 Then
m_arrBullet(iFreeSpot).heading = Atn(sngXComp / sngYComp) + PI
End If
' PLACE BULLET OUTSIDE OF SHIP
m_arrBullet(iFreeSpot).xPos = m_arrBullet(iFreeSpot).xPos + ((m_arrShip(iShip1).radius + 1) * Sin(m_arrBullet(iFreeSpot).heading))
m_arrBullet(iFreeSpot).yPos = m_arrBullet(iFreeSpot).yPos - ((m_arrShip(iShip1).radius + 1) * Cos(m_arrBullet(iFreeSpot).heading))
End If
End If
Next iShip1
' ENEMIES SHOOT
For iEnemy1 = 0 To UBound(m_arrEnemy)
' Check whether the enemy is alive
If m_arrEnemy(iEnemy1).alive = TRUE Then
' Check whether the enemy will fire or not
If Int(Rnd * 100 + 1) = 1 Then
iFreeSpot = -1
For iBullet1 = 0 To UBound(m_arrBullet)
' Check whether the enemy will use an old bullet
If m_arrBullet(iBullet1).alive = FALSE Then
' If so iFreeSpot is the old bullet
iFreeSpot = iBullet1
Exit For
End If
Next iBullet1
' If there were no free spots then create another bullet
If iFreeSpot = -1 Then
' Create the new bullet
ReDim _Preserve m_arrBullet(UBound(m_arrBullet) + 1) As BulletType
' iFreeSpot is this new bullet
iFreeSpot = UBound(m_arrBullet)
End If
' Determine who enemy shoots at
sngShortestDistance = iMaxX + iMaxY + 1
iClosestPlayer = 0
For iShip1 = 1 To m_iNumShips
If m_arrShip(iShip1).shields > 0 Then
sngCheckDistance = GetDist(m_arrEnemy(iEnemy1).xPos, m_arrEnemy(iEnemy1).yPos, m_arrShip(iShip1).xPos, m_arrShip(iShip1).yPos)
If sngCheckDistance < sngShortestDistance Then
sngShortestDistance = sngCheckDistance
iClosestPlayer = iShip1
End If
End If
Next iShip1
' TODO: get this working
If iClosestPlayer > 0 Then
' Set the properties for this bullet
m_arrBullet(iFreeSpot).alive = TRUE ' It is Alive!!!
' Set it so the bullet shoots at the ship
m_arrBullet(iFreeSpot).owner = iEnemy1 ' identify enemy that fired shot
' Aim the shot at the player
m_arrBullet(iFreeSpot).heading = GetAngle(m_arrEnemy(iEnemy1).xPos, m_arrEnemy(iEnemy1).yPos, m_arrShip(iClosestPlayer).xPos, m_arrShip(iClosestPlayer).yPos)
m_arrBullet(iFreeSpot).xPos = m_arrEnemy(iEnemy1).xPos ' Create the bullet where the enemy is
m_arrBullet(iFreeSpot).yPos = m_arrEnemy(iEnemy1).yPos ' Create the bullet where the enemy is
m_arrBullet(iFreeSpot).speed = 6 ' Set the bullet speed
m_arrBullet(iFreeSpot).kind = "ENEMY" ' This is an enemy bullet
m_arrBullet(iFreeSpot).lifespan = BULLET_LIFESPAN * iFPS ' # seconds bullet is alive
m_arrBullet(iFreeSpot).lifetime = 0 ' bullet is brand new
' Move bullet outside of enemy
m_arrBullet(iFreeSpot).xPos = m_arrBullet(iFreeSpot).xPos + ((m_arrEnemy(iEnemy1).radius + 1) * Sin(m_arrBullet(iFreeSpot).heading))
m_arrBullet(iFreeSpot).yPos = m_arrBullet(iFreeSpot).yPos - ((m_arrEnemy(iEnemy1).radius + 1) * Cos(m_arrBullet(iFreeSpot).heading))
End If
End If
End If
Next iEnemy1
End Sub ' Shooting
' /////////////////////////////////////////////////////////////////////////////
' Draw the enemies
Sub DrawEnemy ()
Dim iShip1 As Integer
Dim iEnemy1 As Integer
Dim iColor As _Unsigned Long
Dim iX As Integer
Dim iY As Integer
Dim sngHeading As Single
Dim iRadius As Integer
Dim sngCheckDistance As Single
Dim sngShortestDistance As Single
Dim iClosestPlayer As Integer
Dim sngPercentAlive As Single
For iEnemy1 = 0 To UBound(m_arrEnemy)
' Is this enemy alive
If m_arrEnemy(iEnemy1).alive = TRUE Then
' Determine percentage of life still left in this enemy
sngPercentAlive = m_arrEnemy(iEnemy1).life / m_arrEnemy(iEnemy).maxlife
' Color based on damage
If sngPercentAlive > 0.85 Then
iColor = cWhite
ElseIf sngPercentAlive > 0.71 Then
iColor = cYellow
ElseIf sngPercentAlive > 0.57 Then
iColor = cGold
ElseIf sngPercentAlive > 0.43 Then
iColor = cOrange
ElseIf sngPercentAlive > 0.29 Then
iColor = cDarkOrange
ElseIf sngPercentAlive > 0.14 Then
iColor = cOrangeRed
Else
iColor = cRed
End If
' Draw body
' CIRCLE (x, y), radius, color
'DrawCircleSolid iX, iY, 8, cRed
Circle (m_arrEnemy(iEnemy1).xPos, m_arrEnemy(iEnemy1).yPos), m_arrEnemy(iEnemy1).radius, iColor
' Determine closest player
sngShortestDistance = iMaxX + iMaxY + 1
iClosestPlayer = 0
For iShip1 = 1 To m_iNumShips
If m_arrShip(iShip1).shields > 0 Then
sngCheckDistance = GetDist(m_arrEnemy(iEnemy1).xPos, m_arrEnemy(iEnemy1).yPos, m_arrShip(iShip1).xPos, m_arrShip(iShip1).yPos)
If sngCheckDistance < sngShortestDistance Then
sngShortestDistance = sngCheckDistance
iClosestPlayer = iShip1
End If
End If
Next iShip1
' Draw "eye"
If iClosestPlayer > 0 Then
sngHeading = GetAngle(m_arrEnemy(iEnemy1).xPos, m_arrEnemy(iEnemy1).yPos, m_arrShip(iClosestPlayer).xPos, m_arrShip(iClosestPlayer).yPos)
iX = m_arrEnemy(iEnemy1).xPos
iY = m_arrEnemy(iEnemy1).yPos
iRadius = m_arrEnemy(iEnemy1).radius / 3
iX = iX + (m_arrEnemy(iEnemy1).radius - iRadius) * Sin(sngHeading)
iY = iY - (m_arrEnemy(iEnemy1).radius - iRadius) * Cos(sngHeading)
Circle (iX, iY), iRadius, iColor
End If
End If
Next iEnemy1
End Sub ' DrawEnemy
' /////////////////////////////////////////////////////////////////////////////
' Move Bullets
Sub MoveBullets ()
Dim iBullet1 As Integer ' Used for variables
Dim iShip1 As Integer
For iShip1 = 1 To m_iNumShips
If m_arrShip(iShip1).ShootCount <= m_arrShip(iShip1).ShootTime Then
m_arrShip(iShip1).ShootCount = m_arrShip(iShip1).ShootCount + 1
End If
Next iShip1
For iBullet1 = 0 To UBound(m_arrBullet)
' Is the bullet alive
If m_arrBullet(iBullet1).alive = TRUE Then
' Move the bullets
m_arrBullet(iBullet1).xPos = m_arrBullet(iBullet1).xPos + (m_arrBullet(iBullet1).speed * Sin(m_arrBullet(iBullet1).heading))
m_arrBullet(iBullet1).yPos = m_arrBullet(iBullet1).yPos - (m_arrBullet(iBullet1).speed * Cos(m_arrBullet(iBullet1).heading))
' Did the bullet move off screen horizontally?
If m_arrBullet(iBullet1).xPos < iMinX Then
If WRAP_BULLET = TRUE Then
m_arrBullet(iBullet1).xPos = iMaxX
Else
m_arrBullet(iBullet1).alive = FALSE ' Destroy the bullet
End If
ElseIf m_arrBullet(iBullet1).xPos > iMaxX Then
If WRAP_BULLET = TRUE Then
m_arrBullet(iBullet1).xPos = iMinX
Else
m_arrBullet(iBullet1).alive = FALSE ' Destroy the bullet
End If
End If
' Did the bullet move off screen vertically?
If m_arrBullet(iBullet1).yPos < iMinY Then
If WRAP_BULLET = TRUE Then
m_arrBullet(iBullet1).yPos = iMaxY
Else
m_arrBullet(iBullet1).alive = FALSE ' Destroy the bullet
End If
ElseIf m_arrBullet(iBullet1).yPos > iMaxY Then
If WRAP_BULLET = TRUE Then
m_arrBullet(iBullet1).yPos = iMinY
Else
m_arrBullet(iBullet1).alive = FALSE ' Destroy the bullet
End If
End If
' Time how long bullet stays active
m_arrBullet(iBullet1).lifetime = m_arrBullet(iBullet1).lifetime + 1
If m_arrBullet(iBullet1).lifetime > m_arrBullet(iBullet1).lifespan Then
m_arrBullet(iBullet1).alive = FALSE ' Destroy the bullet
End If
End If
Next iBullet1
End Sub ' MoveBullets
' /////////////////////////////////////////////////////////////////////////////
' Draw the bullets
Sub DrawBullets ()
Dim iBullet1 As Integer ' Used for variables
For iBullet1 = 0 To UBound(m_arrBullet)
' Is the bullet alive
If m_arrBullet(iBullet1).alive = TRUE Then
If m_arrBullet(iBullet1).kind = "SHIP" Then
' Is this a ship bullet, draw a white bullet
'Circle (m_arrBullet(iBullet1).xPos, m_arrBullet(iBullet1).yPos), 3, cWhite
DrawCircleSolid m_arrBullet(iBullet1).xPos, m_arrBullet(iBullet1).yPos, BULLET_RADIUS, cWhite
ElseIf m_arrBullet(iBullet1).kind = "ENEMY" Then
' if this is enemy bullet, draw a red bullet
'Circle (m_arrBullet(iBullet1).xPos, m_arrBullet(iBullet1).yPos), 3, cOrangeRed
DrawCircleSolid m_arrBullet(iBullet1).xPos, m_arrBullet(iBullet1).yPos, BULLET_RADIUS, cOrangeRed
End If
End If
Next iBullet1
End Sub ' DrawBullets
' /////////////////////////////////////////////////////////////////////////////
' Process input + move all ships
Sub MoveAllShips ()
Dim iShip1 As Integer
For iShip1 = 1 To m_iNumShips
If m_arrShip(iShip1).shields > 0 Then
MoveShip iShip1
End If
Next iShip1
End Sub ' MoveAllShips
' /////////////////////////////////////////////////////////////////////////////
' Process input + move the ship
' TODO: fix this to make the movement more natural...
Sub MoveShip (iShip1 As Integer)
Dim sngXComp As Single
Dim sngYComp As Single
' If the left key is pressed then rotate the ship left
If m_arrShip(iShip1).Left_IsPressed = TRUE Then
' ORIGINAL METHOD:
If TRUE = TRUE Then
m_arrShip(iShip1).facing = m_arrShip(iShip1).facing - PI / TURN_SPEED
End If
' NON-TRIG METHOD:
If TRUE = FALSE Then
m_arrShip(iShip1).dx = m_arrShip(iShip1).dx - 1
If m_arrShip(iShip1).dx < 0 Then m_arrShip(iShip1).dx = 143
m_arrShip(iShip1).dy = m_arrShip(iShip1).dy - 1
If m_arrShip(iShip1).dy < 0 Then m_arrShip(iShip1).dy = 143
End If
End If
' If the Right key is pressed then rotate the ship right
If m_arrShip(iShip1).Right_IsPressed = TRUE Then
' ORIGINAL METHOD:
If TRUE = TRUE Then
m_arrShip(iShip1).facing = m_arrShip(iShip1).facing + PI / TURN_SPEED
End If
' NON-TRIG METHOD:
If TRUE = FALSE Then
m_arrShip(iShip1).dx = m_arrShip(iShip1).dx + 1
If m_arrShip(iShip1).dx > 143 Then m_arrShip(iShip1).dx = 0
m_arrShip(iShip1).dy = m_arrShip(iShip1).dy + 1
If m_arrShip(iShip1).dy > 143 Then m_arrShip(iShip1).dy = 0
End If
End If
' If the up key is pressed then and accelerate it in the direction the ship is facing
If m_arrShip(iShip1).Up_IsPressed = TRUE Then
' ORIGINAL METHOD:
If TRUE = TRUE Then
' Determine the X and Y components of the resultant vector
sngXComp = m_arrShip(iShip1).speed * Sin(m_arrShip(iShip1).heading) + SHIP_ACCEL * Sin(m_arrShip(iShip1).facing)
sngYComp = m_arrShip(iShip1).speed * Cos(m_arrShip(iShip1).heading) + SHIP_ACCEL * Cos(m_arrShip(iShip1).facing)
' Determine the resultant speed
m_arrShip(iShip1).speed = Sqr(sngXComp ^ 2 + sngYComp ^ 2)
' Calculate the resultant heading, and adjust for arctangent by adding Pi if necessary
If Sgn(sngYComp) > 0 Then
m_arrShip(iShip1).heading = Atn(sngXComp / sngYComp)
End If
If Sgn(sngYComp) < 0 Then
m_arrShip(iShip1).heading = Atn(sngXComp / sngYComp) + PI
End If
End If
' NON-TRIG METHOD:
' ACCELERATE X AND Y DIRECTIONS BASED ON WHICH DIRECTION WE'RE POINTING
If TRUE = FALSE Then
m_arrShip(iShip1).vx = m_arrShip(iShip1).vx + (m_arrDX(m_arrShip(iShip1).dx) * SHIP_ACCEL)
m_arrShip(iShip1).vy = m_arrShip(iShip1).vy + (m_arrDY(m_arrShip(iShip1).dy) * SHIP_ACCEL)
End If
End If
' If the down key is pressed then and accelerate the ship in the opposite direction it is facing
' ORIGINAL METHOD:
If TRUE = TRUE Then
If m_arrShip(iShip1).Down_IsPressed = TRUE And m_arrShip(iShip1).speed > -MAX_SPEED Then
' Determine the X and Y components of the resultant vector
sngXComp = m_arrShip(iShip1).speed * Sin(m_arrShip(iShip1).heading) - SHIP_ACCEL * Sin(m_arrShip(iShip1).facing)
sngYComp = m_arrShip(iShip1).speed * Cos(m_arrShip(iShip1).heading) - SHIP_ACCEL * Cos(m_arrShip(iShip1).facing)
' Determine the resultant speed
m_arrShip(iShip1).speed = Sqr(sngXComp ^ 2 + sngYComp ^ 2)
' Calculate the resultant heading, and adjust for actangent by adding Pi if necessary
If Sgn(sngYComp) > 0 Then
m_arrShip(iShip1).heading = Atn(sngXComp / sngYComp)
End If
If Sgn(sngYComp) < 0 Then
m_arrShip(iShip1).heading = Atn(sngXComp / sngYComp) + PI
End If
End If
End If
' NON-TRIG METHOD:
' Don't let the ship go faster then the max speed
If TRUE = FALSE Then
If m_arrShip(iShip1).vx < 0 - MAX_SPEED Then
m_arrShip(iShip1).vx = 0 - MAX_SPEED
ElseIf m_arrShip(iShip1).vx > MAX_SPEED Then
m_arrShip(iShip1).vx = MAX_SPEED
End If
If m_arrShip(iShip1).vy < 0 - MAX_SPEED Then
m_arrShip(iShip1).vy = 0 - MAX_SPEED
ElseIf m_arrShip(iShip1).vy > MAX_SPEED Then
m_arrShip(iShip1).vy = MAX_SPEED
End If
End If
' ORIGINAL METHOD:
If TRUE = TRUE Then
If m_arrShip(iShip1).speed > MAX_SPEED Then
m_arrShip(iShip1).speed = MAX_SPEED
End If
End If
' Move the ship
' ORIGINAL METHOD:
If TRUE = TRUE Then
m_arrShip(iShip1).xPos = m_arrShip(iShip1).xPos + m_arrShip(iShip1).speed * Sin(m_arrShip(iShip1).heading)
m_arrShip(iShip1).yPos = m_arrShip(iShip1).yPos - m_arrShip(iShip1).speed * Cos(m_arrShip(iShip1).heading)
End If
' NON-TRIG METHOD:
If TRUE = FALSE Then
m_arrShip(iShip1).xPos = m_arrShip(iShip1).xPos + m_arrShip(iShip1).vx
m_arrShip(iShip1).yPos = m_arrShip(iShip1).yPos + m_arrShip(iShip1).vy
End If
' Keep the ship inside the form
If m_arrShip(iShip1).xPos < iMinX Then
m_arrShip(iShip1).xPos = iMaxX
End If
If m_arrShip(iShip1).xPos > iMaxX Then
m_arrShip(iShip1).xPos = iMinX
End If
If m_arrShip(iShip1).yPos < iMinY Then
m_arrShip(iShip1).yPos = iMaxY
End If
If m_arrShip(iShip1).yPos > iMaxY Then
m_arrShip(iShip1).yPos = iMinY
End If
'' Did player hit button #2?
'If m_arrShip(iShip1).Button2_IsPressed = TRUE Then
' m_arrShip(iShip1).shields = m_arrShip(iShip1).shields + 10
'End If
End Sub ' MoveShip
' /////////////////////////////////////////////////////////////////////////////
' Placeholder
Sub MoveEnemy ()
Dim iEnemy1 As Integer
'For iEnemy1 = 0 To UBound(m_arrEnemy)
' ' Check whether the enemy is alive
' If m_arrEnemy(iEnemy1).alive = TRUE Then
' End If
'Next iEnemy1
End Sub ' MoveEnemy
' /////////////////////////////////////////////////////////////////////////////
Sub ShowScore
If m_bCocktailMode = TRUE Then
ShowScoreCocktail
Else
ShowScoreNormal
End If
End Sub ' ShowScore
' /////////////////////////////////////////////////////////////////////////////
Sub ShowScoreNormal
Dim iStartRow As Integer
Dim iStartCol As Integer
Dim iRow As Integer
Dim iCol As Integer
Dim iCount As Integer
Dim iShip1 As Integer
Dim iPlayer As Integer
Dim sWhich As String
Dim iTotalRows As Integer: iTotalRows = _Height(0) \ _FontHeight
Dim iTotalCols As Integer: iTotalCols = _Width(0) \ _FontWidth
Color cBlue, cBlue: PrintString1 iTotalRows, 0, String$(iTotalCols, " ")
Color cWhite, cEmpty: PrintString1 iTotalRows, 0, "Level: " + cstr$(m_iLevel)
PrintString1 iTotalRows, iTotalCols - 20, "Press Esc to quit"
iRow = 1
iCol = 1
iCount = 0
For iShip1 = 1 To m_iNumShips
Color m_arrShip(iShip1).BodyColor, cEmpty
PrintString1 iRow, iCol, _
m_arrShip(iShip1).name + " " + _
cstr$(m_arrShip(iShip1).score) + " " + _
cstr$(m_arrShip(iShip1).shields)
iCount = iCount + 1
'A 999 (999)[10]{99} B (999)[10]{99} C (999)[10]{99} D (999)[10]{99} E (999)[10]{99} F (999)[10]{99} G (999)[10]{99} H (999)[10]{99}
'12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678
'I (999)[10]{99} J (999)[10]{99} K (999)[10]{99} M (999)[10]{99} N (999)[10]{99} O (999)[10]{99} P (999)[10]{99} Q (999)[10]{99}
iRow = iRow + 2
Next iShip1
For iPlayer = 1 To m_iPlayers
If m_arrPlayer(iPlayer).WhichShip < 0 Then
sWhich = "None (all destroyed)"
ElseIf m_arrPlayer(iPlayer).WhichShip = 0 Then
sWhich = "All"
Else
sWhich = LeftPadString$(cstr$(m_arrPlayer(iPlayer).WhichShip), 2, " ")
End If
Color cWhite, cEmpty
PrintString iRow, iCol, _
"Player #" + _
LeftPadString$(cstr$(iPlayer), 2, " ") + _
" controls " + _
sWhich
iRow = iRow + 2
Next iPlayer
' SHOW INSTRUCTIONS
End Sub ' ShowScoreNormal
Sub ShowScoreCocktail
End Sub ' ShowScoreCocktail
' /////////////////////////////////////////////////////////////////////////////
Sub ShowScore1
Dim iStartRow As Integer
Dim iStartCol As Integer
Dim iRow As Integer
Dim iCol As Integer
Dim iCount As Integer
Dim iShip1 As Integer
Dim iPlayer As Integer
Dim sWhich As String
' Draw background
Color cBlue, cBlue
PrintString 0, 0, String$(120, " ")
' Place the text on the form
'TODO: display score for all players
'Color cLime, cEmpty
'PrintString 0, 10, "Shields: " + cstr$(m_arrShip(iLoop1).shields) ' LeftPadString$(cstr$(m_arrShip(iLoop1).shields), 5, " ")
' Title displays the players score
'TODO: display score for all players
'Color cCyan, cEmpty
'PrintString 0, 40, "Score: " + cstr$(m_iScore) ' LeftPadString$(cstr$(m_iScore), 10, " ")
' Display the level
Color cWhite, cEmpty
PrintString 0, 70, "Level: " + cstr$(m_iLevel) ' LeftPadString$(cstr$(m_iScore), 10, " ")
iRow = 0
iCol = 0
iCount = 0
For iShip1 = 1 To m_iNumShips
Color m_arrShip(iShip1).BodyColor, cEmpty
PrintString iRow, iCol, _
"Player #" + _
LeftPadString$(cstr$(iShip1), 2, " ") + _
" (" + m_arrShip(iShip1).name + ") : " + _
"Shields: " + LeftPadString$(cstr$(m_arrShip(iShip1).shields), 5, " ") + " " + _
"Score: " + LeftPadString$(cstr$(m_arrShip(iShip1).score), 5, " ") + " " + _
"x: " + LeftPadString$(_Trim$(Str$(m_arrShip(iShip1).xPos)), 5, " ") + " " + _
"y: " + LeftPadString$(_Trim$(Str$(m_arrShip(iShip1).yPos)), 5, " ") + " " + _
"dx: " + LeftPadString$(SngRoundedToStr$(m_arrShip(iShip1).dx, 5), 5, " ") + " " + _
"dy: " + LeftPadString$(SngRoundedToStr$(m_arrShip(iShip1).dy, 5), 5, " ") + " " + _
"vx: " + LeftPadString$(SngRoundedToStr$(m_arrShip(iShip1).vx, 5), 5, " ") + " " + _
"vy: " + LeftPadString$(SngRoundedToStr$(m_arrShip(iShip1).vy, 5), 5, " ") + " " + _
IIFSTR$ ( m_arrShip(iShip1).Left_IsPressed, "LEFT ", "") + _
IIFSTR$ ( m_arrShip(iShip1).Right_IsPressed, "RIGHT ", "") + _
IIFSTR$ ( m_arrShip(iShip1).Up_IsPressed, "UP ", "") + _
IIFSTR$ ( m_arrShip(iShip1).Down_IsPressed, "DOWN ", "") + _
IIFSTR$ ( m_arrShip(iShip1).Button1_IsPressed, "BUTTON #1 ", "") + _
IIFSTR$ ( m_arrShip(iShip1).Button2_IsPressed, "BUTTON #2 ", "") + _
""
iRow = iRow + 2
Next iShip1
For iPlayer = 1 To m_iPlayers
If m_arrPlayer(iPlayer).WhichShip < 0 Then
sWhich = "None (all destroyed)"
ElseIf m_arrPlayer(iPlayer).WhichShip = 0 Then
sWhich = "All"
Else
sWhich = LeftPadString$(cstr$(m_arrPlayer(iPlayer).WhichShip), 2, " ")
End If
Color cWhite, cEmpty
PrintString iRow, iCol, _
"Player #" + _
LeftPadString$(cstr$(iPlayer), 2, " ") + _
" controls " + _
sWhich
iRow = iRow + 2
Next iPlayer
'Color cPurple
''PrintString 3, 0, "Facing: " + SngRoundedToStr$(m_arrShip(iLoop1).facing, 5)
'PrintString 3, 0, " dx: " + SngRoundedToStr$(m_arrShip(iLoop1).dx, 5)
'PrintString 4, 0, " vx: " + SngRoundedToStr$(m_arrShip(iLoop1).vx, 5)
'PrintString 5, 0, "m_arrDX: " + SngRoundedToStr$(m_arrDX(m_arrShip(iLoop1).dx), 5)
'
'PrintString 7, 0, " dy: " + SngRoundedToStr$(m_arrShip(iLoop1).dy, 5)
'PrintString 8, 0, " vy: " + SngRoundedToStr$(m_arrShip(iLoop1).vy, 5)
'PrintString 9, 0, "m_arrDY: " + SngRoundedToStr$(m_arrDY(m_arrShip(iLoop1).dy), 5)
' Show instructions
'TODO: SHOW INSTRUCTIONS (MAKE KEYCODE TO TEXT FUNCTIONS?)
'Color cRed, cRed
'PrintString 45, 0, String$(120, " ")
'Color cWhite, cEmpty
'PrintString 45, 0, "CONTROLS: LEFT/RIGHT = TURN UP/DOWN = FORWARD/BACK CTRL=FIRE 1=ADD SHIELD (CHEAT)"
End Sub ' ShowScore1
' /////////////////////////////////////////////////////////////////////////////
' Draw the ship
Sub DrawAllShips ()
Dim iShip1 As Integer
For iShip1 = 1 To m_iNumShips
If m_arrShip(iShip1).shields > 0 Then
DrawShip iShip1
End If
Next iShip1
End Sub ' DrawAllShips
' /////////////////////////////////////////////////////////////////////////////
' Draw the ship
Sub DrawShip (iShip1 As Integer)
Dim intX1 As Integer
Dim intY1 As Integer
Dim intX2 As Integer
Dim intY2 As Integer
Dim intX3 As Integer
Dim intY3 As Integer
Dim intX1b As Integer ' engine flame ends here
Dim intY1b As Integer ' engine flame ends here
Dim intX2b As Integer ' back wall starts here on left
Dim intY2b As Integer ' back wall starts here on left
Dim intX3b As Integer ' back wall starts here on right
Dim intY3b As Integer ' back wall starts here on right
' -----------------------------------------------------------------------------
' Set the coordinates of the ship
' front
intX1 = m_arrShip(iShip1).xPos + SHIP_RADIUS * Sin(m_arrShip(iShip1).facing)
intY1 = m_arrShip(iShip1).yPos - SHIP_RADIUS * Cos(m_arrShip(iShip1).facing)
' left rear
intX2 = m_arrShip(iShip1).xPos + SHIP_RADIUS * Sin(m_arrShip(iShip1).facing + 2 * PI / 3)
intY2 = m_arrShip(iShip1).yPos - SHIP_RADIUS * Cos(m_arrShip(iShip1).facing + 2 * PI / 3)
' left rear (3/4 of the way down)
intX2b = m_arrShip(iShip1).xPos + ENGINE_RADIUS * Sin(m_arrShip(iShip1).facing + 2 * PI / 3)
intY2b = m_arrShip(iShip1).yPos - ENGINE_RADIUS * Cos(m_arrShip(iShip1).facing + 2 * PI / 3)
' right rear
intX3 = m_arrShip(iShip1).xPos + SHIP_RADIUS * Sin(m_arrShip(iShip1).facing + 4 * PI / 3)
intY3 = m_arrShip(iShip1).yPos - SHIP_RADIUS * Cos(m_arrShip(iShip1).facing + 4 * PI / 3)
' right rear (3/4 of the way down)
intX3b = m_arrShip(iShip1).xPos + ENGINE_RADIUS * Sin(m_arrShip(iShip1).facing + 4 * PI / 3)
intY3b = m_arrShip(iShip1).yPos - ENGINE_RADIUS * Cos(m_arrShip(iShip1).facing + 4 * PI / 3)
' rear where engine flames end
intX1b = m_arrShip(iShip1).xPos - FLAME_RADIUS * Sin(m_arrShip(iShip1).facing)
intY1b = m_arrShip(iShip1).yPos + FLAME_RADIUS * Cos(m_arrShip(iShip1).facing)
'm_arrShip(iShip1).facing = m_arrShip(iShip1).facing - Pi / 36
' -----------------------------------------------------------------------------
' Draw the ship
' Draw the left side
Line (intX1, intY1)-(intX2, intY2), m_arrShip(iShip1).BodyColor
' Draw the right side
Line (intX1, intY1)-(intX3, intY3), m_arrShip(iShip1).BodyColor
' Draw the rear / aft side
If m_arrShip(iShip1).Up_IsPressed Then
' Draw rear side
Line (intX2b, intY2b)-(intX3b, intY3b), m_arrShip(iShip1).EngineColor
' Engine is firing
'Line (intX2b, intY2b)-(intX3b, intY3b), m_arrShip(iShip1).FlameColor
' Draw the flame left side
Line (intX1b, intY1b)-(intX2b, intY2b), m_arrShip(iShip1).FlameColor
' Draw the flame right side
Line (intX1b, intY1b)-(intX3b, intY3b), m_arrShip(iShip1).FlameColor
Else
' Draw rear side
Line (intX2b, intY2b)-(intX3b, intY3b), m_arrShip(iShip1).EngineColor
End If
End Sub ' DrawShip
' /////////////////////////////////////////////////////////////////////////////
Sub CheckForEnd ()
Dim iPlayersLeft As Integer
Dim iEnemiesLeft As Integer
Dim iShip1 As Integer
Dim iEnemy1 As Integer
Dim bRespawn As Integer: bRespawn = FALSE
Dim bAdvance As Integer: bAdvance = FALSE
' HOW MANY ENEMIES STILL ALIVE?
iEnemiesLeft = 0
For iEnemy1 = 0 To UBound(m_arrEnemy)
If m_arrEnemy(iEnemy1).alive = TRUE Then
iEnemiesLeft = iEnemiesLeft + 1
End If
Next iEnemy1
' HOW MANY PLAYERS STILL ALIVE?
iPlayersLeft = 0
For iShip1 = 1 To m_iNumShips
If m_arrShip(iShip1).shields > 0 Then
iPlayersLeft = iPlayersLeft + 1
End If
Next iShip1
' IS GAME OVER?
If m_iNumShips = 1 Then
' SINGLE PLAYER GAME
If iPlayersLeft < 1 Then
m_bGameOver = TRUE
Else
' DOES THIS GAME HAVE ENEMIES?
If m_bSimpleEnemies = TRUE Then
' ADVANCE IF ALL ENEMIES DEAD
If iEnemiesLeft = 0 Then
bAdvance = TRUE
bRespawn = TRUE
End If
End If
End If
Else
' MULTIPLAYER GAME
If iPlayersLeft < 2 Then
' LESS THAN 2 PLAYERS LEFT, ADVANCE
bAdvance = TRUE
Else
' MORE THAN ONE PLAYER LEFT...
' DOES THIS GAME HAVE ENEMIES?
If m_bSimpleEnemies = TRUE Then
' ADVANCE IF ALL ENEMIES DEAD
If iEnemiesLeft = 0 Then
' NEXT LEVEL (RESPAWN ENEMIES)
bRespawn = TRUE
End If
End If
End If
End If
' ADVANCE TO NEXT ROUND
If m_bGameOver = FALSE Then
If bAdvance = TRUE Then
If m_iRoundsPerGame > 0 Then
m_iLevel = m_iLevel + 1
' HAVE WE FINISHED THE FINAL ROUND?
If m_iLevel > m_iRoundsPerGame Then
m_bGameOver = TRUE
End If
Else
' INFINITE ROUNDS (STOP COUNTING AFTER 25)
If m_iLevel < 255 Then
m_iLevel = m_iLevel + 1
End If
End If
End If
End If
' ADVANCE OR RESPAWN
If m_bGameOver = FALSE Then
If bAdvance = TRUE Then
StartNextRound
End If
If bRespawn = TRUE Then
Respawn
End If
End If
End Sub ' CheckForEnd
' /////////////////////////////////////////////////////////////////////////////
' Reset players for new round
Sub StartNextRound ()
Dim iShip1 As Integer
Dim iShip2 As Integer
Dim iPlayer As Integer
Dim iLoop1 As Integer
Dim iMinShip As Integer
Dim iMaxShip As Integer
Dim iTurn As Integer
Dim bDone As Integer
' Initialize round
If m_iPlayers > 0 Then
' Game status
m_bGameOver = FALSE
' MAP PLAYERS TO SHIPS AND COUNT TOTAL # OF SHIPS
m_iNumShips = 0
For iPlayer = 1 To m_iPlayers
iMinShip = 0
iMaxShip = 0
For iShip1 = 1 To m_iShipsPerPlayer
' GET SHIP #
m_iNumShips = m_iNumShips + 1
' ASSIGN SHIP TO PLAYER
m_arrShip(m_iNumShips).PlayerNum = iPlayer
' SAVE FIRST & LAST SHIP INDEX FOR CURRENT PLAYER
If iMinShip = 0 Then
iMinShip = m_iNumShips
End If
If m_iNumShips > iMaxShip Then
iMaxShip = m_iNumShips
End If
Next iShip1
' INITIALIZE PLAYER FIRST/LAST/CURRENT SHIP
m_arrPlayer(iPlayer).FirstShip = iMinShip
m_arrPlayer(iPlayer).LastShip = iMaxShip
m_arrPlayer(iPlayer).WhichShip = iMinShip
' RESET BUTTON #2 CONTROL STATUS
m_arrPlayer(iPlayer).Button2_IsReady = TRUE
Next iPlayer
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END WHO CONTROLS WHAT
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' CLEAR CONTROL BUFFER FOR SHIPS
For iShip1 = 1 To 16
ClearInputBuffer iShip1
Next iShip1
' Set the starting positions of the ships
For iShip1 = 1 To m_iNumShips
' EVERYONE STARTS WITH SAME SHIELDS
' TODO: GET THIS VALUE FROM OPTIONS
m_arrShip(iShip1).shields = NUM_SHIELDS
' TODO: ADD OPTIONS FOR FUEL AND AMMO, FOR NOW NOT USED...
m_arrShip(iShip1).fuel = 100
If m_iNumShips > 1 Then
m_arrShip(iShip1).ammo = m_iNumShips * 2 ' 2 shots per opponent
Else
m_arrShip(iShip1).ammo = 10
End If
' PLACE SHIP
' TODO: PLACE SHIPS AROUND EDGES OF SCREEN, ON A BASE, ETC.
bDone = FALSE
Do
m_arrShip(iShip1).xPos = RandomNumber%(iMinX, iMaxX) 'Int(Rnd * ScaleWidth + 1)
m_arrShip(iShip1).yPos = RandomNumber%(iMinY, iMaxY) 'Int(Rnd * ScaleHeight + 1)
For iShip2 = 1 To m_iNumShips
If iShip2 <> iShip1 Then
' Is ship too close to another ship?
If GetDist(m_arrShip(iShip1).xPos, m_arrShip(iShip1).yPos, m_arrShip(iShip2).xPos, m_arrShip(iShip2).yPos) > (m_arrShip(iShip1).radius * 4) Then
bDone = TRUE
Exit For
End If
End If
Next iShip2
If bDone = TRUE Then Exit Do
Loop
' POINT SHIP
iTurn = RandomNumber%(0, 143)
If iTurn = 0 Then
m_arrShip(iShip1).facing = 0
m_arrShip(iShip1).dx = 0
m_arrShip(iShip1).dy = 0
Else
For iLoop1 = 1 To iTurn
m_arrShip(iShip1).facing = m_arrShip(iShip1).facing + PI / TURN_SPEED
m_arrShip(iShip1).dx = m_arrShip(iShip1).dx + 1
If m_arrShip(iShip1).dx > 143 Then m_arrShip(iShip1).dx = 0
m_arrShip(iShip1).dy = m_arrShip(iShip1).dy + 1
If m_arrShip(iShip1).dy > 143 Then m_arrShip(iShip1).dy = 0
Next iLoop1
End If
' SHIP NOT MOVING
' TODO: MAYBE ADD OPTION TO START PLAYERS DRIFTING IN A RANDOM DIRECTION?
m_arrShip(iShip1).dx = 0
m_arrShip(iShip1).dy = 0
m_arrShip(iShip1).vx = 0
m_arrShip(iShip1).vy = 0
' TODO: REMOVE UNUSED VARIABLES
m_arrShip(iShip1).heading = 0
m_arrShip(iShip1).facing = 0
m_arrShip(iShip1).speed = 0
Next iShip1
' RESET BULLETS
ReDim _Preserve m_arrBullet(-1) As BulletType
End If
End Sub ' StartNextRound
' /////////////////////////////////////////////////////////////////////////////
' Respawn the enemies, increase # and difficulty
Sub Respawn ()
Dim iEnemy1 As Integer
Dim iShip1 As Integer
Dim bDone As Integer
' GIVE SURVIVING PLAYERS SOME BONUS SHIELDS
' AND A LEVEL BONUS
' AND RECORD THE HIGHEST LEVEL EACH HAS REACHED
' TODO: ADD OPTION FOR DEAD PLAYERS TO BE RESURRECTED IN NEXT ROUND
' TODO: MAYBE ADD SOME INTERESTING WAY TO DETERMINE LEVEL BONUS
For iShip1 = 1 To m_iNumShips
If m_arrShip(iShip1).shields > 0 Then
m_arrShip(iShip1).shields = m_arrShip(iShip1).shields + BONUS_SHIELDS
m_arrShip(iShip1).level = m_arrShip(iShip1).level + 1
m_arrShip(iShip1).score = m_arrShip(iShip1).score + 100
End If
Next iShip1
' INCREASE THE NUMBER OF ENEMIES
ReDim _Preserve m_arrEnemy(UBound(m_arrEnemy) + 1) As EnemyType
' INCREASE VARIETY OF ENEMY SIZES
If m_iMinEnemyRadius > MIN_ENEMY_RADIUS Then
m_iMinEnemyRadius = m_iMinEnemyRadius - 1
End If
If m_iMaxEnemyRadius < MAX_ENEMY_RADIUS Then
m_iMaxEnemyRadius = m_iMaxEnemyRadius + 1
End If
' SPAWN NEW WAVE OF ENEMIES
For iEnemy1 = 0 To UBound(m_arrEnemy)
' choose a random size
m_arrEnemy(iEnemy1).radius = RandomNumber%(m_iMinEnemyRadius, m_iMaxEnemyRadius)
'' Set the starting positions
'm_arrEnemy(iEnemy1).xPos = m_arrShip(iEnemy1).xPos
'm_arrEnemy(iEnemy1).yPos = m_arrShip(iEnemy1).yPos
' give enemy life
m_arrEnemy(iEnemy1).alive = TRUE
'm_arrEnemy(iEnemy1).life = 30
m_arrEnemy(iEnemy1).life = m_arrEnemy(iEnemy1).radius
m_arrEnemy(iEnemy1).maxlife = m_arrEnemy(iEnemy1).radius
' make sure the enemies don't start on top of any ships
bDone = FALSE
Do
m_arrEnemy(iEnemy1).xPos = RandomNumber%(iMinX, iMaxX) 'Int(Rnd * ScaleWidth + 1)
m_arrEnemy(iEnemy1).yPos = RandomNumber%(iMinY, iMaxY) 'Int(Rnd * ScaleHeight + 1)
For iShip1 = 1 To m_iNumShips
If m_arrShip(iShip1).shields > 0 Then
If GetDist(m_arrEnemy(iEnemy1).xPos, m_arrEnemy(iEnemy1).yPos, m_arrShip(iShip1).xPos, m_arrShip(iShip1).yPos) > SHIP_RADIUS * 10 Then
bDone = TRUE
Exit For
End If
End If
Next iShip1
If bDone Then Exit Do
Loop
Next iEnemy1
End Sub ' Respawn
' /////////////////////////////////////////////////////////////////////////////
Function GetDist! (sngX1 As Single, sngY1 As Single, sngX2 As Single, sngY2 As Single) ' As Single
Dim sngXComp As Single
Dim sngYComp As Single
' Set the X componate
sngXComp = sngX2 - sngX1
' Set the Y Componate
sngYComp = sngY1 - sngY2
' Get the distance between the two objects
GetDist = Sqr(sngXComp ^ 2 + sngYComp ^ 2)
End Function ' GetDist
' /////////////////////////////////////////////////////////////////////////////
Function GetAngle (sngX1 As Single, sngY1 As Single, sngX2 As Single, sngY2 As Single)
Dim sngXComp As Single
Dim sngYComp As Single
' Set the X componate
sngXComp = sngX2 - sngX1
' Set the Y componate
sngYComp = sngY1 - sngY2
' Calculate the resultant angle, and adjust for actangent by adding Pi if necessary
If Sgn(sngYComp) > 0 Then
GetAngle = Atn(sngXComp / sngYComp)
End If
If Sgn(sngYComp) < 0 Then
GetAngle = Atn(sngXComp / sngYComp) + PI
End If
End Function ' GetAngle
' ################################################################################################################################################################
' END GAME CODE @GAME
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN SIMPLE LINE COLLISION DETECTION #COLLISION1
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' Simple test for line intersection
' It might be useful for something (Reply #6)
' https://qb64phoenix.com/forum/showthread.php?tid=2134&pid=29938
' From: MasterGy
' Date: 11-01-2023, 05:14 AM (This post was last modified: 11-01-2023, 05:18 AM by MasterGy.)
Function IsIntersection (X1, Y1, X2, Y2, X3, Y3, X4, Y4)
Denominator = (Y4 - Y3) * (X2 - X1) - (X4 - X3) * (Y2 - Y1)
If Denominator = 0 Then
IsIntersection = 0
Else
Ua = ((X4 - X3) * (Y1 - Y3) - (Y4 - Y3) * (X1 - X3)) / Denominator
Ub = ((X2 - X1) * (Y1 - Y3) - (Y2 - Y1) * (X1 - X3)) / Denominator
If Ua >= 0 And Ua <= 1 And Ub >= 0 And Ub <= 1 Then IsIntersection = 1 Else IsIntersection = 0
End If
End Function ' IsIntersection
' /////////////////////////////////////////////////////////////////////////////
' Test / demo of IsIntersection function by MasterGy
' https://qb64phoenix.com/forum/showthread.php?tid=2134&pid=29938
' From: MasterGy
' Date: 11-01-2023, 05:14 AM (This post was last modified: 11-01-2023, 05:18 AM by MasterGy.)
Sub IsIntersectionTest
Dim x1, y1, x2, y2, x3, y3, x4, y4
Screen _NewImage(800, 600, 32)
Do
Cls
x1 = 800 * Rnd
y1 = 600 * Rnd
x2 = 800 * Rnd
y2 = 600 * Rnd
x3 = 800 * Rnd
y3 = 600 * Rnd
x4 = 800 * Rnd
y4 = 600 * Rnd
Color _RGB32(255, 255, 255)
Locate 1, 1: Print "SPACE to next"
If IsIntersection(x1, y1, x2, y2, x3, y3, x4, y4) Then
Color _RGB32(255, 50, 50)
Locate 3, 10: Print "Intersect !"
End If
Line (x1, y1)-(x2, y2)
Line (x3, y3)-(x4, y4)
Do: Loop Until InKey$ = " "
Loop
End Sub ' IsIntersectionTest
' ################################################################################################################################################################
' END SIMPLE LINE COLLISION DETECTION #COLLISION1
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN COMPLEX LINE COLLISION DETECTION #COLLISION2
' ################################################################################################################################################################
' It might be useful for something (Reply #6)
' https://qb64phoenix.com/forum/showthread.php?tid=2134&pid=29992#pid29992
' From: bplus, Mini-Mod
' Date: 11-21-2024, 05:13 PM
'
' >>(11-01-2023, 08:20 AM) bplus Wrote:
' >> Good stuff! let me know if you want exact point (coordinates) of intersect,
' >> though my code is a little longer Smile
' >(11-21-2024, 01:52 PM) madscijr Wrote:
' > I could use that...
'
' WTH? I lost all the reply I was working on.
' Here's the code, forget the intro:
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' Just worked Rosetta Code for Line Intersect Line
' but what if we want to know if two line segments intersect?
' DATE WHO-DONE-IT DID-WHAT
' 2020-03-14 b+ Two Line Segments Intersect, start
' 2020-03-15 b+ rework this code so we identify points all on same line
' and if there is overlap of line segments say the two x endpoints of the segments
' otherwise, if there is an intersect of 2 line segments say the point x, y.
' Return 0 no intersect or overlap
' Return 1 if intersect and ix, iy point of intersect
' Return -1 if segments are on same and there is overlap: ix = overlap start x, iy overlap end x
' 2020-03-16 b+ "Segments Intersect mod tester" >>> just post testing code
' mod tester for 2 segments of vertical line and found I need to add more parameters to
' FUNCTION twoLineSegmentsIntersect% (ax1, ay1, ax2, ay2, bx1, by1, bx2, by2, ix, iy)
' mod that name and parameters to:
' FUNCTION TwoSegmentsIntersect% (ax1, ay1, ax2, ay2, bx1, by1, bx2, by2, ix1, iy1, ix2, iy2)
' 2020-03-16 b+ Segments Intersect revised 2020-03-16
' OK now get the new FUNCTION working
' ah! I had to tighten down D from >.2 to >.05 but loosen y-axis intersect
' 2025-01-05 madscijr Reformatted bplus's code to match coding style for use in Multispacewar! game.
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' /////////////////////////////////////////////////////////////////////////////
' This function needs: SUB SlopeYintersect (X1, Y1, X2, Y2, slope, Yintercept)
' Receives:
' ax1, ay1, ax2, ay2 = start/end points of line #1
' bx1, by1, bx2, by2 = start/end points of line #2
' Returns by reference:
' ix, iy = if lines intersect, coordinates where they intersect
' Returns -1 (TRUE) if lines intersect or 0 (FALSE) if they don't.
Function LineIntersectLine% (ax1, ay1, ax2, ay2, bx1, by1, bx2, by2, ix, iy)
If ax1 = ax2 Then 'line a is vertical
If bx1 = bx2 Then ' b is vertical
If ax1 = bx1 Then LineIntersectLine% = -1 ' if x's are same it is same vertical line
Exit Function '
Else
ix = ax1
SlopeYintersect bx1, by1, bx2, by2, m2, y02
iy = m2 * ix + y02
LineIntersectLine% = 1 ' signal a point was found
Exit Function
End If
Else
SlopeYintersect ax1, ay1, ax2, ay2, m1, y01 ' -m = a, 1 = b, y0 = c std form
End If
If bx1 = bx2 Then 'b is vertical
ix = bx1: iy = m1 * ix + y01: LineIntersectLine% = 1 'signal a point was found
Exit Function
Else
SlopeYintersect bx1, by1, bx2, by2, m2, y02 ' -m = a, 1 = b, y0 = c std form
End If
d = -m1 - -m2 ' if = 0 then parallel or equal because slopes are same
If Abs(d) > .05 Then 'otherwise about 0 <<< tighten down from .2 to .05
ix = (y01 - y02) / d: iy = (-m1 * y02 - -m2 * y01) / d
LineIntersectLine% = 1 'signal one intersect point was found
Else 'same line or parallel? if y0 (y-axis interssect) are same they are the same
If Abs(y01 - y02) < 15 Then LineIntersectLine% = -1 'signal same line! <<< loosen more! 5 to 15
End If
End Function ' LineIntersectLine%
' /////////////////////////////////////////////////////////////////////////////
' Slope and Y-intersect for non vertical lines,
' if x1 = x2 the line is vertical don't call this sub
' because slope calculation would cause division by 0 error.
Sub SlopeYintersect (X1, Y1, X2, Y2, slope, Yintercept) 'check x1 <> x2 first!
slope = (Y2 - Y1) / (X2 - X1): Yintercept = slope * (0 - X1) + Y1
End Sub ' SlopeYintersect
' /////////////////////////////////////////////////////////////////////////////
Function ts$ (n)
ts$ = _Trim$(Str$(Int(100 * n) / 100))
End Function ' ts$
' /////////////////////////////////////////////////////////////////////////////
' This function needs: FUNCTION LineIntersectLine% (ax1, ay1, ax2, ay2, bx1, by1, bx2, by2, ix, iy)
' which in turn needs: SUB SlopeYintersect (X1, Y1, X2, Y2, slope, Yintercept) 'check x1 <> x2 first!
' Receives:
' ax1, ay1, ax2, ay2 = start/end points of line #1
' bx1, by1, bx2, by2 = start/end points of line #2
' Returns by reference:
' ix1, iy1 = if lines intersect, coordinates where they intersect
' if lines overlap, coordinates where overlap begins
' ix2, iy2 = if lines overlap, coordinates where overlap ends
' Returns -1 (TRUE) if lines intersect or 0 (FALSE) if they don't.
Function TwoSegmentsIntersect% (ax1, ay1, ax2, ay2, bx1, by1, bx2, by2, ix1, iy1, ix2, iy2)
intersect = LineIntersectLine%(ax1, ay1, ax2, ay2, bx1, by1, bx2, by2, ix, iy)
If ax1 < ax2 Then aMinX = ax1: aMaxX = ax2 Else aMinX = ax2: aMaxX = ax1
If ay1 < ay2 Then aMinY = ay1: aMaxY = ay2 Else aMinY = ay2: aMaxY = ay1
If bx1 < bx2 Then bMinX = bx1: bMaxX = bx2 Else bMinX = bx2: bMaxX = bx1
If by1 < by2 Then bMinY = by1: bMaxY = by2 Else bMinY = by2: bMaxY = by1
If intersect = 0 Then 'no intersect
TwoSegmentsIntersect% = 0
ElseIf intersect = 1 Then 'segments intersect at one point
If ax1 = ax2 Then 'is iy between
If iy < aMinY Or iy > aMaxY Or ix < bMinX Or ix > bMaxX Then
TwoSegmentsIntersect% = 0
Else
ix1 = ix: iy1 = iy: TwoSegmentsIntersect% = 1
End If
ElseIf bx1 = bx2 Then
If iy < bMinY Or iy > bMaxY Or ix < aMinX Or ix > aMaxX Then
TwoSegmentsIntersect% = 0
Else
ix1 = ix: iy1 = iy: TwoSegmentsIntersect% = 1
End If
Else
If (aMinX <= ix And ix <= aMaxX) And (bMinX <= ix And ix <= bMaxX) Then
ix1 = ix: iy1 = iy: TwoSegmentsIntersect% = 1
Else
TwoSegmentsIntersect% = 0
End If
End If
ElseIf intersect = -1 Then 'segments are on same line get over lap section
'first check if both are on vertical line
If ax1 = ax2 Then 'and we know both are same line we have two vertical segemnts, do they over lap?
ix1 = ax1: ix2 = ax1
If aMinY < bMinY Then
If aMaxY < bMinY Then
TwoSegmentsIntersect% = 0
Else
TwoSegmentsIntersect% = -1: iy1 = bMinY
If aMaxY > bMaxY Then
iy2 = bMaxY
Else
iy2 = aMaxY
End If
End If
Else 'bMinY <= aMinY
If bMaxY < aMinY Then
TwoSegmentsIntersect% = 0
Else
TwoSegmentsIntersect% = -1: iy1 = aMinY
If bMaxY > aMaxY Then
iy2 = aMaxY
Else
iy2 = bMaxY
End If
End If
End If
Else 'the same line is not vertical
If aMinX < bMinX Then
If aMaxX < bMinX Then
TwoSegmentsIntersect% = 0
Else
TwoSegmentsIntersect% = -1: ix1 = bMinX
If bx1 = bMinX Then iy1 = by1 Else iy1 = by2
If aMaxX > bMaxX Then
ix2 = bMaxX
If bx1 = bMaxX Then iy2 = by1 Else iy2 = by2
Else
ix2 = aMaxX
If ax1 = aMaxX Then iy2 = ay1 Else iy2 = ay2
End If
End If
Else 'aMinX >= bMinX
If aMinX > bMaxX Then
TwoSegmentsIntersect% = 0
Else
TwoSegmentsIntersect% = -1: ix1 = aMinX
If ax1 = aMinX Then iy1 = ay1 Else iy1 = ay2
If bMaxX > aMaxX Then
ix2 = aMaxX
If ax1 = aMaxX Then iy2 = ay1 Else iy2 = ay2
Else
ix2 = bMaxX
If bx1 = bMaxX Then iy2 = by1 Else iy2 = by2
End If
End If
End If
End If
End If
End Function ' TwoSegmentsIntersect
' /////////////////////////////////////////////////////////////////////////////
' Test / demo of LineIntersectLine and TwoSegmentsIntersect functions.
Sub LineIntersectTest
Const xmax = 1200, ymax = 700
Dim ax1 As Integer, ax2 As Integer, ay1 As Integer, ay2 As Integer
Dim bx1 As Integer, bx2 As Integer, by1 As Integer, by2 As Integer
Screen _NewImage(xmax, ymax, 32)
_Delay .25
_ScreenMove _Middle
Do
restartA:
Cls
If Rnd < .3 Then 'throw in some vertical lines
Locate 3, 80: Print "Red Points are vertical."
ax1 = (xmax - 20) * Rnd + 10: ay1 = (ymax - 60) * Rnd + 50
ax2 = ax1: ay2 = (ymax - 60) * Rnd + 50
Else
Locate 3, 80: Print "Red Points are Random."
ax1 = (xmax - 20) * Rnd + 10: ay1 = (ymax - 60) * Rnd + 50
ax2 = (xmax - 20) * Rnd + 10: ay2 = (ymax - 60) * Rnd + 50
End If
If _Hypot(ax1 - ax2, ay1 - ay2) < 50 Then GoTo restartA
If Rnd < .6 Then 'get some points on same line
Locate 3, 80: Print "Blue Points are on same line as Red."
SlopeYintersect ax1, ay1, ax2, ay2, slope1, Yintercept1
bx1 = (xmax - 20) * Rnd + 10: by1 = bx1 * slope1 + Yintercept1
bx2 = (xmax - 20) * Rnd + 10: by2 = bx2 * slope1 + Yintercept1
Else
If Rnd < .4 Then 'throw in some verticals, we already have a doing verticals
Locate 3, 80: Print Space$(50)
Locate 3, 80: Print "All points vertical."
ax1 = (xmax - 20) * Rnd + 10: ax2 = ax1: bx1 = ax1: bx2 = ax1
ay1 = 50 + Rnd * 50: ay2 = ay1 + 50 + Rnd * 50
by1 = ay1 + 25 + Rnd * 50: by2 = by1 + 50 + (Rnd * ymax - 60 - by1)
by1 = (ymax - 60) * Rnd + 50: bx2 = bx1: by2 = (ymax - 60) * Rnd + 50
Else
Locate 4, 80: Print "Blue Points are Random."
bx1 = (xmax - 20) * Rnd + 10: by1 = (ymax - 60) * Rnd + 50
bx2 = (xmax - 20) * Rnd + 10: by2 = (ymax - 60) * Rnd + 50
End If
End If
If bx1 < 10 Or bx1 > xmax - 10 Then GoTo restartA
If bx2 < 10 Or bx2 > xmax - 10 Then GoTo restartA
If by1 < 50 Or by1 > ymax - 10 Then GoTo restartA
If by2 < 50 Or by2 > ymax - 10 Then GoTo restartA
If _Hypot(bx1 - bx2, by1 - by2) < 30 Then GoTo restartA
Line (ax1, ay1)-(ax2, ay2), &HFFFF0000
Circle (ax1, ay1), 4, &HFFFF0000
Circle (ax2, ay2), 4, &HFFFF0000
Line (bx1, by1)-(bx2, by2), &HFF0000FF
Circle (bx1, by1), 4, &HFF0000FF
Circle (bx2, by2), 4, &HFF0000FF
Locate 1, 1
PRINT "Segments ("; ts$(ax1); ", "; ts$(ay1); ") ("; ts$(ax2); ", "; _
ts$(ay2); ") and ("; ts$(bx1); ", "; ts$(by1); ") ("; ts$(bx2); ", "; ts$(by2); ")"
' Plug in your 2 Segment Intersect SUB or FUNCTION Here
' and interpret reults: yellow circle around intersect point
' and an alpha shaded box where two co-linear segments overlap
'=====================================================================================================
intersect = TwoSegmentsIntersect%(ax1, ay1, ax2, ay2, bx1, by1, bx2, by2, ix1, iy1, ix2, iy2)
If intersect = -1 Then 'segments overlap on same line
Print " Segments overlap between: ("; ts$(ix1); ", "; ts$(iy1); ") and ("; ts$(ix2); ", "; ts$(iy2); ")"
Line (ix1, iy1)-(ix2, iy2), &HFFFFFFFF
ElseIf intersect = 1 Then 'segments intersect at one point
Print " Segments intersect: ("; ts$(ix1); ", "; ts$(iy1); ")"
Circle (ix1, iy1), 3, &HFFFFFFFF
ElseIf intersect = 0 Then 'segments do not intersect nor overlap
Print " Segments do not Intersect or Overlap."
End If
'=====================================================================================================
Input "Press enter for another demo, any + enter to quit...", again$
Cls
Loop Until Len(again$)
End Sub ' LineIntersectTest
' ################################################################################################################################################################
' END COMPLEX LINE COLLISION DETECTION #COLLISION2
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN DX/DY TABLES #DYXDY
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' Initializes tables that convert rotation angle to DX, DY values.
' Where the index 0-143 corresponds to 0-359 degrees
'
' Requires the following shared variables be declared:
' Dim Shared m_arrDX(0 To 143) As Single
' Dim Shared m_arrDY(0 To 143) As Single
Sub InitDxDyTables
m_arrDX(0) = 0
m_arrDX(1) = 0.0277777777777778
m_arrDX(2) = 0.0555555555555556
m_arrDX(3) = 0.0833333333333333
m_arrDX(4) = 0.111111111111111
m_arrDX(5) = 0.138888888888889
m_arrDX(6) = 0.166666666666667
m_arrDX(7) = 0.194444444444444
m_arrDX(8) = 0.222222222222222
m_arrDX(9) = 0.25
m_arrDX(10) = 0.277777777777778
m_arrDX(11) = 0.305555555555556
m_arrDX(12) = 0.333333333333333
m_arrDX(13) = 0.361111111111111
m_arrDX(14) = 0.388888888888889
m_arrDX(15) = 0.416666666666667
m_arrDX(16) = 0.444444444444445
m_arrDX(17) = 0.472222222222222
m_arrDX(18) = 0.5
m_arrDX(19) = 0.527777777777778
m_arrDX(20) = 0.555555555555556
m_arrDX(21) = 0.583333333333333
m_arrDX(22) = 0.611111111111111
m_arrDX(23) = 0.638888888888889
m_arrDX(24) = 0.666666666666667
m_arrDX(25) = 0.694444444444445
m_arrDX(26) = 0.722222222222222
m_arrDX(27) = 0.75
m_arrDX(28) = 0.777777777777778
m_arrDX(29) = 0.805555555555556
m_arrDX(30) = 0.833333333333334
m_arrDX(31) = 0.861111111111111
m_arrDX(32) = 0.888888888888889
m_arrDX(33) = 0.916666666666667
m_arrDX(34) = 0.944444444444445
m_arrDX(35) = 0.972222222222223
m_arrDX(36) = 1
m_arrDX(37) = 0.972222222222222
m_arrDX(38) = 0.944444444444445
m_arrDX(39) = 0.916666666666667
m_arrDX(40) = 0.888888888888889
m_arrDX(41) = 0.861111111111111
m_arrDX(42) = 0.833333333333333
m_arrDX(43) = 0.805555555555556
m_arrDX(44) = 0.777777777777778
m_arrDX(45) = 0.75
m_arrDX(46) = 0.722222222222222
m_arrDX(47) = 0.694444444444445
m_arrDX(48) = 0.666666666666667
m_arrDX(49) = 0.638888888888889
m_arrDX(50) = 0.611111111111111
m_arrDX(51) = 0.583333333333333
m_arrDX(52) = 0.555555555555556
m_arrDX(53) = 0.527777777777778
m_arrDX(54) = 0.5
m_arrDX(55) = 0.472222222222222
m_arrDX(56) = 0.444444444444444
m_arrDX(57) = 0.416666666666667
m_arrDX(58) = 0.388888888888889
m_arrDX(59) = 0.361111111111111
m_arrDX(60) = 0.333333333333333
m_arrDX(61) = 0.305555555555555
m_arrDX(62) = 0.277777777777778
m_arrDX(63) = 0.25
m_arrDX(64) = 0.222222222222222
m_arrDX(65) = 0.194444444444444
m_arrDX(66) = 0.166666666666667
m_arrDX(67) = 0.138888888888889
m_arrDX(68) = 0.111111111111111
m_arrDX(69) = 0.0833333333333332
m_arrDX(70) = 0.0555555555555554
m_arrDX(71) = 0.0277777777777776
m_arrDX(72) = 0 ' -1.52655665885959E-16
m_arrDX(73) = -0.0277777777777779
m_arrDX(74) = -0.0555555555555557
m_arrDX(75) = -0.0833333333333335
m_arrDX(76) = -0.111111111111111
m_arrDX(77) = -0.138888888888889
m_arrDX(78) = -0.166666666666667
m_arrDX(79) = -0.194444444444445
m_arrDX(80) = -0.222222222222222
m_arrDX(81) = -0.25
m_arrDX(82) = -0.277777777777778
m_arrDX(83) = -0.305555555555556
m_arrDX(84) = -0.333333333333334
m_arrDX(85) = -0.361111111111111
m_arrDX(86) = -0.388888888888889
m_arrDX(87) = -0.416666666666667
m_arrDX(88) = -0.444444444444445
m_arrDX(89) = -0.472222222222222
m_arrDX(90) = -0.5
m_arrDX(91) = -0.527777777777778
m_arrDX(92) = -0.555555555555556
m_arrDX(93) = -0.583333333333334
m_arrDX(94) = -0.611111111111111
m_arrDX(95) = -0.638888888888889
m_arrDX(96) = -0.666666666666667
m_arrDX(97) = -0.694444444444445
m_arrDX(98) = -0.722222222222223
m_arrDX(99) = -0.75
m_arrDX(100) = -0.777777777777778
m_arrDX(101) = -0.805555555555556
m_arrDX(102) = -0.833333333333334
m_arrDX(103) = -0.861111111111111
m_arrDX(104) = -0.888888888888889
m_arrDX(105) = -0.916666666666667
m_arrDX(106) = -0.944444444444445
m_arrDX(107) = -0.972222222222223
m_arrDX(108) = -1
m_arrDX(109) = -0.972222222222223
m_arrDX(110) = -0.944444444444445
m_arrDX(111) = -0.916666666666667
m_arrDX(112) = -0.888888888888889
m_arrDX(113) = -0.861111111111111
m_arrDX(114) = -0.833333333333334
m_arrDX(115) = -0.805555555555556
m_arrDX(116) = -0.777777777777778
m_arrDX(117) = -0.75
m_arrDX(118) = -0.722222222222223
m_arrDX(119) = -0.694444444444445
m_arrDX(120) = -0.666666666666667
m_arrDX(121) = -0.638888888888889
m_arrDX(122) = -0.611111111111111
m_arrDX(123) = -0.583333333333334
m_arrDX(124) = -0.555555555555556
m_arrDX(125) = -0.527777777777778
m_arrDX(126) = -0.5
m_arrDX(127) = -0.472222222222222
m_arrDX(128) = -0.444444444444445
m_arrDX(129) = -0.416666666666667
m_arrDX(130) = -0.388888888888889
m_arrDX(131) = -0.361111111111111
m_arrDX(132) = -0.333333333333333
m_arrDX(133) = -0.305555555555556
m_arrDX(134) = -0.277777777777778
m_arrDX(135) = -0.25
m_arrDX(136) = -0.222222222222222
m_arrDX(137) = -0.194444444444445
m_arrDX(138) = -0.166666666666667
m_arrDX(139) = -0.138888888888889
m_arrDX(140) = -0.111111111111111
m_arrDX(141) = -0.0833333333333334
m_arrDX(142) = -0.0555555555555556
m_arrDX(143) = -0.0277777777777778
m_arrDY(0) = -1
m_arrDY(1) = -0.972222222222222
m_arrDY(2) = -0.944444444444444
m_arrDY(3) = -0.916666666666667
m_arrDY(4) = -0.888888888888889
m_arrDY(5) = -0.861111111111111
m_arrDY(6) = -0.833333333333333
m_arrDY(7) = -0.805555555555555
m_arrDY(8) = -0.777777777777778
m_arrDY(9) = -0.75
m_arrDY(10) = -0.722222222222222
m_arrDY(11) = -0.694444444444444
m_arrDY(12) = -0.666666666666667
m_arrDY(13) = -0.638888888888889
m_arrDY(14) = -0.611111111111111
m_arrDY(15) = -0.583333333333333
m_arrDY(16) = -0.555555555555555
m_arrDY(17) = -0.527777777777778
m_arrDY(18) = -0.5
m_arrDY(19) = -0.472222222222222
m_arrDY(20) = -0.444444444444444
m_arrDY(21) = -0.416666666666666
m_arrDY(22) = -0.388888888888889
m_arrDY(23) = -0.361111111111111
m_arrDY(24) = -0.333333333333333
m_arrDY(25) = -0.305555555555555
m_arrDY(26) = -0.277777777777777
m_arrDY(27) = -0.25
m_arrDY(28) = -0.222222222222222
m_arrDY(29) = -0.194444444444444
m_arrDY(30) = -0.166666666666666
m_arrDY(31) = -0.138888888888889
m_arrDY(32) = -0.111111111111111
m_arrDY(33) = -0.083333333333333
m_arrDY(34) = -0.0555555555555552
m_arrDY(35) = -0.0277777777777774
m_arrDY(36) = 0 ' 3.7470027081099E-16
m_arrDY(37) = 0.0277777777777782
m_arrDY(38) = 0.0555555555555559
m_arrDY(39) = 0.0833333333333337
m_arrDY(40) = 0.111111111111111
m_arrDY(41) = 0.138888888888889
m_arrDY(42) = 0.166666666666667
m_arrDY(43) = 0.194444444444445
m_arrDY(44) = 0.222222222222223
m_arrDY(45) = 0.25
m_arrDY(46) = 0.277777777777778
m_arrDY(47) = 0.305555555555556
m_arrDY(48) = 0.333333333333334
m_arrDY(49) = 0.361111111111112
m_arrDY(50) = 0.388888888888889
m_arrDY(51) = 0.416666666666667
m_arrDY(52) = 0.444444444444445
m_arrDY(53) = 0.472222222222223
m_arrDY(54) = 0.5
m_arrDY(55) = 0.527777777777778
m_arrDY(56) = 0.555555555555556
m_arrDY(57) = 0.583333333333334
m_arrDY(58) = 0.611111111111112
m_arrDY(59) = 0.638888888888889
m_arrDY(60) = 0.666666666666667
m_arrDY(61) = 0.694444444444445
m_arrDY(62) = 0.722222222222223
m_arrDY(63) = 0.750000000000001
m_arrDY(64) = 0.777777777777778
m_arrDY(65) = 0.805555555555556
m_arrDY(66) = 0.833333333333334
m_arrDY(67) = 0.861111111111112
m_arrDY(68) = 0.88888888888889
m_arrDY(69) = 0.916666666666667
m_arrDY(70) = 0.944444444444445
m_arrDY(71) = 0.972222222222223
m_arrDY(72) = 1
m_arrDY(73) = 0.972222222222223
m_arrDY(74) = 0.944444444444445
m_arrDY(75) = 0.916666666666667
m_arrDY(76) = 0.88888888888889
m_arrDY(77) = 0.861111111111112
m_arrDY(78) = 0.833333333333334
m_arrDY(79) = 0.805555555555556
m_arrDY(80) = 0.777777777777778
m_arrDY(81) = 0.750000000000001
m_arrDY(82) = 0.722222222222223
m_arrDY(83) = 0.694444444444445
m_arrDY(84) = 0.666666666666667
m_arrDY(85) = 0.638888888888889
m_arrDY(86) = 0.611111111111112
m_arrDY(87) = 0.583333333333334
m_arrDY(88) = 0.555555555555556
m_arrDY(89) = 0.527777777777778
m_arrDY(90) = 0.5
m_arrDY(91) = 0.472222222222223
m_arrDY(92) = 0.444444444444445
m_arrDY(93) = 0.416666666666667
m_arrDY(94) = 0.388888888888889
m_arrDY(95) = 0.361111111111111
m_arrDY(96) = 0.333333333333334
m_arrDY(97) = 0.305555555555556
m_arrDY(98) = 0.277777777777778
m_arrDY(99) = 0.25
m_arrDY(100) = 0.222222222222223
m_arrDY(101) = 0.194444444444445
m_arrDY(102) = 0.166666666666667
m_arrDY(103) = 0.138888888888889
m_arrDY(104) = 0.111111111111111
m_arrDY(105) = 0.0833333333333336
m_arrDY(106) = 0.0555555555555558
m_arrDY(107) = 0.0277777777777781
m_arrDY(108) = 0 ' 2.91433543964104E-16
m_arrDY(109) = -0.0277777777777775
m_arrDY(110) = -0.0555555555555553
m_arrDY(111) = -0.083333333333333
m_arrDY(112) = -0.111111111111111
m_arrDY(113) = -0.138888888888889
m_arrDY(114) = -0.166666666666666
m_arrDY(115) = -0.194444444444444
m_arrDY(116) = -0.222222222222222
m_arrDY(117) = -0.25
m_arrDY(118) = -0.277777777777778
m_arrDY(119) = -0.305555555555555
m_arrDY(120) = -0.333333333333333
m_arrDY(121) = -0.361111111111111
m_arrDY(122) = -0.388888888888889
m_arrDY(123) = -0.416666666666666
m_arrDY(124) = -0.444444444444444
m_arrDY(125) = -0.472222222222222
m_arrDY(126) = -0.5
m_arrDY(127) = -0.527777777777778
m_arrDY(128) = -0.555555555555555
m_arrDY(129) = -0.583333333333333
m_arrDY(130) = -0.611111111111111
m_arrDY(131) = -0.638888888888889
m_arrDY(132) = -0.666666666666667
m_arrDY(133) = -0.694444444444444
m_arrDY(134) = -0.722222222222222
m_arrDY(135) = -0.75
m_arrDY(136) = -0.777777777777778
m_arrDY(137) = -0.805555555555555
m_arrDY(138) = -0.833333333333333
m_arrDY(139) = -0.861111111111111
m_arrDY(140) = -0.888888888888889
m_arrDY(141) = -0.916666666666667
m_arrDY(142) = -0.944444444444444
m_arrDY(143) = -0.972222222222222
End Sub ' InitDxDyTables
' ################################################################################################################################################################
' END DX/DY TABLES @DXDY
' ################################################################################################################################################################
' ################################################################################################################################################################
' 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
' /////////////////////////////////////////////////////////////////////////////
Sub AddGrayscaleColors (arrColor() As _Unsigned Long)
Dim iNum As Integer
iNum = 1
AddColors cDimGray, arrColor(), iNum
AddColors cGray, arrColor(), iNum
AddColors cDarkGray, arrColor(), iNum
AddColors cSilver, arrColor(), iNum
AddColors cLightGray, arrColor(), iNum
AddColors cGainsboro, arrColor(), iNum
AddColors cWhiteSmoke, arrColor(), iNum
AddColors cWhite, arrColor(), iNum '* 2
AddColors cWhiteSmoke, arrColor(), iNum
AddColors cGainsboro, arrColor(), iNum
AddColors cLightGray, arrColor(), iNum
AddColors cSilver, arrColor(), iNum
AddColors cDarkGray, arrColor(), iNum
AddColors cGray, arrColor(), iNum
End Sub ' AddGrayscaleColors
' ################################################################################################################################################################
' 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)
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 = _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
dblNew = RoundDouble#(dblOld, 0)
'sValue = _Trim$(Str$(dblNew))
sValue = DblToStr$(dblNew)
'iPos = InStr(1, sValue, ".")
'If iPos > 0 Then
' DblToInt% = Val(Left$(sValue, iPos - 1))
'Else
' DblToInt% = Val(sValue)
'End If
DblToInt% = Val(sValue)
End Function ' DblToInt%
' /////////////////////////////////////////////////////////////////////////////
' 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
DblToStr$ = result$
End Function ' DblToStr$
' /////////////////////////////////////////////////////////////////////////////
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
' /////////////////////////////////////////////////////////////////////////////
Sub DumpScreenAndFontSize ()
Dim iCols As Integer
Dim iRows As Integer
'Screen _NewImage(1024, 768, 32): _ScreenMove 0, 0
iCols = _Width(0) \ _FontWidth
iRows = _Height(0) \ _FontHeight
Print "_Width(0) =" + _Trim$(Str$(_Width(0)))
Print "_Height(0) =" + _Trim$(Str$(_Height(0)))
Print "_FontWidth =" + _Trim$(Str$(_FontWidth))
Print "_FontHeight=" + _Trim$(Str$(_FontHeight))
Print "iCols = _Width(0) \ _FontWidth = " + _Trim$(Str$(iCols))
Print "iRows = _Height(0) \ _FontHeight = " + _Trim$(Str$(iRows))
End Sub ' DumpScreenAndFontSize
' /////////////////////////////////////////////////////////////////////////////
' 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
' PRINT "Current date time (simple format) = " + Chr$(34) + GetCurrentDateTime$("{yyyy}-{mm}-{dd} {rr}:{nn}:{ss}") + Chr$(34)
' PRINT "Current date time (US format) = " + Chr$(34) + GetCurrentDateTime$("{mm}/{dd}/{yyyy} {hh}:{nn}:{ss} {ampm}") + Chr$(34)
' PRINT "Filename timestamp = " + Chr$(34) + GetCurrentDateTime$("{yyyy}{mm}{dd}_{rr}{nn}{ss}") + Chr$(34)
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
' POPULATE TEMPLATE
result$ = sTemplate$
result$ = Replace$(result$, "{yyyy}", sYYYY$)
result$ = Replace$(result$, "{mm}", sMM$)
result$ = Replace$(result$, "{dd}", sDD$)
result$ = Replace$(result$, "{hh}", sHH$)
result$ = Replace$(result$, "{rr}", sHH24$)
result$ = Replace$(result$, "{nn}", sMI$)
result$ = Replace$(result$, "{ss}", sSS$)
result$ = Replace$(result$, "{ampm}", sAMPM$)
' 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
ReDim arrInteger(-1) As Integer
'DebugPrint "GetIntegerArrayFromDelimList " + _
' "MyString=" + chr$(34) + MyString + chr$(34) + ", " + _
' "sDelimiter=" + chr$(34) + sDelimiter + chr$(34) + ", " + _
' "iMinIndex=" + cstr$(iMinIndex) + ", " + _
' "arrInteger()"
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)
result& = result& + Val(sSS$)
result& = result& + (Val(sMI$) * 60)
result& = result& + ((Val(sHH24$) * 60) * 60)
' RETURN RESULT
GetTimeSeconds& = result&
End Function ' GetTimeSeconds&
' /////////////////////////////////////////////////////////////////////////////
' IIF function for QB for integers
Function IIF (Condition, IfTrue, IfFalse)
If Condition Then IIF = IfTrue Else IIF = IfFalse
End Function
' /////////////////////////////////////////////////////////////////////////////
' IIF function for QB for strings
Function IIFSTR$ (Condition, IfTrue$, IfFalse$)
If Condition Then IIFSTR$ = IfTrue$ Else IIFSTR$ = IfFalse$
End Function
' /////////////////////////////////////////////////////////////////////////////
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%
' /////////////////////////////////////////////////////////////////////////////
'Sub IsNumberTest
' Dim in$
' Cls
' IsNumberTest1 "1"
' IsNumberTest1 "01"
' IsNumberTest1 "001"
' IsNumberTest1 "-1"
' IsNumberTest1 "-01"
' IsNumberTest1 "-001"
' IsNumberTest1 "+1"
' IsNumberTest1 "+01"
' IsNumberTest1 "+001"
' IsNumberTest1 ".1"
' IsNumberTest1 ".01"
' IsNumberTest1 ".001"
' IsNumberTest1 ".10"
' IsNumberTest1 ".100"
' IsNumberTest1 "..100"
' IsNumberTest1 "100."
' Input "PRESS ENTER TO CONTINUE TEST";in$
' Cls
' IsNumberTest1 "0.10"
' IsNumberTest1 "00.100"
' IsNumberTest1 "000.1000"
' IsNumberTest1 "000..1000"
' IsNumberTest1 "000.1000.00"
' IsNumberTest1 "+1.00"
' IsNumberTest1 "++1.00"
' IsNumberTest1 "+-1.00"
' IsNumberTest1 "-1.00"
' IsNumberTest1 "-+1.00"
' IsNumberTest1 " 1"
' IsNumberTest1 "1 "
' IsNumberTest1 "1. 01"
' IsNumberTest1 "+1 "
'End Sub ' IsNumberTest
'Sub IsNumberTest1(MyString As String)
' Const cWidth = 16
' Dim sInput As String : sInput = left$(Chr$(34) + MyString + Chr$(34) + String$(cWidth, " "), cWidth)
' Dim sResult As String : sResult = right$(String$(2, " ") + _Trim$(Str$(IsNumber%(MyString))), 2)
' Print "IsNumber%(" + sInput + ") returns " + sResult
'End Sub ' IsNumberTest1
' /////////////////////////////////////////////////////////////////////////////
' 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$
' /////////////////////////////////////////////////////////////////////////////
' Pauses for iDS deciseconds (iDS * 100 ms)
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.
' Example:
' ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
' ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' sFileName = ProgramPath$ + ProgramName$ + ".OUT.txt"
' sText = "This is a test." + chr$(13) + "Here is line 2." + chr$(13) + "End."
' sError = PrintFile$(sFileName, sText, FALSE)
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
sPrompt1$ = Replace$(sPrompt1$, "{min}", cstr$(iMin%))
sPrompt1$ = Replace$(sPrompt1$, "{max}", cstr$(iMax%))
bFinished% = FALSE
Do
Print sPrompt1$
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$
sFileName = "c:\temp\maze_test_1.txt"
sText = "Count" + Chr$(9) + "Min" + Chr$(9) + "Max" + Chr$(9) + "Random"
bAppend = FALSE
sError = PrintFile$(sFileName, sText, bAppend)
If Len(sError) = 0 Then
bAppend = TRUE
iErrorCount = 0
iMin = 0
iMax = iCols - 1
For iLoop = 1 To 100
iNum = RandomNumber%(iMin, iMax)
sText = Str$(iLoop) + Chr$(9) + Str$(iMin) + Chr$(9) + Str$(iMax) + Chr$(9) + Str$(iNum)
sError = PrintFile$(sFileName, sText, bAppend)
If Len(sError) > 0 Then
iErrorCount = iErrorCount + 1
Print Str$(iLoop) + ". ERROR"
Print " " + "iMin=" + Str$(iMin)
Print " " + "iMax=" + Str$(iMax)
Print " " + "iNum=" + Str$(iNum)
Print " " + "Could not write to file " + Chr$(34) + sFileName + Chr$(34) + "."
Print " " + sError
End If
Next iLoop
iMin = 0
iMax = iRows - 1
For iLoop = 1 To 100
iNum = RandomNumber%(iMin, iMax)
sText = Str$(iLoop) + Chr$(9) + Str$(iMin) + Chr$(9) + Str$(iMax) + Chr$(9) + Str$(iNum)
sError = PrintFile$(sFileName, sText, bAppend)
If Len(sError) > 0 Then
iErrorCount = iErrorCount + 1
Print Str$(iLoop) + ". ERROR"
Print " " + "iMin=" + Str$(iMin)
Print " " + "iMax=" + Str$(iMax)
Print " " + "iNum=" + Str$(iNum)
Print " " + "Could not write to file " + Chr$(34) + sFileName + Chr$(34) + "."
Print " " + sError
End If
Next iLoop
Print "Finished generating numbers. Errors: " + Str$(iErrorCount)
Else
Print "Error creating file " + Chr$(34) + sFileName + Chr$(34) + "."
Print sError
End If
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))))
' Return the substring:
Text2 = strBefore + Add2 + strAfter
' Locate the next instance of [Find2]:
lngLocation = InStr(1, Text2, Find2)
' Next instance of [Find2]...
Wend
' OUTPUT:
Replace$ = Text2
End Function ' Replace$
' /////////////////////////////////////////////////////////////////////////////
$If Then
Sub ReplaceTest
Dim in$
Print "-------------------------------------------------------------------------------"
Print "ReplaceTest"
Print
Print "Original value"
in$ = "Thiz iz a teZt."
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print
Print "Replacing lowercase " + Chr$(34) + "z" + Chr$(34) + " with " + Chr$(34) + "s" + Chr$(34) + "..."
in$ = Replace$(in$, "z", "s")
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print
Print "Replacing uppercase " + Chr$(34) + "Z" + Chr$(34) + " with " + Chr$(34) + "s" + Chr$(34) + "..."
in$ = Replace$(in$, "Z", "s")
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print
Print "ReplaceTest finished."
End Sub ' ReplaceTest
$End If
' /////////////////////////////////////////////////////////////////////////////
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
SetBit256% = iResult
End Function ' SetBit256%
' /////////////////////////////////////////////////////////////////////////////
$If Then
Sub ShowDegreesAndRadians
Dim iDegree As Integer
Dim sngRadian As Single
DebugPrint "Degree Radian"
DebugPrint "------ ------"
For iDegree = 0 To 360
sngRadian = _D2R(iDegree)
'DebugPrint LeftPadString$(cstr$(iDegree), 3, " ") + " " + LeftPadString$(cstr$(iRadian), 3, " ")
DebugPrint LeftPadString$(cstr$(iDegree), 3, " ") + " " + SngToStr$(sngRadian)
'Print "SngToStr$(MyValue) =" + SngToStr$(MyValue)
'Print "SngRoundedToStr$(MyValue, 12)=" + SngRoundedToStr$(MyValue, 12)
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
sngNew = RoundSingle!(sngOld, 0)
'sValue = _Trim$(Str$(sngNew))
sValue = SngToStr$(sngNew)
'iPos = InStr(1, sValue, ".")
'If iPos > 0 Then
' SngToInt% = Val(Left$(sValue, iPos - 1))
'Else
' SngToInt% = Val(sValue)
'End If
SngToInt% = Val(sValue)
End Function ' SngToInt%
' /////////////////////////////////////////////////////////////////////////////
' 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
' /////////////////////////////////////////////////////////////////////////////
$If Then
Sub SplitTest
Dim in$
Dim delim$
ReDim arrTest$(0)
Dim iLoop%
delim$ = Chr$(10)
in$ = "this" + delim$ + "is" + delim$ + "a" + delim$ + "test"
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print "delim$ = " + Chr$(34) + delim$ + Chr$(34)
split in$, delim$, arrTest$()
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
' /////////////////////////////////////////////////////////////////////////////
$If Then
Sub SplitAndReplaceTest
Dim in$
Dim out$
Dim iLoop%
ReDim arrTest$(0)
Print "-------------------------------------------------------------------------------"
Print "SplitAndReplaceTest"
Print
Print "Original value"
in$ = "This line 1 " + Chr$(13) + Chr$(10) + "and line 2" + Chr$(10) + "and line 3 " + Chr$(13) + "finally THE END."
out$ = in$
out$ = Replace$(out$, Chr$(13), "\r")
out$ = Replace$(out$, Chr$(10), "\n")
out$ = Replace$(out$, Chr$(9), "\t")
Print "in$ = " + Chr$(34) + out$ + Chr$(34)
Print
Print "Fixing linebreaks..."
in$ = Replace$(in$, Chr$(13) + Chr$(10), Chr$(13))
in$ = Replace$(in$, Chr$(10), Chr$(13))
out$ = in$
out$ = Replace$(out$, Chr$(13), "\r")
out$ = Replace$(out$, Chr$(10), "\n")
out$ = Replace$(out$, Chr$(9), "\t")
Print "in$ = " + Chr$(34) + out$ + Chr$(34)
Print
Print "Splitting up..."
split in$, Chr$(13), arrTest$()
For iLoop% = LBound(arrTest$) To UBound(arrTest$)
out$ = arrTest$(iLoop%)
out$ = Replace$(out$, Chr$(13), "\r")
out$ = Replace$(out$, Chr$(10), "\n")
out$ = Replace$(out$, Chr$(9), "\t")
Print "arrTest$(" + cstr$(iLoop%) + ") = " + Chr$(34) + out$ + Chr$(34)
Next iLoop%
Print
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 StrPadLeft$ (sValue As String, iWidth As Integer)
StrPadLeft$ = Right$(String$(iWidth, " ") + sValue, iWidth)
End Function ' StrPadLeft$
' /////////////////////////////////////////////////////////////////////////////
Function StrJustifyRight$ (sValue As String, iWidth As Integer)
StrJustifyRight$ = Right$(String$(iWidth, " ") + sValue, iWidth)
End Function ' StrJustifyRight$
' /////////////////////////////////////////////////////////////////////////////
Function StrPadRight$ (sValue As String, iWidth As Integer)
StrPadRight$ = Left$(sValue + String$(iWidth, " "), iWidth)
End Function ' StrPadRight$
' /////////////////////////////////////////////////////////////////////////////
Function StrJustifyLeft$ (sValue As String, iWidth As Integer)
StrJustifyLeft$ = Left$(sValue + String$(iWidth, " "), iWidth)
End Function ' StrJustifyLeft$
' /////////////////////////////////////////////////////////////////////////////
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%
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 DEBUGGING ROUTINES #DEBUG
' ################################################################################################################################################################
Sub DebugPrint (MyString As String)
If m_bDebug = TRUE Then
'_Echo MyString
ReDim arrLines(-1) As String
Dim iLoop As Integer
split MyString, Chr$(13), arrLines()
For iLoop = LBound(arrLines) To UBound(arrLines)
_Echo arrLines(iLoop)
Next iLoop
End If
End Sub ' DebugPrint
' same as DebugPrint but includes a timestamp
Sub DebugPrintTS (MyString As String)
If m_bDebug = TRUE Then
'_Echo MyString
ReDim arrLines(-1) As String
Dim iLoop As Integer
Dim sTimeStamp As String
sTimeStamp = GetCurrentDateTime$("{mm}/{dd}/{yyyy} {hh}:{nn}:{ss} {ampm}")
split MyString, Chr$(13), arrLines()
For iLoop = LBound(arrLines) To UBound(arrLines)
_Echo sTimeStamp + " " + arrLines(iLoop)
Next iLoop
End If
End Sub ' DebugPrintTS
'' /////////////////////////////////////////////////////////////////////////////
'
'Sub DebugPause (sPrompt As String, iRow As Integer, iColumn As Integer, fgColor As _Unsigned Long, bgColor As _Unsigned Long)
' Color fgColor, bgColor
'
' PrintString iRow, iColumn, String$(128, " ")
'
' PrintString iRow, iColumn, sPrompt
' Sleep
' '_KEYCLEAR: _DELAY 1
' 'DO
' 'LOOP UNTIL _KEYDOWN(13) ' leave loop when ENTER key pressed
' '_KEYCLEAR: _DELAY 1
'End Sub ' DebugPause
'
'' /////////////////////////////////////////////////////////////////////////////
'
'Sub DebugOut (sPrompt As String, iRow As Integer, iColumn As Integer, fgColor As _Unsigned Long, bgColor As _Unsigned Long)
' Color fgColor, bgColor
' PrintString iRow, iColumn, String$(128, " ")
' PrintString iRow, iColumn, sPrompt
'End Sub ' DebugOut
' ################################################################################################################################################################
' END DEBUGGING ROUTINES @DEBUG
' ################################################################################################################################################################
' ################################################################################################################################################################
' 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
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%
' Screen _NewImage(1024, 768, 32): _ScreenMove 0, 0
' iCols = _Width(0) \ _FontWidth
' iRows = _Height(0) \ _FontHeight
' Print "_Width(0) =" + _Trim$(Str$(_Width(0)))
' Print "_Height(0) =" + _Trim$(Str$(_Height(0)))
' Print "_FontWidth =" + _Trim$(Str$(_FontWidth))
' Print "_FontHeight=" + _Trim$(Str$(_FontHeight))
' Print "iCols = _Width(0) \ _FontWidth = " + _Trim$(Str$(iCols))
' Print "iRows = _Height(0) \ _FontHeight = " + _Trim$(Str$(iRows))
$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
' ################################################################################################################################################################
'#ENDThe vector polygon shape editor "VectorEditor59.bas":
Code: (Select All)
Dim Shared m_sTitle As String: m_sTitle = "2D Vector Shapes v0.36 by madscijr"
_Title m_sTitle ' display in the Window's title bar
' Ship Editor / vector graphics editor for Fast Zap 'Em: Multispacewar
' DATE WHO-DONE-IT DID-WHAT
' 2022-11-21 madscijr Version 0.01 borrowed graphics objects and format from Widescreen Asteroids by Terry Ritchie.
' 2022-12-12 madscijr Version 0.58 (last version before project stalled!)
' 2025-01-05 madscijr Version 0.59 (no changes, just refamiliarize with code and get project back on track)
' 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)
' * fix twinkling stars
' TODO:
' * 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
' BOOLEAN CONSTANTS
Const FALSE = 0
Const TRUE = Not FALSE
' OTHER SETTINGS
Const cFPS = 120
Const cMinStars = 50
Const cMaxStars = 150
Const cSpeed = 2
Const cPolarMin = -63
Const cPolarMax = 63
Const cPolarNone = -64
Const cFlashCurrentLineMax = cFPS / 4 ' flash speed for currently selected line
Const cFlashStatusMessageMax = cFPS / 32 ' flash speed for status message
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN SIMPLE VECTOR ENGINE TYPES
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' 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
z As Integer ' zorder in which object is stacked (in front of or behind other objects)
FillColor As _Unsigned Long ' color to fill in object with (use cEmpty for transparent)
PreviewColor As _Unsigned Long
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
xPos As Single 'Integer ' X co-ordinate of the ship
yPos As Single 'Integer ' Y co-ordinate of the ship
'dx As Single ' x multiplier
'dy As Single ' y multiplier
vx As Single ' x velocity
vy As Single ' y velocity
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
heading As Single ' which direction is the object heading
facing As Single ' which direction is the object facing
speed As Single ' how fast is the object going
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
End Type ' ObjectType
' HOLDS DEFINITION OF A LINE SEGMENT
Type LineType
x1 As Integer
y1 As Integer
x2 As Integer
y2 As Integer
color As _Unsigned Long
IsLast As Integer
IsEnabled As Integer
End Type ' LineType
' HOLDS AN X,Y COORDINATE
Type CoordType
x As Integer
y As Integer
End Type ' CoordType
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END SIMPLE VECTOR ENGINE TYPES
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN CHEAPO PLANETARIUM TYPES
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' 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
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END CHEAPO PLANETARIUM TYPES
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ENABLE / DISABLE DEBUG CONSOLE
Dim Shared m_bDebug As Integer: m_bDebug = TRUE
' BASIC PROGRAM METADATA
Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
Dim Shared m_VersionInfo$: m_VersionInfo$ = "0.57"
' OTHER USEFUL VARIABLES
Dim Shared PI As Single: PI = 4 * Atn(1)
Dim Shared iFPS As Integer: iFPS = 60 ' Delay between frames (frames per second)
' OBJECT VARIABLES
ReDim Shared m_arrObject(1 To 32) As ObjectType ' m_arrObject(ObjectIndex)
ReDim Shared m_arrOrder(1 To 32) As Integer
ReDim Shared m_arrLines(1 To 32, 1 To 32) As LineType ' m_arrLines(ObjectIndex, LineIndex)
ReDim Shared m_arrLineStyle(1 To 8) As Long
ReDim Shared m_arrStars(1 To cMaxStars) As StarType
ReDim Shared m_arrColor(-1) As _Unsigned Long
ReDim Shared m_arrGrayColor(-1) As _Unsigned Long
' ****************************************************************************************************************************************************************
' ACTIVATE DEBUGGING WINDOW
If m_bDebug = TRUE Then
$Console
_Delay 4
_Console On
_Echo "Started " + m_ProgramName$
_Echo "Debugging on..."
End If
' ****************************************************************************************************************************************************************
' =============================================================================
' START THE MAIN ROUTINE
'DrawVectorObjectTest1
EditVectorObject1
' =============================================================================
' FINISH
'Screen 0
'Print m_ProgramName$ + " finished."
'Sleep
' ****************************************************************************************************************************************************************
' DEACTIVATE DEBUGGING WINDOW
If m_bDebug = TRUE Then
_Console Off
End If
' ****************************************************************************************************************************************************************
' FINISHED
System ' return control to the operating system
' ################################################################################################################################################################
' BEGIN BOX DRAWING ROUTINES
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D BOX (OUTLINE)
' https://www.qb64.org/wiki/LINE
Sub DrawBoxOutline (iX As Integer, iY As Integer, iSize As Integer, fgColor As _Unsigned Long)
Line (iX, iY)-(iX + (iSize - 1), iY + (iSize - 1)), fgColor, B ' Draw box outline
End Sub ' DrawBoxOutline
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D BOX (SOLID)
' https://www.qb64.org/wiki/LINE
' Renamed DrawBox/DrawBoxLine to DrawSolidBox
Sub DrawBoxSolid (iX As Integer, iY As Integer, iSize As Integer, fgColor As _Unsigned Long)
Line (iX, iY)-(iX + (iSize - 1), iY + (iSize - 1)), fgColor, BF ' Draw a solid box
End Sub ' DrawBoxSolid
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D RECTANGLE
'DrawRect 0, iX, iY, iSizeW, iSizeH, fgColor, bgColor
Sub DrawRect (img&, iX As Integer, iY As Integer, iSizeW As Integer, iSizeH As Integer, fgColor As _Unsigned Long, bgColor As _Unsigned Long)
'If img& < -1 Then
If img& <= 0 Then
' Select target image
_Dest img& ': Cls , cEmpty
' Draw fill (bgColor)
If bgColor <> cEmpty Then
Line (iX, iY)-(iX + (iSizeW - 1), iY + (iSizeH - 1)), bgColor, BF ' Draw a solid rectangle
End If
' Draw outline (fgColor)
If fgColor <> cEmpty Then
Line (iX, iY)-(iX + (iSizeW - 1), iY + (iSizeH - 1)), fgColor, B ' Draw rectangle outline
End If
End If
End Sub ' DrawRect
' /////////////////////////////////////////////////////////////////////////////
' 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
'DrawCircle 0, iX, iY, iRadius, iThickness, fgColor, bgColor
Sub DrawCircle (img&, iX As Integer, iY As Integer, iRadius As Integer, iThickness As Integer, fgColor As _Unsigned Long, bgColor As _Unsigned Long)
Dim iLoop As Integer
Dim iNextRadius As Integer
Dim iRadiusError As Integer
Dim iNextX As Integer
Dim iNextY As Integer
If (img& <= 0) And (iThickness > 0) And (fgColor <> cEmpty) Then
' Select target image
_Dest img& ': Cls , cEmpty
' Draw circle fill
If bgColor <> cEmpty Then
iNextRadius = Abs(iRadius)
iRadiusError = -iNextRadius
iNextX = iNextRadius
iNextY = 0
If iNextRadius = 0 Then
PSet (iX, iY), bgColor
Else
' 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 (iX - iNextX, iY)-(iX + iNextX, iY), bgColor, BF
While iNextX > iNextY
iRadiusError = iRadiusError + iNextY * 2 + 1
If iRadiusError >= 0 Then
If iNextX <> iNextY + 1 Then
Line (iX - iNextY, iY - iNextX)-(iX + iNextY, iY - iNextX), bgColor, BF
Line (iX - iNextY, iY + iNextX)-(iX + iNextY, iY + iNextX), bgColor, BF
End If
iNextX = iNextX - 1
iRadiusError = iRadiusError - iNextX * 2
End If
iNextY = iNextY + 1
Line (iX - iNextX, iY - iNextY)-(iX + iNextX, iY - iNextY), bgColor, BF
Line (iX - iNextX, iY + iNextY)-(iX + iNextX, iY + iNextY), bgColor, BF
Wend
End If
End If
' Draw circle outline
If fgColor <> cEmpty Then
If iRadius = 0 Then
PSet (iX, iY), fgColor
Else
iNextRadius = iRadius
For iLoop = 1 To iThickness
' DRAW CIRCLE
' CIRCLE (x, y), radius, color
'CIRCLE [[[STEP]]](column, row), radius%, [drawColor%][, startRadian!, stopRadian!] [, aspect!]
Circle (iX, iY), iNextRadius, fgColor
'Line (iLoop * 8, iHeight * 16)-(iLoop * 8 + 8, _Height), cGray, BF
'Circle (iX, iY), 4, cRed
iNextRadius = iNextRadius - 1
If iNextRadius = 0 Then
PSet (iX, iY), fgColor
Exit For
End If
Next iLoop
End If
End If
End If
End Sub ' DrawCircle
' /////////////////////////////////////////////////////////////////////////////
'DrawCircleOutline 0, iX, iY, iRadius, iThickness, fgColor
Sub DrawCircleOutline (img&, iX As Integer, iY As Integer, iRadius As Integer, iThickness As Integer, fgColor As _Unsigned Long)
Dim iNextRadius As Integer
Dim iLoop As Integer
If (img& <= 0) And (iThickness > 0) And (fgColor <> cEmpty) Then
' Select target image
_Dest img& ': Cls , cEmpty
' Initialize
iNextRadius = iRadius
' Draw circle
If Radius = 0 Then
PSet (iX, iY), fgColor
Else
For iLoop = 1 To iThickness
' DRAW CIRCLE
' CIRCLE (x, y), radius, color
'CIRCLE [[[STEP]]](column, row), radius%, [drawColor%][, startRadian!, stopRadian!] [, aspect!]
Circle (iX, iY), iNextRadius, fgColor
'Line (iLoop * 8, iHeight * 16)-(iLoop * 8 + 8, _Height), cGray, BF
'Circle (iX, iY), 4, cRed
iNextRadius = iNextRadius - 1
If iNextRadius = 0 Then
PSet (iX, iY), fgColor
Exit For
End If
Next iLoop
End If
End If
End Sub ' DrawCircleOutline
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D RECTANGLE (OUTLINE)
'DrawRectOutline iX, iY, iSizeW, iSizeH, fgColor
Sub DrawRectOutline (iX As Integer, iY As Integer, iSizeW As Integer, iSizeH As Integer, fgColor As _Unsigned Long)
Line (iX, iY)-(iX + (iSizeW - 1), iY + (iSizeH - 1)), fgColor, B ' Draw rectangle outline
End Sub ' DrawRectOutline
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D RECTANGLE (SOLID)
'DrawRectSolid iX, iY, iSizeW, iSizeH, fgColor
Sub DrawRectSolid (iX As Integer, iY As Integer, iSizeW As Integer, iSizeH As Integer, fgColor As _Unsigned Long)
Line (iX, iY)-(iX + (iSizeW - 1), iY + (iSizeH - 1)), fgColor, BF ' Draw a solid rectangle
End Sub ' DrawRectSolid
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D BOX (OUTLINE)
' https://www.qb64.org/wiki/LINE
' The style parameter 0-255 doesn't seem to have a solid line?
' For that, use DrawOutlineBox.
' LINE [STEP] [(column1, row1)]-[STEP] (column2, row2), color[, [{B|BF}], style%]
' B creates a box outline with each side parallel to the program screen sides. BF creates a filled box.
' The style% signed INTEGER value sets a dotted pattern to draw the line or rectangle outline.
Sub DrawStyledOutlineBox (iX%, iY%, iSize%, iColor~&, iStyle%)
Line (iX%, iY%)-(iX% + (iSize% - 1), iY% + (iSize% - 1)), iColor~&, B , iStyle%
End Sub ' DrawStyledOutlineBox
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D BOX (OUTLINE) WITH A SOLID LINE
Sub DrawOutlineBox (iX%, iY%, iSize2%, iColor~&, iWeight2%)
Dim iFromX%
Dim iFromY%
Dim iToX%
Dim iToY%
iSize% = iSize2% - 1
iWeight% = iWeight2% - 1
If iWeight% = 0 Then
' TOP LINE
iFromX% = iX%
iFromY% = iY%
iToX% = iX% + iSize%
iToY% = iY%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
' BOTTOM LINE
iFromX% = iX%
iFromY% = iY% + iSize%
iToX% = iX% + iSize%
iToY% = iY% + iSize%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
' LEFT LINE
iFromX% = iX%
iFromY% = iY%
iToX% = iX%
iToY% = iY% + iSize%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
' RIGHT LINE
iFromX% = iX% + iSize%
iFromY% = iY%
iToX% = iX% + iSize%
iToY% = iY% + iSize%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
ElseIf iWeight% > 0 Then
' TOP LINE
For iFromY% = iY% To (iY% + iWeight%)
iFromX% = iX%
'iFromY% = iY%
iToX% = iX% + iSize%
iToY% = iFromY%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
Next iFromY%
' BOTTOM LINE
For iFromY% = ((iY% + iSize%) - iWeight%) To (iY% + iSize%)
iFromX% = iX%
'iFromY% = iY% + iSize%
iToX% = iX% + iSize%
iToY% = iFromY%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
Next iFromY%
' LEFT LINE
For iFromX% = iX% To (iX% + iWeight%)
'iFromX% = iX%
iFromY% = iY%
iToX% = iFromX%
iToY% = iY% + iSize%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
Next iFromX%
' RIGHT LINE
For iFromX% = ((iX% + iSize%) - iWeight%) To (iX% + iSize%)
'iFromX% = iX% + iSize%
iFromY% = iY%
iToX% = iFromX%
iToY% = iY% + iSize%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
Next iFromX%
End If
End Sub ' DrawOutlineBox
' /////////////////////////////////////////////////////////////////////////////
'DrawSquare 0, x1, y1, size, fgcolor, bgcolor
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
' ################################################################################################################################################################
' END BOX DRAWING ROUTINES
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN SIMPLE VECTOR ENGINE #VEC
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
Sub EditVectorObject1
Dim RoutineName As String: RoutineName = "EditVectorObject1"
Dim iMouseX As Integer
Dim iMouseY As Integer
Dim iX1 As Integer: iX1 = 0
Dim iY1 As Integer: iY1 = 0
Dim iX2 As Integer: iX2 = 0
Dim iY2 As Integer: iY2 = 0
Dim iPX1 As Integer ' polar x1 coordinate
Dim iPY1 As Integer ' polar y1 coordinate
Dim iPX2 As Integer ' polar x2 coordinate
Dim iPY2 As Integer ' polar y2 coordinate
Dim iCursorX As Integer
Dim iCursorY As Integer
Dim iCX As Integer ' center x = screen coordinate for polar 0,0
Dim iCY As Integer ' center y = screen coordinate for polar 0,0
Dim bLeftClick As Integer: bLeftClick = FALSE
Dim bRightClick As Integer: bRightClick = FALSE
Dim bOldLeftClick As Integer: bOldLeftClick = FALSE
Dim bOldRightClick As Integer: bOldRightClick = FALSE
Dim iCellSize As Integer
Dim iGridSize As Integer
Dim iRadius As Integer
Dim iNextX As Integer
Dim iNextY As Integer
Dim LineColor As _Unsigned Long
Dim FontFgColor As _Unsigned Long
Dim FontBgColor As _Unsigned Long
Dim NewColor As _Unsigned Long
Dim iColorIndex As Integer
Dim iIndex As Integer
Dim iStartCol As Integer
Dim iNextCol As Integer
Dim iColWidth As Integer
Dim iColHeight As Integer
Dim iStartRow As Integer
Dim iNextRow As Integer
Dim iRowHeight As Integer
Dim iRowCount As Integer
Dim iBottomRow As Integer
Dim sFlag As String
Dim bEnableSelect As Integer: bEnableSelect = FALSE
Dim iSelectX As Integer ' when bEnableSelect=TRUE this contains the text click psition in the right (select) pane
Dim iSelectY As Integer ' when bEnableSelect=TRUE this contains the text click psition in the right (select) pane
Dim iPolarX As Integer ' when bEnableSelect=FALSE this contains the polar coordinate click position of the current object
Dim iPolarY As Integer ' when bEnableSelect=FALSE this contains the polar coordinate click position of the current object
Dim iConnectionCount1 As Integer
Dim iConnectionCount2 As Integer
Dim iPreviewX As Integer
Dim iPreviewY As Integer
Dim iCount As Integer
Dim iNextObject As Integer ' temp variable for looping through objects
Dim iSelectedObject As Integer ' the currently selected object
Dim iNextLine As Integer ' temp variable for looping through lines
Dim iSelectedLine As Integer ' the currently selected line
Dim iFirstLine As Integer ' line we started searching at
Dim iFoundLine As Integer
Dim SelectColor As _Unsigned Long
Dim iSelectCount As Integer
Dim iClickedPolarX As Integer
Dim iClickedPolarY As Integer
Dim bFirstClick As Integer
Dim iEditX As Integer ' x of selected point
Dim iEditY As Integer ' y of selected point
Dim iEditWhich As Integer ' 1 means editing x1,y1 else 2 means editing x2,y2
Dim iLastKey As Integer
Dim sCommand As String
Dim iNewPolarX As Integer ' x of new point
Dim iNewPolarY As Integer ' y of new point
Dim iLineCount As Integer ' used to count lines
Dim sStatus As String ' status message to display to user
Dim StatusColor As _Unsigned Long
Dim iStatusCount As Integer
Dim iStatusColorIndex As Integer
Dim oPreview As ObjectType
Dim iMinX As Integer
Dim iMaxX As Integer
Dim iMinY As Integer
Dim iMaxY As Integer
Dim imgObjects& ' used for drawing objects
Dim imgTemp& ' temporary drawing area
Dim lngSolidLineStyle ' selected object's line style
' INITIALIZE
InitializeRandom
iMinX = 0
iMaxX = 1024
iMinY = 0
iMaxY = 768
iSelectedObject = 1
iSelectedLine = LBound(m_arrLines, 2) - 1 ' none selected
SelectColor = cEmpty
iSelectCount = 0
iClickedPolarX = cPolarNone
iClickedPolarY = cPolarNone
iNewPolarX = cPolarNone
iNewPolarY = cPolarNone
iLastKey = 0
sCommand = ""
AddGrayscaleColors m_arrGrayColor() ' SAVE COLORS FOR STARS AND GRAYSCALE OBJECTS
sStatus = "hello world"
StatusColor = cEmpty
iStatusCount = 0
iStatusColorIndex = 0
lngSolidLineStyle = 65535
bFirstClick = TRUE
' USE LATER FOR DRAWING LAYERS:
imgObjects& = _NewImage(iMaxX, iMaxY, 32) ' frontground objects
imgTemp& = _NewImage(iMaxX, iMaxY, 32) ' temporary
' INIT SCREEN
Screen _NewImage(iMaxX, iMaxY, 32): _ScreenMove 0, 0
_Dest 0: Cls , cBlack
' INIT PREVIEW OBJECT
oPreview.x = _Width - (23 * _FontWidth) ' (96 + 88)
oPreview.y = _FontHeight * 10 ' 96 + 32 + (_FontWidth * 2)
oPreview.dx = RandomNumber%(-5, 5)
oPreview.dy = RandomNumber%(-5, 5)
oPreview.cx = 0
oPreview.cy = 0
oPreview.z = 0 ' 0 = front
oPreview.FillColor = cBlack
oPreview.IsEnabled = TRUE
oPreview.heading = 0
oPreview.facing = 0
oPreview.speed = 0
' SAVE COLORS FOR SHAPES
AddShapeColors m_arrColor()
' GET OBJECT PREVIEW POSITION
iPreviewX = _Width - (23 * _FontWidth) ' (96 + 88)
iPreviewY = _FontHeight * 10 ' 96 + 32 + (_FontWidth * 2)
' GET CURSOR SIZE
If _Height < _Width Then
iCellSize = _Height \ 128
Else
iCellSize = _Width \ 128
End If
iRadius = iCellSize \ 2
iGridSize = iCellSize * 126
' GET TEXT POSITION
iStartCol = (iGridSize + (iCellSize * 3)) \ _FontWidth '_Width
iColWidth = 15
iColHeight = ((UBound(m_arrObject) - LBound(m_arrObject)) + 1) \ 2
iRowHeight = _FontHeight * 2
iStartRow = 15 ' leave enough room for 32 objects
iBottomRow = ((iStartRow + iColHeight) - 1) * 2
' LOAD EXISTING OBJECTS
InitVectorObjects
' SAVE COLORS FOR EACH OBJECT (FROM FIRST LINE SEGMENT) TO ARRAY FOR TEXT
' AND SET COORDINATES TO AREA OF SCREEN FOR PREVIEW
iNextRow = iStartRow
iNextCol = iStartCol
iRowCount = 0
For iNextObject = LBound(m_arrObject) To UBound(m_arrObject)
If m_arrObject(iNextObject).IsEnabled = TRUE Then
iNextLine = LBound(m_arrLines, 2)
If m_arrLines(iNextObject, iNextLine).IsEnabled = TRUE Then
m_arrObject(iNextObject).PreviewColor = m_arrLines(iNextObject, iNextLine).color
Else
m_arrObject(iNextObject).PreviewColor = cGray
End If
Else
m_arrObject(iNextObject).PreviewColor = cGray
End If
' GET OBJECT THUMBNAIL POSITION
iRowCount = iRowCount + 1
If iRowCount <= iColHeight Then
iNextRow = iNextRow + 2
Else
iRowCount = 0
iNextRow = iStartRow + 2
iNextCol = iNextCol + iColWidth
End If
m_arrObject(iNextObject).x = (iNextCol + iColWidth) * _FontWidth
m_arrObject(iNextObject).y = (iNextRow * _FontHeight) - _FontHeight
Next iNextObject
' INITIALIZE CURRENT COLOR
NewColor = m_arrObject(iSelectedObject).PreviewColor
iColorIndex = LBound(m_arrColor)
For iIndex = LBound(m_arrColor) To UBound(m_arrColor)
If m_arrColor(iIndex) = NewColor Then
iColorIndex = iIndex
Exit For
End If
Next iIndex
' CALCULATE SCREEN POSITION FOR POLAR (0,0)
iCX = (63 * iCellSize) '+ iRadius
iCY = (63 * iCellSize) '+ iRadius
' GET INPUT
_MouseHide ' hide OS mouse pointer
Do While _MouseInput: Loop
Do
' RESET DISPLAY
_Dest 0: Cls , cBlack ' CLEAR SCREEN
_Dest imgObjects&: Cls , cEmpty ' CLEAR OBJECTS LAYER
_Dest 0
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN DRAW GRID
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
LineColor = _RGB32(105, 105, 105, 64)
' VERTICAL LINES:
For iNextX = 0 To (iGridSize + iCellSize) Step iCellSize
Line (iNextX, 1)-(iNextX, iGridSize + iCellSize), LineColor, BF
Next iNextX
' HORIZONTAL LINES:
For iNextY = 0 To (iGridSize + iCellSize) Step iCellSize
For iNextX = 0 To iGridSize Step iCellSize
Line ((iNextX + 1), iNextY)-((iNextX + iCellSize) - 1, iNextY), LineColor, BF
Next iNextX
Next iNextY
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END DRAW GRID
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN GET CURSOR POSITION & QUANTIZE
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' WHAT THIS SECTION DOES:
' Get raw mouse coordinates, and arrive at:
' * iX1 = 0-126
' * iY1 = 0-126
' * iCursorX = click position quantized to iCellSize
' * iCursorY = click position quantized to iCellSize
' * iPolarX = polar coordinates -63 to 63
' * iPolarY = polar coordinates -63 to 63
' GET RAW MOUSE COORDINATES
iMouseX = _MouseX
iMouseY = _MouseY
' DIVIDE BY CELL SIZE
iX1 = (iMouseX \ iCellSize) ' _FontWidth
iY1 = (iMouseY \ iCellSize) ' _FontHeight
' FIX X POSITION
If iX1 < 0 Then
iX1 = 0
bEnableSelect = FALSE
ElseIf iX1 > 126 Then
iX1 = 126
' IF USER IS EDITING A LINE,
' DON'T LET THEM EXIT UNTIL DONE (OR THEY PRESS ESC)
' ENABLE CURSOR FOR RIGHT (TEXT) SIDE OF SCREEN
bEnableSelect = TRUE
iSelectX = (iMouseX \ _FontWidth) '* _FontWidth
iSelectY = (iMouseY \ _FontHeight) '* _FontHeight
Else
bEnableSelect = FALSE
End If
' FIX Y POSITION
If iY1 < 0 Then
iY1 = 0
ElseIf iY1 > 126 Then
iY1 = 126
End If
' QUANTIZE TO CELL SIZE
iCursorX = iX1 * iCellSize ' click position quantized to iCellSize
iCursorY = iY1 * iCellSize ' click position quantized to iCellSize
' GET POLAR COORDINATE
iPolarX = iX1 - 63
iPolarY = iY1 - 63
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END GET CURSOR POSITION & QUANTIZE
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' FLASH STATUS MESSAGE
iStatusCount = iStatusCount + 1
If iStatusCount > cFlashStatusMessageMax Then
iStatusCount = 0
iStatusColorIndex = iStatusColorIndex + 1
If iStatusColorIndex > UBound(m_arrGrayColor) Then
iStatusColorIndex = 0
End If
StatusColor = m_arrGrayColor(iStatusColorIndex)
End If
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN SHOW TEXT
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
FontBgColor = _RGB32(0, 0, 0, 128)
' SHOW LABELS
Color cWhite, FontBgColor
PrintString 0, iStartCol + 0, "iPolarX ="
PrintString 1, iStartCol + 0, "iPolarY ="
PrintString 2, iStartCol + 0, "Color ="
' SHOW VALUES
Color cWhite, FontBgColor
PrintString 0, iStartCol + 16, Left$(cstr$(iPolarX) + " ", 5)
PrintString 1, iStartCol + 16, Left$(cstr$(iPolarY) + " ", 5)
' SHOW CURRENT COLOR
Color m_arrColor(iColorIndex), FontBgColor
PrintString 2, iStartCol + 16, Left$(ColorName$(m_arrColor(iColorIndex)) + " ", 16)
' SHOW STATUS
Color StatusColor, FontBgColor
PrintString 11, iStartCol + 0, Left$(sStatus + String$(31, " "), 31)
' SHOW INSTRUCTIONS
Color cWhite, FontBgColor
PrintString 13, iStartCol + 0, "PRESS <ESC> TO EXIT "
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END SHOW TEXT
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN SHOW OBJECT NAMES AND THUMBNAILS
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'TODO: instead of "->" draw a flashing box around the current object
iNextRow = iStartRow
iNextCol = iStartCol
iRowCount = 0
For iNextObject = LBound(m_arrObject) To UBound(m_arrObject)
If m_arrObject(iNextObject).IsEnabled = TRUE Then
FontFgColor = m_arrObject(iNextObject).PreviewColor
If iNextObject = iSelectedObject Then
sFlag = "-> "
Else
sFlag = " "
End If
Else
FontFgColor = cGray
sFlag = " "
End If
Color FontFgColor, FontBgColor ' cBlack ' cEmpty 'cBlack
PrintAt iNextRow, iNextCol, sFlag + "Object #" + cstr$(iNextObject)
' ADVANCE TO NEXT
iRowCount = iRowCount + 1
If iRowCount < iColHeight Then
iNextRow = iNextRow + 2
Else
iRowCount = 0
iNextRow = iStartRow
iNextCol = iNextCol + iColWidth
End If
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN DRAW OBJECT'S LINE SEGMENTS (THUMBNAIL)
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
For iNextLine = LBound(m_arrLines, 2) To UBound(m_arrLines, 2)
Line _
(m_arrObject(iNextObject).x + (m_arrLines(iNextObject, iNextLine).x1 \ 4), _
m_arrObject(iNextObject).y + (m_arrLines(iNextObject, iNextLine).y1 \ 4)) _
- _
(m_arrObject(iNextObject).x + (m_arrLines(iNextObject, iNextLine).x2 \ 4), _
m_arrObject(iNextObject).y + (m_arrLines(iNextObject, iNextLine).y2 \ 4) ) _
, _
m_arrLines(iNextObject, iNextLine).color ' , BF
If m_arrLines(iNextObject, iNextLine).IsLast = TRUE Then
Exit For
End If
Next iNextLine
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END DRAW OBJECT'S LINE SEGMENTS (THUMBNAIL)
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
Next iNextObject
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END SHOW OBJECT NAMES AND THUMBNAILS
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' SHOW SELECT CURSOR
If bEnableSelect = TRUE Then
Color cBlack, cWhite
_PrintString (iSelectX * _FontWidth, iSelectY * _FontHeight), " "
End If
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' FLASH SELECTED LINE
iSelectCount = iSelectCount + 1
If iSelectCount > cFlashCurrentLineMax Then
iSelectCount = 0
If SelectColor = cBlack Then
If iSelectedLine >= LBound(m_arrLines, 2) Then
If iSelectedLine <= UBound(m_arrLines, 2) Then
SelectColor = m_arrLines(iSelectedObject, iSelectedLine).color
End If
End If
Else
SelectColor = cBlack
End If
End If
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN DRAW OBJECT'S LINE SEGMENTS (EDITOR)
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
For iNextLine = LBound(m_arrLines, 2) To UBound(m_arrLines, 2)
If m_arrLines(iSelectedObject, iNextLine).IsEnabled = TRUE Then
' CALCULATE POSITIONS ON THE EDIT GRID
iX1 = ((m_arrLines(iSelectedObject, iNextLine).x1 + 63) * iCellSize) + iRadius
iY1 = ((m_arrLines(iSelectedObject, iNextLine).y1 + 63) * iCellSize) + iRadius
iX2 = ((m_arrLines(iSelectedObject, iNextLine).x2 + 63) * iCellSize) + iRadius
iY2 = ((m_arrLines(iSelectedObject, iNextLine).y2 + 63) * iCellSize) + iRadius
' FLASH COLOR FOR SELECTED LINE
If iNextLine = iSelectedLine Then
LineColor = SelectColor
Else
LineColor = m_arrLines(iSelectedObject, iNextLine).color
End If
' DRAW THE LINE
Line (iX1, iY1)-(iX2, iY2), LineColor ' , BF
' SHOW ENDPOINTS
DrawCircle 0, iX1, iY1, iRadius, 1, LineColor, LineColor
DrawCircle 0, iX2, iY2, iRadius, 1, LineColor, LineColor
Else
' (SHOULD WE SHOW DISABLED POINTS?)
End If
If m_arrLines(iSelectedObject, iNextLine).IsLast = TRUE Then
Exit For
End If
Next iNextLine
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END DRAW OBJECT'S LINE SEGMENTS (EDITOR)
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN MOVE PREVIEW OBJECT
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' Move along X axis
oPreview.cx = oPreview.cx + 1
If oPreview.cx > (10 - Abs(oPreview.dx)) Then
oPreview.cx = 0
If oPreview.dx < 0 Then
oPreview.x = oPreview.x - cSpeed
If oPreview.x < iMinX Then
oPreview.x = iMaxX
End If
ElseIf oPreview.dx > 0 Then
oPreview.x = oPreview.x + cSpeed
If oPreview.x > iMaxX Then
oPreview.x = iMinX
End If
End If
End If
' Move along Y axis
oPreview.cy = oPreview.cy + 1
If oPreview.cy > (10 - Abs(oPreview.dy)) Then
oPreview.cy = 0
If oPreview.dy < 0 Then
oPreview.y = oPreview.y - cSpeed
If oPreview.y < iMinY Then
oPreview.y = iMaxY
End If
ElseIf oPreview.dy > 0 Then
oPreview.y = oPreview.y + cSpeed
If oPreview.y > iMaxY Then
oPreview.y = iMinY
End If
End If
End If
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END MOVE PREVIEW OBJECT
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN DRAW OBJECT'S LINE SEGMENTS (PREVIEW)
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' Clear temporary (layer and draw on it
_Dest imgTemp&: Cls , cEmpty
' Draw object's line segments
For iNextLine = LBound(m_arrLines, 2) To UBound(m_arrLines, 2)
If m_arrLines(iSelectedObject, iNextLine).IsLast = FALSE Then
If m_arrLines(iSelectedObject, iNextLine).IsEnabled = TRUE Then
'Line (x1%, y1%)-(x2%, y2%), arrColor(arrStars(iLoop).ColorIndex), BF, lngLineStyle
Line _
(oPreview.x + m_arrLines(iSelectedObject, iNextLine).x1, _
oPreview.y + m_arrLines(iSelectedObject, iNextLine).y1) _
- _
(oPreview.x + m_arrLines(iSelectedObject, iNextLine).x2, _
oPreview.y + m_arrLines(iSelectedObject, iNextLine).y2) _
, _
m_arrLines(iSelectedObject, iNextLine).color, , lngSolidLineStyle
End If
Else
Exit For
End If
Next iNextLine
'TODO:
'' Draw fill color if not transparent
'If oPreview.FillColor <> cEmpty Then
' ' Fill in current object with its fill color...
' 'PAINT [STEP] (column%, row%), fillColor[, borderColor%]
' Paint (oPreview.x, oPreview.y), oPreview.FillColor, oPreview.PreviewColor
'End If
' Add new object to objects layer
'_PUTIMAGE , sourceHandle&, destHandle& 'size full source to fit full destination area
_PutImage , imgTemp&, imgObjects&
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END DRAW OBJECT'S LINE SEGMENTS (PREVIEW)
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' DRAW VECTOR CURSOR
DrawRect 0, iCursorX, iCursorY, iCellSize, iCellSize, cCyan, cEmpty
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN LEFT CLICK
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
bLeftClick = _MouseButton(1)
If bLeftClick Then
If bOldLeftClick = FALSE Then
If bEnableSelect = TRUE Then
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN CLICK RIGHT PANE / SELECT OBJECT
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
If iSelectY >= iStartRow And iSelectY < iBottomRow Then
' every other line:
iSelectedObject = iSelectY - (iStartRow - 1)
iSelectedObject = ((iSelectedObject + 1) \ 2)
' clicked on column 2:
If iSelectX >= (iStartCol + iColWidth) Then
iSelectedObject = iSelectedObject + iColHeight
End If
' out of bounds?
If iSelectedObject > UBound(m_arrLines, 1) Then
iSelectedObject = UBound(m_arrLines, 1)
End If
' INITIALIZE CURRENT COLOR
NewColor = m_arrObject(iSelectedObject).PreviewColor
iColorIndex = LBound(m_arrColor)
For iIndex = LBound(m_arrColor) To UBound(m_arrColor)
If m_arrColor(iIndex) = NewColor Then
iColorIndex = iIndex
Exit For
End If
Next iIndex
End If
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END CLICK RIGHT PANE / SELECT OBJECT
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
Else
' ****************************************************************************************************************************************************************
' LEFT CLICK LEFT PANE
' ****************************************************************************************************************************************************************
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN CLICK LEFT PANE / ANCHOR POINTS
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' DID USER CLICK ON A NEW POINT?
If iPolarX <> iClickedPolarX Or iPolarY <> iClickedPolarY Then
' FIRST CLICK?
if bFirstClick = TRUE then
' FIRST CLICK, REMEMBER THIS POINT
iClickedPolarX = iPolarX
iClickedPolarY = iPolarY
bFirstClick = FALSE
sStatus = "insert point"
else
' INSERT NEW LINE FROM PREVIOUS POINT TO HERE
' HAVE WE USED THE MAX # OF LINES FOR THIS SHAPE?
iFoundLine = LBound(m_arrLines, 2) - 1
For iNextLine = LBound(m_arrLines, 2) To UBound(m_arrLines, 2)
If m_arrLines(iSelectedObject, iNextLine).IsEnabled = FALSE Then
iFoundLine = iNextLine
Exit For
End If
Next iNextLine
' INSERT NEW LINE
if iFoundLine >= LBound(m_arrLines, 2) then
m_arrLines(iSelectedObject, iFoundLine).x1 = iClickedPolarX
m_arrLines(iSelectedObject, iFoundLine).y1 = iClickedPolarY
m_arrLines(iSelectedObject, iFoundLine).x2 = iPolarX
m_arrLines(iSelectedObject, iFoundLine).y2 = iPolarY
m_arrLines(iSelectedObject, iFoundLine).color = m_arrColor(iColorIndex)
m_arrLines(iSelectedObject, iFoundLine).IsEnabled = TRUE
sStatus = "inserted at " + _Trim$(Str$(iFoundLine))
else
sStatus = "Can't insert: max lines used!"
end if
' RESET FLAG
bFirstClick = TRUE
end if
iSelectedLine = LBound(m_arrLines, 2) - 1 ' none selected
Else
' USER CLICKED ON SAME POINT, ARE WE IN INSERT MODE?
if iClickCount = 1 then
' INSERT SINGLE POINT HERE
end if
End If
' GOTO NEXT POINT
If iSelectedLine < LBound(m_arrLines, 2) Then
iNextLine = LBound(m_arrLines, 2) ' start looking at beginning
Else
iNextLine = iSelectedLine + 1
If iNextLine > UBound(m_arrLines, 2) Then
iNextLine = LBound(m_arrLines, 2) ' start looking at beginning
End If
End If
' DETERMINE IF A LINE SEGMENT BEGINS OR ENDS HERE
iFirstLine = iNextLine
iFoundLine = LBound(m_arrLines, 2) - 1 ' none selected
Do
If m_arrLines(iSelectedObject, iNextLine).IsEnabled = TRUE Then
If iNextLine <> iSelectedLine Then
' CHECK START POINT NEXT
If m_arrLines(iSelectedObject, iNextLine).x1 = iPolarX Then
If m_arrLines(iSelectedObject, iNextLine).y1 = iPolarY Then
' MATCHES START POINT
'DebugPrint "found (" + cstr$(iPolarX) + "," + cstr$(iPolarY) + ") = BEGIN POINT " + ColorName$(m_arrLines(iSelectedObject, iNextLine).color)
iFoundLine = iNextLine
iEditWhich = 1 ' remember we selected start point x1,y1
Exit Do
End If
End If
' CHECK END POINT NEXT
If m_arrLines(iSelectedObject, iNextLine).x2 = iPolarX Then
If m_arrLines(iSelectedObject, iNextLine).y2 = iPolarY Then
' MATCHES END POINT
'DebugPrint "found (" + cstr$(iPolarX) + "," + cstr$(iPolarY) + ") = END POINT " + ColorName$(m_arrLines(iSelectedObject, iNextLine).color)
iFoundLine = iNextLine
iEditWhich = 2 ' remember we selected end point x2,y2
Exit Do
End If
End If
End If
End If
' MOVE TO NEXT LINE
iNextLine = iNextLine + 1
If iNextLine > UBound(m_arrLines, 2) Then
iNextLine = LBound(m_arrLines, 2) ' start looking at beginning
End If
' IF WE'RE BACK TO THE START THEN NO MORE FOUND, EXIT
If iNextLine = iFirstLine Then
Exit Do
End If
Loop
' DID WE FIND ONE?
If iFoundLine >= LBound(m_arrLines, 2) Then
If iFoundLine <= UBound(m_arrLines, 2) Then
' CHANGE SELECTION
iSelectedLine = iFoundLine
' REMEMBER WHAT POINT WE CLICKED
iEditX = iPolarX ' remember selected x
iEditY = iPolarY ' remember selected y
Else
' IS THIS NEEDED?
iSelectedLine = LBound(m_arrLines, 2) - 1 ' none selected
End If
Else
' IS THIS NEEDED?
iSelectedLine = LBound(m_arrLines, 2) - 1 ' none selected
End If
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END CLICK LEFT PANE / ANCHOR POINTS
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
End If
' REMEMBER
bOldLeftClick = TRUE
End If
Else
bOldLeftClick = FALSE
End If
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END LEFT CLICK
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN RIGHT CLICK
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
bRightClick = _MouseButton(2)
If bRightClick Then
If bOldRightClick = FALSE Then
If bEnableSelect = TRUE Then
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN RIGHT-CLICK RIGHT PANE / SELECT OBJECT
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' USER CLICKED RIGHT SIDE OF SCREEN FOR SELECT OBJECT:
' (NO RIGHT-CLICK ACTIONS YET IN RIGHT PANE)
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END RIGHT-CLICK RIGHT PANE / SELECT OBJECT
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
Else
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN RIGHT-CLICK LEFT PANE / ANCHOR POINTS
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' IS A LINE SEGMENT SELECTED?
If iSelectedLine >= LBound(m_arrLines, 2) Then
If iSelectedLine <= UBound(m_arrLines, 2) Then
' DID USER RIGHT-CLICK SELECTED ENDPOINT?
If (iPolarX = iEditX) And (iPolarY = iEditY) Then
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN DELETE THE LINE
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' STARTING WITH SELECTED, OVERWRITE EACH WITH THE ONE AFTER
If iSelectedLine < UBound(m_arrLines, 2) Then
For iNextLine = iSelectedLine To (UBound(m_arrLines, 2) - 1)
m_arrLines(iSelectedObject, iNextLine).x1 = m_arrLines(iSelectedObject, iNextLine + 1).x1
m_arrLines(iSelectedObject, iNextLine).y1 = m_arrLines(iSelectedObject, iNextLine + 1).y1
m_arrLines(iSelectedObject, iNextLine).x2 = m_arrLines(iSelectedObject, iNextLine + 1).x2
m_arrLines(iSelectedObject, iNextLine).y2 = m_arrLines(iSelectedObject, iNextLine + 1).y2
m_arrLines(iSelectedObject, iNextLine).color = m_arrLines(iSelectedObject, iNextLine + 1).color
m_arrLines(iSelectedObject, iNextLine).IsLast = m_arrLines(iSelectedObject, iNextLine + 1).IsLast
m_arrLines(iSelectedObject, iNextLine).IsEnabled = m_arrLines(iSelectedObject, iNextLine + 1).IsEnabled
Next iNextLine
Else
' MAKE NEXT-TO-LAST THE LAST ONE
iNextLine = iSelectedLine - 1
m_arrLines(iSelectedObject, iNextLine).IsLast = TRUE
End If
' CLEAR THE LAST ONE
iNextLine = UBound(m_arrLines, 2)
m_arrLines(iSelectedObject, iNextLine).x1 = cPolarNone
m_arrLines(iSelectedObject, iNextLine).y1 = cPolarNone
m_arrLines(iSelectedObject, iNextLine).x2 = cPolarNone
m_arrLines(iSelectedObject, iNextLine).y2 = cPolarNone
m_arrLines(iSelectedObject, iNextLine).color = cEmpty
m_arrLines(iSelectedObject, iNextLine).IsLast = FALSE
m_arrLines(iSelectedObject, iNextLine).IsEnabled = FALSE
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END DELETE THE LINE
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
Else
' NO, MOVE ENDPOINT TO NEW COORDINATE
If iEditWhich = 1 Then
m_arrLines(iSelectedObject, iSelectedLine).x1 = iPolarX
m_arrLines(iSelectedObject, iSelectedLine).y1 = iPolarY
ElseIf iEditWhich = 2 Then
m_arrLines(iSelectedObject, iSelectedLine).x2 = iPolarX
m_arrLines(iSelectedObject, iSelectedLine).y2 = iPolarY
End If
End If
End If
End If
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END RIGHT-CLICK LEFT PANE / ANCHOR POINTS
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
End If
' REMEMBER
bOldRightClick = TRUE
End If
Else
bOldRightClick = FALSE
End If
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END RIGHT CLICK
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' READ MOUSE
Do While _MouseInput
' READ MOUSE WHEEL:
'iY2 = iY2 + (_MouseWheel * _FontHeight) ' -1 up, 0 no movement, 1 down
Loop
' ================================================================================================================================================================
' BEGIN PROCESS KEYBOARD INPUT
' ================================================================================================================================================================
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
' DON'T ACCEPT ANY MORE INPUT UNTIL THE LAST PRESSED KEY IS RELEASED
If iLastKey > 0 Then
If _Button(iLastKey) = FALSE Then
iLastKey = 0
sCommand = ""
End If
End If
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN READY TO ACCEPT MORE INPUT?
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
If iLastKey < 1 Then
' DID PLAYER PRESS ANY KEYS WE KNOW?
If _Button(KeyCode_C%) Then
sCommand = "c"
iLastKey = KeyCode_C%
ElseIf _Button(KeyCode_I%) Then
sCommand = "i"
iLastKey = KeyCode_I%
ElseIf _Button(KeyCode_U%) Then
sCommand = "u"
iLastKey = KeyCode_U%
ElseIf _Button(KeyCode_Del%) Then
sCommand = "delete"
iLastKey = KeyCode_Del%
'ElseIf _Button(KeyCode_Ins%) Then
' sCommand = "insert"
' iLastKey = KeyCode_Ins%
ElseIf _Button(KeyCode_Escape%) Then
if bFirstClick = FALSE then
sCommand = "deselect"
elseIf iSelectedLine >= LBound(m_arrLines, 2) Then
sCommand = "deselect"
Else
sCommand = "esc"
End If
iLastKey = KeyCode_Escape%
ElseIf _Button(KeyCode_Left%) Then
sCommand = "left"
'iLastKey = KeyCode_Left%
iLastKey = -1 ' allow repeat for this key
ElseIf _Button(KeyCode_Right%) Then
sCommand = "right"
'iLastKey = KeyCode_Right%
iLastKey = -1 ' allow repeat for this key
ElseIf _Button(KeyCode_Up%) Then
sCommand = "up"
'iLastKey = KeyCode_Up%
iLastKey = -1 ' allow repeat for this key
ElseIf _Button(KeyCode_Down%) Then
sCommand = "down"
'iLastKey = KeyCode_Down%
iLastKey = -1 ' allow repeat for this key
Else
iLastKey = 0
sCommand = ""
End If
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN IF USER DID PRESS A KEY WE KNOW, PROCESS INPUT
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
If iLastKey <> 0 Then
If sCommand = "" Then
' (DO NOTHING)
ElseIf sCommand = "c" Then
' SELECT NEXT COLOR (CYCLE THROUGH COLORS)
iColorIndex = iColorIndex + 1
If iColorIndex > UBound(m_arrColor) Then
iColorIndex = LBound(m_arrColor)
End If
ElseIf sCommand = "i" Then
' "EYEDROPPER" COPY COLOR FROM CURRENT LINE
If iSelectedLine >= LBound(m_arrLines, 2) Then
iColorIndex = LBound(m_arrColor)
For iIndex = LBound(m_arrColor) To UBound(m_arrColor)
If m_arrColor(iIndex) = m_arrLines(iSelectedObject, iSelectedLine).color Then
iColorIndex = iIndex
Exit For
End If
Next iIndex
End If
ElseIf sCommand = "u" Then
' UPDATE COLOR OF CURRENT LINE
If iSelectedLine >= LBound(m_arrLines, 2) Then
m_arrLines(iSelectedObject, iSelectedLine).color = m_arrColor(iColorIndex)
End If
'ElseIf sCommand = "insert" Then
' ' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ' BEGIN INSERT LINE
' ' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' iLineCount = 0
' For iNextLine = LBound(m_arrLines, 2) To UBound(m_arrLines, 2)
' If m_arrLines(iSelectedObject, iNextLine).IsEnabled = TRUE Then
' iLineCount = iLineCount + 1
' End If
' Next iNextLine
' ' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ' END INSERT LINE
' ' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
ElseIf sCommand = "delete" Then
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN DELETE THE LINE
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' STARTING WITH SELECTED, OVERWRITE EACH WITH THE ONE AFTER
'If iSelectedLine < UBound(m_arrLines, 2) Then
' For iNextLine = iSelectedLine To (UBound(m_arrLines, 2) - 1)
' m_arrLines(iSelectedObject, iNextLine).x1 = m_arrLines(iSelectedObject, iNextLine + 1).x1
' m_arrLines(iSelectedObject, iNextLine).y1 = m_arrLines(iSelectedObject, iNextLine + 1).y1
' m_arrLines(iSelectedObject, iNextLine).x2 = m_arrLines(iSelectedObject, iNextLine + 1).x2
' m_arrLines(iSelectedObject, iNextLine).y2 = m_arrLines(iSelectedObject, iNextLine + 1).y2
' m_arrLines(iSelectedObject, iNextLine).color = m_arrLines(iSelectedObject, iNextLine + 1).color
' m_arrLines(iSelectedObject, iNextLine).IsLast = m_arrLines(iSelectedObject, iNextLine + 1).IsLast
' m_arrLines(iSelectedObject, iNextLine).IsEnabled = m_arrLines(iSelectedObject, iNextLine + 1).IsEnabled
' Next iNextLine
'Else
' ' MAKE NEXT-TO-LAST THE LAST ONE
' iNextLine = iSelectedLine - 1
' m_arrLines(iSelectedObject, iNextLine).IsLast = TRUE
'End If
'' CLEAR THE LAST ONE
'iNextLine = UBound(m_arrLines, 2)
'm_arrLines(iSelectedObject, iNextLine).x1 = cPolarNone
'm_arrLines(iSelectedObject, iNextLine).y1 = cPolarNone
'm_arrLines(iSelectedObject, iNextLine).x2 = cPolarNone
'm_arrLines(iSelectedObject, iNextLine).y2 = cPolarNone
'm_arrLines(iSelectedObject, iNextLine).color = cEmpty
'm_arrLines(iSelectedObject, iNextLine).IsLast = FALSE
'm_arrLines(iSelectedObject, iNextLine).IsEnabled = FALSE
If iSelectedLine >= LBound(m_arrLines, 2) And iSelectedLine < UBound(m_arrLines, 2) Then
m_arrLines(iSelectedObject, iSelectedLine).x1 = cPolarNone
m_arrLines(iSelectedObject, iSelectedLine).y1 = cPolarNone
m_arrLines(iSelectedObject, iSelectedLine).x2 = cPolarNone
m_arrLines(iSelectedObject, iSelectedLine).y2 = cPolarNone
m_arrLines(iSelectedObject, iSelectedLine).color = cEmpty
m_arrLines(iSelectedObject, iSelectedLine).IsLast = FALSE
m_arrLines(iSelectedObject, iSelectedLine).IsEnabled = FALSE
End If
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END DELETE THE LINE
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
ElseIf sCommand = "deselect" Then
iSelectedLine = LBound(m_arrLines, 2) - 1 ' none selected
bFirstClick = TRUE
sStatus = ""
ElseIf sCommand = "left" Then
oPreview.dx = oPreview.dx - 1
If oPreview.dx < -10 Then oPreview.dx = -10
ElseIf sCommand = "right" Then
oPreview.dx = oPreview.dx + 1
If oPreview.dx > 10 Then oPreview.dx = 10
ElseIf sCommand = "up" Then
oPreview.dy = oPreview.dy - 1
If oPreview.dy < -10 Then oPreview.dy = -10
ElseIf sCommand = "down" Then
oPreview.dy = oPreview.dy + 1
If oPreview.dy > 10 Then oPreview.dy = 10
ElseIf sCommand = "esc" Then
Exit Do
End If
End If ' iLastKey <> 0
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END IF USER DID PRESS A KEY WE KNOW, PROCESS INPUT
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
End If ' IF iLastKey = 0
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END READY TO ACCEPT MORE INPUT?
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' CLEAR KEYBOARD BUFFER
_KeyClear ': _Delay 2
' ================================================================================================================================================================
' END PROCESS KEYBOARD INPUT
' ================================================================================================================================================================
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN UPDATE SCREEN
' COPY LAYERS TO SCREEN
'_Dest 0: Cls , cBlack
If imgObjects& < -1 Then
_PutImage , imgObjects&, 0
End If
' UPDATE THE SCREEN
_Display
' END UPDATE SCREEN
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
Loop
_KeyClear
' RESET MOUSE
_MouseShow "default": _Delay 0.5
' CLEAR IMAGES
Screen 0
If imgObjects& < -1 Then _FreeImage imgObjects&
If imgTemp& < -1 Then _FreeImage imgTemp&
' RETURN TO AUTODISPLAY
_AutoDisplay
' Screen 0 set at end of program up top.
Screen 0
End Sub ' EditVectorObject1
' /////////////////////////////////////////////////////////////////////////////
Sub DrawVectorObjectTest1
Dim RoutineName As String: RoutineName = "DrawVectorObjectTest1"
Dim iFPS As Integer: iFPS = cFPS
Dim iLoop As Integer
Dim iObject As Integer
Dim iLayer As Integer
Dim iLine As Integer
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 iLineStyleIndex As Integer
Dim lngLineStyle ' line style
Dim lngDashedLineStyle ' line style for other objects
Dim lngSolidLineStyle ' selected object's line style
Dim iNumStars As Integer
Dim iValue As Integer
Dim iMinValue As Integer
Dim iMaxValue As Integer
Dim iStarLoop As Integer
Dim x1%
Dim x2%
Dim y1%
Dim y2%
Dim imgStars& ' used for drawing background
Dim imgText& ' used for drawing text
Dim imgObjects& ' used for drawing objects
Dim imgTemp& ' temporary drawing area
' =============================================================================
' INITIALIZE
InitializeRandom
Screen _NewImage(iMaxX, iMaxY, 32) ' 100 text columns x 40 text rows
' USE LATER FOR DRAWING LAYERS:
imgStars& = _NewImage(iMaxX, iMaxY, 32) ' background stars
imgText& = _NewImage(iMaxX, iMaxY, 32) ' text
imgObjects& = _NewImage(iMaxX, iMaxY, 32) ' frontground objects
imgTemp& = _NewImage(iMaxX, iMaxY, 32) ' temporary
' =============================================================================
' START NEW GAME
Do
_KeyClear
' CONFIGURE PRINTING FOR _PrintString
_PrintMode _FillBackground
'_PrintMode _KEEPBACKGROUND
' INIT OBJECT DEFINITIONS
InitVectorObjects
' INIT VARS
sKey = ""
' PLACE OBJECTS
iX = 0: iY = 0
iValue = UBound(m_arrObject)
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
m_arrObject(iObject).z = iValue
m_arrObject(iObject).FillColor = cBlack
iX = iX + 200
If iX > 800 Then
iX = 0
iY = iY + 200
If iY > 640 Then
iY = 0
End If
End If
iValue = iValue - 1
Next iObject
' INIT OBJECT Z-ORDER ARRAY
ReDim m_arrOrder(LBound(m_arrObject) To UBound(m_arrObject)) As Integer
For iObject = LBound(m_arrObject) To UBound(m_arrObject)
m_arrOrder(m_arrObject(iObject).z) = iObject
Next iObject
' SAVE LINE STYLE SEQUENCE
iLoop = 0
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 61680 ' 1111000011110000
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 30840 ' 0111100001111000
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 15420 ' 0011110000111100
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 7710 ' 0001111000011110
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 3855 ' 0000111100001111
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 34695 ' 1000011110000111
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 50115 ' 1100001111000011
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 57825 ' 1110000111100001
iLineStyleIndex = LBound(m_arrLineStyle)
lngDashedLineStyle = m_arrLineStyle(iLineStyleIndex)
lngSolidLineStyle = 65535
' 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_arrObject(iObject).PreviewColor = 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
' ================================================================================================================================================================
' BEGIN MAIN LOOP
While TRUE = TRUE
' CLEAR OBJECTS LAYER
_Dest imgObjects&: Cls , cEmpty
' MOVE AND ADD ENABLED OBJECTS (IN STACKING ORDER)
For iLayer = UBound(m_arrOrder) To LBound(m_arrOrder) Step -1
' Get next object
iObject = m_arrOrder(iLayer)
' 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 - cSpeed
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 + cSpeed
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 - cSpeed
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 + cSpeed
If m_arrObject(iObject).y > iMaxY Then
m_arrObject(iObject).y = iMinY
End If
End If
End If
' Clear temporary (layer and draw on it
_Dest imgTemp&: Cls , cEmpty
' Draw object's line segments
For iLine = LBound(m_arrLines, 2) To UBound(m_arrLines, 2)
If m_arrLines(iObject, iLine).IsEnabled = TRUE Then
If m_arrLines(iObject, iLine).IsLast = FALSE Then
'Line (x1%, y1%)-(x2%, y2%), arrColor(arrStars(iLoop).ColorIndex), BF, lngLineStyle
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, , lngSolidLineStyle
Else
Exit For
End If
End If
Next iLine
' Draw fill color if not transparent
If m_arrObject(iObject).FillColor <> cEmpty Then
' Fill in current object with its fill color...
'PAINT [STEP] (column%, row%), fillColor[, borderColor%]
Paint (m_arrObject(iObject).x, m_arrObject(iObject).y), _
m_arrObject(iObject).FillColor, m_arrObject(iObject).PreviewColor
End If
' Make other objects appear drawn with a dashed line
If iObject <> iWhich Then
' Outline with a dashed line
For iLine = LBound(m_arrLines, 2) To UBound(m_arrLines, 2)
If m_arrLines(iObject, iLine).IsEnabled = TRUE Then
If m_arrLines(iObject, iLine).IsLast = FALSE Then
'Line (x1%, y1%)-(x2%, y2%), arrColor(arrStars(iLoop).ColorIndex), BF, lngLineStyle
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) _
, _
cBlack, , lngDashedLineStyle
Else
Exit For
End If
End If
Next iLine
End If
' Add new object to objects layer
'_PUTIMAGE , sourceHandle&, destHandle& 'size full source to fit full destination area
_PutImage , imgTemp&, imgObjects&
End If
Next iLayer
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN STARS
' Twinkle twinkle little stars
_Dest imgStars&: Cls , cEmpty
For iStarLoop = LBound(m_arrStars) To UBound(m_arrStars)
' increment twinkle counter
m_arrStars(iStarLoop).TwinkleCounter = m_arrStars(iStarLoop).TwinkleCounter + 1
' is it time to twinkle the color?
If m_arrStars(iStarLoop).TwinkleCounter > m_arrStars(iStarLoop).MaxTwinkCount Then
m_arrStars(iStarLoop).TwinkleCounter = 0 ' reset counter
m_arrStars(iStarLoop).ColorIndex = m_arrStars(iStarLoop).ColorIndex + 1 ' increment color
If m_arrStars(iStarLoop).ColorIndex > UBound(m_arrGrayColor) Then
m_arrStars(iStarLoop).ColorIndex = LBound(m_arrGrayColor) ' reset color
End If
End If
' increment width counter
If m_arrStars(iStarLoop).BigCounter = 0 Then
m_arrStars(iStarLoop).WidthCounter = m_arrStars(iStarLoop).WidthCounter + 1
' is it time to fluctuate the width
If m_arrStars(iStarLoop).WidthCounter > m_arrStars(iStarLoop).MaxWidthCount Then
m_arrStars(iStarLoop).WidthCounter = 0 ' reset counter
m_arrStars(iStarLoop).BigCounter = 1 ' start big counter
m_arrStars(iStarLoop).width = m_arrStars(iStarLoop).MinWidth ' twinkle width
Else
m_arrStars(iStarLoop).width = m_arrStars(iStarLoop).MaxWidth ' normal width
End If
Else
' increment big counter
m_arrStars(iStarLoop).BigCounter = m_arrStars(iStarLoop).BigCounter + 1
' is it time to return to normal size?
If m_arrStars(iStarLoop).BigCounter > m_arrStars(iStarLoop).MaxBigCount Then
m_arrStars(iStarLoop).BigCounter = 0 ' reset counter
m_arrStars(iStarLoop).width = m_arrStars(iStarLoop).MaxWidth ' normal width
End If
End If
' get size
x1% = m_arrStars(iStarLoop).x: x2% = x1% + m_arrStars(iStarLoop).width
y1% = m_arrStars(iStarLoop).y: y2% = y1% + m_arrStars(iStarLoop).width
' (re)draw it
Line (x1%, y1%)-(x2%, y2%), m_arrGrayColor(m_arrStars(iStarLoop).ColorIndex), BF
Next iStarLoop
' END STARS
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' SHOW TEXT
_Dest imgText&: Cls , cEmpty
DrawText sKey, iWhich
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN UPDATE SCREEN
' COPY LAYERS TO SCREEN
_Dest 0: Cls , cBlack
If imgStars& < -1 Then
_PutImage , imgStars&, 0
End If
If imgText& < -1 Then
_PutImage , imgText&, 0
End If
If imgObjects& < -1 Then
_PutImage , imgObjects&, 0
End If
' UPDATE THE SCREEN
_Display
' END UPDATE SCREEN
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' 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
iLineStyleIndex = iLineStyleIndex + 1
If iLineStyleIndex > UBound(m_arrLineStyle) Then
iLineStyleIndex = LBound(m_arrLineStyle)
End If
lngDashedLineStyle = m_arrLineStyle(iLineStyleIndex)
End If
' CLEAR KEYBOARD BUFFER
_KeyClear
' CONTROL GAME SPEED
_Limit iFPS
Wend
' END MAIN LOOP
' ================================================================================================================================================================
' 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
' CLEAR IMAGES
Screen 0
If imgStars& < -1 Then _FreeImage imgStars&
If imgText& < -1 Then _FreeImage imgText&
If imgObjects& < -1 Then _FreeImage imgObjects&
If imgTemp& < -1 Then _FreeImage imgTemp&
' RETURN TO AUTODISPLAY
_AutoDisplay
End Sub ' DrawVectorObjectTest1
' /////////////////////////////////////////////////////////////////////////////
' 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$
' /////////////////////////////////////////////////////////////////////////////
' Receives:
' String sBitPattern = 16 character string of "1" and "0"
' (a 16-bit binary representation)
' Returns the bit pattern converted to a long integer.
Function LongFromBinaryString& (sBitPattern As String)
Dim sInput As String: sInput = sBitPattern
Dim iLoop As Integer
Dim MyLong As Long
MyLong = 0
If Len(sInput) >= 16 Then
For iLoop = 0 To 15
If Mid$(sInput, 16 - iLoop, 1) = "1" Then
MyLong = MyLong + (2 ^ iLoop)
End If
Next iLoop
End If
LongFromBinaryString& = MyLong
End Function ' LongFromBinaryString&
' /////////////////////////////////////////////////////////////////////////////
' VECTOR OBJECT DEFINITIONS
' future versions will pull this data from an editable file
Sub InitVectorObjects
Dim RoutineName As String: RoutineName = "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
' CLEAR OUT EXISTING
For iObject = LBound(m_arrObject) To UBound(m_arrObject)
m_arrObject(iObject).IsEnabled = FALSE
Next iObject
For iObject = LBound(m_arrLines, 1) To UBound(m_arrLines, 1)
For iLine = LBound(m_arrLines, 2) To UBound(m_arrLines, 2)
m_arrLines(iObject, iLine).x1 = 0
m_arrLines(iObject, iLine).y1 = 0
m_arrLines(iObject, iLine).x2 = 0
m_arrLines(iObject, iLine).y2 = 0
m_arrLines(iObject, iLine).color = cEmpty
m_arrLines(iObject, iLine).IsLast = TRUE
m_arrLines(iObject, iLine).IsEnabled = FALSE
Next iLine
Next iObject
' INITIALIZE FROM SAVED
Restore VectorData
iObject = 1
iLine = 1
bEnabled = TRUE
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 ' NO MORE DATA AT ALL
If iLine <= UBound(m_arrLines, 2) Then
m_arrLines(iObject, iLine).IsEnabled = FALSE
m_arrLines(iObject, iLine).IsLast = TRUE
else
m_arrLines(iObject, UBound(m_arrLines, 2)).IsLast = TRUE
end if
m_arrObject(iObject).IsEnabled = TRUE
Exit For
ElseIf b1 = -254 Then ' NO MORE DATA FOR THIS OBJECT
If iLine <= UBound(m_arrLines, 2) Then
m_arrLines(iObject, iLine).IsEnabled = FALSE
m_arrLines(iObject, iLine).IsLast = TRUE
else
m_arrLines(iObject, UBound(m_arrLines, 2)).IsLast = TRUE
end if
m_arrObject(iObject).IsEnabled = TRUE
iObject = iObject + 1
iLine = 1
If iObject > UBound(m_arrLines, 1) Then Exit For
Else
If iLine <= UBound(m_arrLines, 2) Then
m_arrLines(iObject, iLine).IsEnabled = TRUE
m_arrLines(iObject, iLine).IsLast = FALSE
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)
iLine = iLine + 1
End If
'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,255,0,0
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,-254,-254,-254
'Data 0,0,0,0,-255,-255,-255
'test object
Data -31,-31,-31,31,255,0,0
Data -31,31,31,31,255,0,0
Data 31,31,31,-31,255,0,0
Data 31,-31,-31,-31,255,0,0
Data 0,0,0,0,-254,-254,-254
'test object
Data -31,-31,-31,31,0,0,255
Data -31,31,31,31,0,0,255
Data 31,31,31,-31,0,0,255
Data 31,-31,-31,-31,0,0,255
Data 0,0,0,0,-254,-254,-254
'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,-254,-254,-254
'Data 0,0,0,0,-255,-255,-255
'test object with max lines
Data -63,-63,63,-63,255,0,0
Data 63,-63,63,63,0,255,0
Data 63,63,-63,63,0,0,255
Data -63,63,-63,-63,255,255,0
Data -59,-59,59,-59,255,0,0
Data 59,-59,59,59,0,255,0
Data 59,59,-59,59,0,0,255
Data -59,59,-59,-59,255,255,0
Data -55,-55,55,-55,255,0,0
Data 55,-55,55,55,0,255,0
Data 55,55,-55,55,0,0,255
Data -55,55,-55,-55,255,255,0
Data -51,-51,51,-51,255,0,0
Data 51,-51,51,51,0,255,0
Data 51,51,-51,51,0,0,255
Data -51,51,-51,-51,255,255,0
Data -47,-47,47,-47,255,0,0
Data 47,-47,47,47,0,255,0
Data 47,47,-47,47,0,0,255
Data -47,47,-47,-47,255,255,0
Data -43,-43,43,-43,255,0,0
Data 43,-43,43,43,0,255,0
Data 43,43,-43,43,0,0,255
Data -43,43,-43,-43,255,255,0
Data -39,-39,39,-39,255,0,0
Data 39,-39,39,39,0,255,0
Data 39,39,-39,39,0,0,255
Data -39,39,-39,-39,255,255,0
Data -35,-35,35,-35,255,0,0
Data 35,-35,35,35,0,255,0
Data 35,35,-35,35,0,0,255
Data -35,35,-35,-35,255,255,0
Data 0,0,0,0,-254,-254,-254
'test object
Data -31,-31,-31,31,0,0,255
Data -31,31,31,31,0,0,255
Data 31,31,31,-31,0,0,255
Data 31,-31,-31,-31,0,0,255
Data 0,0,0,0,-254,-254,-254
'test object
Data -31,-31,-31,31,255,0,0
Data -31,31,31,31,255,0,0
Data 31,31,31,-31,255,0,0
Data 31,-31,-31,-31,255,0,0
Data 0,0,0,0,-254,-254,-254
'objaster0 = deep purple square
Data -63,-63,-63,63,96,0,255
Data -63,63,63,63,96,0,255
Data 63,63,63,-63,96,0,255
Data 63,-63,-63,-63,96,0,255
Data 0,0,0,0,-254,-254,-254
'test object
Data -31,-31,-31,31,0,0,255
Data -31,31,31,31,0,0,255
Data 31,31,31,-31,0,0,255
Data 31,-31,-31,-31,0,0,255
Data 0,0,0,0,-254,-254,-254
'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,-254,-254,-254
'Data 0,0,0,0,-255,-255,-255
'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,-254,-254,-254
'FINAL test object
Data -31,-31,-31,31,255,255,255
Data -31,31,31,31,255,255,255
Data 31,31,31,-31,255,255,255
Data 31,-31,-31,-31,255,255,255
Data -31,-31,31,31,255,255,255
Data 31,-31,-31,31,0,255,0
Data 0,0,0,0,-255,-255,-255
End Sub ' InitVectorObjects
' ################################################################################################################################################################
' END SIMPLE VECTOR ENGINE @VEC
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' 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
RowNum = 0
Color cWhite, cEmpty
RowNum = RowNum + 1: PrintAt RowNum, 1, m_sTitle
RowNum = RowNum + 1
Color cYellow, cEmpty
RowNum = RowNum + 1: PrintAt RowNum, 1, "----------------------------------------"
RowNum = RowNum + 1: PrintAt RowNum, 1, "Press 1-6 to select active object."
RowNum = RowNum + 1: PrintAt RowNum, 1, "Arrow keys move active object."
RowNum = RowNum + 1: PrintAt RowNum, 1, "Press ESC to quit"
RowNum = RowNum + 1: PrintAt RowNum, 1, "----------------------------------------"
RowNum = RowNum + 1
' 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_arrObject(iObject).PreviewColor, cEmpty
If iObject = iWhich Then
'Color cCyan, cEmpty
sFlag = "-> "
Else
'Color cDodgerBlue, cEmpty
sFlag = " "
End If
Else
Color cGray, cEmpty
sFlag = " "
End If
RowNum = RowNum + 1: PrintAt RowNum, 1, "" + _
sFlag + _
cstr$(iNum) + ". " + _
"obj #" + cstr$(iObject) + _
"(" + cstr$(m_arrObject(iObject).x) + "," + cstr$(m_arrObject(iObject).y) + ")" + _
"(" + cstr$(m_arrObject(iObject).dx) + "," + cstr$(m_arrObject(iObject).dy) + ")" + _
"(" + cstr$(m_arrObject(iObject).cx) + "," + cstr$(m_arrObject(iObject).cy) + ")" + _
""
Next iObject
Color cGray, cEmpty
RowNum = RowNum + 1: PrintAt RowNum, 1, "----------------------------------------"
RowNum = RowNum + 2
'' SHOW ACTIVE OBJECT
'Color cWhite
'RowNum = RowNum + 1: PrintAt RowNum, 1, "Object # : " + cstr$(iWhich)
' SHOW INPUT
Color cLime, cEmpty
RowNum = RowNum + 1: PrintAt RowNum, 1, "Controls : " + RightPadString$(sKey, 10, " ") + " "
End Sub ' DrawText
' ################################################################################################################################################################
' 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
' /////////////////////////////////////////////////////////////////////////////
Sub AddShapeColors (arrColor() As _Unsigned Long)
Dim iNum As Integer
iNum = 1
AddColors cRed, arrColor(), iNum
AddColors cOrangeRed, arrColor(), iNum
AddColors cDarkOrange, arrColor(), iNum
AddColors cOrange, arrColor(), iNum
AddColors cGold, arrColor(), iNum
AddColors cYellow, arrColor(), iNum
AddColors cChartreuse, arrColor(), iNum
AddColors cOliveDrab1, arrColor(), iNum
AddColors cLime, arrColor(), iNum
AddColors cMediumSpringGreen, arrColor(), iNum
AddColors cSpringGreen, arrColor(), iNum
AddColors cCyan, arrColor(), iNum
AddColors cDeepSkyBlue, arrColor(), iNum
AddColors cDodgerBlue, arrColor(), iNum
AddColors cSeaBlue, arrColor(), iNum
AddColors cBlue, arrColor(), iNum
AddColors cBluePurple, arrColor(), iNum
AddColors cDeepPurple, arrColor(), iNum
AddColors cPurple, arrColor(), iNum
AddColors cPurpleRed, arrColor(), iNum
AddColors cDarkRed, arrColor(), iNum
AddColors cBrickRed, arrColor(), iNum
AddColors cDarkGreen, arrColor(), iNum
AddColors cGreen, arrColor(), iNum
AddColors cOliveDrab, arrColor(), iNum
AddColors cLightPink, arrColor(), iNum
AddColors cHotPink, arrColor(), iNum
AddColors cDeepPink, arrColor(), iNum
AddColors cMagenta, arrColor(), iNum
'AddColors cBlack, arrColor(), iNum
AddColors cDimGray, arrColor(), iNum
AddColors cGray, arrColor(), iNum
AddColors cDarkGray, arrColor(), iNum
AddColors cSilver, arrColor(), iNum
AddColors cLightGray, arrColor(), iNum
AddColors cGainsboro, arrColor(), iNum
AddColors cWhiteSmoke, arrColor(), iNum
AddColors cWhite, arrColor(), iNum
AddColors cDarkBrown, arrColor(), iNum
AddColors cLightBrown, arrColor(), iNum
AddColors cKhaki, arrColor(), iNum
'AddColors cEmpty , arrColor(), iNum
End Sub ' AddShapeColors
' /////////////////////////////////////////////////////////////////////////////
Sub AddGrayscaleColors (arrColor() As _Unsigned Long)
Dim iNum As Integer
iNum = 1
AddColors cDimGray, arrColor(), iNum
AddColors cGray, arrColor(), iNum
AddColors cDarkGray, arrColor(), iNum
AddColors cSilver, arrColor(), iNum
AddColors cLightGray, arrColor(), iNum
AddColors cGainsboro, arrColor(), iNum
AddColors cWhiteSmoke, arrColor(), iNum
AddColors cWhite, arrColor(), iNum '* 2
AddColors cWhiteSmoke, arrColor(), iNum
AddColors cGainsboro, arrColor(), iNum
AddColors cLightGray, arrColor(), iNum
AddColors cSilver, arrColor(), iNum
AddColors cDarkGray, arrColor(), iNum
AddColors cGray, arrColor(), iNum
End Sub ' AddGrayscaleColors
' ################################################################################################################################################################
' END COLOR ARRAY FUNCTIONS @COLR
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN COLOR UTILITY FUNCTIONS #CUTIL
' ################################################################################################################################################################
Function ColorName$ (MyColor~&)
Dim sResult As String
If MyColor~& = cRed Then
sResult = "cRed"
ElseIf MyColor~& = cOrangeRed Then
sResult = "cOrangeRed"
ElseIf MyColor~& = cDarkOrange Then
sResult = "cDarkOrange"
ElseIf MyColor~& = cOrange Then
sResult = "cOrange"
ElseIf MyColor~& = cGold Then
sResult = "cGold"
ElseIf MyColor~& = cYellow Then
sResult = "cYellow"
ElseIf MyColor~& = cChartreuse Then
sResult = "cChartreuse"
ElseIf MyColor~& = cOliveDrab1 Then
sResult = "cOliveDrab1"
ElseIf MyColor~& = cLime Then
sResult = "cLime"
ElseIf MyColor~& = cMediumSpringGreen Then
sResult = "cMediumSpringGreen"
ElseIf MyColor~& = cSpringGreen Then
sResult = "cSpringGreen"
ElseIf MyColor~& = cCyan Then
sResult = "cCyan"
ElseIf MyColor~& = cDeepSkyBlue Then
sResult = "cDeepSkyBlue"
ElseIf MyColor~& = cDodgerBlue Then
sResult = "cDodgerBlue"
ElseIf MyColor~& = cSeaBlue Then
sResult = "cSeaBlue"
ElseIf MyColor~& = cBlue Then
sResult = "cBlue"
ElseIf MyColor~& = cBluePurple Then
sResult = "cBluePurple"
ElseIf MyColor~& = cDeepPurple Then
sResult = "cDeepPurple"
ElseIf MyColor~& = cPurple Then
sResult = "cPurple"
ElseIf MyColor~& = cPurpleRed Then
sResult = "cPurpleRed"
ElseIf MyColor~& = cDarkRed Then
sResult = "cDarkRed"
ElseIf MyColor~& = cBrickRed Then
sResult = "cBrickRed"
ElseIf MyColor~& = cDarkGreen Then
sResult = "cDarkGreen"
ElseIf MyColor~& = cGreen Then
sResult = "cGreen"
ElseIf MyColor~& = cOliveDrab Then
sResult = "cOliveDrab"
ElseIf MyColor~& = cLightPink Then
sResult = "cLightPink"
ElseIf MyColor~& = cHotPink Then
sResult = "cHotPink"
ElseIf MyColor~& = cDeepPink Then
sResult = "cDeepPink"
ElseIf MyColor~& = cMagenta Then
sResult = "cMagenta"
ElseIf MyColor~& = cBlack Then
sResult = "cBlack"
ElseIf MyColor~& = cDimGray Then
sResult = "cDimGray"
ElseIf MyColor~& = cGray Then
sResult = "cGray"
ElseIf MyColor~& = cDarkGray Then
sResult = "cDarkGray"
ElseIf MyColor~& = cSilver Then
sResult = "cSilver"
ElseIf MyColor~& = cLightGray Then
sResult = "cLightGray"
ElseIf MyColor~& = cGainsboro Then
sResult = "cGainsboro"
ElseIf MyColor~& = cWhiteSmoke Then
sResult = "cWhiteSmoke"
ElseIf MyColor~& = cWhite Then
sResult = "cWhite"
ElseIf MyColor~& = cDarkBrown Then
sResult = "cDarkBrown"
ElseIf MyColor~& = cLightBrown Then
sResult = "cLightBrown"
ElseIf MyColor~& = cKhaki Then
sResult = "cKhaki"
ElseIf MyColor~& = cEmpty Then
sResult = "cEmpty"
Else
'COLOR _RGB(_RED(S), _GREEN(S), _BLUE(S))
'r1& = _Red32(p1): g1& = _Green32(p1): b1& = _Blue32(p1): a1& = _Alpha32(p1)
sResult = "(" + _
_Trim$(Str$(_Red32(MyColor~&))) + "," + _
_Trim$(Str$(_Green32(MyColor~&))) + "," + _
_Trim$(Str$(_Blue32(MyColor~&))) + "," + _
_Trim$(Str$(_Alpha32(MyColor~&))) + _
")"
End If
ColorName$ = sResult
End Function ' ColorName$
' ################################################################################################################################################################
' END COLOR UTILITY FUNCTIONS @CUTIL
' ################################################################################################################################################################
' ################################################################################################################################################################
' 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)
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 = _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$ = _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
dblNew = RoundDouble#(dblOld, 0)
'sValue = _Trim$(Str$(dblNew))
sValue = DblToStr$(dblNew)
'iPos = InStr(1, sValue, ".")
'If iPos > 0 Then
' DblToInt% = Val(Left$(sValue, iPos - 1))
'Else
' DblToInt% = Val(sValue)
'End If
DblToInt% = Val(sValue)
End Function ' DblToInt%
' /////////////////////////////////////////////////////////////////////////////
' 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
DblToStr$ = result$
End Function ' DblToStr$
' /////////////////////////////////////////////////////////////////////////////
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
' /////////////////////////////////////////////////////////////////////////////
Sub DumpScreenAndFontSize ()
Dim iCols As Integer
Dim iRows As Integer
'Screen _NewImage(1024, 768, 32): _ScreenMove 0, 0
iCols = _Width(0) \ _FontWidth
iRows = _Height(0) \ _FontHeight
Print "_Width(0) =" + _Trim$(Str$(_Width(0)))
Print "_Height(0) =" + _Trim$(Str$(_Height(0)))
Print "_FontWidth =" + _Trim$(Str$(_FontWidth))
Print "_FontHeight=" + _Trim$(Str$(_FontHeight))
Print "iCols = _Width(0) \ _FontWidth = " + _Trim$(Str$(iCols))
Print "iRows = _Height(0) \ _FontHeight = " + _Trim$(Str$(iRows))
End Sub ' DumpScreenAndFontSize
' /////////////////////////////////////////////////////////////////////////////
' 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
' PRINT "Current date time (simple format) = " + Chr$(34) + GetCurrentDateTime$("{yyyy}-{mm}-{dd} {rr}:{nn}:{ss}") + Chr$(34)
' PRINT "Current date time (US format) = " + Chr$(34) + GetCurrentDateTime$("{mm}/{dd}/{yyyy} {hh}:{nn}:{ss} {ampm}") + Chr$(34)
' PRINT "Filename timestamp = " + Chr$(34) + GetCurrentDateTime$("{yyyy}{mm}{dd}_{rr}{nn}{ss}") + Chr$(34)
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
' POPULATE TEMPLATE
result$ = sTemplate$
result$ = Replace$(result$, "{yyyy}", sYYYY$)
result$ = Replace$(result$, "{mm}", sMM$)
result$ = Replace$(result$, "{dd}", sDD$)
result$ = Replace$(result$, "{hh}", sHH$)
result$ = Replace$(result$, "{rr}", sHH24$)
result$ = Replace$(result$, "{nn}", sMI$)
result$ = Replace$(result$, "{ss}", sSS$)
result$ = Replace$(result$, "{ampm}", sAMPM$)
' 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
ReDim arrInteger(-1) As Integer
'DebugPrint "GetIntegerArrayFromDelimList " + _
' "MyString=" + chr$(34) + MyString + chr$(34) + ", " + _
' "sDelimiter=" + chr$(34) + sDelimiter + chr$(34) + ", " + _
' "iMinIndex=" + cstr$(iMinIndex) + ", " + _
' "arrInteger()"
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)
result& = result& + Val(sSS$)
result& = result& + (Val(sMI$) * 60)
result& = result& + ((Val(sHH24$) * 60) * 60)
' RETURN RESULT
GetTimeSeconds& = result&
End Function ' GetTimeSeconds&
' /////////////////////////////////////////////////////////////////////////////
' IIF function for QB for integers
Function IIF (Condition, IfTrue, IfFalse)
If Condition Then IIF = IfTrue Else IIF = IfFalse
End Function
' /////////////////////////////////////////////////////////////////////////////
' IIF function for QB for strings
Function IIFSTR$ (Condition, IfTrue$, IfFalse$)
If Condition Then IIFSTR$ = IfTrue$ Else IIFSTR$ = IfFalse$
End Function
' /////////////////////////////////////////////////////////////////////////////
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%
' /////////////////////////////////////////////////////////////////////////////
'Sub IsNumberTest
' Dim in$
' Cls
' IsNumberTest1 "1"
' IsNumberTest1 "01"
' IsNumberTest1 "001"
' IsNumberTest1 "-1"
' IsNumberTest1 "-01"
' IsNumberTest1 "-001"
' IsNumberTest1 "+1"
' IsNumberTest1 "+01"
' IsNumberTest1 "+001"
' IsNumberTest1 ".1"
' IsNumberTest1 ".01"
' IsNumberTest1 ".001"
' IsNumberTest1 ".10"
' IsNumberTest1 ".100"
' IsNumberTest1 "..100"
' IsNumberTest1 "100."
' Input "PRESS ENTER TO CONTINUE TEST";in$
' Cls
' IsNumberTest1 "0.10"
' IsNumberTest1 "00.100"
' IsNumberTest1 "000.1000"
' IsNumberTest1 "000..1000"
' IsNumberTest1 "000.1000.00"
' IsNumberTest1 "+1.00"
' IsNumberTest1 "++1.00"
' IsNumberTest1 "+-1.00"
' IsNumberTest1 "-1.00"
' IsNumberTest1 "-+1.00"
' IsNumberTest1 " 1"
' IsNumberTest1 "1 "
' IsNumberTest1 "1. 01"
' IsNumberTest1 "+1 "
'End Sub ' IsNumberTest
'Sub IsNumberTest1(MyString As String)
' Const cWidth = 16
' Dim sInput As String : sInput = left$(Chr$(34) + MyString + Chr$(34) + String$(cWidth, " "), cWidth)
' Dim sResult As String : sResult = right$(String$(2, " ") + _Trim$(Str$(IsNumber%(MyString))), 2)
' Print "IsNumber%(" + sInput + ") returns " + sResult
'End Sub ' IsNumberTest1
' /////////////////////////////////////////////////////////////////////////////
' 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$
' /////////////////////////////////////////////////////////////////////////////
' Pauses for iDS deciseconds (iDS * 100 ms)
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.
' Example:
' ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
' ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' sFileName = ProgramPath$ + ProgramName$ + ".OUT.txt"
' sText = "This is a test." + chr$(13) + "Here is line 2." + chr$(13) + "End."
' sError = PrintFile$(sFileName, sText, FALSE)
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
sPrompt1$ = Replace$(sPrompt1$, "{min}", cstr$(iMin%))
sPrompt1$ = Replace$(sPrompt1$, "{max}", cstr$(iMax%))
bFinished% = FALSE
Do
Print sPrompt1$
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$
sFileName = "c:\temp\maze_test_1.txt"
sText = "Count" + Chr$(9) + "Min" + Chr$(9) + "Max" + Chr$(9) + "Random"
bAppend = FALSE
sError = PrintFile$(sFileName, sText, bAppend)
If Len(sError) = 0 Then
bAppend = TRUE
iErrorCount = 0
iMin = 0
iMax = iCols - 1
For iLoop = 1 To 100
iNum = RandomNumber%(iMin, iMax)
sText = Str$(iLoop) + Chr$(9) + Str$(iMin) + Chr$(9) + Str$(iMax) + Chr$(9) + Str$(iNum)
sError = PrintFile$(sFileName, sText, bAppend)
If Len(sError) > 0 Then
iErrorCount = iErrorCount + 1
Print Str$(iLoop) + ". ERROR"
Print " " + "iMin=" + Str$(iMin)
Print " " + "iMax=" + Str$(iMax)
Print " " + "iNum=" + Str$(iNum)
Print " " + "Could not write to file " + Chr$(34) + sFileName + Chr$(34) + "."
Print " " + sError
End If
Next iLoop
iMin = 0
iMax = iRows - 1
For iLoop = 1 To 100
iNum = RandomNumber%(iMin, iMax)
sText = Str$(iLoop) + Chr$(9) + Str$(iMin) + Chr$(9) + Str$(iMax) + Chr$(9) + Str$(iNum)
sError = PrintFile$(sFileName, sText, bAppend)
If Len(sError) > 0 Then
iErrorCount = iErrorCount + 1
Print Str$(iLoop) + ". ERROR"
Print " " + "iMin=" + Str$(iMin)
Print " " + "iMax=" + Str$(iMax)
Print " " + "iNum=" + Str$(iNum)
Print " " + "Could not write to file " + Chr$(34) + sFileName + Chr$(34) + "."
Print " " + sError
End If
Next iLoop
Print "Finished generating numbers. Errors: " + Str$(iErrorCount)
Else
Print "Error creating file " + Chr$(34) + sFileName + Chr$(34) + "."
Print sError
End If
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))))
' Return the substring:
Text2 = strBefore + Add2 + strAfter
' Locate the next instance of [Find2]:
lngLocation = InStr(1, Text2, Find2)
' Next instance of [Find2]...
Wend
' OUTPUT:
Replace$ = Text2
End Function ' Replace$
' /////////////////////////////////////////////////////////////////////////////
$If Then
Sub ReplaceTest
Dim in$
Print "-------------------------------------------------------------------------------"
Print "ReplaceTest"
Print
Print "Original value"
in$ = "Thiz iz a teZt."
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print
Print "Replacing lowercase " + Chr$(34) + "z" + Chr$(34) + " with " + Chr$(34) + "s" + Chr$(34) + "..."
in$ = Replace$(in$, "z", "s")
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print
Print "Replacing uppercase " + Chr$(34) + "Z" + Chr$(34) + " with " + Chr$(34) + "s" + Chr$(34) + "..."
in$ = Replace$(in$, "Z", "s")
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print
Print "ReplaceTest finished."
End Sub ' ReplaceTest
$End If
' /////////////////////////////////////////////////////////////////////////////
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
SetBit256% = iResult
End Function ' SetBit256%
' /////////////////////////////////////////////////////////////////////////////
$If Then
Sub ShowDegreesAndRadians
Dim iDegree As Integer
Dim sngRadian As Single
DebugPrint "Degree Radian"
DebugPrint "------ ------"
For iDegree = 0 To 360
sngRadian = _D2R(iDegree)
'DebugPrint LeftPadString$(cstr$(iDegree), 3, " ") + " " + LeftPadString$(cstr$(iRadian), 3, " ")
DebugPrint LeftPadString$(cstr$(iDegree), 3, " ") + " " + SngToStr$(sngRadian)
'Print "SngToStr$(MyValue) =" + SngToStr$(MyValue)
'Print "SngRoundedToStr$(MyValue, 12)=" + SngRoundedToStr$(MyValue, 12)
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
sngNew = RoundSingle!(sngOld, 0)
'sValue = _Trim$(Str$(sngNew))
sValue = SngToStr$(sngNew)
'iPos = InStr(1, sValue, ".")
'If iPos > 0 Then
' SngToInt% = Val(Left$(sValue, iPos - 1))
'Else
' SngToInt% = Val(sValue)
'End If
SngToInt% = Val(sValue)
End Function ' SngToInt%
' /////////////////////////////////////////////////////////////////////////////
' 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
' /////////////////////////////////////////////////////////////////////////////
$If Then
Sub SplitTest
Dim in$
Dim delim$
ReDim arrTest$(0)
Dim iLoop%
delim$ = Chr$(10)
in$ = "this" + delim$ + "is" + delim$ + "a" + delim$ + "test"
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print "delim$ = " + Chr$(34) + delim$ + Chr$(34)
split in$, delim$, arrTest$()
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
' /////////////////////////////////////////////////////////////////////////////
$If Then
Sub SplitAndReplaceTest
Dim in$
Dim out$
Dim iLoop%
ReDim arrTest$(0)
Print "-------------------------------------------------------------------------------"
Print "SplitAndReplaceTest"
Print
Print "Original value"
in$ = "This line 1 " + Chr$(13) + Chr$(10) + "and line 2" + Chr$(10) + "and line 3 " + Chr$(13) + "finally THE END."
out$ = in$
out$ = Replace$(out$, Chr$(13), "\r")
out$ = Replace$(out$, Chr$(10), "\n")
out$ = Replace$(out$, Chr$(9), "\t")
Print "in$ = " + Chr$(34) + out$ + Chr$(34)
Print
Print "Fixing linebreaks..."
in$ = Replace$(in$, Chr$(13) + Chr$(10), Chr$(13))
in$ = Replace$(in$, Chr$(10), Chr$(13))
out$ = in$
out$ = Replace$(out$, Chr$(13), "\r")
out$ = Replace$(out$, Chr$(10), "\n")
out$ = Replace$(out$, Chr$(9), "\t")
Print "in$ = " + Chr$(34) + out$ + Chr$(34)
Print
Print "Splitting up..."
split in$, Chr$(13), arrTest$()
For iLoop% = LBound(arrTest$) To UBound(arrTest$)
out$ = arrTest$(iLoop%)
out$ = Replace$(out$, Chr$(13), "\r")
out$ = Replace$(out$, Chr$(10), "\n")
out$ = Replace$(out$, Chr$(9), "\t")
Print "arrTest$(" + cstr$(iLoop%) + ") = " + Chr$(34) + out$ + Chr$(34)
Next iLoop%
Print
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 StrPadLeft$ (sValue As String, iWidth As Integer)
StrPadLeft$ = Right$(String$(iWidth, " ") + sValue, iWidth)
End Function ' StrPadLeft$
' /////////////////////////////////////////////////////////////////////////////
Function StrJustifyRight$ (sValue As String, iWidth As Integer)
StrJustifyRight$ = Right$(String$(iWidth, " ") + sValue, iWidth)
End Function ' StrJustifyRight$
' /////////////////////////////////////////////////////////////////////////////
Function StrPadRight$ (sValue As String, iWidth As Integer)
StrPadRight$ = Left$(sValue + String$(iWidth, " "), iWidth)
End Function ' StrPadRight$
' /////////////////////////////////////////////////////////////////////////////
Function StrJustifyLeft$ (sValue As String, iWidth As Integer)
StrJustifyLeft$ = Left$(sValue + String$(iWidth, " "), iWidth)
End Function ' StrJustifyLeft$
' /////////////////////////////////////////////////////////////////////////////
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%
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 DEBUGGING ROUTINES #DEBUG
' ################################################################################################################################################################
Sub DebugPrint (MyString As String)
If m_bDebug = TRUE Then
'_Echo MyString
ReDim arrLines(-1) As String
Dim iLoop As Integer
split MyString, Chr$(13), arrLines()
For iLoop = LBound(arrLines) To UBound(arrLines)
_Echo arrLines(iLoop)
Next iLoop
End If
End Sub ' DebugPrint
' same as DebugPrint but includes a timestamp
Sub DebugPrintTS (MyString As String)
If m_bDebug = TRUE Then
'_Echo MyString
ReDim arrLines(-1) As String
Dim iLoop As Integer
Dim sTimeStamp As String
sTimeStamp = GetCurrentDateTime$("{mm}/{dd}/{yyyy} {hh}:{nn}:{ss} {ampm}")
split MyString, Chr$(13), arrLines()
For iLoop = LBound(arrLines) To UBound(arrLines)
_Echo sTimeStamp + " " + arrLines(iLoop)
Next iLoop
End If
End Sub ' DebugPrintTS
'' /////////////////////////////////////////////////////////////////////////////
'
'Sub DebugPause (sPrompt As String, iRow As Integer, iColumn As Integer, fgColor As _Unsigned Long, bgColor As _Unsigned Long)
' Color fgColor, bgColor
'
' PrintString iRow, iColumn, String$(128, " ")
'
' PrintString iRow, iColumn, sPrompt
' Sleep
' '_KEYCLEAR: _DELAY 1
' 'DO
' 'LOOP UNTIL _KEYDOWN(13) ' leave loop when ENTER key pressed
' '_KEYCLEAR: _DELAY 1
'End Sub ' DebugPause
'
'' /////////////////////////////////////////////////////////////////////////////
'
'Sub DebugOut (sPrompt As String, iRow As Integer, iColumn As Integer, fgColor As _Unsigned Long, bgColor As _Unsigned Long)
' Color fgColor, bgColor
' PrintString iRow, iColumn, String$(128, " ")
' PrintString iRow, iColumn, sPrompt
'End Sub ' DebugOut
' ################################################################################################################################################################
' END DEBUGGING ROUTINES @DEBUG
' ################################################################################################################################################################
' ################################################################################################################################################################
' 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
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%
' Screen _NewImage(1024, 768, 32): _ScreenMove 0, 0
' iCols = _Width(0) \ _FontWidth
' iRows = _Height(0) \ _FontHeight
' Print "_Width(0) =" + _Trim$(Str$(_Width(0)))
' Print "_Height(0) =" + _Trim$(Str$(_Height(0)))
' Print "_FontWidth =" + _Trim$(Str$(_FontWidth))
' Print "_FontHeight=" + _Trim$(Str$(_FontHeight))
' Print "iCols = _Width(0) \ _FontWidth = " + _Trim$(Str$(iCols))
' Print "iRows = _Height(0) \ _FontHeight = " + _Trim$(Str$(iRows))
$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
' ################################################################################################################################################################
'#ENDCode: (Select All)
Dim Shared m_sTitle As String: m_sTitle = "2D Vector Shapes v0.33 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)
' * fix twinkling stars
' TO DO:
' * 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
' BOOLEAN CONSTANTS
Const FALSE = 0
Const TRUE = Not FALSE
' OTHER SETTINGS
Const cFPS = 120
Const cMinStars = 50
Const cMaxStars = 150
Const cSpeed = 2
' 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
z As Integer ' zorder in which object is stacked (in front of or behind other objects)
FillColor As _Unsigned Long ' color to fill in object with (use cEmpty for transparent)
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_arrOrder(1 To 6) As Integer
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 iLayer As Integer
Dim iLine As Integer
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 iLineStyleIndex As Integer
Dim lngLineStyle ' line style
Dim lngDashedLineStyle ' line style for other objects
Dim lngSolidLineStyle ' selected object's line style
Dim iNumStars As Integer
Dim iValue As Integer
Dim iMinValue As Integer
Dim iMaxValue As Integer
Dim iStarLoop As Integer
Dim x1%
Dim x2%
Dim y1%
Dim y2%
Dim imgStars& ' used for drawing background
Dim imgText& ' used for drawing text
Dim imgObjects& ' used for drawing objects
Dim imgTemp& ' temporary drawing area
' =============================================================================
' INITIALIZE
InitializeRandom
Screen _NewImage(iMaxX, iMaxY, 32) ' 100 text columns x 40 text rows
' USE LATER FOR DRAWING LAYERS:
imgStars& = _NewImage(iMaxX, iMaxY, 32) ' background stars
imgText& = _NewImage(iMaxX, iMaxY, 32) ' text
imgObjects& = _NewImage(iMaxX, iMaxY, 32) ' frontground objects
imgTemp& = _NewImage(iMaxX, iMaxY, 32) ' temporary
' =============================================================================
' START NEW GAME
Do
_KeyClear
' CONFIGURE PRINTING FOR _PrintString
_PrintMode _FillBackground
'_PrintMode _KEEPBACKGROUND
' INIT OBJECT DEFINITIONS
InitVectorObjects
' INIT VARS
sKey = ""
' PLACE OBJECTS
iX = 0: iY = 0
iValue = UBound(m_arrObject)
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
m_arrObject(iObject).z = iValue
m_arrObject(iObject).FillColor = cBlack
iX = iX + 200
If iX > 800 Then
iX = 0
iY = iY + 200
If iY > 640 Then
iY = 0
End If
End If
iValue = iValue - 1
Next iObject
' INIT OBJECT Z-ORDER ARRAY
ReDim m_arrOrder(LBound(m_arrObject) To UBound(m_arrObject)) As Integer
For iObject = LBound(m_arrObject) To UBound(m_arrObject)
m_arrOrder(m_arrObject(iObject).z) = iObject
Next iObject
' SAVE LINE STYLE SEQUENCE
iLoop = 0
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 61680 ' 1111000011110000
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 30840 ' 0111100001111000
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 15420 ' 0011110000111100
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 7710 ' 0001111000011110
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 3855 ' 0000111100001111
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 34695 ' 1000011110000111
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 50115 ' 1100001111000011
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 57825 ' 1110000111100001
iLineStyleIndex = LBound(m_arrLineStyle)
lngDashedLineStyle = m_arrLineStyle(iLineStyleIndex)
lngSolidLineStyle = 65535
' 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
' ================================================================================================================================================================
' BEGIN MAIN LOOP
While TRUE = TRUE
' CLEAR OBJECTS LAYER
_Dest imgObjects&: Cls , cEmpty
' MOVE AND ADD ENABLED OBJECTS (IN STACKING ORDER)
For iLayer = UBound(m_arrOrder) To LBound(m_arrOrder) Step -1
' Get next object
iObject = m_arrOrder(iLayer)
' 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 - cSpeed
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 + cSpeed
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 - cSpeed
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 + cSpeed
If m_arrObject(iObject).y > iMaxY Then
m_arrObject(iObject).y = iMinY
End If
End If
End If
' Clear temporary (layer and draw on it
_Dest imgTemp&: Cls , cEmpty
' Draw object's line segments
For iLine = LBound(m_arrLines, 2) To UBound(m_arrLines, 2)
If m_arrLines(iObject, iLine).IsLast = FALSE Then
'Line (x1%, y1%)-(x2%, y2%), arrColor(arrStars(iLoop).ColorIndex), BF, lngLineStyle
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, , lngSolidLineStyle
Else
Exit For
End If
Next iLine
' Draw fill color if not transparent
If m_arrObject(iObject).FillColor <> cEmpty Then
' Fill in current object with its fill color...
'PAINT [STEP] (column%, row%), fillColor[, borderColor%]
Paint (m_arrObject(iObject).x, m_arrObject(iObject).y), _
m_arrObject(iObject).FillColor, m_arrColor(iObject)
End If
' Make other objects appear drawn with a dashed line
If iObject <> iWhich Then
' Outline with a dashed line
For iLine = LBound(m_arrLines, 2) To UBound(m_arrLines, 2)
If m_arrLines(iObject, iLine).IsLast = FALSE Then
'Line (x1%, y1%)-(x2%, y2%), arrColor(arrStars(iLoop).ColorIndex), BF, lngLineStyle
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) _
, _
cBlack, , lngDashedLineStyle
Else
Exit For
End If
Next iLine
End If
' Add new object to objects layer
'_PUTIMAGE , sourceHandle&, destHandle& 'size full source to fit full destination area
_PutImage , imgTemp&, imgObjects&
End If
Next iLayer
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN STARS
' Twinkle twinkle little stars
_Dest imgStars&: Cls , cEmpty
For iStarLoop = LBound(m_arrStars) To UBound(m_arrStars)
' increment twinkle counter
m_arrStars(iStarLoop).TwinkleCounter = m_arrStars(iStarLoop).TwinkleCounter + 1
' is it time to twinkle the color?
If m_arrStars(iStarLoop).TwinkleCounter > m_arrStars(iStarLoop).MaxTwinkCount Then
m_arrStars(iStarLoop).TwinkleCounter = 0 ' reset counter
m_arrStars(iStarLoop).ColorIndex = m_arrStars(iStarLoop).ColorIndex + 1 ' increment color
If m_arrStars(iStarLoop).ColorIndex > UBound(m_arrGrayColor) Then
m_arrStars(iStarLoop).ColorIndex = LBound(m_arrGrayColor) ' reset color
End If
End If
' increment width counter
If m_arrStars(iStarLoop).BigCounter = 0 Then
m_arrStars(iStarLoop).WidthCounter = m_arrStars(iStarLoop).WidthCounter + 1
' is it time to fluctuate the width
If m_arrStars(iStarLoop).WidthCounter > m_arrStars(iStarLoop).MaxWidthCount Then
m_arrStars(iStarLoop).WidthCounter = 0 ' reset counter
m_arrStars(iStarLoop).BigCounter = 1 ' start big counter
m_arrStars(iStarLoop).width = m_arrStars(iStarLoop).MinWidth ' twinkle width
Else
m_arrStars(iStarLoop).width = m_arrStars(iStarLoop).MaxWidth ' normal width
End If
Else
' increment big counter
m_arrStars(iStarLoop).BigCounter = m_arrStars(iStarLoop).BigCounter + 1
' is it time to return to normal size?
If m_arrStars(iStarLoop).BigCounter > m_arrStars(iStarLoop).MaxBigCount Then
m_arrStars(iStarLoop).BigCounter = 0 ' reset counter
m_arrStars(iStarLoop).width = m_arrStars(iStarLoop).MaxWidth ' normal width
End If
End If
' get size
x1% = m_arrStars(iStarLoop).x: x2% = x1% + m_arrStars(iStarLoop).width
y1% = m_arrStars(iStarLoop).y: y2% = y1% + m_arrStars(iStarLoop).width
' (re)draw it
Line (x1%, y1%)-(x2%, y2%), m_arrGrayColor(m_arrStars(iStarLoop).ColorIndex), BF
Next iStarLoop
' END STARS
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' SHOW TEXT
_Dest imgText&: Cls , cEmpty
DrawText sKey, iWhich
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN UPDATE SCREEN
' COPY LAYERS TO SCREEN
_Dest 0: Cls , cBlack
If imgStars& < -1 Then
_PutImage , imgStars&, 0
End If
If imgText& < -1 Then
_PutImage , imgText&, 0
End If
If imgObjects& < -1 Then
_PutImage , imgObjects&, 0
End If
' UPDATE THE SCREEN
_Display
' END UPDATE SCREEN
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' 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
iLineStyleIndex = iLineStyleIndex + 1
If iLineStyleIndex > UBound(m_arrLineStyle) Then
iLineStyleIndex = LBound(m_arrLineStyle)
End If
lngDashedLineStyle = m_arrLineStyle(iLineStyleIndex)
End If
' CLEAR KEYBOARD BUFFER
_KeyClear
' CONTROL GAME SPEED
_Limit iFPS
Wend
' END MAIN LOOP
' ================================================================================================================================================================
' 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
' CLEAR IMAGES
Screen 0
If imgStars& < -1 Then _FreeImage imgStars&
If imgText& < -1 Then _FreeImage imgText&
If imgObjects& < -1 Then _FreeImage imgObjects&
If imgTemp& < -1 Then _FreeImage imgTemp&
' RETURN TO AUTODISPLAY
_AutoDisplay
End Sub ' DrawVectorObjectTest1
' /////////////////////////////////////////////////////////////////////////////
' 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$
' /////////////////////////////////////////////////////////////////////////////
' Receives:
' String sBitPattern = 16 character string of "1" and "0"
' (a 16-bit binary representation)
' Returns the bit pattern converted to a long integer.
Function LongFromBinaryString& (sBitPattern As String)
Dim sInput As String: sInput = sBitPattern
Dim iLoop As Integer
Dim MyLong As Long
MyLong = 0
If Len(sInput) >= 16 Then
For iLoop = 0 To 15
If Mid$(sInput, 16 - iLoop, 1) = "1" Then
MyLong = MyLong + (2 ^ iLoop)
End If
Next iLoop
End If
LongFromBinaryString& = MyLong
End Function ' LongFromBinaryString&
' /////////////////////////////////////////////////////////////////////////////
' VECTOR OBJECT DEFINITIONS
' 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
End Sub ' InitVectorObjects
' /////////////////////////////////////////////////////////////////////////////
' 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
RowNum = 0
Color cWhite, cEmpty
RowNum = RowNum + 1: PrintAt RowNum, 1, m_sTitle
RowNum = RowNum + 1
Color cYellow, cEmpty
RowNum = RowNum + 1: PrintAt RowNum, 1, "----------------------------------------"
RowNum = RowNum + 1: PrintAt RowNum, 1, "Press 1-6 to select active object."
RowNum = RowNum + 1: PrintAt RowNum, 1, "Arrow keys move active object."
RowNum = RowNum + 1: PrintAt RowNum, 1, "Press ESC to quit"
RowNum = RowNum + 1: PrintAt RowNum, 1, "----------------------------------------"
RowNum = RowNum + 1
' 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
RowNum = RowNum + 1: PrintAt RowNum, 1, "" + _
sFlag + _
cstr$(iNum) + ". " + _
"obj #" + cstr$(iObject) + _
"(" + cstr$(m_arrObject(iObject).x) + "," + cstr$(m_arrObject(iObject).y) + ")" + _
"(" + cstr$(m_arrObject(iObject).dx) + "," + cstr$(m_arrObject(iObject).dy) + ")" + _
"(" + cstr$(m_arrObject(iObject).cx) + "," + cstr$(m_arrObject(iObject).cy) + ")" + _
""
Next iObject
Color cGray, cEmpty
RowNum = RowNum + 1: PrintAt RowNum, 1, "----------------------------------------"
RowNum = RowNum + 2
'' SHOW ACTIVE OBJECT
'Color cWhite
'RowNum = RowNum + 1: PrintAt RowNum, 1, "Object # : " + cstr$(iWhich)
' SHOW INPUT
Color cLime, cEmpty
RowNum = RowNum + 1: PrintAt RowNum, 1, "Controls : " + RightPadString$(sKey, 10, " ") + " "
End Sub ' DrawText
' ################################################################################################################################################################
' 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
' /////////////////////////////////////////////////////////////////////////////
Sub AddGrayscaleColors (arrColor() As _Unsigned Long)
Dim iNum As Integer
iNum = 1
AddColors cDimGray, arrColor(), iNum
AddColors cGray, arrColor(), iNum
AddColors cDarkGray, arrColor(), iNum
AddColors cSilver, arrColor(), iNum
AddColors cLightGray, arrColor(), iNum
AddColors cGainsboro, arrColor(), iNum
AddColors cWhiteSmoke, arrColor(), iNum
AddColors cWhite, arrColor(), iNum '* 2
AddColors cWhiteSmoke, arrColor(), iNum
AddColors cGainsboro, arrColor(), iNum
AddColors cLightGray, arrColor(), iNum
AddColors cSilver, arrColor(), iNum
AddColors cDarkGray, arrColor(), iNum
AddColors cGray, arrColor(), iNum
End Sub ' AddGrayscaleColors
' ################################################################################################################################################################
' 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)
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 = _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
dblNew = RoundDouble#(dblOld, 0)
'sValue = _Trim$(Str$(dblNew))
sValue = DblToStr$(dblNew)
'iPos = InStr(1, sValue, ".")
'If iPos > 0 Then
' DblToInt% = Val(Left$(sValue, iPos - 1))
'Else
' DblToInt% = Val(sValue)
'End If
DblToInt% = Val(sValue)
End Function ' DblToInt%
' /////////////////////////////////////////////////////////////////////////////
' 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
DblToStr$ = result$
End Function ' DblToStr$
' /////////////////////////////////////////////////////////////////////////////
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
' /////////////////////////////////////////////////////////////////////////////
Sub DumpScreenAndFontSize ()
Dim iCols As Integer
Dim iRows As Integer
'Screen _NewImage(1024, 768, 32): _ScreenMove 0, 0
iCols = _Width(0) \ _FontWidth
iRows = _Height(0) \ _FontHeight
Print "_Width(0) =" + _Trim$(Str$(_Width(0)))
Print "_Height(0) =" + _Trim$(Str$(_Height(0)))
Print "_FontWidth =" + _Trim$(Str$(_FontWidth))
Print "_FontHeight=" + _Trim$(Str$(_FontHeight))
Print "iCols = _Width(0) \ _FontWidth = " + _Trim$(Str$(iCols))
Print "iRows = _Height(0) \ _FontHeight = " + _Trim$(Str$(iRows))
End Sub ' DumpScreenAndFontSize
' /////////////////////////////////////////////////////////////////////////////
' 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
' PRINT "Current date time (simple format) = " + Chr$(34) + GetCurrentDateTime$("{yyyy}-{mm}-{dd} {rr}:{nn}:{ss}") + Chr$(34)
' PRINT "Current date time (US format) = " + Chr$(34) + GetCurrentDateTime$("{mm}/{dd}/{yyyy} {hh}:{nn}:{ss} {ampm}") + Chr$(34)
' PRINT "Filename timestamp = " + Chr$(34) + GetCurrentDateTime$("{yyyy}{mm}{dd}_{rr}{nn}{ss}") + Chr$(34)
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
' POPULATE TEMPLATE
result$ = sTemplate$
result$ = Replace$(result$, "{yyyy}", sYYYY$)
result$ = Replace$(result$, "{mm}", sMM$)
result$ = Replace$(result$, "{dd}", sDD$)
result$ = Replace$(result$, "{hh}", sHH$)
result$ = Replace$(result$, "{rr}", sHH24$)
result$ = Replace$(result$, "{nn}", sMI$)
result$ = Replace$(result$, "{ss}", sSS$)
result$ = Replace$(result$, "{ampm}", sAMPM$)
' 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
ReDim arrInteger(-1) As Integer
'DebugPrint "GetIntegerArrayFromDelimList " + _
' "MyString=" + chr$(34) + MyString + chr$(34) + ", " + _
' "sDelimiter=" + chr$(34) + sDelimiter + chr$(34) + ", " + _
' "iMinIndex=" + cstr$(iMinIndex) + ", " + _
' "arrInteger()"
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)
result& = result& + VAL(sSS$)
result& = result& + (VAL(sMI$) * 60)
result& = result& + ( (VAL(sHH24$) * 60) * 60)
' RETURN RESULT
GetTimeSeconds& = result&
End Function ' GetTimeSeconds&
' /////////////////////////////////////////////////////////////////////////////
' IIF function for QB for integers
Function IIF (Condition, IfTrue, IfFalse)
If Condition Then IIF = IfTrue Else IIF = IfFalse
End Function
' /////////////////////////////////////////////////////////////////////////////
' IIF function for QB for strings
Function IIFSTR$ (Condition, IfTrue$, IfFalse$)
If Condition Then IIFSTR$ = IfTrue$ Else IIFSTR$ = IfFalse$
End Function
' /////////////////////////////////////////////////////////////////////////////
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%
' /////////////////////////////////////////////////////////////////////////////
'Sub IsNumberTest
' Dim in$
' Cls
' IsNumberTest1 "1"
' IsNumberTest1 "01"
' IsNumberTest1 "001"
' IsNumberTest1 "-1"
' IsNumberTest1 "-01"
' IsNumberTest1 "-001"
' IsNumberTest1 "+1"
' IsNumberTest1 "+01"
' IsNumberTest1 "+001"
' IsNumberTest1 ".1"
' IsNumberTest1 ".01"
' IsNumberTest1 ".001"
' IsNumberTest1 ".10"
' IsNumberTest1 ".100"
' IsNumberTest1 "..100"
' IsNumberTest1 "100."
' Input "PRESS ENTER TO CONTINUE TEST";in$
' Cls
' IsNumberTest1 "0.10"
' IsNumberTest1 "00.100"
' IsNumberTest1 "000.1000"
' IsNumberTest1 "000..1000"
' IsNumberTest1 "000.1000.00"
' IsNumberTest1 "+1.00"
' IsNumberTest1 "++1.00"
' IsNumberTest1 "+-1.00"
' IsNumberTest1 "-1.00"
' IsNumberTest1 "-+1.00"
' IsNumberTest1 " 1"
' IsNumberTest1 "1 "
' IsNumberTest1 "1. 01"
' IsNumberTest1 "+1 "
'End Sub ' IsNumberTest
'Sub IsNumberTest1(MyString As String)
' Const cWidth = 16
' Dim sInput As String : sInput = left$(Chr$(34) + MyString + Chr$(34) + String$(cWidth, " "), cWidth)
' Dim sResult As String : sResult = right$(String$(2, " ") + _Trim$(Str$(IsNumber%(MyString))), 2)
' Print "IsNumber%(" + sInput + ") returns " + sResult
'End Sub ' IsNumberTest1
' /////////////////////////////////////////////////////////////////////////////
' 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$
' /////////////////////////////////////////////////////////////////////////////
' Pauses for iDS deciseconds (iDS * 100 ms)
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.
' Example:
' ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
' ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' sFileName = ProgramPath$ + ProgramName$ + ".OUT.txt"
' sText = "This is a test." + chr$(13) + "Here is line 2." + chr$(13) + "End."
' sError = PrintFile$(sFileName, sText, FALSE)
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
sPrompt1$ = Replace$(sPrompt1$, "{min}", cstr$(iMin%))
sPrompt1$ = Replace$(sPrompt1$, "{max}", cstr$(iMax%))
bFinished% = FALSE
Do
Print sPrompt1$
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$
sFileName = "c:\temp\maze_test_1.txt"
sText = "Count" + Chr$(9) + "Min" + Chr$(9) + "Max" + Chr$(9) + "Random"
bAppend = FALSE
sError = PrintFile$(sFileName, sText, bAppend)
If Len(sError) = 0 Then
bAppend = TRUE
iErrorCount = 0
iMin = 0
iMax = iCols - 1
For iLoop = 1 To 100
iNum = RandomNumber%(iMin, iMax)
sText = Str$(iLoop) + Chr$(9) + Str$(iMin) + Chr$(9) + Str$(iMax) + Chr$(9) + Str$(iNum)
sError = PrintFile$(sFileName, sText, bAppend)
If Len(sError) > 0 Then
iErrorCount = iErrorCount + 1
Print Str$(iLoop) + ". ERROR"
Print " " + "iMin=" + Str$(iMin)
Print " " + "iMax=" + Str$(iMax)
Print " " + "iNum=" + Str$(iNum)
Print " " + "Could not write to file " + Chr$(34) + sFileName + Chr$(34) + "."
Print " " + sError
End If
Next iLoop
iMin = 0
iMax = iRows - 1
For iLoop = 1 To 100
iNum = RandomNumber%(iMin, iMax)
sText = Str$(iLoop) + Chr$(9) + Str$(iMin) + Chr$(9) + Str$(iMax) + Chr$(9) + Str$(iNum)
sError = PrintFile$(sFileName, sText, bAppend)
If Len(sError) > 0 Then
iErrorCount = iErrorCount + 1
Print Str$(iLoop) + ". ERROR"
Print " " + "iMin=" + Str$(iMin)
Print " " + "iMax=" + Str$(iMax)
Print " " + "iNum=" + Str$(iNum)
Print " " + "Could not write to file " + Chr$(34) + sFileName + Chr$(34) + "."
Print " " + sError
End If
Next iLoop
Print "Finished generating numbers. Errors: " + Str$(iErrorCount)
Else
Print "Error creating file " + Chr$(34) + sFileName + Chr$(34) + "."
Print sError
End If
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))))
' Return the substring:
Text2 = strBefore + Add2 + strAfter
' Locate the next instance of [Find2]:
lngLocation = InStr(1, Text2, Find2)
' Next instance of [Find2]...
Wend
' OUTPUT:
Replace$ = Text2
End Function ' Replace$
' /////////////////////////////////////////////////////////////////////////////
$If Then
Sub ReplaceTest
Dim in$
Print "-------------------------------------------------------------------------------"
Print "ReplaceTest"
Print
Print "Original value"
in$ = "Thiz iz a teZt."
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print
Print "Replacing lowercase " + Chr$(34) + "z" + Chr$(34) + " with " + Chr$(34) + "s" + Chr$(34) + "..."
in$ = Replace$(in$, "z", "s")
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print
Print "Replacing uppercase " + Chr$(34) + "Z" + Chr$(34) + " with " + Chr$(34) + "s" + Chr$(34) + "..."
in$ = Replace$(in$, "Z", "s")
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print
Print "ReplaceTest finished."
End Sub ' ReplaceTest
$End If
' /////////////////////////////////////////////////////////////////////////////
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
SetBit256% = iResult
End Function ' SetBit256%
' /////////////////////////////////////////////////////////////////////////////
$If Then
Sub ShowDegreesAndRadians
Dim iDegree As Integer
Dim sngRadian As Single
DebugPrint "Degree Radian"
DebugPrint "------ ------"
For iDegree = 0 To 360
sngRadian = _D2R(iDegree)
'DebugPrint LeftPadString$(cstr$(iDegree), 3, " ") + " " + LeftPadString$(cstr$(iRadian), 3, " ")
DebugPrint LeftPadString$(cstr$(iDegree), 3, " ") + " " + SngToStr$(sngRadian)
'Print "SngToStr$(MyValue) =" + SngToStr$(MyValue)
'Print "SngRoundedToStr$(MyValue, 12)=" + SngRoundedToStr$(MyValue, 12)
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
sngNew = RoundSingle!(sngOld, 0)
'sValue = _Trim$(Str$(sngNew))
sValue = SngToStr$(sngNew)
'iPos = InStr(1, sValue, ".")
'If iPos > 0 Then
' SngToInt% = Val(Left$(sValue, iPos - 1))
'Else
' SngToInt% = Val(sValue)
'End If
SngToInt% = Val(sValue)
End Function ' SngToInt%
' /////////////////////////////////////////////////////////////////////////////
' 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
' /////////////////////////////////////////////////////////////////////////////
$If Then
Sub SplitTest
Dim in$
Dim delim$
ReDim arrTest$(0)
Dim iLoop%
delim$ = Chr$(10)
in$ = "this" + delim$ + "is" + delim$ + "a" + delim$ + "test"
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print "delim$ = " + Chr$(34) + delim$ + Chr$(34)
split in$, delim$, arrTest$()
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
' /////////////////////////////////////////////////////////////////////////////
$If Then
Sub SplitAndReplaceTest
Dim in$
Dim out$
Dim iLoop%
ReDim arrTest$(0)
Print "-------------------------------------------------------------------------------"
Print "SplitAndReplaceTest"
Print
Print "Original value"
in$ = "This line 1 " + Chr$(13) + Chr$(10) + "and line 2" + Chr$(10) + "and line 3 " + Chr$(13) + "finally THE END."
out$ = in$
out$ = Replace$(out$, Chr$(13), "\r")
out$ = Replace$(out$, Chr$(10), "\n")
out$ = Replace$(out$, Chr$(9), "\t")
Print "in$ = " + Chr$(34) + out$ + Chr$(34)
Print
Print "Fixing linebreaks..."
in$ = Replace$(in$, Chr$(13) + Chr$(10), Chr$(13))
in$ = Replace$(in$, Chr$(10), Chr$(13))
out$ = in$
out$ = Replace$(out$, Chr$(13), "\r")
out$ = Replace$(out$, Chr$(10), "\n")
out$ = Replace$(out$, Chr$(9), "\t")
Print "in$ = " + Chr$(34) + out$ + Chr$(34)
Print
Print "Splitting up..."
split in$, Chr$(13), arrTest$()
For iLoop% = LBound(arrTest$) To UBound(arrTest$)
out$ = arrTest$(iLoop%)
out$ = Replace$(out$, Chr$(13), "\r")
out$ = Replace$(out$, Chr$(10), "\n")
out$ = Replace$(out$, Chr$(9), "\t")
Print "arrTest$(" + cstr$(iLoop%) + ") = " + Chr$(34) + out$ + Chr$(34)
Next iLoop%
Print
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 StrPadLeft$ (sValue As String, iWidth As Integer)
StrPadLeft$ = Right$(String$(iWidth, " ") + sValue, iWidth)
End Function ' StrPadLeft$
' /////////////////////////////////////////////////////////////////////////////
Function StrJustifyRight$ (sValue As String, iWidth As Integer)
StrJustifyRight$ = Right$(String$(iWidth, " ") + sValue, iWidth)
End Function ' StrJustifyRight$
' /////////////////////////////////////////////////////////////////////////////
Function StrPadRight$ (sValue As String, iWidth As Integer)
StrPadRight$ = Left$(sValue + String$(iWidth, " "), iWidth)
End Function ' StrPadRight$
' /////////////////////////////////////////////////////////////////////////////
Function StrJustifyLeft$ (sValue As String, iWidth As Integer)
StrJustifyLeft$ = Left$(sValue + String$(iWidth, " "), iWidth)
End Function ' StrJustifyLeft$
' /////////////////////////////////////////////////////////////////////////////
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%
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
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%
' Screen _NewImage(1024, 768, 32): _ScreenMove 0, 0
' iCols = _Width(0) \ _FontWidth
' iRows = _Height(0) \ _FontHeight
' Print "_Width(0) =" + _Trim$(Str$(_Width(0)))
' Print "_Height(0) =" + _Trim$(Str$(_Height(0)))
' Print "_FontWidth =" + _Trim$(Str$(_FontWidth))
' Print "_FontHeight=" + _Trim$(Str$(_FontHeight))
' Print "iCols = _Width(0) \ _FontWidth = " + _Trim$(Str$(iCols))
' Print "iRows = _Height(0) \ _FontHeight = " + _Trim$(Str$(iRows))
$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
' ################################################################################################################################################################
'#ENDCode: (Select All)
Dim Shared m_sTitle As String: m_sTitle = "2D Vector Shapes v0.33 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.
' DATE WHO-DONE-IT DID-WHAT
' 2022-11-22 madscijr Version 0.34 (last version before project stalled!)
' 2025-01-05 madscijr Version 0.35 (no changes, just refamiliarize with code and get project back on track)
' 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)
' * fix twinkling stars
' TO DO:
' * 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
' BOOLEAN CONSTANTS
Const FALSE = 0
Const TRUE = Not FALSE
' OTHER SETTINGS
Const cFPS = 120
Const cMinStars = 50
Const cMaxStars = 150
Const cSpeed = 2
' 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
z As Integer ' zorder in which object is stacked (in front of or behind other objects)
FillColor As _Unsigned Long ' color to fill in object with (use cEmpty for transparent)
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_arrOrder(1 To 6) As Integer
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
EditVectorObject1
' =============================================================================
' FINISH
Screen 0
System ' return control to the operating system
' /////////////////////////////////////////////////////////////////////////////
' NOTE: this version does NOT change the screen to 1280x1024
' but it might depend on that resolution.
' Screen would be set to 1280x1024 at the top of the program.
Sub EditVectorObject1
Dim RoutineName As String: RoutineName = "EditVectorObject1"
Dim iX1 As Integer: iX1 = 0
Dim iY1 As Integer: iY1 = 0
Dim iOldX1 As Integer: iOldX1 = 0
Dim iOldY1 As Integer: iOldY1 = 0
Dim bLeftClick As Integer: bLeftClick = FALSE
Dim bRightClick As Integer: bRightClick = FALSE
Dim bMiddleClick As Integer: bMiddleClick = FALSE
Dim bOldLeftClick As Integer: bOldLeftClick = FALSE
Dim bOldRightClick As Integer: bOldRightClick = FALSE
Dim bOldMiddleClick As Integer: bOldMiddleClick = FALSE
Dim iX2 As Integer: iX2 = _Width / 2
Dim iY2 As Integer: iY2 = _Height / 2
Dim iOldX2 As Integer: iOldX2 = 0
Dim iOldY2 As Integer: iOldY2 = 0
Dim iColor1 As _Unsigned Long: iColor1 = cRed
Dim iColor2 As _Unsigned Long: iColor2 = cLime
' Screen set at top of program, before main menu.
Screen _NewImage(1280, 1024, 32): _ScreenMove 0, 0
Cls
_MouseHide ' hide OS mouse pointer
Do While _MouseInput: Loop
Do
Color cWhite, cBlack
If iOldX1 <> iX1 Or iOldY1 <> iY1 Then _PrintString (iOldX1, iOldY1), " "
If iOldX2 <> iX2 Or iOldY2 <> iY2 Then _PrintString (iOldX2, iOldY2), " "
Color cWhite, cEmpty
PrintString 0, 0, "_MOUSEX ="
PrintString 1, 0, "_MOUSEY ="
PrintString 2, 0, "_MOUSEBUTTON(1)="
PrintString 3, 0, "_MOUSEBUTTON(2)="
PrintString 4, 0, "_MOUSEBUTTON(3)="
PrintString 5, 0, "_MOUSEWHEEL X ="
PrintString 6, 0, "_MOUSEWHEEL Y ="
PrintString 8, 0, "PRESS <ESC> TO EXIT"
Color cWhite, cBlack
PrintString 0, 16, Left$(cstr$(iX1) + " ", 5)
PrintString 1, 16, Left$(cstr$(iY1) + " ", 5)
PrintString 2, 16, Left$(TrueFalse$(bLeftClick) + " ", 5)
PrintString 3, 16, Left$(TrueFalse$(bRightClick) + " ", 5)
PrintString 4, 16, Left$(TrueFalse$(bMiddleClick) + " ", 5)
PrintString 5, 16, Left$(cstr$(iX2) + " ", 5)
PrintString 6, 16, Left$(cstr$(iY2) + " ", 5)
Color cBlack, iColor1: _PrintString (iX1, iY1), " "
iOldX1 = iX1: iOldY1 = iY1
Color cBlack, iColor2: _PrintString (iX2, iY2), " "
iOldX2 = iX2: iOldY2 = iY2
iX1 = (_MouseX \ _FontWidth) * _FontWidth
iY1 = (_MouseY \ _FontHeight) * _FontHeight
bLeftClick = _MouseButton(1)
If bLeftClick Then
If bOldLeftClick = FALSE Then
If iColor1 = cOrangeRed Then
iColor1 = cRed
ElseIf iColor1 = cRed Then
iColor1 = cMagenta
Else
iColor1 = cOrangeRed
End If
bOldLeftClick = TRUE
End If
Else
bOldLeftClick = FALSE
End If
bRightClick = _MouseButton(2)
If bRightClick Then
If bOldRightClick = FALSE Then
If iColor2 = cBlue Then
iColor2 = cLime
ElseIf iColor2 = cLime Then
iColor2 = cYellow
Else
iColor2 = cBlue
End If
bOldRightClick = TRUE
End If
Else
bOldRightClick = FALSE
End If
bMiddleClick = _MouseButton(3)
Do While _MouseInput
If bMiddleClick Then
iY2 = iY2 + (_MouseWheel * _FontHeight) ' -1 up, 0 no movement, 1 down
Else
iX2 = iX2 + (_MouseWheel * _FontWidth) ' -1 up, 0 no movement, 1 down
End If
Loop
If iY2 < 1 Then iY2 = 1
If iY2 > (_Height - _FontHeight) Then iY2 = (HEIGHT - _FontHeight)
Loop Until _KeyDown(27)
_KeyClear
_MouseShow "default": _Delay 0.5
' Screen 0 set at end of program up top.
Screen 0
End Sub ' EditVectorObject1
' /////////////////////////////////////////////////////////////////////////////
Sub DrawVectorObjectTest1
' LOCAL VARIABLES
Dim iFPS As Integer: iFPS = cFPS
Dim iLoop As Integer
Dim iObject As Integer
Dim iLayer As Integer
Dim iLine As Integer
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 iLineStyleIndex As Integer
Dim lngLineStyle ' line style
Dim lngDashedLineStyle ' line style for other objects
Dim lngSolidLineStyle ' selected object's line style
Dim iNumStars As Integer
Dim iValue As Integer
Dim iMinValue As Integer
Dim iMaxValue As Integer
Dim iStarLoop As Integer
Dim x1%
Dim x2%
Dim y1%
Dim y2%
Dim imgStars& ' used for drawing background
Dim imgText& ' used for drawing text
Dim imgObjects& ' used for drawing objects
Dim imgTemp& ' temporary drawing area
' =============================================================================
' INITIALIZE
InitializeRandom
Screen _NewImage(iMaxX, iMaxY, 32) ' 100 text columns x 40 text rows
' USE LATER FOR DRAWING LAYERS:
imgStars& = _NewImage(iMaxX, iMaxY, 32) ' background stars
imgText& = _NewImage(iMaxX, iMaxY, 32) ' text
imgObjects& = _NewImage(iMaxX, iMaxY, 32) ' frontground objects
imgTemp& = _NewImage(iMaxX, iMaxY, 32) ' temporary
' =============================================================================
' START NEW GAME
Do
_KeyClear
' CONFIGURE PRINTING FOR _PrintString
_PrintMode _FillBackground
'_PrintMode _KEEPBACKGROUND
' INIT OBJECT DEFINITIONS
InitVectorObjects
' INIT VARS
sKey = ""
' PLACE OBJECTS
iX = 0: iY = 0
iValue = UBound(m_arrObject)
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
m_arrObject(iObject).z = iValue
m_arrObject(iObject).FillColor = cBlack
iX = iX + 200
If iX > 800 Then
iX = 0
iY = iY + 200
If iY > 640 Then
iY = 0
End If
End If
iValue = iValue - 1
Next iObject
' INIT OBJECT Z-ORDER ARRAY
ReDim m_arrOrder(lbound(m_arrObject) To ubound(m_arrObject)) As Integer
For iObject = LBound(m_arrObject) To UBound(m_arrObject)
m_arrOrder( m_arrObject(iObject).z ) = iObject
Next iObject
' SAVE LINE STYLE SEQUENCE
iLoop = 0
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 61680 ' 1111000011110000
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 30840 ' 0111100001111000
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 15420 ' 0011110000111100
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 7710 ' 0001111000011110
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 3855 ' 0000111100001111
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 34695 ' 1000011110000111
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 50115 ' 1100001111000011
iLoop = iLoop + 1: m_arrLineStyle(iLoop) = 57825 ' 1110000111100001
iLineStyleIndex = LBound(m_arrLineStyle)
lngDashedLineStyle = m_arrLineStyle(iLineStyleIndex)
lngSolidLineStyle = 65535
' 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
' ================================================================================================================================================================
' BEGIN MAIN LOOP
While TRUE = TRUE
' CLEAR OBJECTS LAYER
_Dest imgObjects&: Cls , cEmpty
' MOVE AND ADD ENABLED OBJECTS (IN STACKING ORDER)
For iLayer = UBound(m_arrOrder) To LBound(m_arrOrder) Step -1
' Get next object
iObject = m_arrOrder(iLayer)
' 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 - cSpeed
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 + cSpeed
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 - cSpeed
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 + cSpeed
If m_arrObject(iObject).y > iMaxY Then
m_arrObject(iObject).y = iMinY
End If
End If
End If
' Clear temporary (layer and draw on it
_Dest imgTemp&: Cls , cEmpty
' Draw object's line segments
For iLine = LBound(m_arrLines, 2) To UBound(m_arrLines, 2)
If m_arrLines(iObject, iLine).IsLast = FALSE Then
'Line (x1%, y1%)-(x2%, y2%), arrColor(arrStars(iLoop).ColorIndex), BF, lngLineStyle
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, , lngSolidLineStyle
Else
Exit For
End If
Next iLine
' Draw fill color if not transparent
if m_arrObject(iObject).FillColor <> cEmpty then
' Fill in current object with its fill color...
'PAINT [STEP] (column%, row%), fillColor[, borderColor%]
Paint (m_arrObject(iObject).x, m_arrObject(iObject).y), _
m_arrObject(iObject).FillColor, m_arrColor(iObject)
end if
' Make other objects appear drawn with a dashed line
If iObject <> iWhich Then
' Outline with a dashed line
For iLine = LBound(m_arrLines, 2) To UBound(m_arrLines, 2)
If m_arrLines(iObject, iLine).IsLast = FALSE Then
'Line (x1%, y1%)-(x2%, y2%), arrColor(arrStars(iLoop).ColorIndex), BF, lngLineStyle
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) _
, _
cBlack, , lngDashedLineStyle
Else
Exit For
End If
Next iLine
End If
' Add new object to objects layer
'_PUTIMAGE , sourceHandle&, destHandle& 'size full source to fit full destination area
_PutImage , imgTemp&, imgObjects&
End If
Next iLayer
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN STARS
' Twinkle twinkle little stars
_Dest imgStars&: Cls , cEmpty
For iStarLoop = LBound(m_arrStars) To UBound(m_arrStars)
' increment twinkle counter
m_arrStars(iStarLoop).TwinkleCounter = m_arrStars(iStarLoop).TwinkleCounter + 1
' is it time to twinkle the color?
If m_arrStars(iStarLoop).TwinkleCounter > m_arrStars(iStarLoop).MaxTwinkCount Then
m_arrStars(iStarLoop).TwinkleCounter = 0 ' reset counter
m_arrStars(iStarLoop).ColorIndex = m_arrStars(iStarLoop).ColorIndex + 1 ' increment color
If m_arrStars(iStarLoop).ColorIndex > UBound(m_arrGrayColor) Then
m_arrStars(iStarLoop).ColorIndex = LBound(m_arrGrayColor) ' reset color
End If
End If
' increment width counter
if m_arrStars(iStarLoop).BigCounter = 0 then
m_arrStars(iStarLoop).WidthCounter = m_arrStars(iStarLoop).WidthCounter + 1
' is it time to fluctuate the width
If m_arrStars(iStarLoop).WidthCounter > m_arrStars(iStarLoop).MaxWidthCount Then
m_arrStars(iStarLoop).WidthCounter = 0 ' reset counter
m_arrStars(iStarLoop).BigCounter = 1 ' start big counter
m_arrStars(iStarLoop).width = m_arrStars(iStarLoop).MinWidth ' twinkle width
Else
m_arrStars(iStarLoop).width = m_arrStars(iStarLoop).MaxWidth ' normal width
End If
else
' increment big counter
m_arrStars(iStarLoop).BigCounter = m_arrStars(iStarLoop).BigCounter + 1
' is it time to return to normal size?
If m_arrStars(iStarLoop).BigCounter > m_arrStars(iStarLoop).MaxBigCount Then
m_arrStars(iStarLoop).BigCounter = 0 ' reset counter
m_arrStars(iStarLoop).width = m_arrStars(iStarLoop).MaxWidth ' normal width
End If
end if
' get size
x1% = m_arrStars(iStarLoop).x: x2% = x1% + m_arrStars(iStarLoop).width
y1% = m_arrStars(iStarLoop).y: y2% = y1% + m_arrStars(iStarLoop).width
' (re)draw it
Line (x1%, y1%)-(x2%, y2%), m_arrGrayColor(m_arrStars(iStarLoop).ColorIndex), BF
Next iStarLoop
' END STARS
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' SHOW TEXT
_Dest imgText&: Cls , cEmpty
DrawText sKey, iWhich
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN UPDATE SCREEN
' COPY LAYERS TO SCREEN
_Dest 0: Cls , cBlack
If imgStars& < -1 Then
_PutImage , imgStars&, 0
End If
If imgText& < -1 Then
_PutImage , imgText&, 0
End If
If imgObjects& < -1 Then
_PutImage , imgObjects&, 0
End If
' UPDATE THE SCREEN
_Display
' END UPDATE SCREEN
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' 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
iLineStyleIndex = iLineStyleIndex + 1
If iLineStyleIndex > UBound(m_arrLineStyle) Then
iLineStyleIndex = LBound(m_arrLineStyle)
End If
lngDashedLineStyle = m_arrLineStyle(iLineStyleIndex)
End If
' CLEAR KEYBOARD BUFFER
_KeyClear
' CONTROL GAME SPEED
_Limit iFPS
Wend
' END MAIN LOOP
' ================================================================================================================================================================
' 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
' CLEAR IMAGES
screen 0
IF imgStars& < -1 THEN _FREEIMAGE imgStars&
IF imgText& < -1 THEN _FREEIMAGE imgText&
IF imgObjects& < -1 THEN _FREEIMAGE imgObjects&
IF imgTemp& < -1 THEN _FREEIMAGE imgTemp&
' RETURN TO AUTODISPLAY
_AutoDisplay
End Sub ' DrawVectorObjectTest1
' /////////////////////////////////////////////////////////////////////////////
' 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$
' /////////////////////////////////////////////////////////////////////////////
' Receives:
' String sBitPattern = 16 character string of "1" and "0"
' (a 16-bit binary representation)
' Returns the bit pattern converted to a long integer.
Function LongFromBinaryString& (sBitPattern As String)
Dim sInput As String: sInput = sBitPattern
Dim iLoop As Integer
Dim MyLong As Long
MyLong = 0
If Len(sInput) >= 16 Then
For iLoop = 0 To 15
If Mid$(sInput, 16 - iLoop, 1) = "1" Then
MyLong = MyLong + (2 ^ iLoop)
End If
Next iLoop
End If
LongFromBinaryString& = MyLong
End Function ' LongFromBinaryString&
' /////////////////////////////////////////////////////////////////////////////
' VECTOR OBJECT DEFINITIONS
' 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
End Sub ' InitVectorObjects
' /////////////////////////////////////////////////////////////////////////////
' 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
RowNum = 0
Color cWhite, cEmpty
RowNum = RowNum + 1: PrintAt RowNum, 1, m_sTitle
RowNum = RowNum + 1
Color cYellow, cEmpty
RowNum = RowNum + 1: PrintAt RowNum, 1, "----------------------------------------"
RowNum = RowNum + 1: PrintAt RowNum, 1, "Press 1-6 to select active object."
RowNum = RowNum + 1: PrintAt RowNum, 1, "Arrow keys move active object."
RowNum = RowNum + 1: PrintAt RowNum, 1, "Press ESC to quit"
RowNum = RowNum + 1: PrintAt RowNum, 1, "----------------------------------------"
RowNum = RowNum + 1
' 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
RowNum = RowNum + 1: PrintAt RowNum, 1, "" + _
sFlag + _
cstr$(iNum) + ". " + _
"obj #" + cstr$(iObject) + _
"(" + cstr$(m_arrObject(iObject).x) + "," + cstr$(m_arrObject(iObject).y) + ")" + _
"(" + cstr$(m_arrObject(iObject).dx) + "," + cstr$(m_arrObject(iObject).dy) + ")" + _
"(" + cstr$(m_arrObject(iObject).cx) + "," + cstr$(m_arrObject(iObject).cy) + ")" + _
""
Next iObject
Color cGray, cEmpty
RowNum = RowNum + 1: PrintAt RowNum, 1, "----------------------------------------"
RowNum = RowNum + 2
'' SHOW ACTIVE OBJECT
'Color cWhite
'RowNum = RowNum + 1: PrintAt RowNum, 1, "Object # : " + cstr$(iWhich)
' SHOW INPUT
Color cLime, cEmpty
RowNum = RowNum + 1: PrintAt RowNum, 1, "Controls : " + RightPadString$(sKey, 10, " ") + " "
End Sub ' DrawText
' ################################################################################################################################################################
' 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
' /////////////////////////////////////////////////////////////////////////////
Sub AddGrayscaleColors (arrColor() As _Unsigned Long)
Dim iNum As Integer
iNum = 1
AddColors cDimGray, arrColor(), iNum
AddColors cGray, arrColor(), iNum
AddColors cDarkGray, arrColor(), iNum
AddColors cSilver, arrColor(), iNum
AddColors cLightGray, arrColor(), iNum
AddColors cGainsboro, arrColor(), iNum
AddColors cWhiteSmoke, arrColor(), iNum
AddColors cWhite, arrColor(), iNum '* 2
AddColors cWhiteSmoke, arrColor(), iNum
AddColors cGainsboro, arrColor(), iNum
AddColors cLightGray, arrColor(), iNum
AddColors cSilver, arrColor(), iNum
AddColors cDarkGray, arrColor(), iNum
AddColors cGray, arrColor(), iNum
End Sub ' AddGrayscaleColors
' ################################################################################################################################################################
' 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)
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 = _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
dblNew = RoundDouble#(dblOld, 0)
'sValue = _Trim$(Str$(dblNew))
sValue = DblToStr$(dblNew)
'iPos = InStr(1, sValue, ".")
'If iPos > 0 Then
' DblToInt% = Val(Left$(sValue, iPos - 1))
'Else
' DblToInt% = Val(sValue)
'End If
DblToInt% = Val(sValue)
End Function ' DblToInt%
' /////////////////////////////////////////////////////////////////////////////
' 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
DblToStr$ = result$
End Function ' DblToStr$
' /////////////////////////////////////////////////////////////////////////////
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
' /////////////////////////////////////////////////////////////////////////////
Sub DumpScreenAndFontSize ()
Dim iCols As Integer
Dim iRows As Integer
'Screen _NewImage(1024, 768, 32): _ScreenMove 0, 0
iCols = _Width(0) \ _FontWidth
iRows = _Height(0) \ _FontHeight
Print "_Width(0) =" + _Trim$(Str$(_Width(0)))
Print "_Height(0) =" + _Trim$(Str$(_Height(0)))
Print "_FontWidth =" + _Trim$(Str$(_FontWidth))
Print "_FontHeight=" + _Trim$(Str$(_FontHeight))
Print "iCols = _Width(0) \ _FontWidth = " + _Trim$(Str$(iCols))
Print "iRows = _Height(0) \ _FontHeight = " + _Trim$(Str$(iRows))
End Sub ' DumpScreenAndFontSize
' /////////////////////////////////////////////////////////////////////////////
' 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
' PRINT "Current date time (simple format) = " + Chr$(34) + GetCurrentDateTime$("{yyyy}-{mm}-{dd} {rr}:{nn}:{ss}") + Chr$(34)
' PRINT "Current date time (US format) = " + Chr$(34) + GetCurrentDateTime$("{mm}/{dd}/{yyyy} {hh}:{nn}:{ss} {ampm}") + Chr$(34)
' PRINT "Filename timestamp = " + Chr$(34) + GetCurrentDateTime$("{yyyy}{mm}{dd}_{rr}{nn}{ss}") + Chr$(34)
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
' POPULATE TEMPLATE
result$ = sTemplate$
result$ = Replace$(result$, "{yyyy}", sYYYY$)
result$ = Replace$(result$, "{mm}", sMM$)
result$ = Replace$(result$, "{dd}", sDD$)
result$ = Replace$(result$, "{hh}", sHH$)
result$ = Replace$(result$, "{rr}", sHH24$)
result$ = Replace$(result$, "{nn}", sMI$)
result$ = Replace$(result$, "{ss}", sSS$)
result$ = Replace$(result$, "{ampm}", sAMPM$)
' 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
ReDim arrInteger(-1) As Integer
'DebugPrint "GetIntegerArrayFromDelimList " + _
' "MyString=" + chr$(34) + MyString + chr$(34) + ", " + _
' "sDelimiter=" + chr$(34) + sDelimiter + chr$(34) + ", " + _
' "iMinIndex=" + cstr$(iMinIndex) + ", " + _
' "arrInteger()"
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)
result& = result& + VAL(sSS$)
result& = result& + (VAL(sMI$) * 60)
result& = result& + ( (VAL(sHH24$) * 60) * 60)
' RETURN RESULT
GetTimeSeconds& = result&
End Function ' GetTimeSeconds&
' /////////////////////////////////////////////////////////////////////////////
' IIF function for QB for integers
Function IIF (Condition, IfTrue, IfFalse)
If Condition Then IIF = IfTrue Else IIF = IfFalse
End Function
' /////////////////////////////////////////////////////////////////////////////
' IIF function for QB for strings
Function IIFSTR$ (Condition, IfTrue$, IfFalse$)
If Condition Then IIFSTR$ = IfTrue$ Else IIFSTR$ = IfFalse$
End Function
' /////////////////////////////////////////////////////////////////////////////
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%
' /////////////////////////////////////////////////////////////////////////////
'Sub IsNumberTest
' Dim in$
' Cls
' IsNumberTest1 "1"
' IsNumberTest1 "01"
' IsNumberTest1 "001"
' IsNumberTest1 "-1"
' IsNumberTest1 "-01"
' IsNumberTest1 "-001"
' IsNumberTest1 "+1"
' IsNumberTest1 "+01"
' IsNumberTest1 "+001"
' IsNumberTest1 ".1"
' IsNumberTest1 ".01"
' IsNumberTest1 ".001"
' IsNumberTest1 ".10"
' IsNumberTest1 ".100"
' IsNumberTest1 "..100"
' IsNumberTest1 "100."
' Input "PRESS ENTER TO CONTINUE TEST";in$
' Cls
' IsNumberTest1 "0.10"
' IsNumberTest1 "00.100"
' IsNumberTest1 "000.1000"
' IsNumberTest1 "000..1000"
' IsNumberTest1 "000.1000.00"
' IsNumberTest1 "+1.00"
' IsNumberTest1 "++1.00"
' IsNumberTest1 "+-1.00"
' IsNumberTest1 "-1.00"
' IsNumberTest1 "-+1.00"
' IsNumberTest1 " 1"
' IsNumberTest1 "1 "
' IsNumberTest1 "1. 01"
' IsNumberTest1 "+1 "
'End Sub ' IsNumberTest
'Sub IsNumberTest1(MyString As String)
' Const cWidth = 16
' Dim sInput As String : sInput = left$(Chr$(34) + MyString + Chr$(34) + String$(cWidth, " "), cWidth)
' Dim sResult As String : sResult = right$(String$(2, " ") + _Trim$(Str$(IsNumber%(MyString))), 2)
' Print "IsNumber%(" + sInput + ") returns " + sResult
'End Sub ' IsNumberTest1
' /////////////////////////////////////////////////////////////////////////////
' 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$
' /////////////////////////////////////////////////////////////////////////////
' Pauses for iDS deciseconds (iDS * 100 ms)
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.
' Example:
' ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
' ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' sFileName = ProgramPath$ + ProgramName$ + ".OUT.txt"
' sText = "This is a test." + chr$(13) + "Here is line 2." + chr$(13) + "End."
' sError = PrintFile$(sFileName, sText, FALSE)
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
sPrompt1$ = Replace$(sPrompt1$, "{min}", cstr$(iMin%))
sPrompt1$ = Replace$(sPrompt1$, "{max}", cstr$(iMax%))
bFinished% = FALSE
Do
Print sPrompt1$
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$
sFileName = "c:\temp\maze_test_1.txt"
sText = "Count" + Chr$(9) + "Min" + Chr$(9) + "Max" + Chr$(9) + "Random"
bAppend = FALSE
sError = PrintFile$(sFileName, sText, bAppend)
If Len(sError) = 0 Then
bAppend = TRUE
iErrorCount = 0
iMin = 0
iMax = iCols - 1
For iLoop = 1 To 100
iNum = RandomNumber%(iMin, iMax)
sText = Str$(iLoop) + Chr$(9) + Str$(iMin) + Chr$(9) + Str$(iMax) + Chr$(9) + Str$(iNum)
sError = PrintFile$(sFileName, sText, bAppend)
If Len(sError) > 0 Then
iErrorCount = iErrorCount + 1
Print Str$(iLoop) + ". ERROR"
Print " " + "iMin=" + Str$(iMin)
Print " " + "iMax=" + Str$(iMax)
Print " " + "iNum=" + Str$(iNum)
Print " " + "Could not write to file " + Chr$(34) + sFileName + Chr$(34) + "."
Print " " + sError
End If
Next iLoop
iMin = 0
iMax = iRows - 1
For iLoop = 1 To 100
iNum = RandomNumber%(iMin, iMax)
sText = Str$(iLoop) + Chr$(9) + Str$(iMin) + Chr$(9) + Str$(iMax) + Chr$(9) + Str$(iNum)
sError = PrintFile$(sFileName, sText, bAppend)
If Len(sError) > 0 Then
iErrorCount = iErrorCount + 1
Print Str$(iLoop) + ". ERROR"
Print " " + "iMin=" + Str$(iMin)
Print " " + "iMax=" + Str$(iMax)
Print " " + "iNum=" + Str$(iNum)
Print " " + "Could not write to file " + Chr$(34) + sFileName + Chr$(34) + "."
Print " " + sError
End If
Next iLoop
Print "Finished generating numbers. Errors: " + Str$(iErrorCount)
Else
Print "Error creating file " + Chr$(34) + sFileName + Chr$(34) + "."
Print sError
End If
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))))
' Return the substring:
Text2 = strBefore + Add2 + strAfter
' Locate the next instance of [Find2]:
lngLocation = InStr(1, Text2, Find2)
' Next instance of [Find2]...
Wend
' OUTPUT:
Replace$ = Text2
End Function ' Replace$
' /////////////////////////////////////////////////////////////////////////////
$If Then
Sub ReplaceTest
Dim in$
Print "-------------------------------------------------------------------------------"
Print "ReplaceTest"
Print
Print "Original value"
in$ = "Thiz iz a teZt."
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print
Print "Replacing lowercase " + Chr$(34) + "z" + Chr$(34) + " with " + Chr$(34) + "s" + Chr$(34) + "..."
in$ = Replace$(in$, "z", "s")
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print
Print "Replacing uppercase " + Chr$(34) + "Z" + Chr$(34) + " with " + Chr$(34) + "s" + Chr$(34) + "..."
in$ = Replace$(in$, "Z", "s")
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print
Print "ReplaceTest finished."
End Sub ' ReplaceTest
$End If
' /////////////////////////////////////////////////////////////////////////////
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
SetBit256% = iResult
End Function ' SetBit256%
' /////////////////////////////////////////////////////////////////////////////
$If Then
Sub ShowDegreesAndRadians
Dim iDegree As Integer
Dim sngRadian As Single
DebugPrint "Degree Radian"
DebugPrint "------ ------"
For iDegree = 0 To 360
sngRadian = _D2R(iDegree)
'DebugPrint LeftPadString$(cstr$(iDegree), 3, " ") + " " + LeftPadString$(cstr$(iRadian), 3, " ")
DebugPrint LeftPadString$(cstr$(iDegree), 3, " ") + " " + SngToStr$(sngRadian)
'Print "SngToStr$(MyValue) =" + SngToStr$(MyValue)
'Print "SngRoundedToStr$(MyValue, 12)=" + SngRoundedToStr$(MyValue, 12)
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
sngNew = RoundSingle!(sngOld, 0)
'sValue = _Trim$(Str$(sngNew))
sValue = SngToStr$(sngNew)
'iPos = InStr(1, sValue, ".")
'If iPos > 0 Then
' SngToInt% = Val(Left$(sValue, iPos - 1))
'Else
' SngToInt% = Val(sValue)
'End If
SngToInt% = Val(sValue)
End Function ' SngToInt%
' /////////////////////////////////////////////////////////////////////////////
' 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
' /////////////////////////////////////////////////////////////////////////////
$If Then
Sub SplitTest
Dim in$
Dim delim$
ReDim arrTest$(0)
Dim iLoop%
delim$ = Chr$(10)
in$ = "this" + delim$ + "is" + delim$ + "a" + delim$ + "test"
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print "delim$ = " + Chr$(34) + delim$ + Chr$(34)
split in$, delim$, arrTest$()
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
' /////////////////////////////////////////////////////////////////////////////
$If Then
Sub SplitAndReplaceTest
Dim in$
Dim out$
Dim iLoop%
ReDim arrTest$(0)
Print "-------------------------------------------------------------------------------"
Print "SplitAndReplaceTest"
Print
Print "Original value"
in$ = "This line 1 " + Chr$(13) + Chr$(10) + "and line 2" + Chr$(10) + "and line 3 " + Chr$(13) + "finally THE END."
out$ = in$
out$ = Replace$(out$, Chr$(13), "\r")
out$ = Replace$(out$, Chr$(10), "\n")
out$ = Replace$(out$, Chr$(9), "\t")
Print "in$ = " + Chr$(34) + out$ + Chr$(34)
Print
Print "Fixing linebreaks..."
in$ = Replace$(in$, Chr$(13) + Chr$(10), Chr$(13))
in$ = Replace$(in$, Chr$(10), Chr$(13))
out$ = in$
out$ = Replace$(out$, Chr$(13), "\r")
out$ = Replace$(out$, Chr$(10), "\n")
out$ = Replace$(out$, Chr$(9), "\t")
Print "in$ = " + Chr$(34) + out$ + Chr$(34)
Print
Print "Splitting up..."
split in$, Chr$(13), arrTest$()
For iLoop% = LBound(arrTest$) To UBound(arrTest$)
out$ = arrTest$(iLoop%)
out$ = Replace$(out$, Chr$(13), "\r")
out$ = Replace$(out$, Chr$(10), "\n")
out$ = Replace$(out$, Chr$(9), "\t")
Print "arrTest$(" + cstr$(iLoop%) + ") = " + Chr$(34) + out$ + Chr$(34)
Next iLoop%
Print
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 StrPadLeft$ (sValue As String, iWidth As Integer)
StrPadLeft$ = Right$(String$(iWidth, " ") + sValue, iWidth)
End Function ' StrPadLeft$
' /////////////////////////////////////////////////////////////////////////////
Function StrJustifyRight$ (sValue As String, iWidth As Integer)
StrJustifyRight$ = Right$(String$(iWidth, " ") + sValue, iWidth)
End Function ' StrJustifyRight$
' /////////////////////////////////////////////////////////////////////////////
Function StrPadRight$ (sValue As String, iWidth As Integer)
StrPadRight$ = Left$(sValue + String$(iWidth, " "), iWidth)
End Function ' StrPadRight$
' /////////////////////////////////////////////////////////////////////////////
Function StrJustifyLeft$ (sValue As String, iWidth As Integer)
StrJustifyLeft$ = Left$(sValue + String$(iWidth, " "), iWidth)
End Function ' StrJustifyLeft$
' /////////////////////////////////////////////////////////////////////////////
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%
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
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%
' Screen _NewImage(1024, 768, 32): _ScreenMove 0, 0
' iCols = _Width(0) \ _FontWidth
' iRows = _Height(0) \ _FontHeight
' Print "_Width(0) =" + _Trim$(Str$(_Width(0)))
' Print "_Height(0) =" + _Trim$(Str$(_Height(0)))
' Print "_FontWidth =" + _Trim$(Str$(_FontWidth))
' Print "_FontHeight=" + _Trim$(Str$(_FontHeight))
' Print "iCols = _Width(0) \ _FontWidth = " + _Trim$(Str$(iCols))
' Print "iRows = _Height(0) \ _FontHeight = " + _Trim$(Str$(iRows))
$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
' ################################################################################################################################################################
'#END