I have been wanting to see this game since oh, 1985 or so, give it a try and tell me how you like it!
This is still very much a WIP - the control mapping is hardcoded for now, but can be changed beginning at line 2043. Player 1 is controlled by the cursor keys and right CTRL.
I plan on making the controls user-configurable, including support for game controllers. I also will add sounds, display player scores/life/etc. along the edges of the screen, add a sun/gravity, and a whole bunch of other menu-driven user configurable options (eventually to be a kind of Spacewar! / Asteroids / Gravitar / Lunar Lander construction set).
But this is the first playable version, so here you go.
PS I forgot to include a screenshot and am not at my PC anymore, so maybe next version.
_Title "Fast Zap 'Em : Multispacewar! by Softintheheadware v0.44"
' Borrowed code:
' * Original VB6 code for "Collisions" by Tassadar, found on PlanetSourceCode.com in 2001.
' * Graphics objects and format from Widescreen Asteroids by Terry Ritchie.
' DATE WHO-DONE-IT DID-WHAT
' 2001-06-10 Tassadar created "Collisions" program
' 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
' 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
' TODO:
' * 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
' * fix jerky ship movement (ships should move & respond like Asteroids)
' * improve collision detection accuracy
' * limited fuel/ammo
' * option: fire button auto-repeat
' (lots more plans for phase 2 and beyond)
' ORIGINAL CREDITS:
'********************************************************************************
'* 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 *
'********************************************************************************
' USEFUL CONSTANTS
Const FALSE = 0
Const TRUE = Not FALSE
'Const Pi = 3.14159 ' Pi , bit obvious
Const SHIP_RADIUS = 10 ' What is the radius of the players ship
Const BULLET_RADIUS = 2 ' What is the radius of the bullets
Const SHIP_ACCEL = 0.05 ' 0.1 ' how fast does it accelerate
Const MAX_SPEED = 12 ' 6 ' what is the ships max speed
Const SHOOT_DELAY = 200 ' Delay between shots for the ship
Const BULLET_SPEED = 9 ' 6 ' Bullet speed - Ship speed + bullet speed = overall bulletspeed
Const BULLET_LIFESPAN = 1 ' # seconds bullet is alive
Const BULLETS_STOP_BULLETS = TRUE
Const TURN_SPEED = 72 ' 36=faster 18=superfast
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
' UDT TO HOLD MENU OPTIONS
Type MenuType
Choice As String
Info As String
End Type ' MenuType
Type ShipType
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 Integer ' X co-ordinate of the ship
yPos As 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_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
Shoot_KeyCode As Integer ' stores key code for Shoot
Cheat_KeyCode As Integer ' stores key code for Cheat
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
Shoot_IsPressed As Integer ' Is the ShootKey depressed
Cheat_IsPressed As Integer ' Is the cheat key depressed
BodyColor As _Unsigned Long
EngineColor As _Unsigned Long
FlameColor As _Unsigned Long
End Type ' ShipType
Type EnemyType
xPos As Integer ' X position of this enemy
yPos As Integer ' Y position of this enemy
life As Integer ' How much life does this enemy have
alive As Integer ' Is this enemy alive
radius As Integer ' size of enemy ship
End Type ' EnemyType
Type BulletType
xPos As Integer ' X co-ordinate of this bullet
yPos As 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
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 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
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' 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$ = "1.00"
' FOR MENU
ReDim Shared m_arrMenu(-1) As MenuType
' 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_bGameOver As Integer ' Is the game over
Dim Shared m_bAllDead As Integer ' Are all the enemies dead
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_arrShip(-1) As ShipType ' A nice array of players
ReDim Shared m_arrEnemy(-1) As EnemyType ' A nice array of enemies
ReDim Shared m_arrBullet(-1) As BulletType ' A nice array of Bullets
' VECTOR OBJECT VARIABLES
ReDim Shared m_arrObject(1 To 8) As ObjectType
ReDim Shared m_arrLines(1 To 8, 1 To 32) As CoordType ' (object #, line segment #)
' ****************************************************************************************************************************************************************
' 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
' ****************************************************************************************************************************************************************
' 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 InitializeGlobal
' *****************************************************************************
' *** BEGIN ADD YOUR MENU CHOICES HERE ****************************************
AddNextMenuItem "game", "Play Multispacewar!"
AddNextMenuItem "DrawVectorObjectTest1", "Test simple vector graphics engine."
AddNextMenuItem "RotatePointsTest1", "Rotate vector object test."
'AddNextMenuItem "Calculate_DX_DY_per_angle_TEST_2", "Calculate dx,dy per angle."
'AddNextMenuItem "SinCosTest1", "Sin/Cos test ."
'AddNextMenuItem "Choice F", "Collision detection."
'AddNextMenuItem "ShowDegreesAndRadians", "Outputs to console if m_bDebug=TRUE."
'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 ' InitializeGlobal
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$ = "game" Then game: ClearKeyboard 3
ElseIf in$ = "DrawVectorObjectTest1" Then DrawVectorObjectTest1: ClearKeyboard 3
ElseIf in$ = "RotatePointsTest1" Then RotatePointsTest1: ClearKeyboard 3
'ElseIf in$ = "Calculate_DX_DY_per_angle_TEST_2C" Then TestRoutineChoiceC: ClearKeyboard 3
'ElseIf in$ = "SinCosTest1" Then TestRoutineChoiceD: ClearKeyboard 3
'ElseIf in$ = "ShowDegreesAndRadians" Then ShowDegreesAndRadians: 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 ***********************
' *****************************************************************************
Sub InitializeGlobal1
' *****************************************************************************
' *** 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 ' InitializeGlobal
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 iInstructColor~&: iInstructColor~& = cCyan
Dim iMenuColor~&: iMenuColor~& = cWhite
Dim iRunColor~&: iRunColor~& = cYellow
Dim iInfoColor~&: iInfoColor~& = cSilver
Dim iMaxColumns As Integer
Dim iIndex 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
' MAIN MENU
bInitPage = TRUE
bInitInfo = TRUE
iLastKey = 0
bMoved = TRUE
bFinished = FALSE
Do
' SHOW INSTRUCTIONS
If bInitPage = TRUE Then
Cls , iBackColor~& ' makes the background opaque black
Color iTitleFgColor~&, iTitleBgColor~&
'PrintString 0, 0, "SimpleMenu"
PrintString 0, 0, "Fast Zap 'Em : Multispacewar! by Softintheheadware, 2022"
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"
ClearKeyboard 1
bInitPage = FALSE
End If
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
'' HIGHLIGHT NAME
'iRow = iStartRow
'For iMenuLoop = iMenuStart To iMenuEnd
' iRow = iRow + 1
' If iMenuLoop = iMenuPos Then
' Color iBackColor~&, iRunColor~&
' PrintString iRow, iCol, right$(" " + cstr$(iMenuLoop), 3) + ". " + _
' left$(m_arrMenu(iMenuLoop).Choice + string$(iColCount, " "), iColCount)
' Exit For
' End If
'Next iMenuLoop
' 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
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 SIMPLE VECTOR ENGINE #VEC
' ****************************************************************************************************************************************************************
Sub SinCosTest1
Dim iAngle As Integer
Dim sngX As Single
Dim sngY As Single
Dim sngDX As Single
Dim sngDY As Single
Dim iWidth As Integer: iWidth = 12
Dim sDelim As String: sDelim = " "
'String$(toWidth%, padChar$)
Print "Press any key to continue"
Sleep
End Sub ' SinCosTest1
' /////////////////////////////////////////////////////////////////////////////
' plot 4 points (4 corners of a square)
' when user presses "-" rotate square counter-clockwise
' when user presses "+" rotate square clockwise
' arrow keys move square around screen
Sub RotatePointsTest1
Dim RoutineName As String: RoutineName = "RotatePointsTest1"
'Dim iFPS As Integer: iFPS = 60
Dim iX As Integer
Dim iY As Integer
Dim iSize As Integer
Dim iHalfSize As Integer
'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 iLoop As Integer
Dim iAngle As Integer
Dim sngRadians As Single
Dim sngX As Integer
Dim sngY As Integer
Dim sngDX As Integer
Dim sngDY As Integer
Dim x1, y1, x2, y2 As Integer
ReDim arrPoints(1 To 4) As PointsType
Dim sKey As String
Dim iRow As Integer
Dim bQuit As Integer: bQuit = FALSE
Dim in$
' PROCESS INPUT
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
sKey = ""
' ROTATE?
If _Button(KeyCode_Minus%) Then
iAngle = iAngle - 1
ElseIf _Button(KeyCode_Equal%) Then
iAngle = iAngle + 1
End If
If iAngle < 0 Then iAngle = 359
If iAngle > 359 Then iAngle = 0
' MOVE LEFT/RIGHT
If _Button(KeyCode_Left%) Then
iX = iX - 1
ElseIf _Button(KeyCode_Right%) Then
iX = iX + 1
End If
If iX < iMinX Then
iX = iMaxX
ElseIf iX > iMaxX Then
iX = iMinX
End If
' MOVE UP/DOWN
If _Button(KeyCode_Up%) Then
iY = iY - 1
ElseIf _Button(KeyCode_Down%) Then
iY = iY + 1
End If
If iY < iMinY Then
iY = iMaxY
ElseIf iY > iMaxY Then
iY = iMinY
End If
' QUIT?
If _Button(KeyCode_Escape%) Then
bQuit = TRUE
' Exit For
End If
' CLEAR KEYBOARD BUFFER
_KeyClear
' UPDATE THE SCREEN
_Display
' CONTROL GAME SPEED
_Limit iFPS
' If bQuit = TRUE Then Exit For
'Next iAngle
If bQuit = TRUE Then Exit While
Wend
' RETURN TO AUTODISPLAY
_AutoDisplay
'Input "Press <ENTER> to continue", in$
End Sub ' RotatePointsTest1
' /////////////////////////////////////////////////////////////////////////////
' Precalculates dx,dy for 0-359 degrees
' and returns as 2 arrays (one for dx, one for dy)
' Helped by code from
' https://wiki.qb64.dev/qb64wiki/index.php/SIN
Sub Calculate_DX_DY_per_angle (arrAngleToDX() As Single, arrAngleToDY() As Single)
Dim PI As Single
Dim iDegree As Integer
Dim sngRadians As Single
Dim iAngle As Integer
Dim iDiff As Integer
' Make sure arrays are dimensioned
ReDim arrAngleToDX(0 To 359) As Single
ReDim arrAngleToDY(0 To 359) As Single
' Calculate Pi
PI = 4 * Atn(1)
' Calculate dx,dy for each of 360 degrees
For iDegree = 0 To 359
' re-orient so 0 degrees is 12 o'clock, 180 degrees is 6 o'clock
If iDegree <= 180 Then
iAngle = 180 - iDegree
ElseIf iDegree = 181 Then
iDiff = 178
iAngle = iDegree + iDiff
Else
iDiff = iDiff - 2
iAngle = iDegree + iDiff
End If
' calculate dx, dy for the current angle
sngRadians = iDegree * PI / 180
arrAngleToDX(iAngle) = Sin(sngRadians)
arrAngleToDY(iAngle) = Cos(sngRadians)
Next iDegree
End Sub ' Calculate_DX_DY_per_angle
'Sub Calculate_DX_DY_per_angle_TEST_1
' Dim arrAngleToDX(0 To 359) As Single
' Dim arrAngleToDY(0 To 359) As Single
' Dim iAngle As Integer
' Dim in$
'
' Calculate_DX_DY_per_angle arrAngleToDX(), arrAngleToDY()
'
' for iAngle = 0 to 359
' DebugPrint _
' LeftPadString$(cstr$(iAngle), 3, " ") + " deg. " + _
' "DX=" + SngRoundedToStr$(arrAngleToDX(iAngle), 6) + " " + _
' "DY=" + SngRoundedToStr$(arrAngleToDY(iAngle), 6) + " " + _
' ""
' next iAngle
'
' Input "Press <ENTER> to continue", in$
'End Sub ' Calculate_DX_DY_per_angle_TEST_1
Sub Calculate_DX_DY_per_angle_TEST_2
Dim RoutineName As String: RoutineName = "Calculate_DX_DY_per_angle_TEST_2"
'Dim iFPS As Integer: iFPS = 120
'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 arrAngleToDX(0 To 359) As Single
Dim arrAngleToDY(0 To 359) As Single
Dim iAngle As Integer
Dim iX As Integer
Dim iY As Integer
Dim sngX As Single
Dim sngY As Single
Dim sngVX As Single: sngVX = 4
Dim sngVY As Single: sngVY = 4
Dim sngDX As Single
Dim sngDY As Single
Dim bQuit As Integer: bQuit = FALSE
Dim in$
' PROCESS INPUT
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
' IF OUT OF BOUNDS, GOTO NEXT ANGLE
If iX < 0 Or iX > iMaxX Or iY < 0 Or iY > iMaxY Then
Exit While
End If
'If _Button(KeyCode_A%) Then
' Exit While
'end if
' QUIT?
If _Button(KeyCode_Escape%) Then
bQuit = TRUE
Exit While
End If
' CLEAR KEYBOARD BUFFER
_KeyClear
' UPDATE THE SCREEN
_Display
' CONTROL GAME SPEED
_Limit iFPS
Wend
If bQuit = TRUE Then Exit For
Next iAngle
If bQuit = TRUE Then Exit While
Wend
' RETURN TO AUTODISPLAY
_AutoDisplay
'Input "Press <ENTER> to continue", in$
End Sub ' Calculate_DX_DY_per_angle_TEST_2
Sub DrawVectorObjectTest1
Dim RoutineName As String: RoutineName = "DrawVectorObjectTest1"
'Dim iFPS As Integer: iFPS = 120
Dim iLoop As Integer
Dim iObject As Integer
Dim iLine As Integer
Dim imgBack&
Dim imgMiddle&
Dim imgFront&
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 iPrintX As Integer
Dim iPrintY As Integer
Screen _NewImage(iMaxX, iMaxY, 32) ' 100 text columns x 40 text rows
'imgBack& = _NewImage(800, 640, 32) ' background
'imgMiddle& = _NewImage(800, 640, 32) ' other stuff
'imgFront& = _NewImage(800, 640, 32) ' foreground
' =============================================================================
' START NEW GAME
Do
_KeyClear
' CONFIGURE PRINTING FOR _PrintString
_PrintMode _FillBackground
'_PrintMode _KEEPBACKGROUND
' INIT VARS
sKey = ""
iX = 0: iY = 0
For iObject = LBound(m_arrObject) To UBound(m_arrObject)
m_arrObject(iObject).IsEnabled = FALSE
m_arrObject(iObject).x = iX
m_arrObject(iObject).y = iY
m_arrObject(iObject).dx = RandomNumber%(-5, 5)
m_arrObject(iObject).dy = RandomNumber%(-5, 5)
m_arrObject(iObject).cx = 0
m_arrObject(iObject).cy = 0
iX = iX + 200
If iX > iMaxX Then
iX = iMinX
iY = iY + 200
If iY > iMaxY Then
iY = iMinY
iX = 100
End If
End If
Next iObject
InitVectorObjects
' MAIN LOOP
While TRUE = TRUE
' REDRAW BACKGROUND LAYERS
DrawLayers imgBack&, imgMiddle&, imgFront&
'_Dest 0: Cls , cBlack
' -----------------------------------------------------------------------------
' BEGIN SHOW VALUES ON SCREEN
' -----------------------------------------------------------------------------
Color cWhite
PrintAt 1, 1, RoutineName
Color cYellow
PrintAt 3, 1, "Press 1-6 to select active object."
PrintAt 4, 1, "Arrow keys move active object."
Color cWhite, cBlue
PrintAt 5, 1, "Press ESC to exit."
Color cWhite, cEmpty
iPrintY = 7
For iObject = LBound(m_arrObject) To UBound(m_arrObject)
If m_arrObject(iObject).IsEnabled = TRUE Then
Color cCyan
Else
Color cGray
End If
PrintAt iPrintY, 1, "" + _
"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) + ")" + _
""
iPrintY = iPrintY + 1
Next iObject
' SHOW INPUT
Color cLime
PrintAt 20, 1, "Controls : " + RightPadString$(sKey, 10, " ") + " "
Color cWhite
PrintAt 21, 1, "Object # : " + cstr$(iWhich)
' -----------------------------------------------------------------------------
' END SHOW VALUES ON SCREEN
' -----------------------------------------------------------------------------
' MOVE + DRAW ENABLED OBJECTS
For iObject = LBound(m_arrObject) To UBound(m_arrObject)
' Only enabled objects
If m_arrObject(iObject).IsEnabled = TRUE Then
' Move along X axis
m_arrObject(iObject).cx = m_arrObject(iObject).cx + 1
If m_arrObject(iObject).cx > (10 - Abs(m_arrObject(iObject).dx)) Then
m_arrObject(iObject).cx = 0
If m_arrObject(iObject).dx < 0 Then
m_arrObject(iObject).x = m_arrObject(iObject).x - 1
If m_arrObject(iObject).x < iMinX Then
m_arrObject(iObject).x = iMaxX
End If
ElseIf m_arrObject(iObject).dx > 0 Then
m_arrObject(iObject).x = m_arrObject(iObject).x + 1
If m_arrObject(iObject).x > iMaxX Then
m_arrObject(iObject).x = iMinX
End If
End If
End If
' Move along Y axis
m_arrObject(iObject).cy = m_arrObject(iObject).cy + 1
If m_arrObject(iObject).cy > (10 - Abs(m_arrObject(iObject).dy)) Then
m_arrObject(iObject).cy = 0
If m_arrObject(iObject).dy < 0 Then
m_arrObject(iObject).y = m_arrObject(iObject).y - 1
If m_arrObject(iObject).y < iMinY Then
m_arrObject(iObject).y = iMaxY
End If
ElseIf m_arrObject(iObject).dy > 0 Then
m_arrObject(iObject).y = m_arrObject(iObject).y + 1
If m_arrObject(iObject).y > iMaxY Then
m_arrObject(iObject).y = iMinY
End If
End If
End If
' Draw object's line segments
For iLine = LBound(m_arrLines, 2) To UBound(m_arrLines, 2)
'Line (x1%, y1%)-(x2%, y2%), arrColor(arrStars(iLoop).ColorIndex), BF
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 ' , BF
If m_arrLines(iObject, iLine).IsLast = TRUE Then
Exit For
End If
Next iLine
End If
Next iObject
' UPDATE THE SCREEN
_Display
' 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
' CLEAR KEYBOARD BUFFER
_KeyClear
' CONTROL GAME SPEED
_Limit iFPS
Wend
' UPDATE THE SCREEN
_Display
' CLEAR KEYBOARD BUFFER
_KeyClear ': _Delay 2
' PLAY ANOTHER ROUND OR QUIT?
If bQuit = FALSE Then
If bExit = FALSE Then Sleep
Color cWhite, cBlack
Else
Exit Do
End If
Loop
' This version stores the vector object definitions in DATA statements
' but we will move back to storing them in an external 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
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
' done with everything, finish last object & exit
m_arrLines(iObject, iLine).IsLast = TRUE
m_arrObject(iObject).IsEnabled = TRUE
Exit For
ElseIf b1 = -254 Then
' done with this object, finish & move to next
m_arrLines(iObject, iLine).IsLast = TRUE
m_arrObject(iObject).IsEnabled = TRUE
iObject = iObject + 1
iLine = 1
' if more data than array, quit
If iObject > UBound(m_arrLines, 1) Then
Exit For
End If
Else
' if more data than array,
' just keep reading until either
' we get to the next object or time to quit
If iLine <= UBound(m_arrLines, 2) Then
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
End If
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 = orange
Data 9,-62,60,-21,255,165,0
Data 60,-21,62,-3,255,165,0
Data 62,-3,24,13,255,165,0
Data 24,13,53,34,255,165,0
Data 53,34,38,55,255,165,0
Data 38,55,20,40,255,165,0
Data 20,40,-37,61,255,165,0
Data -37,61,-63,15,255,165,0
Data -63,15,-57,-24,255,165,0
Data -57,-24,-24,-24,255,165,0
Data -24,-24,-38,-45,255,165,0
Data -38,-45,9,-62,255,165,0
Data 0,0,0,0,-254,-254,-254
'objmouse = yellow
Data 0,-10,6,3,255,255,0
Data 6,3,1,2,255,255,0
Data 1,2,1,10,255,255,0
Data 1,10,-1,10,255,255,0
Data -1,10,-1,2,255,255,0
Data -1,2,-6,3,255,255,0
Data -6,3,0,-10,255,255,0
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
'objufo = green
Data -4,-16,4,-16,0,255,0
Data 4,-16,10,-6,0,255,0
Data 10,-6,25,5,0,255,0
Data 25,5,10,16,0,255,0
Data 10,16,-10,16,0,255,0
Data -10,16,-25,5,0,255,0
Data -25,5,-10,-6,0,255,0
Data -10,-6,-4,-16,0,255,0
Data -10,-6,10,-6,0,255,0
Data -25,5,25,5,0,255,0
Data 0,0,0,0,-255,-255,-255
Sub DrawLayers (imgBack&, imgMiddle&, imgFront&)
Dim RoutineName As String: RoutineName = "DrawLayers"
_Dest 0
Cls , cBlack
If TRUE = FALSE Then
If imgBack& < -1 Then
_PutImage , imgBack&, 0
End If
If imgMiddle& < -1 Then
_PutImage , imgMiddle&, 0
End If
If imgFront& < -1 Then
_PutImage , imgFront&, 0
End If
End If
End Sub ' DrawLayers
' ****************************************************************************************************************************************************************
' 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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Do ' main game loop
Cls ' Clear the form
GetInput
If m_bEscKey = FALSE Then
MoveBullets ' Activates the MoveBullets sub
MoveAllShips ' Activates the MoveAllShips sub
MoveEnemy ' (doesn't do much yet)
Collisions ' Activates the Collisions sub
Else
m_bGameOver = TRUE
End If
If m_bGameOver = FALSE Then
Shooting ' Activates the Shooting sub
DrawEnemy ' Activates the DrawEnemy sub
DrawBullets ' Activates the DrawBullets sub
ShowScore ' Display the score, etc.
DrawAllShips ' Activates the DrawAllShips sub
Respawn ' Activates the Respawn sub
Else
If AskPlayAgain% = TRUE Then
InitVariables
Else
Exit Do
End If
End If
'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
AskPlayAgain% = bResult
End Function ' AskPlayAgain%
' /////////////////////////////////////////////////////////////////////////////
' Set the initial state for variables
Sub InitVariables ()
Dim iLoop1 As Integer ' Used for variables
Dim iLoop2 As Integer
Dim iLoop3 As Integer
Dim iTurn As Integer
Dim iSpread As Integer
Dim iHalf As Integer
Dim iDivisor As Integer
Dim bDone As Integer
Dim in$
' Ask how many players?
Cls
Do
Input "How many players (1-16, 0 to quit) "; in$
in$ = _Trim$(in$)
If Len(in$) < 3 Then
If IsNumber%(in$) = TRUE Then
m_iPlayers = Val(in$)
If m_iPlayers >= 0 And iPlayers <= 16 Then
Exit Do
End If
End If
End If
Print: Print "Please type a number 0-16.": Print
Loop
' Initialize game
If m_iPlayers > 0 Then
' Score
m_iLevel = 1
' Set the starting positions of the ships
For iLoop1 = 1 To m_iPlayers
' FOR NOW JUST NAME EACH PLAYER A LETTER OF THE ALPHABET
m_arrShip(iLoop1).name = Chr$(iLoop1 + 64)
' EVERYONE STARTS WITH SAME SHIELDS
' TODO: GET THIS VALUE FROM OPTIONS
m_arrShip(iLoop1).shields = 100
' 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(iLoop1).radius = SHIP_RADIUS
' TODO: ADD OPTIONS FOR FUEL AND AMMO, FOR NOW NOT USED...
m_arrShip(iLoop1).fuel = 100
If m_iPlayers > 1 Then
m_arrShip(iLoop1).ammo = (m_iPlayers - 1) * 2 ' 2 shots per opponent
Else
m_arrShip(iLoop1).ammo = 10
End If
' PLACE SHIP
' TODO: PLACE SHIPS AROUND EDGES OF SCREEN, ON A BASE, ETC.
bDone = FALSE
Do
m_arrShip(iLoop1).xPos = RandomNumber%(iMinX, iMaxX) 'Int(Rnd * ScaleWidth + 1)
m_arrShip(iLoop1).yPos = RandomNumber%(iMinY, iMaxY) 'Int(Rnd * ScaleHeight + 1)
For iLoop2 = 1 To m_iPlayers
If iLoop2 <> iLoop1 Then
' Is ship too close to another ship?
If GetDist(m_arrShip(iLoop1).xPos, m_arrShip(iLoop1).yPos, m_arrShip(iLoop2).xPos, m_arrShip(iLoop2).yPos) > (m_arrShip(iLoop1).radius * 4) Then
bDone = TRUE
Exit For
End If
End If
Next iLoop2
If bDone = TRUE Then Exit Do
Loop
' POINT SHIP
iTurn = RandomNumber%(0, 143)
If iTurn = 0 Then
m_arrShip(iLoop1).facing = 0
m_arrShip(iLoop1).dx = 0
m_arrShip(iLoop1).dy = 0
Else
For iLoop3 = 1 To iTurn
m_arrShip(iLoop1).facing = m_arrShip(iLoop1).facing + PI / TURN_SPEED
m_arrShip(iLoop1).dx = m_arrShip(iLoop1).dx + 1
If m_arrShip(iLoop1).dx > 143 Then m_arrShip(iLoop1).dx = 0
m_arrShip(iLoop1).dy = m_arrShip(iLoop1).dy + 1
If m_arrShip(iLoop1).dy > 143 Then m_arrShip(iLoop1).dy = 0
Next iLoop3
End If
' SHOP NOT MOVING
' TODO: MAYBE ADD OPTION TO START PLAYERS DRIFTING IN A RANDOM DIRECTION?
m_arrShip(iLoop1).dx = 0
m_arrShip(iLoop1).dy = 0
m_arrShip(iLoop1).vx = 0
m_arrShip(iLoop1).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(iLoop1).ShootTime = iFPS \ 4
m_arrShip(iLoop1).ShootCount = m_arrShip(iLoop1).ShootTime + 1
' Spawn enemy
' TODO: start enemies off screen and let them move in on their own
ReDim _Preserve m_arrEnemy(0) As EnemyType
For iLoop1 = 0 To UBound(m_arrEnemy)
' Set the starting position of the enemies
m_arrEnemy(iLoop1).alive = TRUE
m_arrEnemy(iLoop1).life = 30
'm_arrEnemy(iLoop1).xPos = m_arrShip(iLoop1).xPos
'm_arrEnemy(iLoop1).yPos = m_arrShip(iLoop1).yPos
' choose a random size
m_arrEnemy(iLoop1).radius = RandomNumber%(m_iMinEnemyRadius, m_iMaxEnemyRadius)
' Stops the enemy starting on top of any players
Do
' Place enemy randomly
m_arrEnemy(iLoop1).xPos = RandomNumber%(iMinX, iMaxX) 'Int(Rnd * ScaleWidth + 1)
m_arrEnemy(iLoop1).yPos = RandomNumber%(iMinY, iMaxY) 'Int(Rnd * ScaleHeight + 1)
' Make sure enemy is not too close to any players
bDone = TRUE
For iLoop2 = 1 To m_iPlayers
If GetDist(m_arrEnemy(iLoop1).xPos, m_arrEnemy(iLoop1).yPos, m_arrShip(iLoop2).xPos, m_arrShip(iLoop2).yPos) <= (m_arrShip(iLoop2).radius * 4) Then
bDone = FALSE
Exit For
End If
Next iLoop2
' Have we found a place for this enemy?
If bDone = TRUE Then Exit Do
Loop
Next iLoop1
' RESET BULLETS
ReDim _Preserve m_arrBullet(-1) As BulletType
End If
End Sub ' InitVariables
' /////////////////////////////////////////////////////////////////////////////
' Detect which keys are pressed
Sub GetInput ()
Dim iLoop2 As Integer
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
If _Button(KeyCode_Escape%) Then
m_bEscKey = TRUE
Else
m_bEscKey = FALSE
End If
For iLoop2 = 1 To m_iPlayers
If m_arrShip(iLoop2).shields > 0 Then
If _Button(m_arrShip(iLoop2).Left_KeyCode) Then
m_arrShip(iLoop2).Left_IsPressed = TRUE
m_arrShip(iLoop2).Right_IsPressed = FALSE
ElseIf _Button(m_arrShip(iLoop2).Right_KeyCode) Then
m_arrShip(iLoop2).Left_IsPressed = FALSE
m_arrShip(iLoop2).Right_IsPressed = TRUE
Else
m_arrShip(iLoop2).Left_IsPressed = FALSE
m_arrShip(iLoop2).Right_IsPressed = FALSE
End If
If _Button(m_arrShip(iLoop2).Up_KeyCode) Then
m_arrShip(iLoop2).Up_IsPressed = TRUE
m_arrShip(iLoop2).Down_IsPressed = FALSE
ElseIf _Button(m_arrShip(iLoop2).Down_KeyCode) Then
m_arrShip(iLoop2).Up_IsPressed = FALSE
m_arrShip(iLoop2).Down_IsPressed = TRUE
Else
m_arrShip(iLoop2).Up_IsPressed = FALSE
m_arrShip(iLoop2).Down_IsPressed = FALSE
End If
If _Button(m_arrShip(iLoop2).Shoot_KeyCode) Then
m_arrShip(iLoop2).Shoot_IsPressed = TRUE
Else
m_arrShip(iLoop2).Shoot_IsPressed = FALSE
End If
If _Button(m_arrShip(iLoop2).Cheat_KeyCode) Then
m_arrShip(iLoop2).Cheat_IsPressed = TRUE
Else
m_arrShip(iLoop2).Cheat_IsPressed = FALSE
End If
End If
Next iLoop2
' CLEAR KEYBOARD BUFFER
_KeyClear
End Sub ' GetInput
' /////////////////////////////////////////////////////////////////////////////
' Check for collisions
' TODO: improve collision checking to handle different shape polygons, etc.
Sub Collisions ()
Dim iLoop1 As Integer
Dim iLoop2 As Integer
Dim iCount As Integer
Dim in$
' Check for bullet collisions
For iLoop1 = 0 To UBound(m_arrBullet)
' IS THIS BULLET ALIVE?
If m_arrBullet(iLoop1).alive = TRUE Then
' CHECK FOR BULLET HIT BULLET
For iLoop2 = 0 To UBound(m_arrBullet)
If iLoop2 <> iLoop1 Then
If BULLETS_STOP_BULLETS = TRUE Then
If GetDist(m_arrBullet(iLoop2).xPos, m_arrBullet(iLoop2).yPos, m_arrBullet(iLoop1).xPos, m_arrBullet(iLoop1).yPos) <= BULLET_RADIUS Then
' BOTH SHOTS DESTROYED
m_arrBullet(iLoop1).alive = FALSE ' Destroy the bullet
m_arrBullet(iLoop2).alive = FALSE ' Destroy the other bullet
End If
End If
End If
Next iLoop2
End If
' IS THIS BULLET STILL ALIVE?
If m_arrBullet(iLoop1).alive = TRUE Then
' Check for collision between bullet and ships
For iLoop2 = 1 To m_iPlayers
If GetDist(m_arrShip(iLoop2).xPos, m_arrShip(iLoop2).yPos, m_arrBullet(iLoop1).xPos, m_arrBullet(iLoop1).yPos) <= m_arrShip(iLoop2).radius Then
' ONLY HIT SHIP IF IT'S ALIVE!
If m_arrShip(iLoop2).shields > 0 Then
' TODO: DIFFERENT DAMAGE DEPENDING ON WHETHER IT'S A PLAYER OR ENEMY BULLET, WEAPON TYPE, ETC.
m_arrShip(iLoop2).shields = m_arrShip(iLoop2).shields - BULLET_DAMAGE ' Take Damage
m_arrBullet(iLoop1).alive = FALSE ' Destroy the bullet
' SCORING
If m_arrBullet(iLoop1).kind = "SHIP" Then
' PLAYER SCORES IF OPPONENT KILLED
' TODO: award points for hit but not kill?
If m_arrShip(iLoop2).shields < 1 Then
m_arrShip(m_arrBullet(iLoop1).owner).score = m_arrShip(m_arrBullet(iLoop1).owner).score + 100
Exit For
End If
End If
End If
End If
Next iLoop2
' Check for collision between bullet and enemies
For iLoop2 = 0 To UBound(m_arrEnemy)
' If the enemy is alive then
If m_arrEnemy(iLoop2).alive = TRUE Then
' Check for collision between bullet and enemy
If GetDist(m_arrEnemy(iLoop2).xPos, m_arrEnemy(iLoop2).yPos, m_arrBullet(iLoop1).xPos, m_arrBullet(iLoop1).yPos) <= m_arrEnemy(iLoop2).radius Then
' TODO: DIFFERENT DAMAGE DEPENDING ON WHETHER IT'S A PLAYER OR ENEMY BULLET, WEAPON TYPE, ETC.
m_arrEnemy(iLoop2).life = m_arrEnemy(iLoop2).life - BULLET_DAMAGE ' Enemy take damage
m_arrBullet(iLoop1).alive = FALSE ' Destroy the bullet
' if the enemy is dead then destroy it, add to score
If m_arrEnemy(iLoop2).life <= 0 Then
m_arrEnemy(iLoop2).alive = FALSE
' SCORING
If m_arrBullet(iLoop1).kind = "SHIP" Then
m_arrShip(m_arrBullet(iLoop1).owner).score = m_arrShip(m_arrBullet(iLoop1).owner).score + 10
'm_iScore = m_iScore + 10
End If
End If
End If
End If
Next iLoop2
End If
Next iLoop1
' CHECK FOR SHIP COLLIDING WITH ENEMY
For iLoop1 = 0 To UBound(m_arrEnemy)
' If the enemy is alive then
If m_arrEnemy(iLoop1).alive = TRUE Then
' Check for collision between ships and enemy
For iLoop2 = 1 To m_iPlayers
If GetDist(m_arrShip(iLoop2).xPos, m_arrShip(iLoop2).yPos, m_arrEnemy(iLoop1).xPos, m_arrEnemy(iLoop1).yPos) <= m_arrEnemy(iLoop1).radius Then
m_arrEnemy(iLoop1).life = 0 ' The enemy has no life/Dead
m_arrShip(iLoop2).shields = 0 ' The ship has no shields/Dead
' if the enemy is dead then destroy it, add to score
If m_arrEnemy(iLoop1).life <= 0 Then
m_arrEnemy(iLoop1).alive = FALSE
'm_iScore = m_iScore + 10
m_arrShip(iLoop2).score = m_arrShip(iLoop2).score + 10
End If
Exit For
End If
Next iLoop2
End If
Next iLoop1
' CHECK FOR SHIP COLLIDING WITH SHIP
For iLoop1 = 1 To m_iPlayers
' ONLY CHECK SHIP IF IT'S ALIVE!
If m_arrShip(iLoop1).shields > 0 Then
' CHECK FOR SHIPS COLLIDED WITH
For iLoop2 = 1 To m_iPlayers
' SHIP CAN'T COLLIDE WITH SELF
If iLoop1 <> iLoop2 Then
' ONLY CHECK SHIP IF IT'S ALIVE!
If m_arrShip(iLoop2).shields > 0 Then
' DID THEY COLLIDE?
If GetDist(m_arrShip(iLoop1).xPos, m_arrShip(iLoop1).yPos, m_arrShip(iLoop2).xPos, m_arrShip(iLoop2).yPos) <= m_arrShip(iLoop1).radius Then
' DEAD!
' TODO: MAYBE SHIPS DON'T JUST BLOW UP WHEN THEY COLLIDE, ADD OPTIONS FOR DAMAGE, BOUNCE OFF EACH OTHER, ETC.
m_arrShip(iLoop1).shields = 0
m_arrShip(iLoop2).shields = 0
' SCORE ONE LAST TIME!
m_arrShip(iLoop1).score = m_arrShip(iLoop1).score + 100
m_arrShip(iLoop2).score = m_arrShip(iLoop2).score + 100
End If
End If
End If
Next iLoop2
End If
Next iLoop1
' HOW MANY PLAYERS STILL ALIVE?
iCount = 0
For iLoop2 = 1 To m_iPlayers
If m_arrShip(iLoop2).shields > 0 Then
iCount = iCount + 1
End If
Next iLoop2
' GAME OVER?
If m_iPlayers = 1 Then
' SINGLE PLAYER GAME
If iCount < 1 Then
m_bGameOver = TRUE
End If
Else
If iCount < 2 Then
' MULTIPLAYER GAME
' TODO: ADD OPTION TO ADVANCE TO NEXT ROUND FOR MULTIPLAYER GAME
m_bGameOver = TRUE
End If
End If
Sub Shooting ()
Dim iLoop1 As Integer ' Used for variables
Dim iLoop2 As Integer ' Used for variables
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 iLoop2 = 1 To m_iPlayers
'If m_bShootKey = TRUE Then
If m_arrShip(iLoop2).Shoot_IsPressed = TRUE Then
' Has the gun cooled down yet (prevent bullet being created every 25 milliseconds)
If m_arrShip(iLoop2).ShootCount > m_arrShip(iLoop2).ShootTime Then
m_arrShip(iLoop2).ShootCount = 0
iFreeSpot = -1
For iLoop1 = 0 To UBound(m_arrBullet)
' Check whether it can use another bullet or not
If m_arrBullet(iLoop1).alive = FALSE Then
' if so use the dead bullet
iFreeSpot = iLoop1
Exit For
End If
Next iLoop1
' 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 = iLoop2 ' identify player that fired shot
m_arrBullet(iFreeSpot).alive = TRUE ' The bullet is alive
m_arrBullet(iFreeSpot).xPos = m_arrShip(iLoop2).xPos ' the bullet is created where the ship is
m_arrBullet(iFreeSpot).yPos = m_arrShip(iLoop2).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(iLoop2).speed * Sin(m_arrShip(iLoop2).heading) + BULLET_SPEED * Sin(m_arrShip(iLoop2).facing)
sngYComp = m_arrShip(iLoop2).speed * Cos(m_arrShip(iLoop2).heading) + BULLET_SPEED * Cos(m_arrShip(iLoop2).facing)
'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
' ENEMIES SHOOT
For iLoop1 = 0 To UBound(m_arrEnemy)
' Check whether the enemy is alive
If m_arrEnemy(iLoop1).alive = TRUE Then
' Check whether the enemy will fire or not
If Int(Rnd * 100 + 1) = 1 Then
iFreeSpot = -1
For iLoop2 = 0 To UBound(m_arrBullet)
' Check whether the enemy will use an old bullet
If m_arrBullet(iLoop2).alive = FALSE Then
' If so iFreeSpot is the old bullet
iFreeSpot = iLoop2
Exit For
End If
Next iLoop2
' 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 iLoop2 = 1 To m_iPlayers
If m_arrShip(iLoop2).shields > 0 Then
sngCheckDistance = GetDist(m_arrEnemy(iLoop1).xPos, m_arrEnemy(iLoop1).yPos, m_arrShip(iLoop2).xPos, m_arrShip(iLoop2).yPos)
If sngCheckDistance < sngShortestDistance Then
sngShortestDistance = sngCheckDistance
iClosestPlayer = iLoop2
End If
End If
Next iLoop2
' 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 = iLoop1 ' identify enemy that fired shot
' Aim the shot at the player
m_arrBullet(iFreeSpot).heading = GetAngle(m_arrEnemy(iLoop1).xPos, m_arrEnemy(iLoop1).yPos, m_arrShip(iClosestPlayer).xPos, m_arrShip(iClosestPlayer).yPos)
m_arrBullet(iFreeSpot).xPos = m_arrEnemy(iLoop1).xPos ' Create the bullet where the enemy is
m_arrBullet(iFreeSpot).yPos = m_arrEnemy(iLoop1).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(iLoop1).radius + 1) * Sin(m_arrBullet(iFreeSpot).heading))
m_arrBullet(iFreeSpot).yPos = m_arrBullet(iFreeSpot).yPos - ((m_arrEnemy(iLoop1).radius + 1) * Cos(m_arrBullet(iFreeSpot).heading))
End If
End If
End If
Next iLoop1
End Sub ' Shooting
' /////////////////////////////////////////////////////////////////////////////
' Draw the enemies
Sub DrawEnemy ()
Dim iLoop1 As Integer ' Used for variables
Dim iLoop2 As Integer ' Used for variables
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
For iLoop1 = 0 To UBound(m_arrEnemy)
' Is this enemy alive
If m_arrEnemy(iLoop1).alive = TRUE Then
' Color based on damage
If m_arrEnemy(iLoop1).life >= 30 Then
iColor = cWhite
ElseIf m_arrEnemy(iLoop1).life > 25 Then
iColor = cYellow
ElseIf m_arrEnemy(iLoop1).life > 20 Then
iColor = cGold
ElseIf m_arrEnemy(iLoop1).life > 15 Then
iColor = cOrange
ElseIf m_arrEnemy(iLoop1).life > 10 Then
iColor = cDarkOrange
ElseIf m_arrEnemy(iLoop1).life > 5 Then
iColor = cOrangeRed
Else
iColor = cRed
End If
' Draw body
' CIRCLE (x, y), radius, color
'DrawCircleSolid iX, iY, 8, cRed
Circle (m_arrEnemy(iLoop1).xPos, m_arrEnemy(iLoop1).yPos), m_arrEnemy(iLoop1).radius, iColor
' Determine closest player
sngShortestDistance = iMaxX + iMaxY + 1
iClosestPlayer = 0
For iLoop2 = 1 To m_iPlayers
If m_arrShip(iLoop2).shields > 0 Then
sngCheckDistance = GetDist(m_arrEnemy(iLoop1).xPos, m_arrEnemy(iLoop1).yPos, m_arrShip(iLoop2).xPos, m_arrShip(iLoop2).yPos)
If sngCheckDistance < sngShortestDistance Then
sngShortestDistance = sngCheckDistance
iClosestPlayer = iLoop2
End If
End If
Next iLoop2
' Draw "eye"
' TODO: get this working
If iClosestPlayer > 0 Then
sngHeading = GetAngle(m_arrEnemy(iLoop1).xPos, m_arrEnemy(iLoop1).yPos, m_arrShip(iClosestPlayer).xPos, m_arrShip(iClosestPlayer).yPos)
iX = m_arrEnemy(iLoop1).xPos
iY = m_arrEnemy(iLoop1).yPos
iRadius = m_arrEnemy(iLoop1).radius / 3
iX = iX + (m_arrEnemy(iLoop1).radius - iRadius) * Sin(sngHeading)
iY = iY - (m_arrEnemy(iLoop1).radius - iRadius) * Cos(sngHeading)
Circle (iX, iY), iRadius, iColor
End If
Sub MoveBullets ()
Dim iLoop1 As Integer ' Used for variables
Dim iLoop2 As Integer ' Used for variables
For iLoop2 = 1 To m_iPlayers
If m_arrShip(iLoop2).ShootCount <= m_arrShip(iLoop2).ShootTime Then
m_arrShip(iLoop2).ShootCount = m_arrShip(iLoop2).ShootCount + 1
End If
Next iLoop2
For iLoop1 = 0 To UBound(m_arrBullet)
' Is the bullet alive
If m_arrBullet(iLoop1).alive = TRUE Then
' Move the bullets
m_arrBullet(iLoop1).xPos = m_arrBullet(iLoop1).xPos + (m_arrBullet(iLoop1).speed * Sin(m_arrBullet(iLoop1).heading))
m_arrBullet(iLoop1).yPos = m_arrBullet(iLoop1).yPos - (m_arrBullet(iLoop1).speed * Cos(m_arrBullet(iLoop1).heading))
' Did the bullet move off screen horizontally?
If m_arrBullet(iLoop1).xPos < iMinX Then
If WRAP_BULLET = TRUE Then
m_arrBullet(iLoop1).xPos = iMaxX
Else
m_arrBullet(iLoop1).alive = FALSE ' Destroy the bullet
End If
ElseIf m_arrBullet(iLoop1).xPos > iMaxX Then
If WRAP_BULLET = TRUE Then
m_arrBullet(iLoop1).xPos = iMinX
Else
m_arrBullet(iLoop1).alive = FALSE ' Destroy the bullet
End If
End If
' Did the bullet move off screen vertically?
If m_arrBullet(iLoop1).yPos < iMinY Then
If WRAP_BULLET = TRUE Then
m_arrBullet(iLoop1).yPos = iMaxY
Else
m_arrBullet(iLoop1).alive = FALSE ' Destroy the bullet
End If
ElseIf m_arrBullet(iLoop1).yPos > iMaxY Then
If WRAP_BULLET = TRUE Then
m_arrBullet(iLoop1).yPos = iMinY
Else
m_arrBullet(iLoop1).alive = FALSE ' Destroy the bullet
End If
End If
' Time how long bullet stays active
m_arrBullet(iLoop1).lifetime = m_arrBullet(iLoop1).lifetime + 1
If m_arrBullet(iLoop1).lifetime > m_arrBullet(iLoop1).lifespan Then
m_arrBullet(iLoop1).alive = FALSE ' Destroy the bullet
End If
End If
Next iLoop1
End Sub ' MoveBullets
' /////////////////////////////////////////////////////////////////////////////
' Draw the bullets
Sub DrawBullets ()
Dim iLoop1 As Integer ' Used for variables
For iLoop1 = 0 To UBound(m_arrBullet)
' Is the bullet alive
If m_arrBullet(iLoop1).alive = TRUE Then
If m_arrBullet(iLoop1).kind = "SHIP" Then
' Is this a ship bullet, draw a white bullet
'Circle (m_arrBullet(iLoop1).xPos, m_arrBullet(iLoop1).yPos), 3, cWhite
DrawCircleSolid m_arrBullet(iLoop1).xPos, m_arrBullet(iLoop1).yPos, BULLET_RADIUS, cWhite
ElseIf m_arrBullet(iLoop1).kind = "ENEMY" Then
' if this is enemy bullet, draw a red bullet
'Circle (m_arrBullet(iLoop1).xPos, m_arrBullet(iLoop1).yPos), 3, cOrangeRed
DrawCircleSolid m_arrBullet(iLoop1).xPos, m_arrBullet(iLoop1).yPos, BULLET_RADIUS, cOrangeRed
End If
End If
Next iLoop1
End Sub ' DrawBullets
Sub MoveAllShips ()
Dim iLoop2 As Integer
For iLoop2 = 1 To m_iPlayers
If m_arrShip(iLoop2).shields > 0 Then
MoveShip iLoop2
End If
Next iLoop2
End Sub ' MoveAllShips
' /////////////////////////////////////////////////////////////////////////////
' Move the ship
Sub MoveShip (iShipIndex As Integer)
Dim sngXComp As Single
Dim sngYComp As Single
' If the left key is pressed then rotate the ship left
If m_arrShip(iShipIndex).Left_IsPressed = TRUE Then
m_arrShip(iShipIndex).facing = m_arrShip(iShipIndex).facing - PI / TURN_SPEED
m_arrShip(iShipIndex).dx = m_arrShip(iShipIndex).dx - 1
If m_arrShip(iShipIndex).dx < 0 Then m_arrShip(iShipIndex).dx = 143
m_arrShip(iShipIndex).dy = m_arrShip(iShipIndex).dy - 1
If m_arrShip(iShipIndex).dy < 0 Then m_arrShip(iShipIndex).dy = 143
End If
' If the Right key is pressed then rotate the ship right
If m_arrShip(iShipIndex).Right_IsPressed = TRUE Then
m_arrShip(iShipIndex).facing = m_arrShip(iShipIndex).facing + PI / TURN_SPEED
m_arrShip(iShipIndex).dx = m_arrShip(iShipIndex).dx + 1
If m_arrShip(iShipIndex).dx > 143 Then m_arrShip(iShipIndex).dx = 0
m_arrShip(iShipIndex).dy = m_arrShip(iShipIndex).dy + 1
If m_arrShip(iShipIndex).dy > 143 Then m_arrShip(iShipIndex).dy = 0
End If
' If the up key is pressed then and accelerate it in the direction the ship is facing
If m_arrShip(iShipIndex).Up_IsPressed = TRUE Then
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' TODO: fix this to make the movement more natural...
' ACCELERATE X AND Y DIRECTIONS BASED ON WHICH DIRECTION WE'RE POINTING
m_arrShip(iShipIndex).vx = m_arrShip(iShipIndex).vx + (m_arrDX(m_arrShip(iShipIndex).dx) * SHIP_ACCEL)
m_arrShip(iShipIndex).vy = m_arrShip(iShipIndex).vy + (m_arrDY(m_arrShip(iShipIndex).dy) * SHIP_ACCEL)
If TRUE = FALSE Then
' Determine the X and Y components of the resultant vector
sngXComp = m_arrShip(iShipIndex).speed * Sin(m_arrShip(iShipIndex).heading) + SHIP_ACCEL * Sin(m_arrShip(iShipIndex).facing)
sngYComp = m_arrShip(iShipIndex).speed * Cos(m_arrShip(iShipIndex).heading) + SHIP_ACCEL * Cos(m_arrShip(iShipIndex).facing)
' Calculate the resultant heading, and adjust for arctangent by adding Pi if necessary
If Sgn(sngYComp) > 0 Then
m_arrShip(iShipIndex).heading = Atn(sngXComp / sngYComp)
End If
If Sgn(sngYComp) < 0 Then
m_arrShip(iShipIndex).heading = Atn(sngXComp / sngYComp) + PI
End If
End If
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
End If
' If the down key is pressed then and accelerate the ship in the opposite direction it is facing
If TRUE = FALSE Then
If m_arrShip(iShipIndex).Down_IsPressed = TRUE And m_arrShip(iShipIndex).speed > -MAX_SPEED Then
' Determine the X and Y components of the resultant vector
sngXComp = m_arrShip(iShipIndex).speed * Sin(m_arrShip(iShipIndex).heading) - SHIP_ACCEL * Sin(m_arrShip(iShipIndex).facing)
sngYComp = m_arrShip(iShipIndex).speed * Cos(m_arrShip(iShipIndex).heading) - SHIP_ACCEL * Cos(m_arrShip(iShipIndex).facing)
' Calculate the resultant heading, and adjust for actangent by adding Pi if necessary
If Sgn(sngYComp) > 0 Then
m_arrShip(iShipIndex).heading = Atn(sngXComp / sngYComp)
End If
If Sgn(sngYComp) < 0 Then
m_arrShip(iShipIndex).heading = Atn(sngXComp / sngYComp) + PI
End If
End If
End If
' Did player hit cheat key?
If m_arrShip(iShipIndex).Cheat_IsPressed = TRUE Then
m_arrShip(iShipIndex).shields = m_arrShip(iShipIndex).shields + 10
End If
' Don't let the ship go faster then the max speed
If m_arrShip(iShipIndex).vx < 0 - MAX_SPEED Then
m_arrShip(iShipIndex).vx = 0 - MAX_SPEED
ElseIf m_arrShip(iShipIndex).vx > MAX_SPEED Then
m_arrShip(iShipIndex).vx = MAX_SPEED
End If
If m_arrShip(iShipIndex).vy < 0 - MAX_SPEED Then
m_arrShip(iShipIndex).vy = 0 - MAX_SPEED
ElseIf m_arrShip(iShipIndex).vy > MAX_SPEED Then
m_arrShip(iShipIndex).vy = MAX_SPEED
End If
If TRUE = FALSE Then
If m_arrShip(iShipIndex).speed > MAX_SPEED Then
m_arrShip(iShipIndex).speed = MAX_SPEED
End If
End If
' Keep the ship inside the form
If m_arrShip(iShipIndex).xPos < iMinX Then
m_arrShip(iShipIndex).xPos = iMaxX
End If
If m_arrShip(iShipIndex).xPos > iMaxX Then
m_arrShip(iShipIndex).xPos = iMinX
End If
If m_arrShip(iShipIndex).yPos < iMinY Then
m_arrShip(iShipIndex).yPos = iMaxY
End If
If m_arrShip(iShipIndex).yPos > iMaxY Then
m_arrShip(iShipIndex).yPos = iMinY
End If
End Sub ' MoveShip
Sub MoveEnemy ()
Dim iLoop1 As Integer
'For iLoop1 = 0 To UBound(m_arrEnemy)
' ' Check whether the enemy is alive
' If m_arrEnemy(iLoop1).alive = TRUE Then
' End If
'Next iLoop1
End Sub ' MoveEnemy
' Show instructions
'TODO: SHOW INSTRUCTIONS (MAKE KEYCODE TO TEXT FUNCTIONS?)
'Color cRed, cRed
'PrintAt 45, 0, String$(120, " ")
'Color cWhite, cEmpty
'PrintAt 45, 0, "CONTROLS: LEFT/RIGHT = TURN UP/DOWN = FORWARD/BACK CTRL=FIRE 1=ADD SHIELD (CHEAT)"
End Sub ' ShowScore
' /////////////////////////////////////////////////////////////////////////////
' Draw the ship
Sub DrawAllShips ()
Dim iLoop2 As Integer
For iLoop2 = 1 To m_iPlayers
If m_arrShip(iLoop2).shields > 0 Then
DrawShip iLoop2
End If
Next iLoop2
End Sub ' DrawAllShips
' /////////////////////////////////////////////////////////////////////////////
' Draw the ship
Sub DrawShip (iShipIndex 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
' left rear
intX2 = m_arrShip(iShipIndex).xPos + SHIP_RADIUS * Sin(m_arrShip(iShipIndex).facing + 2 * PI / 3)
intY2 = m_arrShip(iShipIndex).yPos - SHIP_RADIUS * Cos(m_arrShip(iShipIndex).facing + 2 * PI / 3)
' left rear (3/4 of the way down)
intX2b = m_arrShip(iShipIndex).xPos + ENGINE_RADIUS * Sin(m_arrShip(iShipIndex).facing + 2 * PI / 3)
intY2b = m_arrShip(iShipIndex).yPos - ENGINE_RADIUS * Cos(m_arrShip(iShipIndex).facing + 2 * PI / 3)
' right rear
intX3 = m_arrShip(iShipIndex).xPos + SHIP_RADIUS * Sin(m_arrShip(iShipIndex).facing + 4 * PI / 3)
intY3 = m_arrShip(iShipIndex).yPos - SHIP_RADIUS * Cos(m_arrShip(iShipIndex).facing + 4 * PI / 3)
' right rear (3/4 of the way down)
intX3b = m_arrShip(iShipIndex).xPos + ENGINE_RADIUS * Sin(m_arrShip(iShipIndex).facing + 4 * PI / 3)
intY3b = m_arrShip(iShipIndex).yPos - ENGINE_RADIUS * Cos(m_arrShip(iShipIndex).facing + 4 * PI / 3)
' rear where engine flames end
intX1b = m_arrShip(iShipIndex).xPos - FLAME_RADIUS * Sin(m_arrShip(iShipIndex).facing)
intY1b = m_arrShip(iShipIndex).yPos + FLAME_RADIUS * Cos(m_arrShip(iShipIndex).facing)
'm_arrShip(iShipIndex).facing = m_arrShip(iShipIndex).facing - Pi / 36
' -----------------------------------------------------------------------------
' Draw the ship
' Draw the left side
Line (intX1, intY1)-(intX2, intY2), m_arrShip(iShipIndex).BodyColor
' Draw the right side
Line (intX1, intY1)-(intX3, intY3), m_arrShip(iShipIndex).BodyColor
' Draw the rear / aft side
If m_arrShip(iShipIndex).Up_IsPressed Then
' Draw rear side
Line (intX2b, intY2b)-(intX3b, intY3b), m_arrShip(iShipIndex).EngineColor
' Engine is firing
'Line (intX2b, intY2b)-(intX3b, intY3b), m_arrShip(iShipIndex).FlameColor
' Draw the flame left side
Line (intX1b, intY1b)-(intX2b, intY2b), m_arrShip(iShipIndex).FlameColor
' Draw the flame right side
Line (intX1b, intY1b)-(intX3b, intY3b), m_arrShip(iShipIndex).FlameColor
Else
' Draw rear side
Line (intX2b, intY2b)-(intX3b, intY3b), m_arrShip(iShipIndex).EngineColor
End If
End Sub ' DrawShip
' /////////////////////////////////////////////////////////////////////////////
' Respawn the enemies if there all dead
Sub Respawn ()
Dim iLoop1 As Integer ' Used for variables
Dim iLoop2 As Integer ' Used for variables
Dim bDone As Integer
' Check if all enemies are dead
m_bAllDead = TRUE
For iLoop1 = 0 To UBound(m_arrEnemy)
' If an enemy is alive then
If m_arrEnemy(iLoop1).alive = TRUE Then
' enemies aren't all dead
m_bAllDead = FALSE
Exit For
End If
Next iLoop1
' if all dead, respawn and create one more enemy
' advance to next level
If m_bAllDead = TRUE Then
' INCREASE LEVEL
m_iLevel = m_iLevel + 1
' 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 iLoop2 = 1 To m_iPlayers
If m_arrShip(iLoop2).shields > 0 Then
m_arrShip(iLoop2).shields = m_arrShip(iLoop2).shields + BONUS_SHIELDS
m_arrShip(iLoop2).level = m_arrShip(iLoop2).level + 1
m_arrShip(iLoop2).score = m_arrShip(iLoop2).score + 100
End If
Next iLoop2
' 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 iLoop1 = 0 To UBound(m_arrEnemy)
' Set the starting positions
m_arrEnemy(iLoop1).alive = TRUE
m_arrEnemy(iLoop1).life = 30
'm_arrEnemy(iLoop1).xPos = m_arrShip(iLoop1).xPos
'm_arrEnemy(iLoop1).yPos = m_arrShip(iLoop1).yPos
' choose a random size
m_arrEnemy(iLoop1).radius = RandomNumber%(m_iMinEnemyRadius, m_iMaxEnemyRadius)
' make sure the enemies don't start on the ship
bDone = FALSE
Do
m_arrEnemy(iLoop1).xPos = RandomNumber%(iMinX, iMaxX) 'Int(Rnd * ScaleWidth + 1)
m_arrEnemy(iLoop1).yPos = RandomNumber%(iMinY, iMaxY) 'Int(Rnd * ScaleHeight + 1)
For iLoop2 = 1 To m_iPlayers
If m_arrShip(iLoop2).shields > 0 Then
If GetDist(m_arrEnemy(iLoop1).xPos, m_arrEnemy(iLoop1).yPos, m_arrShip(iLoop2).xPos, m_arrShip(iLoop2).yPos) > SHIP_RADIUS * 10 Then
bDone = TRUE
Exit For
End If
End If
Next iLoop2
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 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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END DX/DY TABLES @DXDY
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN TRIG FUNCTIONS #TRIG
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' 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
' /////////////////////////////////////////////////////////////////////////////
' 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
' /////////////////////////////////////////////////////////////////////////////
' 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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END TRIG FUNCTIONS @TRIG
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 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$
' /////////////////////////////////////////////////////////////////////////////
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
Function DblToStr$ (n#)
Dim result$: result$ = ""
Dim value$
Dim Xpos%
Dim expo%
Dim sign$
Dim valu$
Dim dot%
Dim L%
Dim add$
Dim min$
Dim DP$
Dim n%
value$ = UCase$(LTrim$(Str$(n#)))
Xpos% = InStr(value$, "D") + InStr(value$, "E") ' only D or E can be present
If Xpos% Then
expo% = Val(Mid$(value$, Xpos% + 1))
If Val(value$) < 0 Then
sign$ = "-"
valu$ = Mid$(value$, 2, Xpos% - 2)
Else
valu$ = Mid$(value$, 1, Xpos% - 1)
End If
dot% = InStr(valu$, ".")
L% = Len(valu$)
If expo% > 0 Then
add$ = String$(expo% - (L% - dot%), "0")
End If
If expo% < 0 Then
min$ = String$(Abs(expo%) - (dot% - 1), "0")
DP$ = "."
End If
For n% = 1 To L%
If Mid$(valu$, n%, 1) <> "." Then
num$ = num$ + Mid$(valu$, n%, 1)
End If
Next n%
result$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
Else
result$ = value$
End If
Function DblRoundedToStr$ (dblValue As Double, intNumPlaces As Integer)
Dim dblNew As Double
dblNew = RoundDouble#(dblValue, intNumPlaces)
DblRoundedToStr$ = DblToStr$(dblNew)
End Function ' DblRoundedToStr$
' /////////////////////////////////////////////////////////////////////////////
' Receives an {sDelim} delimited list {sInput}
' returns the list with all duplicate entries removed.
Function DedupeDelimList$ (sInput As String, sDelim As String)
ReDim arrLines(-1) As String
Dim sOutput As String
Dim iLoop As Integer
split sInput, sDelim, arrLines()
sOutput = sDelim
For iLoop = LBound(arrLines) To UBound(arrLines)
If InStr(1, sOutput, sDelim + arrLines(iLoop) + sDelim) = 0 Then
sOutput = sOutput + arrLines(iLoop) + sDelim
End If
Next iLoop
DedupeDelimList$ = sOutput
End Function ' DedupeDelimList$
Function DoubleABS# (dblValue As Double)
If Sgn(dblValue) = -1 Then
DoubleABS# = 0 - dblValue
Else
DoubleABS# = dblValue
End If
End Function ' DoubleABS#
' /////////////////////////////////////////////////////////////////////////////
' bplus: The Gold Standard is even better than THE QB64 CIRCLE sub in this respect!
' https://forum.qb64.org/index.php?topic=1044.135
' from Steve Gold standard
' Renamed fcirc to DrawCircleSolid
' Not as fast as DrawCircleTopLeft but pretty fast.
' Example:
' Screen _NewImage(800, 600, 32)
' _ScreenMove 250, 60
' For r = 250 To 0 Step -60
' DrawCircleSolid 400, 300, r, _RGBA(255, 255, 255, 100)
' Next r
Sub DrawCircleSolid (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R)
RadiusError = -Radius
X = Radius
Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
' Draw the middle span here so we don't draw it twice in the main loop,
' which would be a problem with blending turned on.
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub ' DrawCircleSolid
' /////////////////////////////////////////////////////////////////////////////
' SMcNeill
' More efficient version of ExtendedTimer.
' This stores our day values and only updates them when necessary.
' We really don't need to figure out how many seconds are in today over and over endlessly
' -- just count them once, and when the clock swaps back to 0:0:0, add 24*60*60 seconds to the count.
' Re: how to time something (ie do loop for n seconds)
' https://forum.qb64.org/index.php?topic=4682.0
Function ExtendedTimer##
'modified extendedtimer to store the old day's count, and not have to recalculate it every time the routine is called.
Static olds As _Float, old_day As _Float
Dim m As Integer, d As Integer, y As Integer
Dim s As _Float, day As String
If olds = 0 Then 'calculate the day the first time the extended timer runs
day = Date$
m = Val(Left$(day, 2))
d = Val(Mid$(day, 4, 2))
y = Val(Right$(day, 4)) - 1970
Select Case m 'Add the number of days for each previous month passed
Case 2: d = d + 31
Case 3: d = d + 59
Case 4: d = d + 90
Case 5: d = d + 120
Case 6: d = d + 151
Case 7: d = d + 181
Case 8: d = d + 212
Case 9: d = d + 243
Case 10: d = d + 273
Case 11: d = d + 304
Case 12: d = d + 334
End Select
If (y Mod 4) = 2 And m > 2 Then d = d + 1 'add a day if this is leap year and we're past february
d = (d - 1) + 365 * y 'current month days passed + 365 days per each standard year
d = d + (y + 2) \ 4 'add in days for leap years passed
s = d * 24 * 60 * 60 'Seconds are days * 24 hours * 60 minutes * 60 seconds
old_day = s
End If
If Timer < oldt Then 'we went from 23:59:59 (a second before midnight) to 0:0:0 (midnight)
old_day = s + 83400 'add another worth of seconds to our counter
End If
oldt = Timer
olds = old_day + oldt
ExtendedTimer## = olds
End Function ' ExtendedTimer##
Function FloatRoundedToStr$ (fValue As _Float, intNumPlaces As Integer)
Dim fNew As _Float
fNew = Round##(fValue, intNumPlaces)
FloatRoundedToStr$ = FloatToStr$(fNew)
End Function ' DblRoundedToStr$
' /////////////////////////////////////////////////////////////////////////////
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
Function FloatToStr$ (n##)
value$ = UCase$(LTrim$(Str$(n##)))
Xpos% = InStr(value$, "D") + InStr(value$, "E") 'only D or E can be present
If Xpos% Then
expo% = Val(Mid$(value$, Xpos% + 1))
If Val(value$) < 0 Then
sign$ = "-"
valu$ = Mid$(value$, 2, Xpos% - 2)
Else
valu$ = Mid$(value$, 1, Xpos% - 1)
End If
dot% = InStr(valu$, ".")
L% = Len(valu$)
If expo% > 0 Then
add$ = String$(expo% - (L% - dot%), "0")
End If
If expo% < 0 Then
min$ = String$(Abs(expo%) - (dot% - 1), "0")
DP$ = "."
End If
For n = 1 To L%
If Mid$(valu$, n, 1) <> "." Then
num$ = num$ + Mid$(valu$, n, 1)
End If
Next n
Else
FloatToStr$ = value$
Exit Function
End If
FloatToStr$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
End Function ' FloatToStr$
' /////////////////////////////////////////////////////////////////////////////
' TODO: find the newer formatting function?
Function FormatNumber$ (myValue, iDigits As Integer)
Dim strValue As String
strValue = DblToStr$(myValue) + String$(iDigits, " ")
If myValue < 1 Then
If myValue < 0 Then
strValue = Replace$(strValue, "-.", "-0.")
ElseIf myValue > 0 Then
strValue = "0" + strValue
End If
End If
FormatNumber$ = Left$(strValue, iDigits)
End Function ' FormatNumber$
' /////////////////////////////////////////////////////////////////////////////
' From: Bitwise Manipulations By Steven Roman
' http://www.romanpress.com/Articles/Bitwise_R/Bitwise.htm
' Returns the 8-bit binary representation
' of an integer iInput where 0 <= iInput <= 255
Function GetBinary$ (iInput1 As Integer)
Dim sResult As String
Dim iLoop As Integer
Dim iInput As Integer: iInput = iInput1
sResult = ""
If iInput >= 0 And iInput <= 255 Then
For iLoop = 1 To 8
sResult = LTrim$(RTrim$(Str$(iInput Mod 2))) + sResult
iInput = iInput \ 2
'If iLoop = 4 Then sResult = " " + sResult
Next iLoop
End If
GetBinary$ = sResult
End Function ' GetBinary$
' /////////////////////////////////////////////////////////////////////////////
' wonderfully inefficient way to read if a bit is set
' ival = GetBit256%(int we are comparing, int containing the bits we want to read)
' See also: GetBit256%, SetBit256%
Function GetBit256% (iNum1 As Integer, iBit1 As Integer)
Dim iResult As Integer
Dim sNum As String
Dim sBit As String
Dim iLoop As Integer
Dim bContinue As Integer
'DIM iTemp AS INTEGER
Dim iNum As Integer: iNum = iNum1
Dim iBit As Integer: iBit = iBit1
iResult = FALSE
bContinue = TRUE
If iNum < 256 And iBit <= 128 Then
sNum = GetBinary$(iNum)
sBit = GetBinary$(iBit)
For iLoop = 1 To 8
If Mid$(sBit, iLoop, 1) = "1" Then
'if any of the bits in iBit are false, return false
If Mid$(sNum, iLoop, 1) = "0" Then
iResult = FALSE
bContinue = FALSE
Exit For
End If
End If
Next iLoop
If bContinue = TRUE Then
iResult = TRUE
End If
End If
GetBit256% = iResult
End Function ' GetBit256%
' /////////////////////////////////////////////////////////////////////////////
' Returns the text character at positon x%, y%
' Does the same as:
' Locate y%, x%
' GetCharXY% = Screen(CsrLin, Pos(0))
' See also: GetColorXY&
Function GetCharXY% (x%, y%)
GetCharXY% = Screen(y%, x%, 0) ' when 3rd parameter = 0 returns character code
End Function ' GetCharXY%
' /////////////////////////////////////////////////////////////////////////////
' Returns the text color at positon x%, y%
' See also: GetCharXY%
Function GetColorXY& (x%, y%)
GetColorXY& = Screen(y%, x%, 1) ' when 3rd parameter = 1 returns character color
End Function ' GetColorXY
' /////////////////////////////////////////////////////////////////////////////
' Simple timestamp function
' Format: {YYYY}-{MM}-{DD} {hh}:[mm}:{ss}
' Uses:
' TIME$
' The TIME$ Function returns a STRING representation
' of the current computer time in a 24 hour format.
' https://qb64phoenix.com/qb64wiki/index.php/TIME$
' DATE$
' The DATE$ function returns the current computer date
' as a string in the format "mm-dd-yyyy".
' https://qb64phoenix.com/qb64wiki/index.php/DATE$
'
' TODO: support template where
' {yyyy} = 4 digit year
' {mm} = 2 digit month
' {dd} = 2 digit day
' {hh} = 2 digit hour (12-hour)
' {rr} = 2 digit hour (24-hour)
' {nn} = 2 digit minute
' {ss} = 2 digit second
' {ampm} = AM/PM
' We got the nn for minute from Microsoft > Office VBA Reference > DateDiff function
' https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/datediff-function
Function GetCurrentDateTime$ (sTemplate$)
Dim sDate$: sDate$ = Date$
Dim sTime$: sTime$ = Time$
Dim sYYYY$: sYYYY$ = Mid$(sDate$, 7, 4)
Dim sMM$: sMM$ = Mid$(sDate$, 1, 2)
Dim sDD$: sDD$ = Mid$(sDate$, 4, 2)
Dim sHH24$: sHH24$ = Mid$(sTime$, 1, 2)
Dim sHH$: sHH$ = ""
Dim sMI$: sMI$ = Mid$(sTime$, 4, 2)
Dim sSS$: sSS$ = Mid$(sTime$, 7, 2)
Dim iHour%: iHour% = Val(sHH24$)
Dim sAMPM$: sAMPM$ = ""
Dim result$: result$ = ""
' FIGURE OUT AM/PM
If InStr(sTemplate$, "{ampm}") > 0 Then
If iHour% = 0 Then
sAMPM$ = "AM"
iHour% = 12
ElseIf iHour% > 0 And iHour% < 12 Then
sAMPM$ = "AM"
ElseIf iHour% = 12 Then
sAMPM$ = "PM"
Else
sAMPM$ = "PM"
iHour% = iHour% - 12
End If
sHH$ = Right$("00" + _Trim$(Str$(iHour%)), 2)
End If
' RETURN RESULT
GetCurrentDateTime$ = result$
End Function ' GetCurrentDateTime$
' /////////////////////////////////////////////////////////////////////////////
' From: Bitwise Manipulations By Steven Roman
' http://www.romanpress.com/Articles/Bitwise_R/Bitwise.htm
' Returns the integer that corresponds to a binary string of length 8
Function GetIntegerFromBinary% (sBinary1 As String)
Dim iResult As Integer
Dim iLoop As Integer
Dim strBinary As String
Dim sBinary As String: sBinary = sBinary1
iResult = 0
strBinary = Replace$(sBinary, " ", "") ' Remove any spaces
For iLoop = 0 To Len(strBinary) - 1
iResult = iResult + 2 ^ iLoop * Val(Mid$(strBinary, Len(strBinary) - iLoop, 1))
Next iLoop
GetIntegerFromBinary% = iResult
End Function ' GetIntegerFromBinary%
' /////////////////////////////////////////////////////////////////////////////
' Receives a {sDelimeter} delimited list of numbers {MyString}
' and splits it up into an integer array arrInteger()
' beginning at index {iMinIndex}.
Sub GetIntegerArrayFromDelimList (MyString As String, sDelimiter As String, iMinIndex As Integer, arrInteger() As Integer)
ReDim arrString(-1) As String
Dim CleanString As String
Dim iLoop As Integer
Dim iCount As Integer: iCount = iMinIndex - 1
If Len(sDelimiter) > 0 Then
CleanString = MyString
If sDelimiter <> " " Then
CleanString = Replace$(CleanString, " ", "")
End If
split CleanString, sDelimiter, arrString()
iCount = iMinIndex - 1
For iLoop = LBound(arrString) To UBound(arrString)
If IsNum%(arrString(iLoop)) = TRUE Then
iCount = iCount + 1
ReDim _Preserve arrInteger(iMinIndex To iCount) As Integer
arrInteger(iCount) = Val(arrString(iLoop))
'DebugPrint "5633 arrInteger(" + cstr$(iCount) + ") = VAL(arrString(" + cstr$(iLoop) + ")) = " + cstr$(arrInteger(iCount))
End If
Next iLoop
Else
If IsNum%(MyString) = TRUE Then
ReDim _Preserve arrInteger(iMinIndex To iMinIndex) As Integer
arrInteger(iMinIndex) = Val(MyString)
End If
End If
'CleanString=""
'for iLoop=lbound(arrInteger) to ubound(arrInteger)
'CleanString = CleanString + iifstr$(iLoop=lbound(arrInteger), "", ",") + cstr$(arrInteger(iLoop))
'next iLoop
'DebugPrint "arrInteger=(" + CleanString + ")"
End Sub ' GetIntegerArrayFromDelimList
' /////////////////////////////////////////////////////////////////////////////
' 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%
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if number n is odd
' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
' see also: IsEven%
Function IsOdd% (n)
If n Mod 2 = 1 Then
IsOdd% = TRUE
Else
IsOdd% = FALSE
End If
End Function ' IsOdd%
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'Combine all elements of in$() into a single string with delimiter$ separating the elements.
Function join$ (in$(), delimiter$)
Dim result$
Dim i As Long
result$ = in$(LBound(in$))
For i = LBound(in$) + 1 To UBound(in$)
result$ = result$ + delimiter$ + in$(i)
Next i
join$ = result$
End Function ' join$
Function LeftPadString$ (myString$, toWidth%, padChar$)
LeftPadString$ = Right$(String$(toWidth%, padChar$) + myString$, toWidth%)
End Function ' LeftPadString$
' /////////////////////////////////////////////////////////////////////////////
' ABS was returning strange values with type LONG
' so I created this which does not.
Function LongABS& (lngValue As Long)
If Sgn(lngValue) = -1 Then
LongABS& = 0 - lngValue
Else
LongABS& = lngValue
End If
End Function ' LongABS&
' /////////////////////////////////////////////////////////////////////////////
' remove scientific Notation to String (~40 LOC)
' SMcNeill Jan 7, 2020
' https://www.qb64.org/forum/index.php?topic=1555.msg112989#msg112989
' Last Function in code marked Best Answer (removed debug comments and
' blank lines added these 2 lines.)
Function N2S$ (EXP$)
ReDim t$, sign$, l$, r$, r&&
ReDim dp As Long, dm As Long, ep As Long, em As Long, check1 As Long, l As Long, i As Long
t$ = LTrim$(RTrim$(EXP$))
If Left$(t$, 1) = "-" Or Left$(t$, 1) = "N" Then sign$ = "-": t$ = Mid$(t$, 2)
dp = InStr(t$, "D+"): dm = InStr(t$, "D-")
ep = InStr(t$, "E+"): em = InStr(t$, "E-")
check1 = Sgn(dp) + Sgn(dm) + Sgn(ep) + Sgn(em)
If check1 < 1 Or check1 > 1 Then N2S = _Trim$(EXP$): Exit Function ' If no scientic notation is found, or if we find more than 1 type, it's not SN!
Select Case l ' l now tells us where the SN starts at.
Case Is < dp: l = dp
Case Is < dm: l = dm
Case Is < ep: l = ep
Case Is < em: l = em
End Select
l$ = Left$(t$, l - 1) ' The left of the SN
r$ = Mid$(t$, l + 1): r&& = Val(r$) ' The right of the SN, turned into a workable long
If InStr(l$, ".") Then ' Location of the decimal, if any
If r&& > 0 Then
r&& = r&& - Len(l$) + 2
Else
r&& = r&& + 1
End If
l$ = Left$(l$, 1) + Mid$(l$, 3)
End If
Select Case r&&
Case 0 ' what the heck? We solved it already?
' l$ = l$
Case Is < 0
For i = 1 To -r&&
l$ = "0" + l$
Next
l$ = "." + l$
Case Else
For i = 1 To r&&
l$ = l$ + "0"
Next
l$ = l$
End Select
N2S$ = sign$ + l$
End Function ' N2S$
Sub PauseDecisecond (iDS As Integer)
Dim iCount As Integer
iCount = 0
Do
iCount = iCount + 1
_Limit 10 ' run 10x every second
Loop Until iCount = iDS
End Sub ' PauseDecisecond
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if point (x1%, y1%) is adjacent to point (x2%, y2%)
Function PointsAreAdjacent% (x1%, y1%, x2%, y2%)
Dim bResult%: bResult% = FALSE
' x or y can be the same, but not both
If (x1% <> x2%) Or (y1% <> y2%) Then
If (x1% = x2%) Or ((x1% = (x2% + 1)) Or (x2% = (x1% + 1))) Then
If (y1% = y2%) Or ((y1% = (y2% + 1)) Or (y2% = (y1% + 1))) Then
bResult% = TRUE
End If
End If
End If
PointsAreAdjacent% = bResult%
End Function ' PointsAreAdjacent%
' /////////////////////////////////////////////////////////////////////////////
' Does a _PrintString at the specified row+column.
'
'
' iRow% and iCol% are 0-based in this version
'
' See also: PrintString, PrintString1, PutCharXY
Sub PrintAt (iRow%, iCol%, sText$)
'_PrintString (iCol% * 8, iRow% * 16), sText$
_PrintString (iCol% * 8, iRow% * 16), sText$
'_PrintString (iCol%, iRow%), sText$
End Sub ' PrintAt
' /////////////////////////////////////////////////////////////////////////////
' Writes sText to file sFileName.
' If bAppend=TRUE appends to file, else overwrites it.
' Returns blank if successful else returns error message.
Function PrintFile$ (sFileName As String, sText As String, bAppend As Integer)
Dim sError As String: sError = ""
If Len(sError) = 0 Then
If (bAppend = TRUE) Then
If _FileExists(sFileName) Then
Open sFileName For Append As #1 ' opens an existing file for appending
Else
sError = "Error in PrintFile$ : File not found. Cannot append."
End If
Else
Open sFileName For Output As #1 ' opens and clears an existing file or creates new empty file
End If
End If
If Len(sError) = 0 Then
' NOTE: WRITE places text in quotes in the file
'WRITE #1, x, y, z$
'WRITE #1, sText
' PRINT does not put text inside quotes
Print #1, sText
Close #1
End If
PrintFile$ = sError
End Function ' PrintFile$
' /////////////////////////////////////////////////////////////////////////////
' Does a _PrintString at the specified row+column.
' iRow and iCol are 0-based.
' See also: PrintString1
Sub PrintString (iRow As Integer, iCol As Integer, MyString As String)
Dim iX As Integer
Dim iY As Integer
iX = _FontWidth * iCol
iY = _FontHeight * iRow ' (iRow + 1)
_PrintString (iX, iY), MyString
End Sub ' PrintString
' /////////////////////////////////////////////////////////////////////////////
' Does a _PrintString at the specified row+column.
' iRow and iCol are 1-based.
' See also: PrintString
Sub PrintString1 (iRow As Integer, iCol As Integer, MyString As String)
Dim iX As Integer
Dim iY As Integer
iX = _FontWidth * (iCol - 1)
iY = _FontHeight * (iRow - 1)
_PrintString (iX, iY), MyString
End Sub ' PrintString1
' /////////////////////////////////////////////////////////////////////////////
' 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
' /////////////////////////////////////////////////////////////////////////////
' Generate random value between Min and Max inclusive.
Function RandomNumber% (Min%, Max%)
Dim NumSpread%
' SET RANDOM SEED
'Randomize ' Initialize random-number generator.
Randomize Timer
' GET RANDOM # Min%-Max%
'RandomNumber = Int((Max * Rnd) + Min) ' generate number
NumSpread% = (Max% - Min%) + 1
RandomNumber% = Int(Rnd * NumSpread%) + Min% ' GET RANDOM # BETWEEN Max% AND Min%
End Function ' RandomNumber%
'' /////////////////////////////////////////////////////////////////////////////
'
'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
' /////////////////////////////////////////////////////////////////////////////
' FROM: String Manipulation
' found at abandoned, outdated and now likely malicious qb64 dot net website
' http://www.qb64.[net]/forum/index_topic_5964-0/
'
'SUMMARY:
' Purpose: A library of custom functions that transform strings.
' Author: Dustinian Camburides (dustinian@gmail.com)
' Platform: QB64 (www.qb64.org)
' Revision: 1.6
' Updated: 5/28/2012
'SUMMARY:
'[Replace$] replaces all instances of the [Find] sub-string with the [Add] sub-string within the [Text] string.
'INPUT:
'Text: The input string; the text that's being manipulated.
'Find: The specified sub-string; the string sought within the [Text] string.
'Add: The sub-string that's being added to the [Text] string.
Function Replace$ (Text1 As String, Find1 As String, Add1 As String)
' VARIABLES:
Dim Text2 As String
Dim Find2 As String
Dim Add2 As String
Dim lngLocation As Long ' The address of the [Find] substring within the [Text] string.
Dim strBefore As String ' The characters before the string to be replaced.
Dim strAfter As String ' The characters after the string to be replaced.
' INITIALIZE:
' MAKE COPIESSO THE ORIGINAL IS NOT MODIFIED (LIKE ByVal IN VBA)
Text2 = Text1
Find2 = Find1
Add2 = Add1
lngLocation = InStr(1, Text2, Find2)
' PROCESSING:
' While [Find2] appears in [Text2]...
While lngLocation
' Extract all Text2 before the [Find2] substring:
strBefore = Left$(Text2, lngLocation - 1)
' Extract all text after the [Find2] substring:
strAfter = Right$(Text2, ((Len(Text2) - (lngLocation + Len(Find2) - 1))))
Function RightPadString$ (myString$, toWidth%, padChar$)
RightPadString$ = Left$(myString$ + String$(toWidth%, padChar$), toWidth%)
End Function ' RightPadString$
'' /////////////////////////////////////////////////////////////////////////////
'' https://staging.qb64phoenix.com/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
Function SmallestOf3% (i1%, i2%, i3%)
Dim iMin%
iMin% = i1%
If i2% < iMin% Then iMin% = i2%
If i3% < iMin% Then iMin% = i3%
SmallestOf3% = iMin%
End Function ' SmallestOf3
Function SngRoundedToStr$ (sngValue As Single, intNumPlaces As Integer)
Dim sngNew As Single
sngNew = RoundSingle!(sngValue, intNumPlaces)
SngRoundedToStr$ = SngToStr$(sngNew)
End Function ' SngRoundedToStr$
' /////////////////////////////////////////////////////////////////////////////
' Hack function, to be replaced with something better
Function SngToInt% (sngOld As Single)
Dim sngNew As Single
Dim sValue As String
Dim iPos As Integer
' /////////////////////////////////////////////////////////////////////////////
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
Function SngToStr$ (n!)
Dim result$: result$ = ""
Dim value$
Dim Xpos%
Dim expo%
Dim sign$
Dim valu$
Dim dot%
Dim L%
Dim add$
Dim min$
Dim DP$
Dim n%
value$ = UCase$(LTrim$(Str$(n!)))
Xpos% = InStr(value$, "D") + InStr(value$, "E") ' only D or E can be present
If Xpos% Then
expo% = Val(Mid$(value$, Xpos% + 1))
If Val(value$) < 0 Then
sign$ = "-"
valu$ = Mid$(value$, 2, Xpos% - 2)
Else
valu$ = Mid$(value$, 1, Xpos% - 1)
End If
dot% = InStr(valu$, ".")
L% = Len(valu$)
If expo% > 0 Then
add$ = String$(expo% - (L% - dot%), "0")
End If
If expo% < 0 Then
min$ = String$(Abs(expo%) - (dot% - 1), "0")
DP$ = "."
End If
For n% = 1 To L%
If Mid$(valu$, n%, 1) <> "." Then
num$ = num$ + Mid$(valu$, n%, 1)
End If
Next n%
result$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
Else
result$ = value$
End If
SngToStr$ = result$
End Function ' SngToStr$
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'
' FROM luke, QB64 Developer
' Date: February 15, 2019, 04:11:07 AM
'
' Given a string of words separated by spaces (or any other character),
' splits it into an array of the words. I've no doubt many people have
' written a version of this over the years and no doubt there's a million
' ways to do it, but I thought I'd put mine here so we have at least one
' version. There's also a join function that does the opposite
' array -> single string.
'
' Code is hopefully reasonably self explanatory with comments and a little demo.
' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.
'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences
'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$().
'
'delimiter$ must be one character long.
'result$() must have been REDIMmed previously.
' Modified to handle multi-character delimiters
Sub split (in$, delimiter$, result$())
Dim start As Integer
Dim finish As Integer
Dim iDelimLen As Integer
ReDim result$(-1)
iDelimLen = Len(delimiter$)
start = 1
Do
'While Mid$(in$, start, 1) = delimiter$
While Mid$(in$, start, iDelimLen) = delimiter$
'start = start + 1
start = start + iDelimLen
If start > Len(in$) Then
Exit Sub
End If
Wend
finish = InStr(start, in$, delimiter$)
If finish = 0 Then
finish = Len(in$) + 1
End If
ReDim _Preserve result$(0 To UBound(result$) + 1)
result$(UBound(result$)) = Mid$(in$, start, finish - start)
start = finish + 1
Loop While start <= Len(in$)
End Sub ' split
' /////////////////////////////////////////////////////////////////////////////
' Converts a chr$(13) delimited string
' into a 2-dimensional array.
' Usage:
' Dim StringArray(1 To 48, 1 To 128) As String
' StringTo2dArray StringArray(), GetMap$
' Version 2 with indexed array(row, columm)
' Renamed StringToArray to StringTo2dArray.
' See also: Array2dToString$
Sub StringTo2dArray (MyArray() As String, MyString As String)
Dim sDelim As String
ReDim arrLines(0) As String
Dim iRow As Integer
Dim iCol As Integer
Dim sChar As String
Dim iDim1 As Integer
Dim iDim2 As Integer
Dim iIndex1 As Integer
Dim iIndex2 As Integer
iDim1 = LBound(MyArray, 1)
iDim2 = LBound(MyArray, 2)
sDelim = Chr$(13)
split MyString, sDelim, arrLines()
For iRow = LBound(arrLines) To UBound(arrLines)
If iRow <= UBound(MyArray, 1) Then
For iCol = 1 To Len(arrLines(iRow))
If iCol <= UBound(MyArray, 2) Then
sChar = Mid$(arrLines(iRow), iCol, 1)
If Len(sChar) > 1 Then
sChar = Left$(sChar, 1)
Else
If Len(sChar) = 0 Then
sChar = "."
End If
End If
iIndex1 = iRow + iDim1
iIndex2 = (iCol - 1) + iDim2
MyArray(iIndex1, iIndex2) = sChar
'DebugPrint "MyArray(" + cstr$(iIndex1) + ", " + cstr$(iIndex2) + " = " + chr$(34) + sChar + chr$(34)
Else
' Exit if out of bounds
Exit For
End If
Next iCol
Else
' Exit if out of bounds
Exit For
End If
Next iRow
End Sub ' StringTo2dArray
Function StrJustifyRight$ (sValue As String, iWidth As Integer)
StrJustifyRight$ = Right$(String$(iWidth, " ") + sValue, iWidth)
End Function ' StrJustifyRight$
Function StrJustifyLeft$ (sValue As String, iWidth As Integer)
StrJustifyLeft$ = Left$(sValue + String$(iWidth, " "), iWidth)
End Function ' StrJustifyLeft$
Function StrJustifyCenter$ (sValue As String, iWidth As Integer)
Dim iLen0 As Integer
Dim iLen1 As Integer
Dim iLen2 As Integer
Dim iExtra As Integer
iLen0 = Len(sValue)
If iWidth = iLen0 Then
' no extra space: return unchanged
StrJustifyCenter$ = sValue
ElseIf iWidth > iLen0 Then
If IsOdd%(iWidth) Then
iWidth = iWidth - 1
End If
' center
iExtra = iWidth - iLen0
iLen1 = iExtra \ 2
iLen2 = iLen1 + (iExtra Mod 2)
StrJustifyCenter$ = String$(iLen1, " ") + sValue + String$(iLen2, " ")
Else
' string is too long: truncate
StrJustifyCenter$ = Left$(sValue, iWidth)
End If
End Function ' StrJustifyCenter$
' /////////////////////////////////////////////////////////////////////////////
' Use to pretty print TRUE and FALSE values.
Function TrueFalse$ (myValue)
If myValue = TRUE Then
TrueFalse$ = "TRUE"
Else
TrueFalse$ = "FALSE"
End If
End Function ' TrueFalse$
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GENERAL PURPOSE ROUTINES @GEN
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN COLOR FUNCTIONS #COLOR
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Function cRed~& ()
cRed = _RGB32(255, 0, 0)
End Function
Function cOrangeRed~& ()
cOrangeRed = _RGB32(255, 69, 0)
End Function ' cOrangeRed~&
Function cDarkOrange~& ()
cDarkOrange = _RGB32(255, 140, 0)
End Function ' cDarkOrange~&
Function cOrange~& ()
cOrange = _RGB32(255, 165, 0)
End Function ' cOrange~&
Function cGold~& ()
cGold = _RGB32(255, 215, 0)
End Function ' cGold~&
Function cYellow~& ()
cYellow = _RGB32(255, 255, 0)
End Function ' cYellow~&
' LONG-HAIRED FRIENDS OF JESUS OR NOT,
' THIS IS NOT YELLOW ENOUGH (TOO CLOSE TO LIME)
' TO USE FOR OUR COMPLEX RAINBOW SEQUENCE:
Function cChartreuse~& ()
cChartreuse = _RGB32(127, 255, 0)
End Function ' cChartreuse~&
' WE SUBSTITUTE THIS CSS3 COLOR FOR INBETWEEN LIME AND YELLOW:
Function cOliveDrab1~& ()
cOliveDrab1 = _RGB32(192, 255, 62)
End Function ' cOliveDrab1~&
Function cLime~& ()
cLime = _RGB32(0, 255, 0)
End Function ' cLime~&
Function cMediumSpringGreen~& ()
cMediumSpringGreen = _RGB32(0, 250, 154)
End Function ' cMediumSpringGreen~&
' ADDED THIS FOR THE GAUGE COLOR:
Function cSpringGreen~& ()
cSpringGreen = _RGB32(0, 255, 160)
End Function ' cSpringGreen~&
Function cCyan~& ()
cCyan = _RGB32(0, 255, 255)
End Function ' cCyan~&
Function cDeepSkyBlue~& ()
cDeepSkyBlue = _RGB32(0, 191, 255)
End Function ' cDeepSkyBlue~&
Function cDodgerBlue~& ()
cDodgerBlue = _RGB32(30, 144, 255)
End Function ' cDodgerBlue~&
Function cSeaBlue~& ()
cSeaBlue = _RGB32(0, 64, 255)
End Function ' cSeaBlue~&
Function cBlue~& ()
cBlue = _RGB32(0, 0, 255)
End Function ' cBlue~&
Function cBluePurple~& ()
cBluePurple = _RGB32(64, 0, 255)
End Function ' cBluePurple~&
Function cDeepPurple~& ()
cDeepPurple = _RGB32(96, 0, 255)
End Function ' cDeepPurple~&
Function cPurple~& ()
cPurple = _RGB32(128, 0, 255)
End Function ' cPurple~&
Function cPurpleRed~& ()
cPurpleRed = _RGB32(128, 0, 192)
End Function ' cPurpleRed~&
Function cDarkRed~& ()
cDarkRed = _RGB32(160, 0, 64)
End Function ' cDarkRed~&
Function cBrickRed~& ()
cBrickRed = _RGB32(192, 0, 32)
End Function ' cBrickRed~&
Function cDarkGreen~& ()
cDarkGreen = _RGB32(0, 100, 0)
End Function ' cDarkGreen~&
Function cGreen~& ()
cGreen = _RGB32(0, 128, 0)
End Function ' cGreen~&
Function cOliveDrab~& ()
cOliveDrab = _RGB32(107, 142, 35)
End Function ' cOliveDrab~&
Function cLightPink~& ()
cLightPink = _RGB32(255, 182, 193)
End Function ' cLightPink~&
Function cHotPink~& ()
cHotPink = _RGB32(255, 105, 180)
End Function ' cHotPink~&
Function cDeepPink~& ()
cDeepPink = _RGB32(255, 20, 147)
End Function ' cDeepPink~&
Function cMagenta~& ()
cMagenta = _RGB32(255, 0, 255)
End Function ' cMagenta~&
Function cBlack~& ()
cBlack = _RGB32(0, 0, 0)
End Function ' cBlack~&
Function cDimGray~& ()
cDimGray = _RGB32(105, 105, 105)
End Function ' cDimGray~&
Function cGray~& ()
cGray = _RGB32(128, 128, 128)
End Function ' cGray~&
Function cDarkGray~& ()
cDarkGray = _RGB32(169, 169, 169)
End Function ' cDarkGray~&
Function cSilver~& ()
cSilver = _RGB32(192, 192, 192)
End Function ' cSilver~&
Function cLightGray~& ()
cLightGray = _RGB32(211, 211, 211)
End Function ' cLightGray~&
Function cGainsboro~& ()
cGainsboro = _RGB32(220, 220, 220)
End Function ' cGainsboro~&
Function cWhiteSmoke~& ()
cWhiteSmoke = _RGB32(245, 245, 245)
End Function ' cWhiteSmoke~&
Function cWhite~& ()
cWhite = _RGB32(255, 255, 255)
'cWhite = _RGB32(254, 254, 254)
End Function ' cWhite~&
Function cDarkBrown~& ()
cDarkBrown = _RGB32(128, 64, 0)
End Function ' cDarkBrown~&
Function cLightBrown~& ()
cLightBrown = _RGB32(196, 96, 0)
End Function ' cLightBrown~&
Function cKhaki~& ()
cKhaki = _RGB32(240, 230, 140)
End Function ' cKhaki~&
Function cEmpty~& ()
'cEmpty~& = -1
cEmpty = _RGB32(0, 0, 0, 0)
End Function ' cEmpty~&
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END COLOR FUNCTIONS @COLOR
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ################################################################################################################################################################
' BEGIN KEYBOARD CODE 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 CODE FUNCTIONS @KEYCODE
' ################################################################################################################################################################
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 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
'' /////////////////////////////////////////////////////////////////////////////
'
'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
I have just started again with qb64 after retiring , never had a lot of time for it before, and tried my hand at creating a game. Don't laugh , it is my first. I "borrowed" a lot of parts from the tutorial and sprite library to get it going. All the files are in the zip. Do with it what you will.
If you add some features to it , let me know so I can learn from your coding skills. I will be in and reading a lot more now that I have time.
Jack
MarioFood.zip (Size: 3.04 MB / Downloads: 42)
I tried to add a SetClipboardData to your WinAPI routine below, but no luck. No luck as in my addition of SetClipboardData caused the program to crash before the console even opened. I posted your routine below. Could it be modified so instead of just reading the present clipboard contents, it gets the highlighted text from the active window and adds that highlighted text to the clipboard? If that would be a PITA to code, just let me know and don't go to the trouble. What I'm looking for is an API alternative to using _SCREENPRINT CHR$(3) because in our IDE, if applied from another program, it doesn't copy the QB64 text, it just removes the highlighted text and leaves lowercase c in its place.
DECLARE DYNAMIC LIBRARY "User32"
FUNCTION OpenClipboard%% (BYVAL hWndNewOwner AS LONG)
'FUNCTION CountClipboardFormats% ()
FUNCTION GetClipboardData& (BYVAL uFormat AS _UNSIGNED INTEGER)
FUNCTION CloseClipboard%% ()
END DECLARE
DECLARE DYNAMIC LIBRARY "Kernel32"
FUNCTION GlobalLock%& (BYVAL hMem AS LONG)
FUNCTION GlobalUnlock%% (BYVAL hMem AS LONG)
END DECLARE
DECLARE CUSTOMTYPE LIBRARY "peekpoke"
FUNCTION peekb~%% (BYVAL p AS _UNSIGNED _OFFSET) 'Byte
END DECLARE
PRINT Clipboard$
SLEEP
FUNCTION Clipboard$
DIM a AS LONG
a = OpenClipboard(0)
a = GetClipboardData(CF_TEXT)
DIM b AS _UNSIGNED _OFFSET
b = GlobalLock(a)
DIM x AS _UNSIGNED INTEGER
DIM clip AS STRING
DO
clip = clip + CHR$(peekb(b + x))
x = x + 1
LOOP UNTIL CHR$(peekb(b + x)) = CHR$(0)
DIM closeclip AS _BYTE
closeclip = GlobalUnlock(a)
closeclip = CloseClipboard
Clipboard = clip
END FUNCTION
Data "BIG","SMALL","LION","TIGER","CAR","TRUCK","BLACK","WHITE","WEED","FLOWER","BEDROOM","KITCHEN","COPPER","BRASS","DESERT","OASIS","MILK","HONEY","HORSE","SHEEP"
Data "BADGE","MEDAL","MARRY","DIVORCE","SHED","HOUSE","WAR","PEACE","SUIT","DRESS","BOX","CARTON","ROAD","STREET","DUNCE","GENIUS","CUP","PLATE","STEAK","EGGS"
AlchemyDescription:
Print
Color 14
Print Tab(36); "ALCHEMY": Color 15
Print
Print " Alchemy (al/ke/mi) can be defined as the process of changing something into"
Print " something different in a mystical way, such as changing ";: Color 14: Print "STONE";: Color 15
Print " into ";: Color 14: Print "GOLD.": Color 15
Print
Print " This game calls upon your skills in this art, to change a word into a"
Print " totally different one, with the least number of changes."
Print
Print " In the usual word-swap game, you repeatedly change one letter of a word for a"
Print " different one, creating a new word, until the target word is produced."
Print
Print " But in Alchemy, you have another tool available to you for the transformation."
Print " You can also ";: Color 14: Print "add";: Color 15: Print " or ";: Color 14: Print "remove";: Color 15: Print " a letter, before re-arranging them, so the word may"
Print " change in length several times as you progress."
Print
Print " As an example, we can change STONE into GOLD with 4 changes:"
Color 14: Print Tab(23); "STONE - TONE - GONE - LONG - GOLD": Color 15
Print
Print " If the wordslists directory is present, each word entered is checked against"
Print " these. If not, they are assumed to be legitimate words."
Print " The wordlist files are the Complete Collins Scrabble Words (2019)."
Print: Color 14
Print Tab(29); "Press a key to continue"
While InKey$ = "": Wend
Play ok$
LoadPairs
Choice: ' invites replacing best scores in file with defaults
Color 14
Locate 23, 17
Print "Would you like to delete all previous Best Scores (y/n)";
Sleep
Color 15: y$ = UCase$(InKey$)
If y$ = "Y" Then
Refresh
Play ok$
End If
SetPair: ' Select pair of words
LoadPairs
Color 14: Print Tab(22); "Which pair would you like, from A to T";
getpair:
pair$ = UCase$(InKey$)
If pair$ = "" Or pair$ = Chr$(13) Then GoTo getpair
If pair$ = Chr$(27) Then Stop
If pair$ < "A" Or pair$ > "T" Then pair$ = Chr$(65 + Int(Rnd * 20))
pairnumber = Asc(pair$) - 64
StartGame:
Cls
remain = 21: tries = 0: fail = 0 ' start each game with 21 tries remaining
first$ = firstwords$(pairnumber): last$ = lastwords$(pairnumber)
train$(pairnumber) = first$
target = targets(pairnumber): name$ = names$(pairnumber) ' get selected pair details
prev$ = first$ ' pretend the first was a previous try
Color 14
Locate 1, 39 - Int(Len(first$) / 2): Print first$; Tab(52); "Record:"; target ' display the first word in yellow on row 2
Color 15
For a = 2 To maxtries + 1: Locate a, 35
Print String$(9, "."): Next ' show 9 dots for each try (rows 2 to 21)
Color 14
Locate 22, 39 - Int(Len(last$) / 2): Print last$; ' display the last word in yellow on row 23
tryvert = 2 ' row 3 will take the first try
InviteTry:
If tries = maxtries Then
Play fail$
WIPE "23": Color 3:
Locate 23, 21: Print "You've Used up all of your tries, sorry!"
WIPE "24"
Color 15
Sleep 3
GoTo StartGame ' ran out of tries, restart the same pair
Else
Locate tryvert, 35: Print String$(9, "."); Tab(46); Space$(30)
WIPE "23": Color 14 ' refresh remaining tries advice
Locate 23, 27
Print "You have"; 20 - tries; "tries remaining"
Locate tryvert, 3 ' display invite at tab 10 of current try-line
Print "Your word (q to quit)";
End If
DealWithTry:
Locate tryvert, 25
Input try$ ' show ? outside try-line and set try to first dot
Color 15
try$ = UCase$(try$)
If try$ = "Q" Then Stop
If try$ < "A" Or try$ > "Z" Then Play fail$: GoTo SetPair
tries = tries + 1
Locate tryvert, 35: Print Space$(12)
Locate tryvert, 39 - Int(Len(try$) / 2): Print try$
CheckWord ' Call Sub to Check the Player's Word
DealWithCheck:
Locate tryvert, 1: Print Space$(35)
If fail = 1 Then
Locate tryvert, 35: Print " "
Color 3
Locate tryvert, 39 - Len(try$) / 2
Print try$
Color 15
tryvert = tryvert + 1
GoTo InviteTry
Else
If try$ = last$ Then
Finished
GoTo SetPair
Else
Locate 23, 30
Print Space$(50)
tryvert = tryvert + 1
GoTo InviteTry
End If
End If
Sub Refresh
Restore
target = 21: name$ = "Unsolved"
Open "alchpairs" For Output As #1
For a = 1 To 20
Read first$, last$
Write #1, first$, last$, target, name$, ""
Print first$; " "; last$; target; name$
Next
Close
Cls
End Sub
Sub WIPE (ln$) ' call with ln$ string of 2-digit line numbers only eg "012223" for lines 1, 22 and 23
For a = 1 To Len(ln$) - 1 Step 2
Locate Val(Mid$(ln$, a, 2)): Print Space$(80);
Next
End Sub
Sub LoadPairs
Restore
Cls
Color 14: Print Tab(37); "Word Pairs"
Print Tab(20); "Pair"; Tab(30); "From"; Tab(41); "To"; Tab(50); "Best"; Tab(62); "By"
Color 15
If _FileExists("alchpairs") Then
Open "alchpairs" For Input As #1
For a = 1 To 20
Input #1, firstwords$(a), lastwords$(a), targets(a), names$(a), train$(a) ' loads word-pairs from "alchpairs" file
Color 14: Print Tab(20); Chr$(a + 64);: Color 15: Print Tab(30); firstwords$(a); Tab(40); lastwords$(a); Tab(50); targets(a); Tab(60); names$(a)
Next
Close #1
Else Refresh
End If
End Sub
Sub CheckWord
added = 0: added$ = "": removed = 0: removed$ = "": fail = 0 ' initialise added, removed and fail flag
Locate tryvert, 48: Print Space$(32)
Locate tryvert, 48
CountAdded:
temp$ = prev$ ' use temp$ as sacrificial to keep prev$ intact while checking for added
For a = 1 To Len(try$) ' for each letter in try$...
l$ = Mid$(try$, a, 1) ' take a letter l$ of temp$
po = InStr(temp$, l$) ' find its position po in temp$ (if any)
If po < 1 Then ' if not found...
added = added + 1
added$ = added$ + l$ ' count it and add to added$
Else
Mid$(temp$, po, 1) = " "
End If
Next
CountRemoved:
temp$ = try$ ' use temp$ as sacrificial to keep prev$ intact while checking for added
For a = 1 To Len(prev$) ' for each letter in try$...
l$ = Mid$(prev$, a, 1) ' take a letter l$ of temp$
po = InStr(temp$, l$) ' find its position po in temp$ (if any)
If po < 1 Then ' if not found...
removed = removed + 1
removed$ = removed$ + l$ ' add it to added$
Else
Mid$(temp$, po, 1) = " "
End If
Next
If added > 1 Then Color 3 Else Color 15
Print "Added "; added$;
If removed > 1 Then Color 3 Else Color 15
Print Tab(60); "Removed "; removed$ ' show letters that have been added or removed, colour cyan if too many
DictionaryCheck:
If Not _DirExists("wordlists") Then isaword = 1: GoTo checksfinished
WIPE "23"
filename$ = "wordlists/" + Left$(try$, 1) ' select dictionary file of first letter of try-word
Open filename$ For Input As #1
getaword:
isaword = 0
While Not EOF(1)
Input #1, dictword$ ' read each word from dictionary
If try$ = dictword$ Then isaword = 1: Exit While ' if word is found, don't look any further
Wend
Close
checksfinished:
Locate 23, 1
If added > 1 Or removed > 1 Or isaword = 0 Then ' if more than one letter added or removed, or word not found, set fail flag
Play fail$
Color 3 ' colour of try changed to cyan if word failed
Print Tab(35); "Word failed";
Color 15
fail = 1
Else
Play ok$
Print Tab(37); "Word ok"; ' otherwise, declare word as ok and make this the new prev$
prev$ = try$
train$(pairnumber) = train$(pairnumber) + "-" + try$
End If
Sleep 1
WIPE "23"
End Sub
Sub Finished
Play ok$: Play ok$
Locate tryvert, 35: Print Space$(12)
Locate tryvert, 39 - Len(try$) / 2: Print try$
WIPE "2223"
Locate 22, 21: Color 14: Print "You did it in"; tries; "changes. Target was"; targets(pairnumber)
Sleep 2
If tries >= targets(pairnumber) Then ' if target is not beaten,
Exit Sub ' go back for next game
Else
targets(pairnumber) = tries ' change the target for that pair to the new best score
Cls
Locate 10, 4
Input "Enter a name for the Best Scores list (or <ENTER> for anonymous)"; winname$ ' get the player's name
If Len(winname$) < 2 Then winname$ = "ANONYMOUS" ' if <ENTER> (or only one character) is given, name is Anonymous
names$(pairnumber) = UCase$(winname$) ' change the name for that pair to the new name
Open "alchpairs" For Output As #1
For a = 1 To 20
Write #1, firstwords$(a), lastwords$(a), targets(a), names$(a), train$(a) ' re-write the alchpairs file with the new details
Next
Close
End If
Cls
Locate 10, 40 - Len(train$(pairnumber)) / 2: Print train$(pairnumber)
Print: Print Tab(36); "Press a key"
Sleep
End Sub
This collection of libraries was developed and has grown over the period of approximately one decade. Most of the libraries were created out of my own need for a particular purpose, but as many of it are of common use, I've decided to put this collection together for everybody.
These libraries work with every QB64 version since v0.954, so if you're one of these normal people who not update to the latest build every week, that's not a problem. Just use whatever QB64 version you've installed, as long it's greater or equal to the 0.954 version. This also includes all Phoenix Edition versions.
Make sure to move the extracted QB64Library folder with its entire contents into your QB64 installation folder. You find an overview of all libraries in the QB64Library-Info.html file.
This is an update to a math adding puzzle game I posted a few years ago. The previous version was limited and used dozens of image files for numbers. I added a new board display method, it should look the same size on every desktop. This version has more grid sizes, and some sound effects, and a simple Help screen.
Basically you click to remove/add numbers in the grid so that the ones left on add up to the number shown on the edges. The rows and columns numbers must total up to the number on the edge. Make all the edge numbers highlighted to solve the puzzle and advance to a bigger grid size. You can change grid sizes by pressing +/- keys.
It's nothing great, and probably could be done in half the amount of code, I just wanted to work on something today and landed on this for some reason.
- Dav
Code: (Select All)
'============
'RoCoLoco.bas v2.0
'============
'Row & Column number adding puzzle game.
'Based on popular math game found online.
'Coded by Dav for QB64-PE, Nov/2022
'New for v2: * Playing board now adapts to users desktop size.
' It should displays the same on every screen.
' (Screen size is not hardcoded to specific size)
' * No longer uses external .jpg images for numbers.
' * Change grid size using the +/- keys.
' * Added HELP screen (not much) - press H for it.
' * Added some cheap sound effects.
'
'~~~~~~~~~~~
'HOW TO PLAY:
'Click numbers inside the grid to turn them on/off.
'Each row/column of red number totals must add up to the number
'on the edge of the grid. When they do, the edge numbers will
'turn on too. You must tun on all the edge numbers to solve it.
'
'~~~~~~~~
'CONTROLS:
'
'You can change the grid size anytime by using +/- keys.
'H = Show a simple help screen
'SPACE = Generate a new puzzle grid
'ESC = Quits game
REDIM SHARED tilev(tiles) 'make array for all titles values
REDIM SHARED tilef(tiles) 'make array for flag if tile is on/off
REDIM SHARED tilex(tiles), tiley(tiles) 'x/y positions for tiles
RANDOMIZE TIMER 'set random seed
'init x/y values for drawing tiles
bc = 1
FOR x = 1 TO grid
FOR y = 1 TO grid
tilex(bc) = (x * tilesize) - tilesize: tiley(bc) = (y * tilesize) - tilesize
tilev(bc) = INT(RND * 9 + 1) '<<< for testing only, give all some data
bc = bc + 1
NEXT
NEXT
SCRAMTIME = TIMER
'==========
regenerate:
'==========
SOUND 500 + RND * 1000, 1
'generate random tile value and on/off settings
T = grid + 2
FOR y = 2 TO grid - 1
regeneratex:
makesurex = 0: thold = T
FOR x = 2 TO grid - 1
tilev(thold) = INT(RND * 5 + 1) 'make random number, from 1-5
IF INT(RND * grid - (INT(RND * 1.5))) = 0 THEN
tilef(thold) = 0 'randomly turn tile on/off
makesurex = 1 'make sure at least one out on this column
ELSE
tilef(thold) = 1
END IF
'show something while computing...
LINE (tilex(thold), tiley(thold))-(tilex(thold) + tilesize, tiley(thold) + tilesize), _RGB(255, 100, 100), BF
PPRINT tilex(thold) + (tilesize / 1.8), tiley(thold) + (tilesize / 4.5), tilesize / 2, _RGB(255, 255, 255), 0, LTRIM$(STR$(tilev(thold)))
thold = thold + 1
NEXT
'if row didnt have one turned off, do this column over...
IF makesurex = 0 THEN GOTO regeneratex
T = thold + 2
_LIMIT 10 * grid 'slow down, let's see it.
NEXT
'now check rows left to right for on/off, if none off, regenerate
FOR x = 0 TO grid - 3
makesurex = 0
FOR y = grid + 2 TO (grid * grid) - grid - 2 STEP grid
IF tilef(y + x) = 0 THEN makesurex = 1
NEXT
IF makesurex = 0 THEN GOTO regenerate
NEXT
IF TIMER < (SCRAMTIME + 1) THEN GOTO regenerate
'compute left/right edges totals
FOR y = 0 TO grid - 3
total = 0
FOR x = grid + 2 TO (grid * grid) - grid - 2 STEP grid
IF tilef(y + x) = 1 THEN
total = total + tilev(y + x)
END IF
NEXT
tilev(y + x) = total 'set total data to tile
NEXT
'compute top/bottom edges
FOR x = grid + 2 TO (grid * grid) - grid - 2 STEP grid
total = 0
FOR y = 0 TO grid - 3
IF tilef(y + x) = 1 THEN
total = total + tilev(y + x)
END IF
NEXT
tilev(y + x) = total
NEXT
'Lastly, mark all inside grid tiles as on, hiding generated solution.
FOR T = grid + 2 TO (grid * grid) - grid - 1
'skip the outside rows
FOR tt = 1 TO grid * grid STEP grid
IF T = tt THEN GOTO skipmark
IF T = tt + (grid - 1) THEN GOTO skipmark
NEXT
tilef(T) = 1
skipmark:
NEXT
DO
'wait until mouse button up to continue
WHILE _MOUSEBUTTON(1) <> 0: n = _MOUSEINPUT: WEND
trap = _MOUSEINPUT
IF _MOUSEBUTTON(1) THEN
mx = _MOUSEX: my = _MOUSEY
'cycle through tiles
FOR T = grid + 2 TO (grid * grid) - grid - 1
'skip the outside rows
FOR tt = 1 TO grid * grid STEP grid
IF T = tt THEN GOTO skip
IF T = tt + (grid - 1) THEN GOTO skip
NEXT
'see if puzzle completed
IF win = 1 THEN
PLAY "mbl16o2cdedefgabagfedc"
'remove unused numbers
FOR T = grid + 2 TO (grid * grid) - grid - 1
'skip the outside rows
FOR tt = 1 TO grid * grid STEP grid
IF T = tt THEN GOTO skipcheck
IF T = tt + (grid - 1) THEN GOTO skipcheck
NEXT
IF tilef(T) = 0 THEN
LINE (tilex(T), tiley(T))-(tilex(T) + tilesize, tiley(T) + tilesize), _RGB(77, 77, 77), BF
END IF
skipcheck:
NEXT
_DELAY 5
IF grid < 15 THEN grid = grid + 1
GOTO top
END IF
RETURN
SUB PPRINT (x, y, SquareSize, clr&, trans&, text$)
orig& = _DEST
bit = 32: IF _PIXELSIZE(0) = 1 THEN bit = 256
FOR t = 0 TO LEN(text$) - 1
pprintimg& = _NEWIMAGE(16, 16, bit)
_DEST pprintimg&
CLS , trans&: COLOR clr&
PRINT MID$(text$, t + 1, 1);
_CLEARCOLOR _RGB(0, 0, 0), pprintimg&
_DEST orig&
x1 = x + (t * SquareSize): x2 = x1 + SquareSize
y1 = y: y2 = y + SquareSize
_PUTIMAGE (x1 - (SquareSize / 2), y1)-(x2, y2 + (SquareSize / 3)), pprintimg&
_FREEIMAGE pprintimg&
NEXT
END SUB
This started as an old VB6 Asteroids type game by someone named Tassadar that I downloaded from planetsourcecode.com years ago, and converted to QB64.
It's very easy to understand and modify to make something more interesting.
The next thing I would like to figure out is how to change how it handles x/y velocity for smoother more natural acceleration / momentum.
Enjoy
Code: (Select All)
_Title "Collisions"
' Original VB6 code for "Collisions" by Tassadar,
' found on PlanetSourceCode.com in 2001.
' Converted to QB64 by madscijr.
' DATE WHO-DONE-IT DID-WHAT
' 2001-06-10 Tassadar created program
' 2022-11-01 madscijr v0.19, got it working in QB64, added some tweaks
' 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??
' TODO:
' * track x/y velocity differently (movement is jerky)
' * option: enemies can shoot each other
' * option: fire button auto-repeat
' * support simple polygon shapes
' * improve collisions
' * support higher resolution upto 4k to fit lots of stuff on screen
' * local multiplayer Spacewar! (upto 16 players)
' * sound effects
' * explosions and stuff
' * menu + customize input + options
' * sun and gravity
' * asteroids
' * enemies can move + enemy AI
' * vary difficulty + scoring based on difficulty
' * limited fuel/ammo
' * player must dock with space station for more fuel/ammo/repair
' * gravity for large asteroids/moons
' * lunar lander mode, players land moons/asteroids to refuel, etc.
' * attack opponents' bases, etc.
' * etc.
' ORIGINAL CREDITS:
'********************************************************************************
'* 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 *
'********************************************************************************
' USEFUL CONSTANTS
Const FALSE = 0
Const TRUE = Not FALSE
'Const Pi = 3.14159 ' Pi , bit obvious
Const iFPS = 60 ' Delay between frames (frames per second)
Const SHIP_RADIUS = 10 ' What is the radius of the players ship
Const BULLET_RADIUS = 2 ' What is the radius of the bullets
Const SHIP_ACCEL = 0.05 ' 0.1 ' how fast does it accelerate
Const MAX_SPEED = 12 ' 6 ' what is the ships max speed
Const SHOOT_DELAY = 200 ' Delay between shots for the ship
Const BULLET_SPEED = 9 ' 6 ' Bullet speed - Ship speed + bullet speed = overall bulletspeed
Const BULLET_LIFESPAN = 1 ' # seconds bullet is alive
Const BULLETS_STOP_BULLETS = TRUE
Const TURN_SPEED = 72 ' 36=faster 18=superfast
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
Type ShipType
xPos As Integer ' X co-ordinate of the ship
yPos As Integer ' Y co-ordinate of the ship
heading As Single ' which direction is the ship heading
facing As Single ' which direction is the ship facing
shields As Integer ' how much shields does the ship have
speed As Single ' how fast is the ship going
ShootTime As Long
ShootCount As Long
End Type ' ShipType
Type EnemyType
xPos As Integer ' X position of this enemy
yPos As Integer ' Y position of this enemy
life As Integer ' How much life does this enemy have
alive As Integer ' Is this enemy alive
radius As Integer ' size of enemy ship
End Type ' EnemyType
Type BulletType
xPos As Integer ' X co-ordinate of this bullet
yPos As 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)
lifespan As Long
lifetime As Long
End Type ' BulletType
' 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)
' 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
' GAME STATE
Dim Shared m_bGameOver As Integer ' Is the game over
Dim Shared m_bAllDead As Integer ' Are all the enemies dead
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_bLeftKey As Integer ' Is the LeftKey depressed
Dim Shared m_bRightKey As Integer ' Is the RightKey depressed
Dim Shared m_bUpKey As Integer ' Is the UpKey depressed
Dim Shared m_bDownKey As Integer ' Is the DownKey depressed
Dim Shared m_bShootKey As Integer ' Is the ShootKey depressed
Dim Shared m_bCheatKey As Integer
Dim Shared m_bEscKey As Integer
' GAME OBJECTS
Dim Shared m_Ship As ShipType ' The Players Ship
ReDim Shared m_arrEnemy(-1) As EnemyType ' A nice array of enemies
ReDim Shared m_arrBullet(-1) As BulletType ' A nice array of Bullets
' FINISHED
System ' return control to the operating system
'' ****************************************************************************************************************************************************************
'' DEACTIVATE DEBUGGING WINDOW
'If m_bDebug = TRUE Then
' _Console Off
'End If
' ****************************************************************************************************************************************************************
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GAME CODE
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub main ()
Dim RoutineName As String: RoutineName = "main"
Screen _NewImage(iMaxX, iMaxY, 32) ' 100 text columns x 40 text rows
_KeyClear
InitVariables ' Initialize variables
Do ' main game loop
Cls ' Clear the form
GetInput
If m_bEscKey = FALSE Then
MoveBullets ' Activates the MoveBullets sub
MoveShip ' Activates the MoveShip sub
MoveEnemy ' (doesn't do much yet)
Collisions ' Activates the Collisions sub
Else
m_bGameOver = TRUE
End If
If m_bGameOver = FALSE Then
Shooting ' Activates the Shooting sub
DrawEnemy ' Activates the DrawEnemy sub
DrawBullets ' Activates the DrawBullets sub
ShowScore ' Display the score, etc.
DrawShip ' Activates the DrawShip sub
Respawn ' Activates the Respawn sub
Else
If AskPlayAgain% = TRUE Then
InitVariables
Else
Exit Do
End If
End If
Function AskPlayAgain%
Dim bResult As Integer
Dim in$
Cls
Print "GAME OVER"
Print
Print "Level: " + cstr$(m_iLevel)
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
AskPlayAgain% = bResult
End Function ' AskPlayAgain%
' /////////////////////////////////////////////////////////////////////////////
' Set the initial state for variables
Sub InitVariables ()
Dim iLoop1 As Integer ' Used for variables
Dim iSpread As Integer
Dim iHalf As Integer
Dim iDivisor As Integer
' Msgbox telling you how to play
'MsgBox "Use the arrow keys to fly around" + vbCrLf + "Control to shoot", vbOKOnly, "How To Play"
' Spawn enemy
ReDim _Preserve m_arrEnemy(0) As EnemyType
For iLoop1 = 0 To UBound(m_arrEnemy)
' Set the starting position of the enemies
m_arrEnemy(iLoop1).alive = TRUE
m_arrEnemy(iLoop1).life = 30
m_arrEnemy(iLoop1).xPos = m_Ship.xPos
m_arrEnemy(iLoop1).yPos = m_Ship.yPos
' choose a random size
m_arrEnemy(iLoop1).radius = RandomNumber%(m_iMinEnemyRadius, m_iMaxEnemyRadius)
' Stops the enemy starting on top of the ship
Do Until GetDist(m_arrEnemy(iLoop1).xPos, m_arrEnemy(iLoop1).yPos, m_Ship.xPos, m_Ship.yPos) > SHIP_RADIUS * 10
m_arrEnemy(iLoop1).xPos = RandomNumber%(iMinX, iMaxX) 'Int(Rnd * ScaleWidth + 1)
m_arrEnemy(iLoop1).yPos = RandomNumber%(iMinY, iMaxY) 'Int(Rnd * ScaleHeight + 1)
Loop
Next iLoop1
' RESET BULLETS
ReDim _Preserve m_arrBullet(-1) As BulletType
End Sub ' InitVariables
' /////////////////////////////////////////////////////////////////////////////
' Detect which keys are pressed
Sub GetInput ()
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
If _Button(KeyCode_Left%) Then
m_bLeftKey = TRUE
m_bRightKey = FALSE
ElseIf _Button(KeyCode_Right%) Then
m_bLeftKey = FALSE
m_bRightKey = TRUE
Else
m_bLeftKey = FALSE
m_bRightKey = FALSE
End If
If _Button(KeyCode_Up%) Then
m_bUpKey = TRUE
m_bDownKey = FALSE
ElseIf _Button(KeyCode_Down%) Then
m_bUpKey = FALSE
m_bDownKey = TRUE
Else
m_bUpKey = FALSE
m_bDownKey = FALSE
End If
If _Button(KeyCode_CtrlLeft%) Then
m_bShootKey = TRUE
ElseIf _Button(KeyCode_CtrlRight%) Then
m_bShootKey = TRUE
Else
m_bShootKey = FALSE
End If
If _Button(KeyCode_1%) Then
m_bCheatKey = TRUE
Else
m_bCheatKey = FALSE
End If
If _Button(KeyCode_Escape%) Then
m_bEscKey = TRUE
Else
m_bEscKey = FALSE
End If
' CLEAR KEYBOARD BUFFER
_KeyClear
End Sub ' GetInput
' /////////////////////////////////////////////////////////////////////////////
' Check for collisions
' TODO: improve collision checking to handle different shape polygons, etc.
Sub Collisions ()
Dim iLoop1 As Integer
Dim iLoop2 As Integer
Dim in$
' Check for bullet collisions
For iLoop1 = 0 To UBound(m_arrBullet)
' IS THIS BULLET ALIVE?
If m_arrBullet(iLoop1).alive = TRUE Then
' CHECK FOR BULLET HIT BULLET
For iLoop2 = 0 To UBound(m_arrBullet)
If iLoop2 <> iLoop1 Then
If BULLETS_STOP_BULLETS = TRUE Then
If GetDist(m_arrBullet(iLoop2).xPos, m_arrBullet(iLoop2).yPos, m_arrBullet(iLoop1).xPos, m_arrBullet(iLoop1).yPos) <= BULLET_RADIUS Then
' BOTH SHOTS DESTROYED
m_arrBullet(iLoop1).alive = FALSE ' Destroy the bullet
m_arrBullet(iLoop2).alive = FALSE ' Destroy the other bullet
End If
End If
End If
Next iLoop2
End If
' IS THIS BULLET STILL ALIVE?
If m_arrBullet(iLoop1).alive = TRUE Then
' CHECK ENEMY BULLET
If m_arrBullet(iLoop1).kind = "ENEMY" Then
' Check for collision between bullet and ship
If GetDist(m_Ship.xPos, m_Ship.yPos, m_arrBullet(iLoop1).xPos, m_arrBullet(iLoop1).yPos) <= SHIP_RADIUS Then
m_Ship.shields = m_Ship.shields - BULLET_DAMAGE ' Take Damage
m_arrBullet(iLoop1).alive = FALSE ' Destroy the bullet
End If
Else
' CHECK FOR PLAYER'S BULLET
If m_arrBullet(iLoop1).kind = "SHIP" Then
For iLoop2 = 0 To UBound(m_arrEnemy)
' If the enemy is alive then
If m_arrEnemy(iLoop2).alive = TRUE Then
' Check for collision between bullet and enemy
If GetDist(m_arrEnemy(iLoop2).xPos, m_arrEnemy(iLoop2).yPos, m_arrBullet(iLoop1).xPos, m_arrBullet(iLoop1).yPos) <= m_arrEnemy(iLoop2).radius Then
m_arrEnemy(iLoop2).life = m_arrEnemy(iLoop2).life - BULLET_DAMAGE ' Enemy take damage
m_arrBullet(iLoop1).alive = FALSE ' Destroy the bullet
End If
End If
Next iLoop2
End If
End If
End If
Next iLoop1
' CHECK FOR SHIP COLLIDING WITH ENEMY
For iLoop1 = 0 To UBound(m_arrEnemy)
' If the enemy is alive then
If m_arrEnemy(iLoop1).alive = TRUE Then
' Check for collision between ship and enemy
If GetDist(m_Ship.xPos, m_Ship.yPos, m_arrEnemy(iLoop1).xPos, m_arrEnemy(iLoop1).yPos) <= m_arrEnemy(iLoop1).radius Then
m_arrEnemy(iLoop1).life = 0 ' The enemy has no life/Dead
m_Ship.shields = 0 ' The ship has no shields/Dead
End If
' if the enemy is dead then destroy it, add to score
If m_arrEnemy(iLoop1).life <= 0 Then
m_arrEnemy(iLoop1).alive = FALSE
m_iScore = m_iScore + 10
End If
End If
Next iLoop1
' IS SHIP DEAD?
If m_Ship.shields <= 0 Then
'' Display the message box
'iLoop1 = MsgBox("You have a score of " & m_iScore & vbCrLf & vbCrLf & "Do you wish to try again?", vbYesNo, "Try Again")
'Select Case iLoop1
' Case vbYes
' ' Restart if yes is clicked
' InitVariables
' Case vbNo
' ' End if no clicked
' End
'End Select
m_bGameOver = TRUE
End If
End Sub ' Collisions
Sub Shooting ()
Dim iLoop1 As Integer ' Used for variables
Dim iLoop2 As Integer ' Used for variables
Dim iFreeSpot As Integer
Dim sngXComp As Single
Dim sngYComp As Single
' DID PLAYER SHOOT?
If m_bShootKey = TRUE Then
' Has the gun cooled down yet (prevent bullet being created every 25 milliseconds)
If m_Ship.ShootCount > m_Ship.ShootTime Then
m_Ship.ShootCount = 0
iFreeSpot = -1
For iLoop1 = 0 To UBound(m_arrBullet)
' Check whether it can use another bullet or not
If m_arrBullet(iLoop1).alive = FALSE Then
' if so use the dead bullet
iFreeSpot = iLoop1
Exit For
End If
Next iLoop1
' 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).alive = TRUE ' The bullet is alive
m_arrBullet(iFreeSpot).xPos = m_Ship.xPos ' the bullet is created where the ship is
m_arrBullet(iFreeSpot).yPos = m_Ship.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_Ship.speed * Sin(m_Ship.heading) + BULLET_SPEED * Sin(m_Ship.facing)
sngYComp = m_Ship.speed * Cos(m_Ship.heading) + BULLET_SPEED * Cos(m_Ship.facing)
'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
End If
End If
' ENEMIES SHOOT
For iLoop1 = 0 To UBound(m_arrEnemy)
' Check whether the enemy is alive
If m_arrEnemy(iLoop1).alive = TRUE Then
' Check whether the enemy will fire or not
If Int(Rnd * 100 + 1) = 1 Then
iFreeSpot = -1
For iLoop2 = 0 To UBound(m_arrBullet)
' Check whether the enemy will use an old bullet
If m_arrBullet(iLoop2).alive = FALSE Then
' If so iFreeSpot is the old bullet
iFreeSpot = iLoop2
Exit For
End If
Next iLoop2
' 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
' 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).heading = GetAngle(m_arrEnemy(iLoop1).xPos, m_arrEnemy(iLoop1).yPos, m_Ship.xPos, m_Ship.yPos)
m_arrBullet(iFreeSpot).xPos = m_arrEnemy(iLoop1).xPos ' Create the bullet where the enemy is
m_arrBullet(iFreeSpot).yPos = m_arrEnemy(iLoop1).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
' /////////////////////////////////////////////////////////////////////////////
' Draw the enemies
Sub DrawEnemy ()
Dim iLoop1 As Integer ' Used for variables
Dim iLoop2 As Integer ' Used for variables
Dim iColor As _Unsigned Long
Dim iX As Integer
Dim iY As Integer
Dim sngHeading As Single
Dim iRadius As Integer
For iLoop1 = 0 To UBound(m_arrEnemy)
' Is this enemy alive
If m_arrEnemy(iLoop1).alive = TRUE Then
' Color based on damage
If m_arrEnemy(iLoop1).life >= 30 Then
iColor = cWhite
ElseIf m_arrEnemy(iLoop1).life > 25 Then
iColor = cYellow
ElseIf m_arrEnemy(iLoop1).life > 20 Then
iColor = cGold
ElseIf m_arrEnemy(iLoop1).life > 15 Then
iColor = cOrange
ElseIf m_arrEnemy(iLoop1).life > 10 Then
iColor = cDarkOrange
ElseIf m_arrEnemy(iLoop1).life > 5 Then
iColor = cOrangeRed
Else
iColor = cRed
End If
' Draw body
' CIRCLE (x, y), radius, color
'DrawCircleSolid iX, iY, 8, cRed
Circle (m_arrEnemy(iLoop1).xPos, m_arrEnemy(iLoop1).yPos), m_arrEnemy(iLoop1).radius, iColor
Sub MoveBullets ()
Dim iLoop1 As Integer ' Used for variables
If m_Ship.ShootCount <= m_Ship.ShootTime Then
m_Ship.ShootCount = m_Ship.ShootCount + 1
End If
For iLoop1 = 0 To UBound(m_arrBullet)
' Is the bullet alive
If m_arrBullet(iLoop1).alive = TRUE Then
' Move the bullets
m_arrBullet(iLoop1).xPos = m_arrBullet(iLoop1).xPos + (m_arrBullet(iLoop1).speed * Sin(m_arrBullet(iLoop1).heading))
m_arrBullet(iLoop1).yPos = m_arrBullet(iLoop1).yPos - (m_arrBullet(iLoop1).speed * Cos(m_arrBullet(iLoop1).heading))
' Did the bullet move off screen horizontally?
If m_arrBullet(iLoop1).xPos < iMinX Then
If WRAP_BULLET = TRUE Then
m_arrBullet(iLoop1).xPos = iMaxX
Else
m_arrBullet(iLoop1).alive = FALSE ' Destroy the bullet
End If
ElseIf m_arrBullet(iLoop1).xPos > iMaxX Then
If WRAP_BULLET = TRUE Then
m_arrBullet(iLoop1).xPos = iMinX
Else
m_arrBullet(iLoop1).alive = FALSE ' Destroy the bullet
End If
End If
' Did the bullet move off screen vertically?
If m_arrBullet(iLoop1).yPos < iMinY Then
If WRAP_BULLET = TRUE Then
m_arrBullet(iLoop1).yPos = iMaxY
Else
m_arrBullet(iLoop1).alive = FALSE ' Destroy the bullet
End If
ElseIf m_arrBullet(iLoop1).yPos > iMaxY Then
If WRAP_BULLET = TRUE Then
m_arrBullet(iLoop1).yPos = iMinY
Else
m_arrBullet(iLoop1).alive = FALSE ' Destroy the bullet
End If
End If
' Time how long bullet stays active
m_arrBullet(iLoop1).lifetime = m_arrBullet(iLoop1).lifetime + 1
If m_arrBullet(iLoop1).lifetime > m_arrBullet(iLoop1).lifespan Then
m_arrBullet(iLoop1).alive = FALSE ' Destroy the bullet
End If
End If
Next iLoop1
End Sub ' MoveBullets
' /////////////////////////////////////////////////////////////////////////////
' Draw the bullets
Sub DrawBullets ()
Dim iLoop1 As Integer ' Used for variables
For iLoop1 = 0 To UBound(m_arrBullet)
' Is the bullet alive
If m_arrBullet(iLoop1).alive = TRUE Then
If m_arrBullet(iLoop1).kind = "SHIP" Then
' Is this a ship bullet, draw a white bullet
'Circle (m_arrBullet(iLoop1).xPos, m_arrBullet(iLoop1).yPos), 3, cWhite
DrawCircleSolid m_arrBullet(iLoop1).xPos, m_arrBullet(iLoop1).yPos, BULLET_RADIUS, cWhite
ElseIf m_arrBullet(iLoop1).kind = "ENEMY" Then
' if this is enemy bullet, draw a red bullet
'Circle (m_arrBullet(iLoop1).xPos, m_arrBullet(iLoop1).yPos), 3, cOrangeRed
DrawCircleSolid m_arrBullet(iLoop1).xPos, m_arrBullet(iLoop1).yPos, BULLET_RADIUS, cOrangeRed
End If
End If
Next iLoop1
End Sub ' DrawBullets
' /////////////////////////////////////////////////////////////////////////////
' Move the ship
Sub MoveShip ()
Dim sngXComp As Single
Dim sngYComp As Single
' If the left key is pressed then rotate the ship left
If m_bLeftKey = TRUE Then
m_Ship.facing = m_Ship.facing - PI / TURN_SPEED
End If
' If the Right key is pressed then rotate the ship right
If m_bRightKey = TRUE Then
m_Ship.facing = m_Ship.facing + PI / TURN_SPEED
End If
' If the up key is pressed then and accelerate it in the direction the ship is facing
If m_bUpKey = TRUE Then
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' TODO: fix this to make the movement more natural...
' Determine the X and Y components of the resultant vector
sngXComp = m_Ship.speed * Sin(m_Ship.heading) + SHIP_ACCEL * Sin(m_Ship.facing)
sngYComp = m_Ship.speed * Cos(m_Ship.heading) + SHIP_ACCEL * Cos(m_Ship.facing)
' Calculate the resultant heading, and adjust for arctangent by adding Pi if necessary
If Sgn(sngYComp) > 0 Then
m_Ship.heading = Atn(sngXComp / sngYComp)
End If
If Sgn(sngYComp) < 0 Then
m_Ship.heading = Atn(sngXComp / sngYComp) + PI
End If
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
End If
' If the down key is pressed then and accelerate the ship in the opposite direction it is facing
If m_bDownKey = TRUE And m_Ship.speed > -MAX_SPEED Then
' Determine the X and Y components of the resultant vector
sngXComp = m_Ship.speed * Sin(m_Ship.heading) - SHIP_ACCEL * Sin(m_Ship.facing)
sngYComp = m_Ship.speed * Cos(m_Ship.heading) - SHIP_ACCEL * Cos(m_Ship.facing)
' Calculate the resultant heading, and adjust for actangent by adding Pi if necessary
If Sgn(sngYComp) > 0 Then
m_Ship.heading = Atn(sngXComp / sngYComp)
End If
If Sgn(sngYComp) < 0 Then
m_Ship.heading = Atn(sngXComp / sngYComp) + PI
End If
End If
' Did player hit cheat key?
If m_bCheatKey = TRUE Then
m_Ship.shields = m_Ship.shields + 10
End If
' Don't let the ship go faster then the max speed
If m_Ship.speed > MAX_SPEED Then
m_Ship.speed = MAX_SPEED
End If
' Keep the ship inside the form
If m_Ship.xPos < iMinX Then
m_Ship.xPos = iMaxX
End If
If m_Ship.xPos > iMaxX Then
m_Ship.xPos = iMinX
End If
If m_Ship.yPos < iMinY Then
m_Ship.yPos = iMaxY
End If
If m_Ship.yPos > iMaxY Then
m_Ship.yPos = iMinY
End If
End Sub ' MoveShip
Sub MoveEnemy ()
Dim iLoop1 As Integer
'For iLoop1 = 0 To UBound(m_arrEnemy)
' ' Check whether the enemy is alive
' If m_arrEnemy(iLoop1).alive = TRUE Then
' End If
'Next iLoop1
End Sub ' MoveEnemy
Sub ShowScore
' Draw background
Color cBlue, cBlue
PrintAt 0, 0, String$(120, " ")
' Place the text on the form
Color cLime, cEmpty
PrintAt 0, 10, "Shields: " + cstr$(m_Ship.shields) ' LeftPadString$(cstr$(m_Ship.shields), 5, " ")
' Title displays the players score
'frmCollision.Caption = "Score: " & m_iScore
Color cCyan, cEmpty
PrintAt 0, 40, "Score: " + cstr$(m_iScore) ' LeftPadString$(cstr$(m_iScore), 10, " ")
' Display the level
Color cWhite, cEmpty
PrintAt 0, 70, "Level: " + cstr$(m_iLevel) ' LeftPadString$(cstr$(m_iScore), 10, " ")
' Show instructions
Color cRed, cRed
PrintAt 39, 0, String$(120, " ")
Color cWhite, cEmpty
PrintAt 39, 0, "CONTROLS: LEFT/RIGHT = TURN UP/DOWN = FORWARD/BACK CTRL=FIRE 1=ADD SHIELD (CHEAT)"
End Sub ' ShowScore
' /////////////////////////////////////////////////////////////////////////////
' Draw the ship
Sub DrawShip ()
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
' left rear
intX2 = m_Ship.xPos + SHIP_RADIUS * Sin(m_Ship.facing + 2 * PI / 3)
intY2 = m_Ship.yPos - SHIP_RADIUS * Cos(m_Ship.facing + 2 * PI / 3)
' left rear (3/4 of the way down)
intX2b = m_Ship.xPos + ENGINE_RADIUS * Sin(m_Ship.facing + 2 * PI / 3)
intY2b = m_Ship.yPos - ENGINE_RADIUS * Cos(m_Ship.facing + 2 * PI / 3)
' right rear
intX3 = m_Ship.xPos + SHIP_RADIUS * Sin(m_Ship.facing + 4 * PI / 3)
intY3 = m_Ship.yPos - SHIP_RADIUS * Cos(m_Ship.facing + 4 * PI / 3)
' right rear (3/4 of the way down)
intX3b = m_Ship.xPos + ENGINE_RADIUS * Sin(m_Ship.facing + 4 * PI / 3)
intY3b = m_Ship.yPos - ENGINE_RADIUS * Cos(m_Ship.facing + 4 * PI / 3)
' rear where engine flames end
intX1b = m_Ship.xPos - FLAME_RADIUS * Sin(m_Ship.facing)
intY1b = m_Ship.yPos + FLAME_RADIUS * Cos(m_Ship.facing)
'm_Ship.facing = m_Ship.facing - Pi / 36
' -----------------------------------------------------------------------------
' Draw the ship
' Draw the left side
Line (intX1, intY1)-(intX2, intY2), cWhite
' Draw the right side
Line (intX1, intY1)-(intX3, intY3), cWhite
' Draw the rear / aft side
If m_bUpKey Then
' Draw rear side
Line (intX2b, intY2b)-(intX3b, intY3b), cSilver
' Engine is firing
'Line (intX2b, intY2b)-(intX3b, intY3b), cOrangeRed
' Draw the flame left side
Line (intX1b, intY1b)-(intX2b, intY2b), cOrangeRed
' Draw the flame right side
Line (intX1b, intY1b)-(intX3b, intY3b), cOrangeRed
Else
' Draw rear side
Line (intX2b, intY2b)-(intX3b, intY3b), cSilver
End If
End Sub ' DrawShip
' /////////////////////////////////////////////////////////////////////////////
' Respawn the enemies if there all dead
Sub Respawn ()
Dim iLoop1 As Integer ' Used for variables
' Check if all enemies are dead
m_bAllDead = TRUE
For iLoop1 = 0 To UBound(m_arrEnemy)
' If an enemy is alive then
If m_arrEnemy(iLoop1).alive = TRUE Then
' enemies aren't all dead
m_bAllDead = FALSE
Exit For
End If
Next iLoop1
' if all dead, respawn and create one more enemy
' advance to next level
If m_bAllDead = TRUE Then
' INCREASE LEVEL
m_iLevel = m_iLevel + 1
' GIVE PLAYER SOME BONUS SHIELDS
m_Ship.shields = m_Ship.shields + BONUS_SHIELDS
' 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 iLoop1 = 0 To UBound(m_arrEnemy)
' Set the starting positions
m_arrEnemy(iLoop1).alive = TRUE
m_arrEnemy(iLoop1).life = 30
m_arrEnemy(iLoop1).xPos = m_Ship.xPos
m_arrEnemy(iLoop1).yPos = m_Ship.yPos
' choose a random size
m_arrEnemy(iLoop1).radius = RandomNumber%(m_iMinEnemyRadius, m_iMaxEnemyRadius)
' make sure the enemies don't start on the ship
Do Until GetDist(m_arrEnemy(iLoop1).xPos, m_arrEnemy(iLoop1).yPos, m_Ship.xPos, m_Ship.yPos) > SHIP_RADIUS * 10
m_arrEnemy(iLoop1).xPos = RandomNumber%(iMinX, iMaxX) 'Int(Rnd * ScaleWidth + 1)
m_arrEnemy(iLoop1).yPos = RandomNumber%(iMinY, iMaxY) 'Int(Rnd * ScaleHeight + 1)
Loop
Next iLoop1
End If
End Sub ' Respawn
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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN TRIG FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' 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
' /////////////////////////////////////////////////////////////////////////////
' 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
' /////////////////////////////////////////////////////////////////////////////
' 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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END TRIG FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Integer to string
Function cstr$ (myValue)
'cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
cstr$ = _Trim$(Str$(myValue))
End Function ' cstr$
' /////////////////////////////////////////////////////////////////////////////
' Hack function, to be replaced with something better
Function DblToInt% (dblOld As Double)
Dim dblNew As Double
Dim sValue As String
Dim iPos As Integer
' /////////////////////////////////////////////////////////////////////////////
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
Function DblToStr$ (n#)
Dim result$: result$ = ""
Dim value$
Dim Xpos%
Dim expo%
Dim sign$
Dim valu$
Dim dot%
Dim L%
Dim add$
Dim min$
Dim DP$
Dim n%
value$ = UCase$(LTrim$(Str$(n#)))
Xpos% = InStr(value$, "D") + InStr(value$, "E") ' only D or E can be present
If Xpos% Then
expo% = Val(Mid$(value$, Xpos% + 1))
If Val(value$) < 0 Then
sign$ = "-"
valu$ = Mid$(value$, 2, Xpos% - 2)
Else
valu$ = Mid$(value$, 1, Xpos% - 1)
End If
dot% = InStr(valu$, ".")
L% = Len(valu$)
If expo% > 0 Then
add$ = String$(expo% - (L% - dot%), "0")
End If
If expo% < 0 Then
min$ = String$(Abs(expo%) - (dot% - 1), "0")
DP$ = "."
End If
For n% = 1 To L%
If Mid$(valu$, n%, 1) <> "." Then
num$ = num$ + Mid$(valu$, n%, 1)
End If
Next n%
result$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
Else
result$ = value$
End If
Function DblRoundedToStr$ (dblValue As Double, intNumPlaces As Integer)
Dim dblNew As Double
dblNew = RoundDouble#(dblValue, intNumPlaces)
DblRoundedToStr$ = DblToStr$(dblNew)
End Function ' DblRoundedToStr$
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
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$
' /////////////////////////////////////////////////////////////////////////////
' By sMcNeill 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%
' /////////////////////////////////////////////////////////////////////////////
' 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&
' /////////////////////////////////////////////////////////////////////////////
' iRow% and iCol% are 0-based in this version
Sub PrintAt (iRow%, iCol%, sText$)
'_PrintString (iCol% * 8, iRow% * 16), sText$
_PrintString (iCol% * 8, iRow% * 16), sText$
'_PrintString (iCol%, iRow%), sText$
End Sub ' PrintAt
' /////////////////////////////////////////////////////////////////////////////
' Generate random value between Min and Max.
Function RandomNumber% (Min%, Max%)
Dim NumSpread%
' SET RANDOM SEED
'Randomize ' Initialize random-number generator.
Randomize Timer
' GET RANDOM # Min%-Max%
'RandomNumber = Int((Max * Rnd) + Min) ' generate number
NumSpread% = (Max% - Min%) + 1
RandomNumber% = Int(Rnd * NumSpread%) + Min% ' GET RANDOM # BETWEEN Max% AND Min%
Function RightPadString$ (myString$, toWidth%, padChar$)
RightPadString$ = Left$(myString$ + String$(toWidth%, padChar$), toWidth%)
End Function ' RightPadString$
' /////////////////////////////////////////////////////////////////////////////
' 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
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
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
Function SmallestOf3% (i1%, i2%, i3%)
Dim iMin%
iMin% = i1%
If i2% < iMin% Then iMin% = i2%
If i3% < iMin% Then iMin% = i3%
SmallestOf3% = iMin%
End Function ' SmallestOf3
Function SngRoundedToStr$ (sngValue As Single, intNumPlaces As Integer)
Dim sngNew As Single
sngNew = RoundSingle!(sngValue, intNumPlaces)
SngRoundedToStr$ = SngToStr$(sngNew)
End Function ' SngRoundedToStr$
' /////////////////////////////////////////////////////////////////////////////
' Hack function, to be replaced with something better
Function SngToInt% (sngOld As Single)
Dim sngNew As Single
Dim sValue As String
Dim iPos As Integer
' /////////////////////////////////////////////////////////////////////////////
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
Function SngToStr$ (n!)
Dim result$: result$ = ""
Dim value$
Dim Xpos%
Dim expo%
Dim sign$
Dim valu$
Dim dot%
Dim L%
Dim add$
Dim min$
Dim DP$
Dim n%
value$ = UCase$(LTrim$(Str$(n!)))
Xpos% = InStr(value$, "D") + InStr(value$, "E") ' only D or E can be present
If Xpos% Then
expo% = Val(Mid$(value$, Xpos% + 1))
If Val(value$) < 0 Then
sign$ = "-"
valu$ = Mid$(value$, 2, Xpos% - 2)
Else
valu$ = Mid$(value$, 1, Xpos% - 1)
End If
dot% = InStr(valu$, ".")
L% = Len(valu$)
If expo% > 0 Then
add$ = String$(expo% - (L% - dot%), "0")
End If
If expo% < 0 Then
min$ = String$(Abs(expo%) - (dot% - 1), "0")
DP$ = "."
End If
For n% = 1 To L%
If Mid$(valu$, n%, 1) <> "." Then
num$ = num$ + Mid$(valu$, n%, 1)
End If
Next n%
result$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
Else
result$ = value$
End If
SngToStr$ = result$
End Function ' SngToStr$
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'
' FROM luke, QB64 Developer
' Date: February 15, 2019, 04:11:07 AM
'
' Given a string of words separated by spaces (or any other character),
' splits it into an array of the words. I've no doubt many people have
' written a version of this over the years and no doubt there's a million
' ways to do it, but I thought I'd put mine here so we have at least one
' version. There's also a join function that does the opposite
' array -> single string.
'
' Code is hopefully reasonably self explanatory with comments and a little demo.
' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.
'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences
'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$().
'
'delimiter$ must be one character long.
'result$() must have been REDIMmed previously.
' Modified to handle multi-character delimiters
Sub split (in$, delimiter$, result$())
Dim start As Integer
Dim finish As Integer
Dim iDelimLen As Integer
ReDim result$(-1)
iDelimLen = Len(delimiter$)
start = 1
Do
'While Mid$(in$, start, 1) = delimiter$
While Mid$(in$, start, iDelimLen) = delimiter$
'start = start + 1
start = start + iDelimLen
If start > Len(in$) Then
Exit Sub
End If
Wend
finish = InStr(start, in$, delimiter$)
If finish = 0 Then
finish = Len(in$) + 1
End If
ReDim _Preserve result$(0 To UBound(result$) + 1)
result$(UBound(result$)) = Mid$(in$, start, finish - start)
start = finish + 1
Loop While start <= Len(in$)
End Sub ' split
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN COLOR FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Function cRed~& ()
cRed = _RGB32(255, 0, 0)
End Function
Function cOrangeRed~& ()
cOrangeRed = _RGB32(255, 69, 0)
End Function ' cOrangeRed~&
Function cDarkOrange~& ()
cDarkOrange = _RGB32(255, 140, 0)
End Function ' cDarkOrange~&
Function cOrange~& ()
cOrange = _RGB32(255, 165, 0)
End Function ' cOrange~&
Function cGold~& ()
cGold = _RGB32(255, 215, 0)
End Function ' cGold~&
Function cYellow~& ()
cYellow = _RGB32(255, 255, 0)
End Function ' cYellow~&
' LONG-HAIRED FRIENDS OF JESUS OR NOT,
' THIS IS NOT YELLOW ENOUGH (TOO CLOSE TO LIME)
' TO USE FOR OUR COMPLEX RAINBOW SEQUENCE:
Function cChartreuse~& ()
cChartreuse = _RGB32(127, 255, 0)
End Function ' cChartreuse~&
' WE SUBSTITUTE THIS CSS3 COLOR FOR INBETWEEN LIME AND YELLOW:
Function cOliveDrab1~& ()
cOliveDrab1 = _RGB32(192, 255, 62)
End Function ' cOliveDrab1~&
Function cLime~& ()
cLime = _RGB32(0, 255, 0)
End Function ' cLime~&
Function cMediumSpringGreen~& ()
cMediumSpringGreen = _RGB32(0, 250, 154)
End Function ' cMediumSpringGreen~&
' ADDED THIS FOR THE GAUGE COLOR:
Function cSpringGreen~& ()
cSpringGreen = _RGB32(0, 255, 160)
End Function ' cSpringGreen~&
Function cCyan~& ()
cCyan = _RGB32(0, 255, 255)
End Function ' cCyan~&
Function cDeepSkyBlue~& ()
cDeepSkyBlue = _RGB32(0, 191, 255)
End Function ' cDeepSkyBlue~&
Function cDodgerBlue~& ()
cDodgerBlue = _RGB32(30, 144, 255)
End Function ' cDodgerBlue~&
Function cSeaBlue~& ()
cSeaBlue = _RGB32(0, 64, 255)
End Function ' cSeaBlue~&
Function cBlue~& ()
cBlue = _RGB32(0, 0, 255)
End Function ' cBlue~&
Function cBluePurple~& ()
cBluePurple = _RGB32(64, 0, 255)
End Function ' cBluePurple~&
Function cDeepPurple~& ()
cDeepPurple = _RGB32(96, 0, 255)
End Function ' cDeepPurple~&
Function cPurple~& ()
cPurple = _RGB32(128, 0, 255)
End Function ' cPurple~&
Function cPurpleRed~& ()
cPurpleRed = _RGB32(128, 0, 192)
End Function ' cPurpleRed~&
Function cDarkRed~& ()
cDarkRed = _RGB32(160, 0, 64)
End Function ' cDarkRed~&
Function cBrickRed~& ()
cBrickRed = _RGB32(192, 0, 32)
End Function ' cBrickRed~&
Function cDarkGreen~& ()
cDarkGreen = _RGB32(0, 100, 0)
End Function ' cDarkGreen~&
Function cGreen~& ()
cGreen = _RGB32(0, 128, 0)
End Function ' cGreen~&
Function cOliveDrab~& ()
cOliveDrab = _RGB32(107, 142, 35)
End Function ' cOliveDrab~&
Function cLightPink~& ()
cLightPink = _RGB32(255, 182, 193)
End Function ' cLightPink~&
Function cHotPink~& ()
cHotPink = _RGB32(255, 105, 180)
End Function ' cHotPink~&
Function cDeepPink~& ()
cDeepPink = _RGB32(255, 20, 147)
End Function ' cDeepPink~&
Function cMagenta~& ()
cMagenta = _RGB32(255, 0, 255)
End Function ' cMagenta~&
Function cBlack~& ()
cBlack = _RGB32(0, 0, 0)
End Function ' cBlack~&
Function cDimGray~& ()
cDimGray = _RGB32(105, 105, 105)
End Function ' cDimGray~&
Function cGray~& ()
cGray = _RGB32(128, 128, 128)
End Function ' cGray~&
Function cDarkGray~& ()
cDarkGray = _RGB32(169, 169, 169)
End Function ' cDarkGray~&
Function cSilver~& ()
cSilver = _RGB32(192, 192, 192)
End Function ' cSilver~&
Function cLightGray~& ()
cLightGray = _RGB32(211, 211, 211)
End Function ' cLightGray~&
Function cGainsboro~& ()
cGainsboro = _RGB32(220, 220, 220)
End Function ' cGainsboro~&
Function cWhiteSmoke~& ()
cWhiteSmoke = _RGB32(245, 245, 245)
End Function ' cWhiteSmoke~&
Function cWhite~& ()
cWhite = _RGB32(255, 255, 255)
'cWhite = _RGB32(254, 254, 254)
End Function ' cWhite~&
Function cDarkBrown~& ()
cDarkBrown = _RGB32(128, 64, 0)
End Function ' cDarkBrown~&
Function cLightBrown~& ()
cLightBrown = _RGB32(196, 96, 0)
End Function ' cLightBrown~&
Function cKhaki~& ()
cKhaki = _RGB32(240, 230, 140)
End Function ' cKhaki~&
Function cEmpty~& ()
'cEmpty~& = -1
cEmpty = _RGB32(0, 0, 0, 0)
End Function ' cEmpty~&
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END COLOR FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ################################################################################################################################################################
' BEGIN KEYBOARD CODE FUNCTIONS
' NOTE: 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 CODE FUNCTIONS
' ################################################################################################################################################################
'' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'' BEGIN DEBUGGING ROUTINES #DEBUGGING
'' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'
'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
'
'' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'' END DEBUGGING ROUTINES @DEBUGGING
'' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
I've created an Odysee channel for the QB64pe project! Odysee is a blockchain site for sharing videos, livestreams, and articles. The first article I've posted there is the announcement of version 3.4.0! To see the article, follow this link: https://odysee.com/v3.4.0
I hope to also share some videos there later for showcasing new features as they come out. Maybe this could be something like Fellippe was trying to get going a while back. I don't know. I'm not as charismatic as he is.
If you all have ideas for videos and things, please let me know. I can't guarantee I'll be quick to get stuff out, though.
![[Image: screenshot.jpg]](https://i.ibb.co/WcNXt0Q/screenshot.jpg)
