+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://qb64phoenix.com/forum/forumdisplay.php?fid=26)
+---- Forum: madscijr (https://qb64phoenix.com/forum/forumdisplay.php?fid=46)
+---- Thread: game input mapping system v1.0 for gamepad, keyboard (/showthread.php?tid=1678)
game input mapping system v1.0 for gamepad, keyboard - madscijr - 05-12-2023
This is the first version of my joystick & keyboard mapping + input library (original post).
Version 2 followed, which added a simple GUI (what a pain and interesting project THAT was!)
(I'm currently working on Version 3 which removes the GUI abomination and simplifies things.)
madscijr
game input mapping system v1.0 for gamepad, keyboard
« on: January 07, 2022, 06:43:22 pm »
I needed some basic reusable functionality to map game input from USB game controllers and the keyboard, which could be saved to a config file and reused.
Everything is working now, you can map controls, load/save/edit mappings, test the mapping, or test game controllers.
The input is menu driven, and the menus are very rudimentary, text-based, but it works (at least as far as I can tell).
1. Basic controller test
2. Load controller mapping
3. View controller mapping
4. Edit controller mapping for 1 or more players
5. Reset controller mapping for 1 or more players
6. Map controllers for 1 or more players
7. Test controller mappings to move around screen
8. Save controller mappings
Code is below and fully self-contained.
Enjoy.
Code: (Select All)
' ################################################################################################################################################################
' #TOP
' Game Input Mapping Test
' Version 1.0 by madscijr
' BASED ON CODE BY SMcNeill FROM:
' Simple Joystick Detection and Interaction (Read 316 times)
' https://www.qb64.org/forum/index.php?topic=2160.msg129051#msg129051
' https://qb64forum.alephc.xyz/index.php?topic=2160.msg129083#msg129083
' and others (sources cited throughout).
' ################################################################################################################################################################
' #CONSTANTS = GLOBAL CONSTANTS
' boolean constants:
Const FALSE = 0
Const TRUE = Not FALSE
' BEGIN GAME CONTROLLER MAPPING CONSTANTS
Const cInputNone = 0
Const cInputKey = 1
Const cInputButton = 2
Const cInputAxis = 3
Const cMaxButtons = 12
Const cMaxAxis = 8
Const cMaxControllers = 8
Const cMaxPlayers = 8
' Use as index for array of ControlInputType
Const cInputUp = 1
Const cInputDown = 2
Const cInputLeft = 3
Const cInputRight = 4
Const cInputButton1 = 5
Const cInputButton2 = 6
Const cInputButton3 = 7
Const cInputButton4 = 8
Const c_iKeyDown_F10 = 17408
Const c_iKeyHit_AltLeft = -30764
Const c_iKeyHit_AltRight = -30765
' END GAME CONTROLLER MAPPING CONSTANTS
' ################################################################################################################################################################
' #UDT #TYPES = USER DEFINED TYPES
' UDT TO HOLD THE INFO FOR A PLAYER
Type PlayerType
x As Integer ' player x position
y As Integer ' player y position
c As Integer ' character to display on screen
xOld As Integer
yOld As Integer
' control buffer
moveX As Integer
moveY As Integer
moveUp As Integer
moveDown As Integer
moveLeft As Integer
moveRight As Integer
button1 As Integer
button2 As Integer
button3 As Integer
button4 As Integer
' control previous move
'lastMoveX As Integer
'lastMoveY As Integer
lastMoveUp As Integer
lastMoveDown As Integer
lastMoveLeft As Integer
lastMoveRight As Integer
lastButton1 As Integer
lastButton2 As Integer
lastButton3 As Integer
lastButton4 As Integer
'repeat As Integer
End Type ' PlayerType
' UDT TO HOLD THE INFO FOR A GAME CONTROLLER
Type ControllerType
buttonCount As Integer
axisCount As Integer
End Type ' ControllerType
' UDT TO HOLD THE INFO FOR A GAME CONTROLLER
Type ControlInputType
device As Integer
typ As Integer ' cInputKey, cInputButton, cInputAxis
code As Integer
value As Integer
repeat As Integer
End Type ' ControlInputType
' ################################################################################################################################################################
' #VARS = GLOBAL VARIABLES
' ENABLE / DISABLE DEBUG CONSOLE
Dim Shared m_bTesting As Integer: m_bTesting = 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)
' GAME CONTROLLER MAPPING
Dim Shared m_ControlMapFileName$: m_ControlMapFileName$ = Left$(m_ProgramName$, _InStrRev(m_ProgramName$, ".")) + "map.txt"
ReDim Shared m_arrControlMap(1 To 8, 1 To 8) As ControlInputType ' holds control mapping for each player (player #, direction)
ReDim Shared m_arrController(1 To 8) As ControllerType ' holds info for each game controller
ReDim Shared m_arrButtonCode(1 To 99) As Integer ' Long
ReDim Shared m_arrButtonKey(1 To 99) As String
ReDim Shared m_arrButtonKeyDesc(0 To 512) As String
Dim Shared m_bInitialized As Integer: m_bInitialized = FALSE
Dim Shared m_bHaveMapping As Integer: m_bHaveMapping = FALSE
' USE TO GLOBALLY ENABLE/DISABLE REPEATING INPUT PER FUNCTION
' To enable override set m_bRepeatOverride=TRUE,
' otherwise this can be configured for each individual controller
' when you map the functions.
Dim Shared m_bRepeatOverride As Integer: m_bRepeatOverride = TRUE
Dim Shared m_bRepeatUp As Integer: m_bRepeatUp = TRUE
Dim Shared m_bRepeatDown As Integer: m_bRepeatDown = TRUE
Dim Shared m_bRepeatLeft As Integer: m_bRepeatLeft = FALSE
Dim Shared m_bRepeatRight As Integer: m_bRepeatRight = FALSE
Dim Shared m_bRepeatButton1 As Integer: m_bRepeatButton1 = TRUE
Dim Shared m_bRepeatButton2 As Integer: m_bRepeatButton2 = TRUE
Dim Shared m_bRepeatButton3 As Integer: m_bRepeatButton3 = FALSE
Dim Shared m_bRepeatButton4 As Integer: m_bRepeatButton4 = FALSE
' VARIABLES FOR GRAPHIC PRINTING ROUTINES
Dim Shared m_NumColumns As Integer: m_NumColumns = 1
Dim Shared m_PrintRow As Integer: m_PrintRow = 0
Dim Shared m_PrintCol As Integer: m_PrintCol = 0
Dim Shared m_StartRow As Integer: m_StartRow = 0
Dim Shared m_EndRow As Integer: m_EndRow = 0
Dim Shared m_StartCol As Integer: m_StartCol = 0
Dim Shared m_EndCol As Integer: m_EndCol = 0
' DEMO GAME / TESTING
ReDim Shared m_arrPlayer(1 To 8) As PlayerType ' holds info for each player
' =============================================================================
' LOCAL VARIABLES
Dim in$
' ****************************************************************************************************************************************************************
' ACTIVATE DEBUGGING WINDOW
If m_bTesting = TRUE Then
$Console
_Delay 4
_Console On
_Echo "Started " + m_ProgramName$
_Echo "Debugging on..."
End If
' ****************************************************************************************************************************************************************
' =============================================================================
' START THE MAIN ROUTINE
main
' =============================================================================
' FINISH
Screen 0
Print m_ProgramName$ + " finished."
Input "Press <ENTER> to continue", in$
' ****************************************************************************************************************************************************************
' DEACTIVATE DEBUGGING WINDOW
If m_bTesting = TRUE Then
_Console Off
End If
' ****************************************************************************************************************************************************************
System ' return control to the operating system
End
' /////////////////////////////////////////////////////////////////////////////
Sub main
Dim RoutineName As String: RoutineName = "main"
Dim in$
Dim result$: result$ = ""
' SET UP SCREEN
Screen _NewImage(1280, 1024, 32): _ScreenMove 0, 0
Do
If Len(result$) = 0 Then
Cls
Else
Print
End If
Print m_ProgramName$
Print
Print "Game Input Mapping Test"
Print "v1.0, by Softintheheadware (Jan, 2022)"
Print
Print "1. Basic controller test"
Print "2. Load controller mapping"
Print "3. View controller mapping"
Print "4. Edit controller mapping for 1 or more players"
Print "5. Reset controller mapping for 1 or more players"
Print "6. Map controllers for 1 or more players"
Print "7. Test controller mappings to move around screen"
Print "8. Save controller mappings"
Print
Print "What to do? ('q' to exit)"
Input in$: in$ = LCase$(Left$(in$, 1))
If in$ = "1" Then
result$ = TestJoysticks$
ElseIf in$ = "2" Then
result$ = LoadMappings$
If Len(result$) = 0 Then result$ = "Loaded mappings."
ElseIf in$ = "3" Then
result$ = ViewMappings$
ElseIf in$ = "4" Then
result$ = EditMappings$
ElseIf in$ = "5" Then
result$ = ResetMapping$
ElseIf in$ = "6" Then
result$ = MapInput$
ElseIf in$ = "7" Then
result$ = TestMappings$
ElseIf in$ = "8" Then
result$ = SaveMappings$
End If
If Len(result$) > 0 Then
Print result$
End If
Loop Until in$ = "q"
' RETURN TO TEXT SCREEN
Screen 0
End Sub ' main
' /////////////////////////////////////////////////////////////////////////////
' TODO: get keyboard input working
' TODO: get continuous movement working for digital joysticks
' TODO: adjust analog joystick sensitivity
Function TestMappings$
Dim sResult As String: sResult = ""
Dim sError As String: sError = ""
Dim iDeviceCount As Integer
Dim iDevice As Integer
Dim iNumControllers As Integer
Dim iController As Integer
Dim iValue As Integer
Dim iWhichInput As Integer
Dim arrButton(32, 16) As Integer ' number of buttons on the joystick
Dim arrButtonNew(32, 16) As Integer ' tracks when to initialize values
Dim arrAxis(32, 16) As Double ' number of axis on the joystick
Dim arrAxisNew(32, 16) As Integer ' tracks when to initialize values
Dim iCols As Integer
Dim iRows As Integer
Dim iPlayer As Integer
Dim iNextY As Integer
Dim iNextX As Integer
Dim iNextC As Integer
Dim iMinX As Integer
Dim iMaxX As Integer
Dim iMinY As Integer
Dim iMaxY As Integer
Dim bHaveInput As Integer
Dim bFinished As Integer
Dim bFoundWho As Integer
Dim bRepeat As Integer
Dim in$
' MAKE SURE WE HAVE MAPPING
If m_bHaveMapping = TRUE Then
' INITIALIZE
Cls
InitKeyboardButtonCodes
iCols = _Width(0) \ _FontWidth
iRows = _Height(0) \ _FontHeight
iMinX = 0: iMaxX = iCols
iMinY = 0: iMaxY = iRows
' INITIALIZE PLAYER COORDINATES AND SCREEN CHARACTERS
iNextY = 1
iNextX = -3
iNextC = 64
For iPlayer = LBound(m_arrControlMap, 1) To UBound(m_arrControlMap, 1)
iNextX = iNextX + 4
If iNextX >= iMaxX Then
iNextX = iMinX
iNextY = iNextY + 4
If iNextY > iMaxY Then
iNextY = iMinY
End If
End If
iNextC = iNextC + 1
m_arrPlayer(iPlayer).x = iNextX
m_arrPlayer(iPlayer).y = iNextY
m_arrPlayer(iPlayer).c = iNextC
m_arrPlayer(iPlayer).xOld = iNextX
m_arrPlayer(iPlayer).yOld = iNextY
m_arrPlayer(iPlayer).moveX = 0
m_arrPlayer(iPlayer).moveY = 0
m_arrPlayer(iPlayer).moveUp = FALSE
m_arrPlayer(iPlayer).moveDown = FALSE
m_arrPlayer(iPlayer).moveLeft = FALSE
m_arrPlayer(iPlayer).moveRight = FALSE
m_arrPlayer(iPlayer).button1 = FALSE
m_arrPlayer(iPlayer).button2 = FALSE
m_arrPlayer(iPlayer).button3 = FALSE
m_arrPlayer(iPlayer).button4 = FALSE
m_arrPlayer(iPlayer).lastMoveUp = FALSE
m_arrPlayer(iPlayer).lastMoveDown = FALSE
m_arrPlayer(iPlayer).lastMoveLeft = FALSE
m_arrPlayer(iPlayer).lastMoveRight = FALSE
m_arrPlayer(iPlayer).lastButton1 = FALSE
m_arrPlayer(iPlayer).lastButton2 = FALSE
m_arrPlayer(iPlayer).lastButton3 = FALSE
m_arrPlayer(iPlayer).lastButton4 = FALSE
Next iPlayer
' COUNT # OF JOYSTICKS
' TODO: find out the right way to count joysticks
If Len(sError) = 0 Then
' D= _DEVICES ' MUST be read in order for other 2 device functions to work!
iDeviceCount = _Devices ' Find the number of devices on someone's system
If iDeviceCount > 2 Then
' LIMIT # OF DEVICES, IF THERE IS A LIMIT DEFINED
iNumControllers = iDeviceCount - 2
If cMaxControllers > 0 Then
If iNumControllers > cMaxControllers Then
iNumControllers = cMaxControllers
End If
End If
Else
' ONLY 2 FOUND (KEYBOARD, MOUSE)
'sError = "No game controllers found."
iNumControllers = 0
End If
End If
' INITIALIZE CONTROLLER DATA
If Len(sError) = 0 Then
For iController = 1 To iNumControllers
m_arrController(iController).buttonCount = cMaxButtons
m_arrController(iController).axisCount = cMaxAxis
For iLoop = 1 To cMaxButtons
arrButtonNew(iController, iLoop) = TRUE
Next iLoop
For iLoop = 1 To cMaxAxis
arrAxisNew(iController, iLoop) = TRUE
Next iLoop
Next iController
End If
' INITIALIZE CONTROLLER INPUT
If Len(sError) = 0 Then
_KeyClear: _Delay 1
For iController = 1 To iNumControllers
iDevice = iController + 2
While _DeviceInput(iDevice) ' clear and update the device buffer
For iLoop = 1 To _LastButton(iDevice)
If (iLoop > cMaxButtons) Then Exit For
m_arrController(iController).buttonCount = iLoop
arrButton(iController, iLoop) = FALSE
Next iLoop
For iLoop = 1 To _LastAxis(iDevice) ' this loop checks all my axis
If (iLoop > cMaxAxis) Then Exit For
m_arrController(iController).axisCount = iLoop
arrAxis(iController, iLoop) = 0
Next iLoop
Wend ' clear and update the device buffer
Next iController
End If
' GET INPUT AND MOVE PLAYERS AROUND ON SCREEN
_KeyClear: _Delay 1
bFinished = FALSE
Do
' Clear control buffer for players
For iPlayer = LBound(m_arrControlMap, 1) To UBound(m_arrControlMap, 1)
m_arrPlayer(iPlayer).moveUp = FALSE
m_arrPlayer(iPlayer).moveDown = FALSE
m_arrPlayer(iPlayer).moveLeft = FALSE
m_arrPlayer(iPlayer).moveRight = FALSE
m_arrPlayer(iPlayer).button1 = FALSE
m_arrPlayer(iPlayer).button2 = FALSE
m_arrPlayer(iPlayer).button3 = FALSE
m_arrPlayer(iPlayer).button4 = FALSE
Next iPlayer
' -----------------------------------------------------------------------------
' BEGIN CHECK FOR CONTROLLER INPUT
If iNumControllers > 0 Then
For iController = 1 To iNumControllers
iDevice = iController + 2
' Check all devices
While _DeviceInput(iDevice)
Wend ' clear and update the device buffer
' Check each button
For iLoop = 1 To _LastButton(iDevice)
If (iLoop > cMaxButtons) Then Exit For
' update button array to indicate if a button is up or down currently.
'if TRUE=TRUE then
If _ButtonChange(iLoop) Then
iValue = _Button(iLoop)
If iValue <> arrButton(iController, iLoop) Then
' *****************************************************************************
' PRESSED BUTTON
' BEGIN find who this is mapped for
bFoundWho = FALSE
For iPlayer = LBound(m_arrControlMap, 1) To UBound(m_arrControlMap, 1)
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
If m_arrControlMap(iPlayer, iWhichInput).device = iDevice Then
If m_arrControlMap(iPlayer, iWhichInput).typ = cInputButton Then
If m_arrControlMap(iPlayer, iWhichInput).code = iLoop Then
'if m_arrControlMap(iPlayer, iWhichInput).value = iValue then
bFoundWho = TRUE
Select Case iWhichInput
Case cInputUp:
m_arrPlayer(iPlayer).moveUp = TRUE
Case cInputDown:
m_arrPlayer(iPlayer).moveDown = TRUE
Case cInputLeft:
m_arrPlayer(iPlayer).moveLeft = TRUE
Case cInputRight:
m_arrPlayer(iPlayer).moveRight = TRUE
Case cInputButton1:
m_arrPlayer(iPlayer).button1 = TRUE
Case cInputButton2:
m_arrPlayer(iPlayer).button2 = TRUE
Case cInputButton3:
m_arrPlayer(iPlayer).button3 = TRUE
Case cInputButton4:
m_arrPlayer(iPlayer).button4 = TRUE
Case Else:
'(IGNORE)
End Select
Exit For
'end if
End If
End If
End If
Next iWhichInput
If bFoundWho = TRUE Then Exit For
Next iPlayer
' END find who this is mapped for
End If
End If
Next iLoop
' Check each axis
For iLoop = 1 To _LastAxis(iDevice)
If (iLoop > cMaxAxis) Then Exit For
dblNextAxis = _Axis(iLoop)
dblNextAxis = RoundUpDouble#(dblNextAxis, 3)
' I like to give a little "jiggle" resistance to my controls, as I have an old joystick
' which is prone to always give minute values and never really center on true 0.
' A value of 1 means my axis is pushed fully in one direction.
' A value greater than 0.1 means it's been partially pushed in a direction (such as at a 45 degree diagional angle).
' A value of less than 0.1 means we count it as being centered. (As if it was 0.)
' Set sensitivity:
'These are way too sensitive for analog:
'IF ABS(_AXIS(iLoop)) <= 1 AND ABS(_AXIS(iLoop)) >= .1 THEN
'IF ABS(dblNextAxis) <= 1 AND ABS(dblNextAxis) >= .01 THEN
'IF ABS(dblNextAxis) <= 1 AND ABS(dblNextAxis) >= .001 THEN
''For digital input, we'll use a big picture:
'IF ABS(dblNextAxis) <= 1 AND ABS(dblNextAxis) >= 0.75 THEN
If Abs(dblNextAxis) <= 1 And Abs(dblNextAxis) >= 0.5 Then
' WE WANT CONTINUOUS MOVEMENT (DISABLE FOR NOT)
'if TRUE=TRUE then
If dblNextAxis <> arrAxis(iController, iLoop) Then
' *****************************************************************************
' MOVED STICK
' convert to a digital value
If dblNextAxis < 0 Then
iValue = -1
Else
iValue = 1
End If
' BEGIN find who this is mapped for
bFoundWho = FALSE
For iPlayer = LBound(m_arrControlMap, 1) To UBound(m_arrControlMap, 1)
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
If m_arrControlMap(iPlayer, iWhichInput).device = iDevice Then
If m_arrControlMap(iPlayer, iWhichInput).typ = cInputAxis Then
If m_arrControlMap(iPlayer, iWhichInput).code = iLoop Then
If m_arrControlMap(iPlayer, iWhichInput).value = iValue Then
bFoundWho = TRUE
Select Case iWhichInput
Case cInputUp:
m_arrPlayer(iPlayer).moveUp = TRUE
Case cInputDown:
m_arrPlayer(iPlayer).moveDown = TRUE
Case cInputLeft:
m_arrPlayer(iPlayer).moveLeft = TRUE
Case cInputRight:
m_arrPlayer(iPlayer).moveRight = TRUE
Case cInputButton1:
m_arrPlayer(iPlayer).button1 = TRUE
Case cInputButton2:
m_arrPlayer(iPlayer).button2 = TRUE
Case cInputButton3:
m_arrPlayer(iPlayer).button3 = TRUE
Case cInputButton4:
m_arrPlayer(iPlayer).button4 = TRUE
Case Else:
'(IGNORE)
End Select
Exit For
End If
End If
End If
End If
Next iWhichInput
If bFoundWho = TRUE Then Exit For
Next iPlayer
' END find who this is mapped for
End If
End If
Next iLoop
Next iController
End If
' END CHECK FOR CONTROLLER INPUT
' -----------------------------------------------------------------------------
' -----------------------------------------------------------------------------
' BEGIN CHECK FOR KEYBOARD INPUT #1
'_KEYCLEAR: _DELAY 1
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
' Detect changed key state
iDevice = 1 ' keyboard
For iLoop = LBound(m_arrButtonCode) To UBound(m_arrButtonCode)
iCode = m_arrButtonCode(iLoop)
If _Button(iCode) <> FALSE Then
' *****************************************************************************
' PRESSED KEYBOARD
'PRINT "PRESSED " + m_arrButtonKey(iLoop)
' BEGIN find who this is mapped for
bFoundWho = FALSE
For iPlayer = LBound(m_arrControlMap, 1) To UBound(m_arrControlMap, 1)
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
If m_arrControlMap(iPlayer, iWhichInput).device = iDevice Then
If m_arrControlMap(iPlayer, iWhichInput).typ = cInputKey Then
'if m_arrControlMap(iPlayer, iWhichInput).code = iLoop then
If m_arrControlMap(iPlayer, iWhichInput).code = iCode Then
'if m_arrControlMap(iPlayer, iWhichInput).value = iValue then
bFoundWho = TRUE
Select Case iWhichInput
Case cInputUp:
m_arrPlayer(iPlayer).moveUp = TRUE
Case cInputDown:
m_arrPlayer(iPlayer).moveDown = TRUE
Case cInputLeft:
m_arrPlayer(iPlayer).moveLeft = TRUE
Case cInputRight:
m_arrPlayer(iPlayer).moveRight = TRUE
Case cInputButton1:
m_arrPlayer(iPlayer).button1 = TRUE
Case cInputButton2:
m_arrPlayer(iPlayer).button2 = TRUE
Case cInputButton3:
m_arrPlayer(iPlayer).button3 = TRUE
Case cInputButton4:
m_arrPlayer(iPlayer).button4 = TRUE
Case Else:
'(IGNORE)
End Select
Exit For
'end if
End If
End If
End If
Next iWhichInput
If bFoundWho = TRUE Then Exit For
Next iPlayer
' END find who this is mapped for
End If
Next iLoop
' END CHECK FOR KEYBOARD INPUT #1
' -----------------------------------------------------------------------------
' NOW DRAW PLAYERS ON SCREEN
For iPlayer = LBound(m_arrControlMap, 1) To UBound(m_arrControlMap, 1)
' -----------------------------------------------------------------------------
' BEGIN UPDATE MOVEMENT CONTROL STATES
' If repeating keys are disabled then
' disable until the key has been released
If m_arrControlMap(iPlayer, cInputUp).repeat = FALSE Then
If m_arrPlayer(iPlayer).moveUp = TRUE Then
If m_arrPlayer(iPlayer).lastMoveUp = TRUE Then
m_arrPlayer(iPlayer).moveUp = FALSE
End If
Else
m_arrPlayer(iPlayer).lastMoveUp = FALSE
End If
End If
If m_arrControlMap(iPlayer, cInputDown).repeat = FALSE Then
If m_arrPlayer(iPlayer).moveDown = TRUE Then
If m_arrPlayer(iPlayer).lastMoveDown = TRUE Then
m_arrPlayer(iPlayer).moveDown = FALSE
End If
Else
m_arrPlayer(iPlayer).lastMoveDown = FALSE
End If
End If
If m_arrControlMap(iPlayer, cInputLeft).repeat = FALSE Then
If m_arrPlayer(iPlayer).moveLeft = TRUE Then
If m_arrPlayer(iPlayer).lastMoveLeft = TRUE Then
m_arrPlayer(iPlayer).moveLeft = FALSE
End If
Else
m_arrPlayer(iPlayer).lastMoveLeft = FALSE
End If
End If
If m_arrControlMap(iPlayer, cInputRight).repeat = FALSE Then
If m_arrPlayer(iPlayer).moveRight = TRUE Then
If m_arrPlayer(iPlayer).lastMoveRight = TRUE Then
m_arrPlayer(iPlayer).moveRight = FALSE
End If
Else
m_arrPlayer(iPlayer).lastMoveRight = FALSE
End If
End If
' END UPDATE MOVEMENT CONTROL STATES
' -----------------------------------------------------------------------------
' -----------------------------------------------------------------------------
' BEGIN MOVEMENT ACTIONS
m_arrPlayer(iPlayer).moveY = 0
m_arrPlayer(iPlayer).moveX = 0
If m_arrPlayer(iPlayer).moveUp = TRUE Then
m_arrPlayer(iPlayer).moveY = -1
m_arrPlayer(iPlayer).lastMoveUp = TRUE
End If
If m_arrPlayer(iPlayer).moveDown = TRUE Then
m_arrPlayer(iPlayer).moveY = 1
m_arrPlayer(iPlayer).lastMoveDown = TRUE
End If
If m_arrPlayer(iPlayer).moveLeft = TRUE Then
m_arrPlayer(iPlayer).moveX = -1
m_arrPlayer(iPlayer).lastMoveLeft = TRUE
End If
If m_arrPlayer(iPlayer).moveRight = TRUE Then
m_arrPlayer(iPlayer).moveX = 1
m_arrPlayer(iPlayer).lastMoveRight = TRUE
End If
' END MOVEMENT ACTIONS
' -----------------------------------------------------------------------------
' -----------------------------------------------------------------------------
' BEGIN MOVEMENT
' MOVE RIGHT/LEFT
m_arrPlayer(iPlayer).x = m_arrPlayer(iPlayer).x + m_arrPlayer(iPlayer).moveX
If m_arrPlayer(iPlayer).x < iMinX Then
m_arrPlayer(iPlayer).x = m_arrPlayer(iPlayer).xOld ' iMinX
ElseIf m_arrPlayer(iPlayer).x > iMaxX Then
m_arrPlayer(iPlayer).x = m_arrPlayer(iPlayer).xOld ' iMaxX
End If
' MOVE UP/DOWN
m_arrPlayer(iPlayer).y = m_arrPlayer(iPlayer).y + m_arrPlayer(iPlayer).moveY
If m_arrPlayer(iPlayer).y < iMinY Then
m_arrPlayer(iPlayer).y = m_arrPlayer(iPlayer).yOld ' iMinY
ElseIf m_arrPlayer(iPlayer).y > iMaxY Then
m_arrPlayer(iPlayer).y = m_arrPlayer(iPlayer).yOld ' iMaxY
End If
' UPDATE SCREEN
'_PRINTSTRING (m_arrPlayer(iPlayer).xOld, m_arrPlayer(iPlayer).yOld), " "
'_PRINTSTRING (m_arrPlayer(iPlayer).x, m_arrPlayer(iPlayer).y), CHR$(m_arrPlayer(iPlayer).c)
PrintString m_arrPlayer(iPlayer).xOld, m_arrPlayer(iPlayer).yOld, " "
PrintString m_arrPlayer(iPlayer).x, m_arrPlayer(iPlayer).y, Chr$(m_arrPlayer(iPlayer).c)
m_arrPlayer(iPlayer).xOld = m_arrPlayer(iPlayer).x
m_arrPlayer(iPlayer).yOld = m_arrPlayer(iPlayer).y
' END MOVEMENT
' -----------------------------------------------------------------------------
' -----------------------------------------------------------------------------
' BEGIN UPDATE BUTTON STATES
' If repeating keys are disabled then
' disable until the key has been released
'if m_bRepeatButton1 = FALSE then
If m_arrControlMap(iPlayer, cInputButton1).repeat = FALSE Then
If m_arrPlayer(iPlayer).button1 = TRUE Then
If m_arrPlayer(iPlayer).lastButton1 = TRUE Then
m_arrPlayer(iPlayer).button1 = FALSE
End If
Else
m_arrPlayer(iPlayer).lastButton1 = FALSE
End If
End If
If m_arrControlMap(iPlayer, cInputButton2).repeat = FALSE Then
If m_arrPlayer(iPlayer).button2 = TRUE Then
If m_arrPlayer(iPlayer).lastButton2 = TRUE Then
m_arrPlayer(iPlayer).button2 = FALSE
End If
Else
m_arrPlayer(iPlayer).lastButton2 = FALSE
End If
End If
If m_arrControlMap(iPlayer, cInputButton3).repeat = FALSE Then
If m_arrPlayer(iPlayer).button3 = TRUE Then
If m_arrPlayer(iPlayer).lastButton3 = TRUE Then
m_arrPlayer(iPlayer).button3 = FALSE
End If
Else
m_arrPlayer(iPlayer).lastButton3 = FALSE
End If
End If
If m_arrControlMap(iPlayer, cInputButton4).repeat = FALSE Then
If m_arrPlayer(iPlayer).button4 = TRUE Then
If m_arrPlayer(iPlayer).lastButton4 = TRUE Then
m_arrPlayer(iPlayer).button4 = FALSE
End If
Else
m_arrPlayer(iPlayer).lastButton4 = FALSE
End If
End If
' END UPDATE BUTTON STATES
' -----------------------------------------------------------------------------
' -----------------------------------------------------------------------------
' BEGIN BUTTON ACTIONS
If m_arrPlayer(iPlayer).button1 = TRUE Then
MakeSound iPlayer, 1
m_arrPlayer(iPlayer).lastButton1 = TRUE
End If
If m_arrPlayer(iPlayer).button2 = TRUE Then
MakeSound iPlayer, 2
m_arrPlayer(iPlayer).lastButton2 = TRUE
End If
If m_arrPlayer(iPlayer).button3 = TRUE Then
MakeSound iPlayer, 3
m_arrPlayer(iPlayer).lastButton3 = TRUE
End If
If m_arrPlayer(iPlayer).button4 = TRUE Then
MakeSound iPlayer, 4
m_arrPlayer(iPlayer).lastButton4 = TRUE
End If
' END BUTTON ACTIONS
' -----------------------------------------------------------------------------
Next iPlayer
_Limit 30
Loop Until _KeyHit = 27 ' ESCAPE to quit
_KeyClear: _Delay 1
sResult = sError
Else
sResult = "No mapping loaded. Please load a mapping or map keys."
End If
TestMappings$ = sResult
End Function ' TestMappings$
' /////////////////////////////////////////////////////////////////////////////
Sub MakeSound (iPlayer As Integer, iButton As Integer)
Dim note%
If iPlayer < 1 Then
iPlayer = 1
ElseIf iPlayer > 8 Then
iPlayer = 8
End If
If iButton < 1 Then
iButton = 1
ElseIf iButton > 4 Then
iButton = 4
End If
note% = iPlayer * 100 + (iButton * 25)
If note% > 4186 Then
note% = 4186
End If
Sound note%, .75
End Sub ' MakeSound
' /////////////////////////////////////////////////////////////////////////////
' V2 prints in 2 columns.
Sub PrintControllerMap2
Dim RoutineName As String:: RoutineName = "PrintControllerMap2"
Dim iPlayer As Integer
Dim iWhichInput As Integer
Dim iCount As Integer
Dim sLine As String
Dim iHalf As Integer
Dim sColumn1 As String: sColumn1 = ""
Dim sColumn2 As String: sColumn2 = ""
ReDim arrColumn1(-1) As String
ReDim arrColumn2(-1) As String
Dim iLoop As Integer
Dim iColWidth As Integer: iColWidth = 75
Dim sValue As String
Dim in$
' INITIALIZE
InitKeyboardButtonCodes
' START OUTPUT
Print "Controller mapping:"
'Print "Player# Input Device# Type Code Value"
' 1 button #2 x unknown x x
' 9 11 9 9 18 9
' 12345678912345678901123456789123456789123456789012345678123456789
' 12345678901234567890123456789012345678901234567890123456789012345678901234567890
' 00000000011111111112222222222333333333344444444445555555555666666666677777777778
If m_bHaveMapping = TRUE Then
' THIS IS A LAZY WAY TO GET 2 COLUMNS!
iHalf = UBound(m_arrControlMap, 1) / 2
sLine = "Player# Input Device# Type Code Value Repeat"
sColumn1 = sColumn1 + StrPadRight$(sLine, iColWidth) + Chr$(13)
sLine = "-----------------------------------------------------------------------"
sColumn1 = sColumn1 + StrPadRight$(sLine, iColWidth) + Chr$(13)
For iPlayer = LBound(m_arrControlMap, 1) To iHalf
iCount = 0
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
If InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ) <> "unknown" Then
iCount = iCount + 1
End If
Next iWhichInput
If iCount > 0 Then
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
If InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ) <> "unknown" Then
sLine = IntPadRight$(iPlayer, 9)
sLine = sLine + StrPadRight$(InputToString$(iWhichInput), 11)
sLine = sLine + IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).device, 9)
sLine = sLine + StrPadRight$(InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ), 9)
'sLine = sLine + IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).code, 9)
If m_arrControlMap(iPlayer, iWhichInput).typ = cInputKey Then
sValue = GetKeyboardButtonCodeText$(m_arrControlMap(iPlayer, iWhichInput).code)
sValue = StrPadRight$(sValue, 18)
Else
sValue = IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).code, 18)
End If
sLine = sLine + sValue
sLine = sLine + IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).value, 9)
sValue = TrueFalse$(m_arrControlMap(iPlayer, iWhichInput).repeat)
sLine = sLine + StrPadRight$(sValue, 6)
'Print sLine
sLine = StrPadRight$(sLine, iColWidth)
sColumn1 = sColumn1 + sLine + Chr$(13)
End If
Next iWhichInput
Else
sLine = IntPadRight$(iPlayer, 9) + "(NONE)"
'Print sLine
sLine = StrPadRight$(sLine, iColWidth)
sColumn1 = sColumn1 + sLine + Chr$(13)
End If
Next iPlayer
'sLine = "Player# Input Device# Type Code Value"
sLine = "Player# Input Device# Type Code Value Repeat"
sColumn2 = sColumn2 + StrPadRight$(sLine, iColWidth) + Chr$(13)
'sLine = "-------------------------------------------------------------"
sLine = "-----------------------------------------------------------------------"
sColumn2 = sColumn2 + StrPadRight$(sLine, iColWidth) + Chr$(13)
For iPlayer = iHalf + 1 To UBound(m_arrControlMap, 1)
iCount = 0
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
If InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ) <> "unknown" Then
iCount = iCount + 1
End If
Next iWhichInput
If iCount > 0 Then
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
If InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ) <> "unknown" Then
sLine = IntPadRight$(iPlayer, 9)
sLine = sLine + StrPadRight$(InputToString$(iWhichInput), 11)
sLine = sLine + IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).device, 9)
sLine = sLine + StrPadRight$(InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ), 9)
'sLine = sLine + IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).code, 9)
If m_arrControlMap(iPlayer, iWhichInput).typ = cInputKey Then
sValue = GetKeyboardButtonCodeText$(m_arrControlMap(iPlayer, iWhichInput).code)
sValue = StrPadRight$(sValue, 18)
Else
sValue = IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).code, 18)
End If
sLine = sLine + sValue
sLine = sLine + IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).value, 9)
sValue = TrueFalse$(m_arrControlMap(iPlayer, iWhichInput).repeat)
sLine = sLine + StrPadRight$(sValue, 6)
'Print sLine
sLine = StrPadRight$(sLine, iColWidth)
sColumn2 = sColumn2 + sLine + Chr$(13)
End If
Next iWhichInput
Else
sLine = IntPadRight$(iPlayer, 9) + "(NONE)"
'Print sLine
sLine = StrPadRight$(sLine, iColWidth)
sColumn2 = sColumn2 + sLine + Chr$(13)
End If
Next iPlayer
split sColumn1, Chr$(13), arrColumn1()
split sColumn2, Chr$(13), arrColumn2()
If UBound(arrColumn1) > UBound(arrColumn2) Then
iCount = UBound(arrColumn1)
Else
iCount = UBound(arrColumn2)
End If
For iLoop = 0 To iCount
sLine = ""
If UBound(arrColumn1) >= iLoop Then
sLine = sLine + arrColumn1(iLoop)
Else
sLine = sLine + String$(iColWidth, " ")
End If
sLine = sLine + " "
If UBound(arrColumn2) >= iLoop Then
sLine = sLine + arrColumn2(iLoop)
Else
sLine = sLine + String$(iColWidth, " ")
End If
Print sLine
Next iLoop
Else
Print "No mapping loaded. Please load a mapping or map keys."
End If
End Sub ' PrintControllerMap2
' /////////////////////////////////////////////////////////////////////////////
' Original (simple) routine
Sub PrintControllerMap1
Dim RoutineName As String:: RoutineName = "PrintControllerMap1"
Dim iPlayer As Integer
Dim iWhichInput As Integer
Dim sLine As String
Dim iCount As Integer
Dim in$
' INITIALIZE
InitKeyboardButtonCodes
' OUTPUT MAPPING
Print "Controller mapping:"
Print "Player# Input Device# Type Code Value"
' 1 button #2 x unknown x x
' 9 11 9 9 9 9
' 12345678912345678901123456789123456789123456789123456789
' 12345678901234567890123456789012345678901234567890123456789012345678901234567890
For iPlayer = LBound(m_arrControlMap, 1) To UBound(m_arrControlMap, 1)
iCount = 0
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
If InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ) <> "unknown" Then
iCount = iCount + 1
End If
Next iWhichInput
If iCount > 0 Then
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
If InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ) <> "unknown" Then
sLine = IntPadRight$(iPlayer, 9)
sLine = sLine + StrPadRight$(InputToString$(iWhichInput), 11)
sLine = sLine + IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).device, 9)
sLine = sLine + StrPadRight$(InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ), 9)
sLine = sLine + IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).code, 9)
sLine = sLine + IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).value, 9)
Print sLine
End If
Next iWhichInput
Else
sLine = IntPadRight$(iPlayer, 9) + "(NONE)"
Print sLine
End If
Next iPlayer
End Sub ' PrintControllerMap1
' /////////////////////////////////////////////////////////////////////////////
Function LoadMappings$
Dim sResult As String: sResult = ""
' INITIALIZE
InitKeyboardButtonCodes
' Try loading map
sResult = LoadControllerMap$
LoadMappings$ = sResult
End Function ' LoadMappings$
' /////////////////////////////////////////////////////////////////////////////
Function SaveMappings$
Dim sResult As String: sResult = ""
Dim sError As String: sError = ""
' INITIALIZE
InitKeyboardButtonCodes
' Try saving map
sResult = SaveControllerMap$
SaveMappings$ = sResult
End Function ' SaveMappings$
' /////////////////////////////////////////////////////////////////////////////
Function ViewMappings$
' INITIALIZE
InitKeyboardButtonCodes
PrintControllerMap2
Print
Input "PRESS <ENTER> TO CONTINUE", in$
Print
ViewMappings$ = ""
End Function ' ViewMappings$
' /////////////////////////////////////////////////////////////////////////////
' TODO: test this
Function EditMappings$
Dim RoutineName As String: RoutineName = "EditMappings$"
Dim in$
Dim iPlayer As Integer
Dim iWhichInput As Integer
Dim iDevice As Integer
Dim iType As Integer
Dim iCode As Integer
Dim iValue As Integer
Dim iRepeat As Integer
Dim iItem As Integer
Dim sResult As String: sResult = ""
Dim bContinue1 As Integer: bContinue1 = TRUE
Dim bContinue2 As Integer: bContinue2 = TRUE
Dim bContinue3 As Integer: bContinue3 = TRUE
Dim bContinue4 As Integer: bContinue4 = TRUE
' INITIALIZE
InitKeyboardButtonCodes
' EDIT
Do
PrintControllerMap2
Print "To edit a mapping, enter a player number: " _
"1-" + cstr$(cMaxPlayers) + ", " + _
cstr$(cMaxPlayers+1) + ") or q to exit."
Input "Edit mapping for player"; in$
If IsNum%(in$) Then
iPlayer = Val(in$)
If iPlayer > 0 And iPlayer <= cMaxPlayers Then
bContinue2 = TRUE
Do
Print "Editing mappings for player " + cstr$(iPlayer) + "."
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
'Print right$(" " + cstr$(iWhichInput), 2) + ". " + InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ)
Print Right$(" " + cstr$(iWhichInput), 2) + ". " + InputToString$(iWhichInput)
Next iWhichInput
Input "Type # of control to edit or q to quit editing player"; in$
If IsNum%(in$) Then
iWhichInput = Val(in$)
If iWhichInput >= LBound(m_arrControlMap, 2) And m_arrControlMap <= UBound(m_arrControlMap, 2) Then
bContinue3 = TRUE
Do
Print "Settings for " + InputToString$(iWhichInput) + ":"
Print "1. Device # : " + cstr$(m_arrControlMap(iPlayer, iWhichInput).device)
Print "2. Device type : " + InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ)
If m_arrControlMap(iPlayer, iWhichInput).typ = cInputKey Then
Print "3. Input code : " + GetKeyboardButtonCodeText$(m_arrControlMap(iPlayer, iWhichInput).code) + _
" (" + _Trim$(Str$(m_arrControlMap(iPlayer, iWhichInput).code)) + ")"
Else
Print "3. Input code : " + _Trim$(Str$(m_arrControlMap(iPlayer, iWhichInput).code))
End If
Print "4. Input value : " + _Trim$(Str$(m_arrControlMap(iPlayer, iWhichInput).value))
Print "5. Enable repeat: " + TrueFalse$(m_arrControlMap(iPlayer, iWhichInput).repeat)
Input "Change item? (1-5 or q to quit editing control)"; in$
If IsNum%(in$) Then
iItem = Val(in$)
Select Case iItem
Case 1:
Print "Change the device number."
Input "Type a new device #, 0 for none (disabled), or blank to leave it unchanged"; in$
If IsNum%(in$) Then
iDevice = Val(in$)
m_arrControlMap(iPlayer, iWhichInput).device = iDevice
Print "Updated device number. Remember to save mappings when done."
Else
Print "(No change.)"
End If
Case 2:
bContinue4 = TRUE
Do
Print "Change the device type."
Print cstr$(cInputKey) + "=keyboard"
Print cstr$(cInputButton) + "=game controller button"
Print cstr$(cInputAxis) + "=game controller joystick/axis"
Print cstr$(cInputNone) + "=none"
Input "Device type or blank to leave it unchanged"; in$
If IsNum%(in$) Then
iType = Val(in$)
if iType=cInputKey or iType=cInputButton or _
iType=cInputAxis or iType=cInputNone then
m_arrControlMap(iPlayer, iWhichInput).typ = iType
Print "Updated device type. Remember to save mappings when done."
bContinue4 = FALSE: Exit Do
Else
Print "Please choose one of the listed values."
End If
Else
Print "(No change.)"
bContinue4 = FALSE: Exit Do
End If
Loop Until bContinue4 = FALSE
Case 3:
Print "Change the input code."
Input "Type a new input code, or blank to leave it unchanged"; in$
If IsNum%(in$) Then
iCode = Val(in$)
m_arrControlMap(iPlayer, iWhichInput).code = iCode
Print "Updated input code. Remember to save mappings when done."
Else
Print "(No change.)"
End If
Case 4:
Print "Change the input value."
Input "Type a new input value, or blank to leave it unchanged"; in$
If IsNum%(in$) Then
iValue = Val(in$)
m_arrControlMap(iPlayer, iWhichInput).value = iValue
Print "Updated input value. Remember to save mappings when done."
Else
Print "(No change.)"
End If
Case 5:
Print "Change the repeat setting."
Input "Type 1 to enable or 0 to disable, or blank to leave it unchanged"; in$
If IsNum%(in$) Then
iRepeat = Val(in$)
If iRepeat = 0 Then
m_arrControlMap(iPlayer, iWhichInput).repeat = FALSE
Print "Repeat disabled. Remember to save mappings when done."
ElseIf iRepeat = 1 Then
m_arrControlMap(iPlayer, iWhichInput).repeat = TRUE
Print "Repeat enabled. Remember to save mappings when done."
Else
Print "(No change.)"
End If
Else
Print "(No change.)"
End If
Case Else:
Print "Please choose a number between 1 and 4."
End Select
Else
bContinue3 = FALSE: Exit Do
End If
Loop Until bContinue3 = FALSE
Else
Print "Please choose a number between " + cstr$(LBound(m_arrControlMap, 2)) + " and " + cstr$(UBound(m_arrControlMap, 2)) + "."
End If
Else
bContinue2 = FALSE: Exit Do
End If
Loop Until bContinue2 = FALSE
If bContinue1 = FALSE Then Exit Do
Else
Print "Please choose a number between 1 and " + cstr$(cMaxPlayers) + "."
End If
Else
If Len(sResult) = 0 Then sResult = "(Cancelled.)"
bContinue1 = FALSE: Exit Do
End If
Loop Until bContinue1 = FALSE
_KeyClear: _Delay 1
EditMappings$ = sResult
End Function ' EditMappings$
' /////////////////////////////////////////////////////////////////////////////
Function ResetMapping$
Dim RoutineName As String: RoutineName = "ResetMapping$"
Dim in$
Dim iPlayer As Integer
Dim sResult As String: sResult = ""
' INITIALIZE
InitKeyboardButtonCodes
' RESET
Do
PrintControllerMap2
Print "To delete mapping, enter a player number: " _
"1-" + cstr$(cMaxPlayers) + ", " + _
cstr$(cMaxPlayers+1) + " for all, or 0 to exit."
Input "Delete mapping for player? "; iPlayer
If iPlayer > 0 And iPlayer <= cMaxPlayers Then
Print "Delete mappings for player " + cstr$(iPlayer) + "."
Input "Delete (y/n)"; in$: in$ = LCase$(_Trim$(in$))
If in$ = "y" Then
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
If InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ) <> "unknown" Then
m_arrControlMap(iPlayer, iWhichInput).device = 0
m_arrControlMap(iPlayer, iWhichInput).typ = 0
m_arrControlMap(iPlayer, iWhichInput).code = 0
m_arrControlMap(iPlayer, iWhichInput).value = 0
m_arrControlMap(iPlayer, iWhichInput).repeat = 0 ' GetGlobalInputRepeatSetting%(iWhichInput)
End If
Next iWhichInput
sResult = "Mappings deleted for player " + cstr$(iPlayer) + "."
Print sResult
End If
ElseIf iPlayer = (cMaxPlayers + 1) Then
Input "Delete all mappings (y/n)"; in$: in$ = LCase$(_Trim$(in$))
If in$ = "y" Then
For iPlayer = 1 To cMaxPlayers
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
If InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ) <> "unknown" Then
m_arrControlMap(iPlayer, iWhichInput).device = 0
m_arrControlMap(iPlayer, iWhichInput).typ = 0
m_arrControlMap(iPlayer, iWhichInput).code = 0
m_arrControlMap(iPlayer, iWhichInput).value = 0
m_arrControlMap(iPlayer, iWhichInput).repeat = 0 ' GetGlobalInputRepeatSetting%(iWhichInput)
End If
Next iWhichInput
Next iPlayer
sResult = "All mappings deleted."
Print sResult
End If
Else
If Len(sResult) = 0 Then sResult = "(Cancelled.)"
Exit Do
End If
Loop
ResetMapping$ = sResult
End Function ' ResetMapping$
' /////////////////////////////////////////////////////////////////////////////
Function MapInput$
Dim RoutineName As String: RoutineName = "MapInput$"
Dim in$
Dim iDeviceCount As Integer
Dim iPlayer As Integer
Dim sResult As String
Dim sError As String
' INITIALIZE
InitKeyboardButtonCodes
' SET UP SCREEN
Screen _NewImage(1280, 1024, 32): _ScreenMove 0, 0
' MAKE SURE WE HAVE DEVICES
' 1 is the keyboard
' 2 is the mouse
' 3 is the joystick
' unless someone has a strange setup with multiple mice/keyboards/ect...
' In that case, you can use _DEVICE$(i) to look for "KEYBOARD", "MOUSE", "JOYSTICK", if necessary.
' I've never actually found it necessary, but I figure it's worth mentioning, just in case...
iDeviceCount = _Devices ' Find the number of devices on someone's system
If iDeviceCount > 2 Then
'' Try loading map
'sError = LoadControllerMap$
'if len(sError) = 0 then
' print "Previous controller mapping loaded."
'else
' print "*******************************************************************************"
' print "There were errors loading the controller mapping file:"
' print sError
' print
' print "Try remapping - a new file will be created."
' print "*******************************************************************************"
'end if
Do
PrintControllerMap2
Print "To edit mapping, enter a player number (1-" + cstr$(cMaxPlayers) + ") or 0 to exit."
Input "Get input for player? "; iPlayer
If iPlayer > 0 And iPlayer <= cMaxPlayers Then
sResult = MapInput1$(iPlayer)
If Len(sResult) = 0 Then
Print "Remember to save mappings when done."
Else
Print sResult
End If
Else
sResult = "(Cancelled.)"
Exit Do
End If
Loop
Else
sResult = "No controller devices found."
Input "PRESS <ENTER> TO CONTINUE", in$
End If
MapInput$ = sResult
End Function ' MapInput$
' /////////////////////////////////////////////////////////////////////////////
' Detect controls
' THIS VERSION SUPPORTS UPTO 8 JOYSTICKS, WITH UPTO 2 BUTTONS AND 2 AXES EACH
' (THIS IS FOR ATARI 2600 JOYSTICKS)
' The following shared arrays must be declared:
' ReDim Shared m_arrButtonCode(1 To 99) As Long
' ReDim Shared m_arrButtonKey(1 To 99) As String
Function MapInput1$ (iPlayer As Integer)
Dim RoutineName As String:: RoutineName = "MapInput1$"
Dim sResult As String: sResult = ""
Dim sError As String: sError = ""
Dim in$
Dim iDeviceCount As Integer
Dim iDevice As Integer
Dim iNumControllers As Integer
Dim iController As Integer
Dim iLoop As Integer
Dim strValue As String
Dim strAxis As String
Dim dblNextAxis
Dim iCount As Long
Dim iValue As Integer
Dim iCode As Integer
Dim arrButton(32, 16) As Integer ' number of buttons on the joystick
Dim arrButtonNew(32, 16) As Integer ' tracks when to initialize values
Dim arrAxis(32, 16) As Double ' number of axis on the joystick
Dim arrAxisNew(32, 16) As Integer ' tracks when to initialize values
'Dim arrInput(1 To 8) As ControlInputType
Dim iWhichInput As Integer
Dim bFinished As Integer
Dim bHaveInput As Integer
Dim bMoveNext As Integer
Dim bCancel As Integer
Dim iNextInput As Integer
' FOR PRINTING OUTPUT
Dim iDigits As Integer ' # digits to display (values are truncated to this length)
Dim iColCount As Integer
Dim iGroupCount As Integer
Dim sLine As String
Dim iCols As Integer
Dim iRows As Integer
Dim iMaxCols As Integer
' INITIALIZE
If Len(sError) = 0 Then
iDigits = 4 ' 11
iColCount = 3
iGroupCount = 0 ' re-initialized at the top of every loop
iCols = _Width(0) \ _FontWidth
iRows = _Height(0) \ _FontHeight
End If
' COUNT # OF JOYSTICKS
' TODO: find out the right way to count joysticks
If Len(sError) = 0 Then
' D= _DEVICES ' MUST be read in order for other 2 device functions to work!
iDeviceCount = _Devices ' Find the number of devices on someone's system
If iDeviceCount > 2 Then
' LIMIT # OF DEVICES, IF THERE IS A LIMIT DEFINED
iNumControllers = iDeviceCount - 2
If cMaxControllers > 0 Then
If iNumControllers > cMaxControllers Then
iNumControllers = cMaxControllers
End If
End If
Else
' ONLY 2 FOUND (KEYBOARD, MOUSE)
sError = "No game controllers found."
End If
End If
' INITIALIZE CONTROLLER DATA
If Len(sError) = 0 Then
For iController = 1 To iNumControllers
m_arrController(iController).buttonCount = cMaxButtons
m_arrController(iController).axisCount = cMaxAxis
For iLoop = 1 To cMaxButtons
arrButtonNew(iController, iLoop) = TRUE
Next iLoop
For iLoop = 1 To cMaxAxis
arrAxisNew(iController, iLoop) = TRUE
Next iLoop
Next iController
End If
' INITIALIZE CONTROLLER INPUT
If Len(sError) = 0 Then
Cls
Print "We will now detect controllers."
Print "Do not touch any keys or game controllers during detection."
Input "Press <ENTER> to begin"; in$
_KeyClear: Print
sLine = "Initializing controllers": Print sLine;
iMaxCols = (iCols - Len(sLine)) - 1
iCount = 0
Do
iCount = iCount + 1
If iCount < iMaxCols Then
Print ".";
Else
Print ".": Print sLine: iCount = 0
End If
For iController = 1 To iNumControllers
iDevice = iController + 2
While _DeviceInput(iDevice) ' clear and update the device buffer
For iLoop = 1 To _LastButton(iDevice)
If (iLoop > cMaxButtons) Then Exit For
m_arrController(iController).buttonCount = iLoop
'IF _BUTTONCHANGE(iLoop) THEN
' arrButton(iController, iLoop) = _BUTTON(iLoop)
'END IF
arrButton(iController, iLoop) = FALSE
Next iLoop
For iLoop = 1 To _LastAxis(iDevice) ' this loop checks all my axis
If (iLoop > cMaxAxis) Then Exit For
m_arrController(iController).axisCount = iLoop
arrAxis(iController, iLoop) = 0
Next iLoop
Wend ' clear and update the device buffer
Next iController
_Limit 30
Loop Until iCount > 60 ' quit after 2 seconds
Print: Print
End If
' WAIT FOR INPUT
If Len(sError) = 0 Then
Cls
Print "Press <ESCAPE> to cancel at any time."
Print
_KeyClear: _Delay 1
bCancel = FALSE
bFinished = FALSE
iLastPressed = 0
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
'print "iWhichInput=" + cstr$(iWhichInput)
Print "Player #" + cstr$(iPlayer) + " press control for " + InputToString$(iWhichInput) + " or ESC to skip: ";
' =============================================================================
' BEGIN LOOK FOR NEXT INPUT
bMoveNext = FALSE
Do
' -----------------------------------------------------------------------------
' BEGIN CHECK FOR CONTROLLER INPUT
For iController = 1 To iNumControllers
iDevice = iController + 2
' Check all devices
While _DeviceInput(iDevice)
' Check each button
If bMoveNext = FALSE Then
For iLoop = 1 To _LastButton(iDevice)
If (iLoop > cMaxButtons) Then Exit For
'm_arrController(iController).buttonCount = iLoop
' update button array to indicate if a button is up or down currently.
If _ButtonChange(iLoop) Then
iValue = _Button(iLoop)
If iValue <> arrButton(iController, iLoop) Then
' *****************************************************************************
' PRESSED BUTTON
' make sure this isn't already mapped
bHaveInput = TRUE
If iWhichInput > LBound(m_arrControlMap, 2) Then
' is input unique?
For iNextInput = LBound(m_arrControlMap, 2) To iWhichInput - 1
If m_arrControlMap(iPlayer, iNextInput).device = iDevice Then
If m_arrControlMap(iPlayer, iNextInput).typ = cInputButton Then
If m_arrControlMap(iPlayer, iNextInput).code = iLoop Then
If m_arrControlMap(iPlayer, iNextInput).value = iValue Then
bHaveInput = FALSE
End If
End If
End If
End If
Next iNextInput
End If
If bHaveInput Then
m_arrControlMap(iPlayer, iWhichInput).device = iDevice
m_arrControlMap(iPlayer, iWhichInput).typ = cInputButton
m_arrControlMap(iPlayer, iWhichInput).code = iLoop
m_arrControlMap(iPlayer, iWhichInput).value = iValue
bMoveNext = TRUE
End If
End If
End If
Next iLoop
End If
' Check each axis
If bMoveNext = FALSE Then
For iLoop = 1 To _LastAxis(iDevice)
If (iLoop > cMaxAxis) Then Exit For
'm_arrController(iController).axisCount = iLoop
dblNextAxis = _Axis(iLoop)
dblNextAxis = RoundUpDouble#(dblNextAxis, 3)
' I like to give a little "jiggle" resistance to my controls, as I have an old joystick
' which is prone to always give minute values and never really center on true 0.
' A value of 1 means my axis is pushed fully in one direction.
' A value greater than 0.1 means it's been partially pushed in a direction (such as at a 45 degree diagional angle).
' A value of less than 0.1 means we count it as being centered. (As if it was 0.)
'These are way too sensitive for analog:
'IF ABS(_AXIS(iLoop)) <= 1 AND ABS(_AXIS(iLoop)) >= .1 THEN
'IF ABS(dblNextAxis) <= 1 AND ABS(dblNextAxis) >= .01 THEN
'IF ABS(dblNextAxis) <= 1 AND ABS(dblNextAxis) >= .001 THEN
'For digital input, we'll use a big picture:
If Abs(dblNextAxis) <= 1 And Abs(dblNextAxis) >= 0.75 Then
If dblNextAxis <> arrAxis(iController, iLoop) Then
' *****************************************************************************
' MOVED STICK
' convert to a digital value
If dblNextAxis < 0 Then
iValue = -1
Else
iValue = 1
End If
' make sure this isn't already mapped
bHaveInput = TRUE
If iWhichInput > LBound(m_arrControlMap, 2) Then
' is input unique?
For iNextInput = LBound(m_arrControlMap, 2) To iWhichInput - 1
If m_arrControlMap(iPlayer, iNextInput).device = iDevice Then
If m_arrControlMap(iPlayer, iNextInput).typ = cInputAxis Then
If m_arrControlMap(iPlayer, iNextInput).code = iLoop Then
If m_arrControlMap(iPlayer, iNextInput).value = iValue Then
bHaveInput = FALSE
End If
End If
End If
End If
Next iNextInput
End If
If bHaveInput Then
m_arrControlMap(iPlayer, iWhichInput).device = iDevice
m_arrControlMap(iPlayer, iWhichInput).typ = cInputAxis
m_arrControlMap(iPlayer, iWhichInput).code = iLoop
m_arrControlMap(iPlayer, iWhichInput).value = iValue
bMoveNext = TRUE
End If
End If
End If
Next iLoop
End If
Wend ' clear and update the device buffer
Next iController
' END CHECK FOR CONTROLLER INPUT
' -----------------------------------------------------------------------------
' -----------------------------------------------------------------------------
' BEGIN CHECK FOR KEYBOARD INPUT #1
If bMoveNext = FALSE Then
'_KEYCLEAR: _DELAY 1
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
' Detect changed key state
For iLoop = LBound(m_arrButtonCode) To UBound(m_arrButtonCode)
iCode = m_arrButtonCode(iLoop)
If _Button(iCode) <> FALSE Then
' *****************************************************************************
' PRESSED KEYBOARD
'PRINT "PRESSED " + m_arrButtonKey(iLoop)
' make sure this isn't already mapped
bHaveInput = TRUE
If iWhichInput > LBound(m_arrControlMap, 2) Then
' is input unique?
For iNextInput = LBound(m_arrControlMap, 2) To iWhichInput - 1
If m_arrControlMap(iPlayer, iNextInput).device = 1 Then ' .device 1 = keyboard
If m_arrControlMap(iPlayer, iNextInput).typ = cInputKey Then
If m_arrControlMap(iPlayer, iNextInput).code = iCode Then
'if m_arrControlMap(iPlayer, iNextInput).value = TRUE then
bHaveInput = FALSE
'end if
End If
End If
End If
Next iNextInput
End If
If bHaveInput Then
m_arrControlMap(iPlayer, iWhichInput).device = 1 ' .device 1 = keyboard
m_arrControlMap(iPlayer, iWhichInput).typ = cInputKey
m_arrControlMap(iPlayer, iWhichInput).code = iCode
m_arrControlMap(iPlayer, iWhichInput).value = TRUE
bMoveNext = TRUE
End If
End If
Next iLoop
End If
' END CHECK FOR KEYBOARD INPUT #1
' -----------------------------------------------------------------------------
If bMoveNext = TRUE Then Exit Do
_Limit 30
Loop Until _KeyHit = 27 ' ESCAPE to quit
' END LOOK FOR NEXT INPUT
' =============================================================================
If bMoveNext = TRUE Then
Print "Device #" + cstr$(m_arrControlMap(iPlayer, iWhichInput).device) + " " + _
InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ) + " " + _
cstr$(m_arrControlMap(iPlayer, iWhichInput).code) + " = " + _
cstr$(m_arrControlMap(iPlayer, iWhichInput).value)
' Only ask user to select repeat if no override.
If m_bRepeatOverride = FALSE Then
Input "Enable repeat (y/n)"; in$: in$ = LCase$(_Trim$(in$))
If in$ = "y" Then
m_arrControlMap(iPlayer, iWhichInput).repeat = TRUE
Else
m_arrControlMap(iPlayer, iWhichInput).repeat = FALSE
End If
Else
m_arrControlMap(iPlayer, iWhichInput).repeat = GetGlobalInputRepeatSetting%(iWhichInput)
End If
Else
Print "(Skipped)"
bCancel = TRUE
bFinished = TRUE
End If
If bFinished = TRUE Then Exit For
Next iWhichInput
End If
If Len(sError) = 0 Then
m_bHaveMapping = TRUE
Else
sResult = "ERRORS: " + sError
End If
_KeyClear: _Delay 1
MapInput1$ = sResult
End Function ' MapInput1$
' /////////////////////////////////////////////////////////////////////////////
' Receives which input contstant and returns a text description
Function InputToString$ (iWhich As Integer)
Select Case iWhich
Case cInputUp:
InputToString$ = "up"
Case cInputDown:
InputToString$ = "down"
Case cInputLeft:
InputToString$ = "left"
Case cInputRight:
InputToString$ = "right"
Case cInputButton1:
InputToString$ = "button #1"
Case cInputButton2:
InputToString$ = "button #2"
Case cInputButton3:
InputToString$ = "button #3"
Case cInputButton4:
InputToString$ = "button #4"
Case Else:
InputToString$ = "unknown"
End Select
End Function ' InputToString$
' /////////////////////////////////////////////////////////////////////////////
' Receives which input contstant and returns its global "repeat" setting
' usage:
' m_arrControlMap(iPlayer, iWhichInput).repeat = GetGlobalInputRepeatSetting%(cInputUp)
Function GetGlobalInputRepeatSetting% (iWhich As Integer)
Select Case iWhich
Case cInputUp:
GetGlobalInputRepeatSetting% = m_bRepeatUp
Case cInputDown:
GetGlobalInputRepeatSetting% = m_bRepeatDown
Case cInputLeft:
GetGlobalInputRepeatSetting% = m_bRepeatLeft
Case cInputRight:
GetGlobalInputRepeatSetting% = m_bRepeatRight
Case cInputButton1:
GetGlobalInputRepeatSetting% = m_bRepeatButton1
Case cInputButton2:
GetGlobalInputRepeatSetting% = m_bRepeatButton2
Case cInputButton3:
GetGlobalInputRepeatSetting% = m_bRepeatButton3
Case cInputButton4:
GetGlobalInputRepeatSetting% = m_bRepeatButton4
Case Else:
GetGlobalInputRepeatSetting% = FALSE
End Select
End Function ' GetGlobalInputRepeatSetting%
' /////////////////////////////////////////////////////////////////////////////
Function InputTypeToString$ (iCode As Integer)
Select Case iCode
Case cInputNone:
InputTypeToString$ = "none"
Case cInputKey:
InputTypeToString$ = "key"
Case cInputButton:
InputTypeToString$ = "button"
Case cInputAxis:
InputTypeToString$ = "axis"
Case Else:
InputTypeToString$ = "unknown"
End Select
End Function ' InputTypeToString$
' /////////////////////////////////////////////////////////////////////////////
' METHOD v2 = faster
Function GetKeyboardButtonCodeText$ (iCode As Integer)
Dim sResult As String: sResult = ""
If LBound(m_arrButtonKeyDesc) <= iCode Then
If UBound(m_arrButtonKeyDesc) >= iCode Then
sResult = m_arrButtonKeyDesc(iCode)
End If
End If
If Len(sResult) = 0 Then
sResult = _Trim$(Str$(iCode)) + " (?)"
End If
GetKeyboardButtonCodeText$ = sResult
End Function ' GetKeyboardButtonCodeText$
' /////////////////////////////////////////////////////////////////////////////
' METHOD v2
' Faster lookup - a dictionary with a hash lookup would be best
' but this is a quick way to do it since the values never change.
' The following shared arrays must be declared:
' ReDim Shared m_arrButtonCode(1 To 99) As Long
' ReDim Shared m_arrButtonKey(1 To 99) As String
' ReDim Shared m_arrButtonKeyDesc(0 To 512) As String
Sub InitKeyboardButtonCodes ()
Dim iLoop As Integer
If m_bInitialized = FALSE Then
' CODE(S) DETECTED WITH _BUTTON:
m_arrButtonCode(1) = 2: m_arrButtonKey(1) = "Esc"
m_arrButtonCode(2) = 60: m_arrButtonKey(2) = "F1"
m_arrButtonCode(3) = 61: m_arrButtonKey(3) = "F2"
m_arrButtonCode(4) = 62: m_arrButtonKey(4) = "F3"
m_arrButtonCode(5) = 63: m_arrButtonKey(5) = "F4"
m_arrButtonCode(6) = 64: m_arrButtonKey(6) = "F5"
m_arrButtonCode(7) = 65: m_arrButtonKey(7) = "F6"
m_arrButtonCode(8) = 66: m_arrButtonKey(8) = "F7"
m_arrButtonCode(9) = 67: m_arrButtonKey(9) = "F8"
m_arrButtonCode(10) = 68: m_arrButtonKey(10) = "F9"
m_arrButtonCode(11) = 88: m_arrButtonKey(11) = "F11"
m_arrButtonCode(12) = 89: m_arrButtonKey(12) = "F12"
m_arrButtonCode(13) = 42: m_arrButtonKey(13) = "Tilde"
m_arrButtonCode(14) = 3: m_arrButtonKey(14) = "1"
m_arrButtonCode(15) = 4: m_arrButtonKey(15) = "2"
m_arrButtonCode(16) = 5: m_arrButtonKey(16) = "3"
m_arrButtonCode(17) = 6: m_arrButtonKey(17) = "4"
m_arrButtonCode(18) = 7: m_arrButtonKey(18) = "5"
m_arrButtonCode(19) = 8: m_arrButtonKey(19) = "6"
m_arrButtonCode(20) = 9: m_arrButtonKey(20) = "7"
m_arrButtonCode(21) = 10: m_arrButtonKey(21) = "8"
m_arrButtonCode(22) = 11: m_arrButtonKey(22) = "9"
m_arrButtonCode(23) = 12: m_arrButtonKey(23) = "0"
m_arrButtonCode(24) = 13: m_arrButtonKey(24) = "Minus"
m_arrButtonCode(25) = 14: m_arrButtonKey(25) = "Equal"
m_arrButtonCode(26) = 15: m_arrButtonKey(26) = "BkSp"
m_arrButtonCode(27) = 16: m_arrButtonKey(27) = "Tab"
m_arrButtonCode(28) = 17: m_arrButtonKey(28) = "Q"
m_arrButtonCode(29) = 18: m_arrButtonKey(29) = "W"
m_arrButtonCode(30) = 19: m_arrButtonKey(30) = "E"
m_arrButtonCode(31) = 20: m_arrButtonKey(31) = "R"
m_arrButtonCode(32) = 21: m_arrButtonKey(32) = "T"
m_arrButtonCode(33) = 22: m_arrButtonKey(33) = "Y"
m_arrButtonCode(34) = 23: m_arrButtonKey(34) = "U"
m_arrButtonCode(35) = 24: m_arrButtonKey(35) = "I"
m_arrButtonCode(36) = 25: m_arrButtonKey(36) = "O"
m_arrButtonCode(37) = 26: m_arrButtonKey(37) = "P"
m_arrButtonCode(38) = 27: m_arrButtonKey(38) = "BracketLeft"
m_arrButtonCode(39) = 28: m_arrButtonKey(39) = "BracketRight"
m_arrButtonCode(40) = 44: m_arrButtonKey(40) = "Backslash"
m_arrButtonCode(41) = 59: m_arrButtonKey(41) = "CapsLock"
m_arrButtonCode(42) = 31: m_arrButtonKey(42) = "A"
m_arrButtonCode(43) = 32: m_arrButtonKey(43) = "S"
m_arrButtonCode(44) = 33: m_arrButtonKey(44) = "D"
m_arrButtonCode(45) = 34: m_arrButtonKey(45) = "F"
m_arrButtonCode(46) = 35: m_arrButtonKey(46) = "G"
m_arrButtonCode(47) = 36: m_arrButtonKey(47) = "H"
m_arrButtonCode(48) = 37: m_arrButtonKey(48) = "J"
m_arrButtonCode(49) = 38: m_arrButtonKey(49) = "K"
m_arrButtonCode(50) = 39: m_arrButtonKey(50) = "L"
m_arrButtonCode(51) = 40: m_arrButtonKey(51) = "Semicolon"
m_arrButtonCode(52) = 41: m_arrButtonKey(52) = "Apostrophe"
m_arrButtonCode(53) = 29: m_arrButtonKey(53) = "Enter"
m_arrButtonCode(54) = 43: m_arrButtonKey(54) = "ShiftLeft"
m_arrButtonCode(55) = 45: m_arrButtonKey(55) = "Z"
m_arrButtonCode(56) = 46: m_arrButtonKey(56) = "X"
m_arrButtonCode(57) = 47: m_arrButtonKey(57) = "C"
m_arrButtonCode(58) = 48: m_arrButtonKey(58) = "V"
m_arrButtonCode(59) = 49: m_arrButtonKey(59) = "B"
m_arrButtonCode(60) = 50: m_arrButtonKey(60) = "N"
m_arrButtonCode(61) = 51: m_arrButtonKey(61) = "M"
m_arrButtonCode(62) = 52: m_arrButtonKey(62) = "Comma"
m_arrButtonCode(63) = 53: m_arrButtonKey(63) = "Period"
m_arrButtonCode(64) = 54: m_arrButtonKey(64) = "Slash"
m_arrButtonCode(65) = 55: m_arrButtonKey(65) = "ShiftRight"
m_arrButtonCode(66) = 30: m_arrButtonKey(66) = "CtrlLeft"
m_arrButtonCode(67) = 348: m_arrButtonKey(67) = "WinLeft"
m_arrButtonCode(68) = 58: m_arrButtonKey(68) = "Spacebar"
m_arrButtonCode(69) = 349: m_arrButtonKey(69) = "WinRight"
m_arrButtonCode(70) = 350: m_arrButtonKey(70) = "Menu"
m_arrButtonCode(71) = 286: m_arrButtonKey(71) = "CtrlRight"
m_arrButtonCode(72) = 339: m_arrButtonKey(72) = "Ins"
m_arrButtonCode(73) = 328: m_arrButtonKey(73) = "Home"
m_arrButtonCode(74) = 330: m_arrButtonKey(74) = "PgUp"
m_arrButtonCode(75) = 340: m_arrButtonKey(75) = "Del"
m_arrButtonCode(76) = 336: m_arrButtonKey(76) = "End"
m_arrButtonCode(77) = 338: m_arrButtonKey(77) = "PgDn"
m_arrButtonCode(78) = 329: m_arrButtonKey(78) = "Up"
m_arrButtonCode(79) = 332: m_arrButtonKey(79) = "Left"
m_arrButtonCode(80) = 337: m_arrButtonKey(80) = "Down"
m_arrButtonCode(81) = 334: m_arrButtonKey(81) = "Right"
m_arrButtonCode(82) = 71: m_arrButtonKey(82) = "ScrollLock"
m_arrButtonCode(83) = 326: m_arrButtonKey(83) = "NumLock"
m_arrButtonCode(84) = 310: m_arrButtonKey(84) = "KeypadSlash"
m_arrButtonCode(85) = 56: m_arrButtonKey(85) = "KeypadMultiply"
m_arrButtonCode(86) = 75: m_arrButtonKey(86) = "KeypadMinus"
m_arrButtonCode(87) = 72: m_arrButtonKey(87) = "Keypad7Home"
m_arrButtonCode(88) = 73: m_arrButtonKey(88) = "Keypad8Up"
m_arrButtonCode(89) = 74: m_arrButtonKey(89) = "Keypad9PgUp"
m_arrButtonCode(90) = 79: m_arrButtonKey(90) = "KeypadPlus"
m_arrButtonCode(91) = 76: m_arrButtonKey(91) = "Keypad4Left"
m_arrButtonCode(92) = 77: m_arrButtonKey(92) = "Keypad5"
m_arrButtonCode(93) = 78: m_arrButtonKey(93) = "Keypad6Right"
m_arrButtonCode(94) = 80: m_arrButtonKey(94) = "Keypad1End"
m_arrButtonCode(95) = 81: m_arrButtonKey(95) = "Keypad2Down"
m_arrButtonCode(96) = 82: m_arrButtonKey(96) = "Keypad3PgDn"
m_arrButtonCode(97) = 285: m_arrButtonKey(97) = "KeypadEnter"
m_arrButtonCode(98) = 83: m_arrButtonKey(98) = "Keypad0Ins"
m_arrButtonCode(99) = 84: m_arrButtonKey(99) = "KeypadPeriodDel"
' not sure if this works:
'' CODE(S) DETECTED WITH _KEYDOWN:
'm_arrButtonCode(100) = -1 : m_arrButtonCode(100) = "F10"
' not sure if this works:
'' CODE(S) DETECTED WITH _KEYHIT:
'm_arrButtonCode(101) = -2 : m_arrButtonCode(101) = "AltLeft"
'm_arrButtonCode(102) = -3 : m_arrButtonCode(102) = "AltRight"
' DESCRIPTIONS BY KEYCODE
For iLoop = LBound(m_arrButtonKeyDesc) To UBound(m_arrButtonKeyDesc)
m_arrButtonKeyDesc(iLoop) = ""
Next iLoop
m_arrButtonKeyDesc(2) = "Esc"
m_arrButtonKeyDesc(60) = "F1"
m_arrButtonKeyDesc(61) = "F2"
m_arrButtonKeyDesc(62) = "F3"
m_arrButtonKeyDesc(63) = "F4"
m_arrButtonKeyDesc(64) = "F5"
m_arrButtonKeyDesc(65) = "F6"
m_arrButtonKeyDesc(66) = "F7"
m_arrButtonKeyDesc(67) = "F8"
m_arrButtonKeyDesc(68) = "F9"
m_arrButtonKeyDesc(88) = "F11"
m_arrButtonKeyDesc(89) = "F12"
m_arrButtonKeyDesc(42) = "Tilde"
m_arrButtonKeyDesc(3) = "1"
m_arrButtonKeyDesc(4) = "2"
m_arrButtonKeyDesc(5) = "3"
m_arrButtonKeyDesc(6) = "4"
m_arrButtonKeyDesc(7) = "5"
m_arrButtonKeyDesc(8) = "6"
m_arrButtonKeyDesc(9) = "7"
m_arrButtonKeyDesc(10) = "8"
m_arrButtonKeyDesc(11) = "9"
m_arrButtonKeyDesc(12) = "0"
m_arrButtonKeyDesc(13) = "Minus"
m_arrButtonKeyDesc(14) = "Equal"
m_arrButtonKeyDesc(15) = "BkSp"
m_arrButtonKeyDesc(16) = "Tab"
m_arrButtonKeyDesc(17) = "Q"
m_arrButtonKeyDesc(18) = "W"
m_arrButtonKeyDesc(19) = "E"
m_arrButtonKeyDesc(20) = "R"
m_arrButtonKeyDesc(21) = "T"
m_arrButtonKeyDesc(22) = "Y"
m_arrButtonKeyDesc(23) = "U"
m_arrButtonKeyDesc(24) = "I"
m_arrButtonKeyDesc(25) = "O"
m_arrButtonKeyDesc(26) = "P"
m_arrButtonKeyDesc(27) = "BracketLeft"
m_arrButtonKeyDesc(28) = "BracketRight"
m_arrButtonKeyDesc(44) = "Backslash"
m_arrButtonKeyDesc(59) = "CapsLock"
m_arrButtonKeyDesc(31) = "A"
m_arrButtonKeyDesc(32) = "S"
m_arrButtonKeyDesc(33) = "D"
m_arrButtonKeyDesc(34) = "F"
m_arrButtonKeyDesc(35) = "G"
m_arrButtonKeyDesc(36) = "H"
m_arrButtonKeyDesc(37) = "J"
m_arrButtonKeyDesc(38) = "K"
m_arrButtonKeyDesc(39) = "L"
m_arrButtonKeyDesc(40) = "Semicolon"
m_arrButtonKeyDesc(41) = "Apostrophe"
m_arrButtonKeyDesc(29) = "Enter"
m_arrButtonKeyDesc(43) = "ShiftLeft"
m_arrButtonKeyDesc(45) = "Z"
m_arrButtonKeyDesc(46) = "X"
m_arrButtonKeyDesc(47) = "C"
m_arrButtonKeyDesc(48) = "V"
m_arrButtonKeyDesc(49) = "B"
m_arrButtonKeyDesc(50) = "N"
m_arrButtonKeyDesc(51) = "M"
m_arrButtonKeyDesc(52) = "Comma"
m_arrButtonKeyDesc(53) = "Period"
m_arrButtonKeyDesc(54) = "Slash"
m_arrButtonKeyDesc(55) = "ShiftRight"
m_arrButtonKeyDesc(30) = "CtrlLeft"
m_arrButtonKeyDesc(348) = "WinLeft"
m_arrButtonKeyDesc(58) = "Spacebar"
m_arrButtonKeyDesc(349) = "WinRight"
m_arrButtonKeyDesc(350) = "Menu"
m_arrButtonKeyDesc(286) = "CtrlRight"
m_arrButtonKeyDesc(339) = "Ins"
m_arrButtonKeyDesc(328) = "Home"
m_arrButtonKeyDesc(330) = "PgUp"
m_arrButtonKeyDesc(340) = "Del"
m_arrButtonKeyDesc(336) = "End"
m_arrButtonKeyDesc(338) = "PgDn"
m_arrButtonKeyDesc(329) = "Up"
m_arrButtonKeyDesc(332) = "Left"
m_arrButtonKeyDesc(337) = "Down"
m_arrButtonKeyDesc(334) = "Right"
m_arrButtonKeyDesc(71) = "ScrollLock"
m_arrButtonKeyDesc(326) = "NumLock"
m_arrButtonKeyDesc(310) = "KeypadSlash"
m_arrButtonKeyDesc(56) = "KeypadMultiply"
m_arrButtonKeyDesc(75) = "KeypadMinus"
m_arrButtonKeyDesc(72) = "Keypad7Home"
m_arrButtonKeyDesc(73) = "Keypad8Up"
m_arrButtonKeyDesc(74) = "Keypad9PgUp"
m_arrButtonKeyDesc(79) = "KeypadPlus"
m_arrButtonKeyDesc(76) = "Keypad4Left"
m_arrButtonKeyDesc(77) = "Keypad5"
m_arrButtonKeyDesc(78) = "Keypad6Right"
m_arrButtonKeyDesc(80) = "Keypad1End"
m_arrButtonKeyDesc(81) = "Keypad2Down"
m_arrButtonKeyDesc(82) = "Keypad3PgDn"
m_arrButtonKeyDesc(285) = "KeypadEnter"
m_arrButtonKeyDesc(83) = "Keypad0Ins"
m_arrButtonKeyDesc(84) = "KeypadPeriodDel"
m_bInitialized = TRUE
End If
End Sub ' InitKeyboardButtonCodes
' /////////////////////////////////////////////////////////////////////////////
' not sure if this works
' Returns TRUE if the F10 key is held down.
' We use _KEYDOWN for this because _BUTTON doesn't detect F10.
' Constant must be declared globally:
' Const c_iKeyDown_F10 = 17408
Function KeydownF10%
Dim iCode As Long
'_KEYCLEAR: _DELAY 1
If _KeyDown(c_iKeyDown_F10) = TRUE Then
KeydownF10% = TRUE
Else
KeydownF10% = FALSE
End If
'_KEYCLEAR
End Function ' KeydownF10%
' /////////////////////////////////////////////////////////////////////////////
' not sure if this works
' Returns TRUE if the left ALT key is held down.
' We use _KEYHIT for this because _BUTTON doesn't detect ALT.
' Constant must be declared globally:
' Const c_iKeyHit_AltLeft = -30764
Function KeyhitAltLeft%
'_KEYCLEAR: _DELAY 1
If _KeyHit = c_iKeyHit_AltLeft Then
KeyhitAltLeft% = TRUE
Else
KeyhitAltLeft% = FALSE
End If
'_KEYCLEAR
End Function ' KeyhitAltLeft%
' /////////////////////////////////////////////////////////////////////////////
' not sure if this works
' Returns TRUE if the right ALT key is held down.
' We use _KEYHIT for this because _BUTTON doesn't detect ALT.
' Constant must be declared globally:
' Const c_iKeyHit_AltRight = -30765
Function KeyhitAltRight%
'_KEYCLEAR: _DELAY 1
If _KeyHit = c_iKeyHit_AltRight Then
KeyhitAltRight% = TRUE
Else
KeyhitAltRight% = FALSE
End If
'_KEYCLEAR
End Function ' KeyhitAltRight%
' /////////////////////////////////////////////////////////////////////////////
' DEVICES Button
' _LASTBUTTON(1) keyboards will normally return 512 buttons. One button is read per loop through all numbers.
' _BUTTONCHANGE(number) returns -1 when pressed, 1 when released and 0 when there is no event since the last read.
' _BUTTON(number) returns -1 when a button is pressed and 0 when released
' Detects most keys (where the codes are documented?)
' However, does not seem to detect:
' Key Use
' --- ---
' F10 Function KeydownF10%
' Left Alt Function KeyhitAltLeft%
' Right Alt Function KeyhitAltRight%
' Print Screen (system API call?)
' Pause/Break (system API call?)
Function KeyPressed% (iCode As Integer)
'_KEYCLEAR: _DELAY 1
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
If _Button(iCode) <> FALSE Then
KeyPressed% = TRUE
Else
KeyPressed% = FALSE
End If
'_KEYCLEAR
End Function ' KeyPressed%
' /////////////////////////////////////////////////////////////////////////////
Function TestJoysticks$
Dim RoutineName As String: RoutineName = "TestJoysticks$"
Dim iDeviceCount As Integer
Dim sResult As String
' 1 is the keyboard
' 2 is the mouse
' 3 is the joystick
' unless someone has a strange setup with multiple mice/keyboards/ect...
' In that case, you can use _DEVICE$(i) to look for "KEYBOARD", "MOUSE", "JOYSTICK", if necessary.
' I've never actually found it necessary, but I figure it's worth mentioning, just in case...
iDeviceCount = _Devices ' Find the number of devices on someone's system
If iDeviceCount > 2 Then
TestJoysticks1
sResult = ""
Else
sResult = "No joysticks found."
End If
_KeyClear
TestJoysticks$ = sResult
End Function ' TestJoysticks$
' /////////////////////////////////////////////////////////////////////////////
' Reads controllers and displays values on screen.
' Currently this is set up to support up to 8 joysticks,
' with upto 4 buttons and 2 axes each
' Testing with an old USB Logitech RumblePad 2
' and Atari 2600 joysticks plugged into using
' iCode Atari Joystick, Paddle, Driving to USB Adapter 4 ports
Sub TestJoysticks1 ()
Dim RoutineName As String:: RoutineName = "TestJoysticks1"
Dim in$
Dim iDeviceCount As Integer
Dim iDevice As Integer
Dim arrButton(32, 16) As Integer ' number of buttons on the joystick
Dim arrButtonMin(32, 16) As Integer ' stores the minimum value read
Dim arrButtonMax(32, 16) As Integer ' stores the maximum value read
Dim arrAxis(32, 16) As Double ' number of axis on the joystick
Dim arrAxisMin(32, 16) As Double ' stores the minimum value read
Dim arrAxisMax(32, 16) As Double ' stores the maximum value read
Dim arrAxisAvg(32, 16) As Double ' stores the average value read in the last few measurements
Dim arrButtonNew(32, 16) As Integer ' tracks when to initialize values
Dim arrAxisNew(32, 16) As Integer ' tracks when to initialize values
Dim arrController(8) As ControllerType ' holds info for each player
Dim iNumControllers As Integer
Dim iController As Integer
Dim iNextY As Integer
Dim iNextX As Integer
Dim iNextC As Integer
Dim iLoop As Integer
Dim iDigits As Integer ' # digits to display (values are truncated to this length)
Dim strValue As String
Dim strAxis As String
Dim dblNextAxis
'DIM iMeasureCount AS INTEGER
Dim dblAverage As Double
Dim sngAverage As Single
Dim sLine As String
Dim iX As Integer
Dim iY As Integer
Dim iCol As Integer
Dim iRow As Integer
Dim iCols As Integer
Dim iRows As Integer
Dim iColWidth As Integer
Dim iColCount As Integer
Dim iGroupCount As Integer
' SET UP SCREEN
Screen _NewImage(1280, 1024, 32): _ScreenMove 0, 0
' INITIALIZE
iDigits = 4 ' 11
iColCount = 3
iCols = _Width(0) \ _FontWidth
iRows = _Height(0) \ _FontHeight
iColWidth = iCols \ iColCount
' COUNT # OF JOYSTICKS
' D= _DEVICES ' MUST be read in order for other 2 device functions to work!
iDeviceCount = _Devices ' Find the number of devices on someone's system
If iDeviceCount < 3 Then
Cls
Print "NO JOYSTICKS FOUND, EXITING..."
Input "PRESS <ENTER>"; in$
Exit Sub
End If
' BASE # OF PLAYERS ON HOW MANY CONTROLLERS FOUND
iNumControllers = iDeviceCount - 2 ' TODO: find out the right way to count joysticks
If iNumControllers > cMaxControllers Then
iNumControllers = cMaxControllers
End If
' INITIALIZE PLAYER COORDINATES AND SCREEN CHARACTERS
iNextY = 1
iNextX = -3
iNextC = 64
For iController = 1 To iNumControllers
iNextX = iNextX + 4
If iNextX > 80 Then
iNextX = 1
iNextY = iNextY + 4
End If
iNextC = iNextC + 1
arrController(iController).buttonCount = cMaxButtons
arrController(iController).axisCount = cMaxAxis
For iLoop = 1 To cMaxButtons
arrButtonNew(iController, iLoop) = TRUE
Next iLoop
For iLoop = 1 To cMaxAxis
arrAxisNew(iController, iLoop) = TRUE
arrAxisAvg(iController, iLoop) = 0
Next iLoop
Next iController
' CLEAR THE SCREEN
'iMeasureCount = 0
Do
For iController = 1 To iNumControllers
iDevice = iController + 2
While _DeviceInput(iDevice) ' clear and update the device buffer
''IF _DEVICEINPUT = 3 THEN ' this says we only care about joystick input values
' check all the buttons
For iLoop = 1 To _LastButton(iDevice)
If (iLoop > cMaxButtons) Then
Exit For
End If
arrController(iController).buttonCount = iLoop
' update button array to indicate if a button is up or down currently.
If _ButtonChange(iLoop) Then
'' _BUTTON(number) returns -1 when a button is pressed and 0 when released.
''arrButton(iLoop) = NOT arrButton(iLoop)
arrButton(iController, iLoop) = _Button(iLoop)
End If
'' SAVE MINIMUM VALUE
'if arrButton(iController, iLoop) < arrButtonMin(iController, iLoop) then
' arrButtonMin(iController, iLoop) = arrButton(iController, iLoop)
'
' ' INITIALIZE THE MAX TO THE MINIMUM VALUE
' IF arrButtonNew(iController, iLoop) = TRUE THEN
' arrButtonMax(iController, iLoop) = arrButtonMin(iController, iLoop)
' arrButtonNew(iController, iLoop) = FALSE
' END IF
'end if
'
'' SAVE MAXIMUM VALUE
'if arrButton(iController, iLoop) > arrButtonMax(iController, iLoop) then
' arrButtonMax(iController, iLoop) = arrButton(iController, iLoop)
'end if
Next iLoop
For iLoop = 1 To _LastAxis(iDevice) ' this loop checks all my axis
If (iLoop > cMaxAxis) Then
Exit For
End If
arrController(iController).axisCount = iLoop
' I like to give a little "jiggle" resistance to my controls, as I have an old joystick
' which is prone to always give minute values and never really center on true 0.
' A value of 1 means my axis is pushed fully in one direction.
' A value greater than 0.1 means it's been partially pushed in a direction (such as at a 45 degree diagional angle).
' A value of less than 0.1 means we count it as being centered. (As if it was 0.)
'IF ABS(_AXIS(iLoop)) <= 1 AND ABS(_AXIS(iLoop)) >= .1 THEN
dblNextAxis = _Axis(iLoop)
dblNextAxis = RoundUpDouble#(dblNextAxis, 3)
'IF ABS(dblNextAxis) <= 1 AND ABS(dblNextAxis) >= .01 THEN
If Abs(dblNextAxis) <= 1 And Abs(dblNextAxis) >= .001 Then
arrAxis(iController, iLoop) = dblNextAxis
Else
arrAxis(iController, iLoop) = 0
End If
'' SAVE MINIMUM VALUE
'if arrAxis(iController, iLoop) < arrAxisMin(iController, iLoop) then
' arrAxisMin(iController, iLoop) = arrAxis(iController, iLoop)
'
' ' INITIALIZE THE MAX TO THE MINIMUM VALUE
' IF arrAxisNew(iController, iLoop) = TRUE THEN
' arrAxisMax(iController, iLoop) = arrAxisMin(iController, iLoop)
' arrAxisNew(iController, iLoop) = FALSE
' END IF
'end if
'
'' SAVE MAXIMUM VALUE
'if arrAxis(iController, iLoop) > arrAxisMax(iController, iLoop) then
' arrAxisMax(iController, iLoop) = arrAxis(iController, iLoop)
'end if
'
'' ADD CURRENT VALUE TO AVERAGE SUM
'arrAxisAvg(iController, iLoop) = arrAxisAvg(iController, iLoop) + arrAxis(iController, iLoop)
Next iLoop
Wend ' clear and update the device buffer
Next iController
'PRINT "*** iNumControllers=" + cstr$(iNumControllers) + " ***"
'iMeasureCount = iMeasureCount + 1
'if iMeasureCount = 10 then
'iMeasureCount = 0
' And below here is just the simple display routine which displays our values.
' If this was for a game, I'd choose something like arrAxis(1) = -1 for a left arrow style input,
' arrAxis(1) = 1 for a right arrow style input, rather than just using _KEYHIT or INKEY$.
InitColumns iColCount
m_StartRow = 6
m_EndRow = iRows - 2
'm_StartCol
'm_EndCol
Cls
PrintString 1, 1, "Game controller test program."
PrintString 1, 2, "This program is free to use and distribute per GNU GPLv3 license."
PrintString 1, 3, "Tests up to 4 controllers with 2 axes / 2 buttons each."
PrintString 1, 4, "Plug in controllers and move them & press buttons."
PrintString 1, 5, "-------------------------------------------------------------------------------"
iGroupCount = 0
For iController = 1 To iNumControllers
For iLoop = 1 To arrController(iController).axisCount ' A loop for each axis
strAxis = Right$(" " + cstr$(iLoop), 2)
sLine = ""
' display their status to the screen
sLine = sLine + "Player " + cstr$(iController)
strValue = FormatNumber$(arrAxis(iController, iLoop), iDigits)
sLine = sLine + ", Axis #" + strAxis + " = " + strValue
'strValue = FormatNumber$(arrAxisMin(iController, iLoop), iDigits)
'sLine = sLine + ", Min=" + strValue
'
'strValue = FormatNumber$(arrAxisMax(iController, iLoop), iDigits)
'sLine = sLine + ", Max=" + strValue
'
'' COMPUTE AVERAGE
'dblAverage = arrAxisAvg(iController, iLoop) / 10
'dblAverage = RoundUpDouble# (dblAverage, 3)
'strValue = FormatNumber$(dblAverage, iDigits)
'sLine = sLine + ", Avg=" + strValue
'
'' CLEAR THE AVERAGE
'arrAxisAvg(iController, iLoop) = 0
PrintColumn sLine
Next iLoop
For iLoop = 1 To arrController(iController).buttonCount ' A loop for each button
strAxis = Right$(" " + cstr$(iLoop), 2)
sLine = ""
' display their status to the screen
sLine = sLine + "Player " + cstr$(iController)
strValue = FormatNumber$(arrButton(iController, iLoop), iDigits)
sLine = sLine + ", Button #" + strAxis + " = " + strValue
'strValue = FormatNumber$(arrButtonMin(iController, iLoop), iDigits)
'sLine = sLine + ", Min=" + strValue
'
'strValue = FormatNumber$(arrButtonMax(iController, iLoop), iDigits)
'sLine = sLine + ", Max=" + strValue
PrintColumn sLine
Next iLoop
iGroupCount = iGroupCount + 1
If iGroupCount = 2 Then
ColumnBreak
iGroupCount = 0
End If
Next iController
PrintString 1, iRows - 1, "-------------------------------------------------------------------------------"
PrintString 1, iRows - 0, "PRESS <ESC> TO EXIT"
'end if
_Limit 30
Loop Until _KeyHit = 27 ' ESCAPE to quit
' RETURN TO TEXT SCREEN
Screen 0
End Sub ' TestJoysticks1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN FILE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' File format is comma-delimited
' containing controller info for one action per line
' where each line contains the following in this order:
' TAB ORDER INFO TYPE DESCRIPTION
' 1 {player #} Integer player # this mapping is for
' 2 {which action} Integer which action this mapping is for (up/down/right/left/button 1/button 2, etc.)
' 3 {device #} Integer number of the device this is mapped to
' 4 {type} Integer type of input (one of: cInputKey, cInputButton, cInputAxis)
' 5 {code} Integer if button the _BUTTON #, if axis the _AXIS #, if keyboard the _BUTTON #
' 6 {value} Integer if axis, the value (-1 or 1), else can be ignored
' 7 {repeat} Integer if TRUE, and repeating keys not controlled by global values (when m_bRepeatOverride=TRUE), controls repeating keys for this control
' These need to be declared globally and populated:
' ReDim Shared m_arrControlMap(1 To 8, 1 To 8) As ControlInputType
' Dim Shared m_ControlMapFileName$: m_ControlMapFileName$ = Left$(m_ProgramName$, _InStrRev(m_ProgramName$, ".")) + "map.txt"
' Dim Shared m_bRepeatOverride As Integer
' If there is an error, returns error message,
' else returns blank string.
Function SaveControllerMap$
Dim RoutineName As String:: RoutineName = "SaveControllerMap$"
Dim sResult As String: sResult = ""
Dim sError As String: sError = ""
Dim sFile As String
Dim in$
Dim iPlayer As Integer
Dim iWhichInput As Integer
Dim sLine As String
Dim iCount As Long: iCount = 0
'Dim iError As Long: iError = 0
Dim sDelim As String: sDelim = "," ' CHR$(9)
'DebugPrint "--------------------------------------------------------------------------------"
'DebugPrint "Started " + RoutineName
'DebugPrint "--------------------------------------------------------------------------------"
' Get file name
If Len(m_ControlMapFileName$) = 0 Then
m_ControlMapFileName$ = Left$(m_ProgramName$, _InStrRev(m_ProgramName$, ".")) + "map.txt"
End If
sFile = Mid$(m_ControlMapFileName$, _InStrRev(m_ControlMapFileName$, "\") + 1)
'_KeyClear
'Cls
'Print "SAVE CONTROLLER MAPPING:"
'Print "Default file name is " + Chr$(34) + m_ControlMapFileName$ + Chr$(34) + "."
'Input "Type save file name, or blank for default: ", in$
'in$ = _Trim$(in$)
'If Len(in$) > 0 Then
' m_ControlMapFileName$ = in$
'End If
'sFile = m_ProgramPath$ + m_ControlMapFileName$
'DebugPrint "m_ControlMapFileName$=" + CHR$(34) + m_ControlMapFileName$ + CHR$(34)
' Save mapping to file
Open m_ControlMapFileName$ For Output As #1
For iPlayer = LBound(m_arrControlMap, 1) To UBound(m_arrControlMap, 1)
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
sLine = ""
sLine = sLine + _Trim$(Str$(iPlayer))
sLine = sLine + sDelim
sLine = sLine + _Trim$(Str$(iWhichInput))
sLine = sLine + sDelim
sLine = sLine + _Trim$(Str$(m_arrControlMap(iPlayer, iWhichInput).device))
sLine = sLine + sDelim
sLine = sLine + _Trim$(Str$(m_arrControlMap(iPlayer, iWhichInput).typ))
sLine = sLine + sDelim
sLine = sLine + _Trim$(Str$(m_arrControlMap(iPlayer, iWhichInput).code))
sLine = sLine + sDelim
sLine = sLine + _Trim$(Str$(m_arrControlMap(iPlayer, iWhichInput).value))
sLine = sLine + sDelim
sLine = sLine + _Trim$(Str$(m_arrControlMap(iPlayer, iWhichInput).repeat))
Print #1, sLine
iCount = iCount + 1
Next iWhichInput
Next iPlayer
Close #1
'DebugPrint "Wrote " + _Trim$(Str$(iCount)) + " lines."
'Print "Skipped " + _Trim$(Str$(iError)) + " lines."
'DebugPrint ""
'Input "PRESS <ENTER> TO CONTINUE", in$
If Len(sError) = 0 Then
sResult = "Saved mapping file " + Chr$(34) + sFile + Chr$(34) + "."
Else
sResult = "ERRORS: " + sError
End If
SaveControllerMap$ = sResult
End Function ' SaveControllerMap$
' /////////////////////////////////////////////////////////////////////////////
Function LoadControllerMap$
Dim RoutineName As String:: RoutineName = "LoadControllerMap$"
Dim sResult As String: sResult = ""
Dim sError As String: sError = ""
Dim sNextErr As String
Dim sFile As String
Dim sText As String
Dim iTotal As Long: iTotal = 0
Dim iRead As Long: iRead = 0
Dim iValid As Long: iValid = 0
Dim iBad As Long: iBad = 0
Dim iBlank As Long: iBlank = 0
Dim sLine As String
ReDim arrNextLine(-1) As String
Dim iNumValues As Integer
Dim iAdjust As Integer
Dim iPlayer As Integer
Dim iWhichInput As Integer
Dim iDevice As Integer
Dim iType As Integer
Dim iCode As Integer
Dim iValue As Integer
Dim bRepeat As Integer
'Dim sDebugLine As String
'DebugPrint "--------------------------------------------------------------------------------"
'DebugPrint "Started " + RoutineName
'DebugPrint "--------------------------------------------------------------------------------"
' Get file name
If Len(sError) = 0 Then
If Len(m_ControlMapFileName$) = 0 Then
m_ControlMapFileName$ = Left$(m_ProgramName$, _InStrRev(m_ProgramName$, ".")) + "map.txt"
End If
sFile = Mid$(m_ControlMapFileName$, _InStrRev(m_ControlMapFileName$, "\") + 1)
End If
'' Get file name
'If Len(sError) = 0 Then
' Cls
' If Len(m_ControlMapFileName$) = 0 Then
' m_ControlMapFileName$ = Left$(m_ProgramName$, _InStrRev(m_ProgramName$, ".")) + "map.txt"
' End If
' Print "LOAD CONTROLLER MAPPING:"
' Print "Default file name is " + Chr$(34) + m_ControlMapFileName$ + Chr$(34) + "."
' Input "Type name of file to open, or blank for default: ", in$
' in$ = _Trim$(in$)
' If Len(in$) > 0 Then
' m_ControlMapFileName$ = in$
' End If
' sFile = m_ProgramPath$ + m_ControlMapFileName$
'End If
' Make sure file exists
If Len(sError) = 0 Then
If _FileExists(m_ControlMapFileName$) = FALSE Then
sError = "File not found: " + Chr$(34) + m_ControlMapFileName$ + Chr$(34)
Else
'DebugPrint "Found file: " + chr$(34) + m_ControlMapFileName$ + chr$(34)
End If
End If
' Read data from file
If Len(sError) = 0 Then
'DebugPrint "OPEN m_ControlMapFileName$ FOR BINARY AS #1"
Open m_ControlMapFileName$ For Binary As #1
sText = Space$(LOF(1))
Get #1, , sText
Close #1
iTotal = Len(sText) - Len(Replace$(sText, Chr$(13), ""))
sText = ""
Open m_ControlMapFileName$ For Input As #1
While Not EOF(1)
'INPUT #1, sLine
Line Input #1, sLine ' read entire text file line
iRead = iRead + 1
'DebugPrint "Parsing line " + _Trim$(Str$(iRead)) + _
' " of " + _Trim$(Str$(iTotal))
sLine = Replace$(sLine, " ", "") ' Remove spaces
sLine = Replace$(sLine, Chr$(9), "") ' Remove tabs
sLine = Replace$(sLine, Chr$(10), "") ' Remove line breaks
sLine = Replace$(sLine, Chr$(13), "") ' Remove carriage returns
'DebugPrint " Trimmed=" + chr$(34) + sLine + chr$(34)
If Len(sLine) > 0 Then
split sLine, ",", arrNextLine()
'DebugPrint "split into arrNextLine()"
'DebugPrint " lbound =" + _Trim$(Str$(lbound(arrNextLine))) '+ CHR$(10)
'DebugPrint " ubound =" + _Trim$(Str$(ubound(arrNextLine))) '+ CHR$(10)
iNumValues = (UBound(arrNextLine) - LBound(arrNextLine)) + 1
If iNumValues > 5 Then
iAdjust = -1 '- lbound(arrNextLine)
If Len(sNextErr) = 0 Then
If IsNum%(arrNextLine(1 + iAdjust)) = TRUE Then
iPlayer = Val(arrNextLine(1 + iAdjust))
Else
sNextErr = "Error on line " + cstr$(iRead) + ", value 1: not a number"
End If
End If
If Len(sNextErr) = 0 Then
If IsNum%(arrNextLine(2 + iAdjust)) = TRUE Then
iWhichInput = Val(arrNextLine(2 + iAdjust))
Else
sNextErr = "Error on line " + cstr$(iRead) + ", value 2: not a number"
End If
End If
If Len(sNextErr) = 0 Then
If IsNum%(arrNextLine(3 + iAdjust)) = TRUE Then
iDevice = Val(arrNextLine(3 + iAdjust))
Else
sNextErr = "Error on line " + cstr$(iRead) + ", value 3: not a number"
End If
End If
If Len(sNextErr) = 0 Then
If IsNum%(arrNextLine(4 + iAdjust)) = TRUE Then
iType = Val(arrNextLine(4 + iAdjust))
Else
sNextErr = "Error on line " + cstr$(iRead) + ", value 4: not a number"
End If
End If
If Len(sNextErr) = 0 Then
If IsNum%(arrNextLine(5 + iAdjust)) = TRUE Then
iCode = Val(arrNextLine(5 + iAdjust))
Else
sNextErr = "Error on line " + cstr$(iRead) + ", value 5: not a number"
End If
End If
If Len(sNextErr) = 0 Then
If IsNum%(arrNextLine(6 + iAdjust)) = TRUE Then
iValue = Val(arrNextLine(6 + iAdjust))
Else
sNextErr = "Error on line " + cstr$(iRead) + ", value 6: not a number"
End If
End If
' validate iPlayer
If Len(sNextErr) = 0 Then
If iPlayer < LBound(m_arrControlMap, 1) Then
sNextErr = "Player value " + _Trim$(Str$(iPlayer)) + _
" is outside lbound(m_arrControlMap, 1) " + _
" which is " + _Trim$(Str$(lbound(m_arrControlMap, 1))) + "."
ElseIf iPlayer > UBound(m_arrControlMap, 1) Then
sNextErr = "Player value " + _Trim$(Str$(iPlayer)) + _
" is outside ubound(m_arrControlMap, 1) " + _
" which is " + _Trim$(Str$(ubound(m_arrControlMap, 1))) + "."
End If
End If
' validate iWhichInput
If Len(sNextErr) = 0 Then
If iWhichInput < LBound(m_arrControlMap, 2) Then
sNextErr = "WhichInput value " + _Trim$(Str$(iWhichInput)) + _
" is outside lbound(m_arrControlMap, 2) " + _
" which is " + _Trim$(Str$(lbound(m_arrControlMap, 2))) + "."
ElseIf iWhichInput > UBound(m_arrControlMap, 2) Then
sNextErr = "WhichInput value " + _Trim$(Str$(iWhichInput)) + _
" is outside ubound(m_arrControlMap, 2) " + _
" which is " + _Trim$(Str$(ubound(m_arrControlMap, 2))) + "."
End If
End If
' validate repeat setting
If iNumValues > 6 Then
If Len(sNextErr) = 0 Then
If IsNum%(arrNextLine(7 + iAdjust)) = TRUE Then
bRepeat = Val(arrNextLine(7 + iAdjust))
Else
sNextErr = "Error on line " + cstr$(iRead) + ", value 7: not a number"
End If
End If
Else
' get values from global
'if m_bRepeatOverride = TRUE then
bRepeat = GetGlobalInputRepeatSetting%(iWhichInput)
'end if
End If
Else
sNextErr = "Error on line " + cstr$(iRead) + ": detected " + cstr$(iNumValues) + " values, expected 6."
End If
If Len(sNextErr) = 0 Then
iValid = iValid + 1
m_arrControlMap(iPlayer, iWhichInput).device = iDevice
m_arrControlMap(iPlayer, iWhichInput).typ = iType
m_arrControlMap(iPlayer, iWhichInput).code = iCode
m_arrControlMap(iPlayer, iWhichInput).value = iValue
m_arrControlMap(iPlayer, iWhichInput).repeat = bRepeat
Else
iBad = iBad + 1
DebugPrint sNextErr
End If
Else
'DebugPrint " Line is blank: skipped"
iBlank = iBlank + 1
End If ' LEN(sLine) > 0
Wend
Close #1
End If
'DebugPrint ""
'DebugPrint "Lines read: " + _Trim$(Str$(iRead))
'DebugPrint "Valid : " + _Trim$(Str$(iValid))
'DebugPrint "Invalid : " + _Trim$(Str$(iErrors))
'DebugPrint "Blank : " + _Trim$(Str$(iBlank))
'DebugPrint ""
'Input "PRESS <ENTER> TO CONTINUE", in$
If Len(sError) = 0 Then
sResult = "Loaded mapping file " + Chr$(34) + sFile + Chr$(34) + "."
m_bHaveMapping = TRUE
Else
sResult = "ERRORS: " + sError
End If
LoadControllerMap$ = sResult
End Function ' LoadControllerMap$
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END FILE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GRAPHIC PRINTING ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Eliminates the math.
' Text resolution:
' 648 x 480: 80 x 30
' 720 x 480: 90 x 30
' 800 x 600: 100 x 37
' 1024 x 768: 128 x 48
' 1280 x 1024: 160 x 64
' 1920 x 1080: 240 x 67
' 2048 x 1152: 256 x 72 (truncated after 70 rows, 255 columns)
' 3840 x 2160: 480 x135 (truncated after 133 rows, 479 columns)
Sub PrintString (iCol As Integer, iRow As Integer, MyString As String)
Dim iCols As Integer
Dim iRows As Integer
Dim iX As Integer
Dim iY As Integer
iCols = _Width(0) \ _FontWidth
iRows = _Height(0) \ _FontHeight
iX = _FontWidth * (iCol - 1)
iY = _FontHeight * (iRow - 1)
_PrintString (iX, iY), MyString
End Sub ' PrintString
' /////////////////////////////////////////////////////////////////////////////
' A way to automatically print to columns.
' Depends on the following shared variables:
' Dim Shared m_NumColumns As Integer : m_NumColumns = 1
' Dim Shared m_PrintRow As Integer : m_PrintRow = 0
' Dim Shared m_PrintCol As Integer : m_PrintCol = 0
' Dim Shared m_StartRow As Integer : m_StartRow = 0
' Dim Shared m_EndRow As Integer : m_EndRow = 0
' Dim Shared m_StartCol As Integer : m_StartCol = 0
' Dim Shared m_EndCol As Integer : m_EndCol = 0
' InitColumns 2
' m_PrintRow = 5
' m_PrintCol = 2
' PrintColumn "Col 2, Row 5"
' PrintColumn "m_NumColumns=" + cstr$(m_NumColumns)
Sub PrintColumn (MyString As String)
Dim iCols As Integer
Dim iRows As Integer
Dim iX As Integer
Dim iY As Integer
ReDim arrLines(-1) As String
Dim iRow As Integer
Dim iCol As Integer
Dim sChar As String
Dim sLine As String
Dim iColWidth As Integer
iCols = _Width(0) \ _FontWidth
iRows = _Height(0) \ _FontHeight
If m_NumColumns < 1 Or m_NumColumns > iCols Then
m_NumColumns = 1
End If
If m_StartRow < 1 Or m_StartRow > iRows Then
m_StartRow = 1
End If
If m_EndRow < m_StartRow Or m_EndRow > iRows Then
m_EndRow = iRows
End If
If m_StartCol < 1 Or m_StartCol > m_NumColumns Then
m_StartCol = 1
End If
If m_EndCol < m_StartCol Or m_EndCol > m_NumColumns Then
m_EndCol = m_NumColumns
End If
If m_PrintRow < m_StartRow Then
m_PrintRow = m_StartRow
End If
If m_PrintCol < m_StartCol Then
m_PrintCol = m_StartCol
End If
iColWidth = iCols \ m_NumColumns
If m_PrintRow <= m_EndRow Then
If m_PrintCol <= m_EndCol Then
split MyString, Chr$(13), arrLines()
For iRow = 0 To UBound(arrlines)
sLine = Left$(arrLines(iRow), iColWidth)
'TODO: wrap remaining text
iX = _FontWidth * ((m_PrintCol - 1) * iColWidth)
iY = _FontHeight * (m_PrintRow - 1)
_PrintString (iX, iY), sLine
m_PrintRow = m_PrintRow + 1
If m_PrintRow > m_EndRow Then
m_PrintRow = m_StartRow
m_PrintCol = m_PrintCol + 1
If m_PrintCol > m_NumColumns Then
'TODO: options for when we reach the bottom of the last column (stop printing, wrap around)
m_PrintCol = 1
End If
End If
Next iRow
End If
End If
End Sub ' PrintColumn
' /////////////////////////////////////////////////////////////////////////////
' A way to automatically print to columns.
Sub ColumnBreak ()
m_PrintRow = m_StartRow
m_PrintCol = m_PrintCol + 1
If m_PrintCol > m_NumColumns Then
'TODO: options for when we go past the last column (stop printing, wrap around)
End If
End Sub ' ColumnBreak
' /////////////////////////////////////////////////////////////////////////////
' A way to automatically print to columns.
Sub InitColumns (iNumColumns As Integer)
Dim iCols As Integer
Dim iRows As Integer
iCols = _Width(0) \ _FontWidth
iRows = _Height(0) \ _FontHeight
If iNumColumns < 1 Or iNumColumns > iCols Then
m_NumColumns = 1
Else
m_NumColumns = iNumColumns
End If
If m_StartRow < 1 Or m_StartRow > iRows Then
m_StartRow = 1
End If
If m_EndRow < m_StartRow Or m_EndRow > iRows Then
m_EndRow = iRows
End If
If m_StartCol < 1 Or m_StartCol > m_NumColumns Then
m_StartCol = 1
End If
If m_EndCol < m_StartCol Or m_EndCol > m_NumColumns Then
m_EndCol = m_NumColumns
End If
m_PrintRow = 1
m_PrintCol = 1
End Sub ' InitColumns
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GRAPHIC PRINTING ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN DEBUGGING ROUTINES #DEBUGGING
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub DebugPrint (s$)
If m_bTesting = TRUE Then
_Echo s$
'ReDim arrLines$(0)
'dim delim$ : delim$ = Chr$(13)
'split MyString, delim$, arrLines$()
End If
End Sub ' DebugPrint
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END DEBUGGING ROUTINES @DEBUGGING
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GENERAL PURPOSE ROUTINES #GEN
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Convert a value to string and trim it (because normal Str$ adds spaces)
Function cstr$ (myValue)
'cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
cstr$ = _Trim$(Str$(myValue))
End Function ' cstr$
' /////////////////////////////////////////////////////////////////////////////
' Convert a Long value to string and trim it (because normal Str$ adds spaces)
Function cstrl$ (myValue As Long)
cstrl$ = _Trim$(Str$(myValue))
End Function ' cstrl$
' /////////////////////////////////////////////////////////////////////////////
' Convert a Single value to string and trim it (because normal Str$ adds spaces)
Function cstrs$ (myValue As Single)
''cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
cstrs$ = _Trim$(Str$(myValue))
End Function ' cstrs$
' /////////////////////////////////////////////////////////////////////////////
' Convert an unsigned Long value to string and trim it (because normal Str$ adds spaces)
Function cstrul$ (myValue As _Unsigned Long)
cstrul$ = _Trim$(Str$(myValue))
End Function ' cstrul$
' /////////////////////////////////////////////////////////////////////////////
' 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#)
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")
If expo% < 0 Then min$ = String$(Abs(expo%) - (dot% - 1), "0"): DP$ = "."
For n = 1 To L%
If Mid$(valu$, n, 1) <> "." Then num$ = num$ + Mid$(valu$, n, 1)
Next
Else DblToStr$ = value$: Exit Function
End If
DblToStr$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
End Function ' DblToStr$
' /////////////////////////////////////////////////////////////////////////////
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%
' /////////////////////////////////////////////////////////////////////////////
' 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%
' /////////////////////////////////////////////////////////////////////////////
Function IIF (Condition, IfTrue, IfFalse)
If Condition Then IIF = IfTrue Else IIF = IfFalse
End Function
' /////////////////////////////////////////////////////////////////////////////
Function IIFSTR$ (Condition, IfTrue$, IfFalse$)
If Condition Then IIFSTR$ = IfTrue$ Else IIFSTR$ = IfFalse$
End Function
' /////////////////////////////////////////////////////////////////////////////
' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
Function IsEven% (n)
If n Mod 2 = 0 Then
IsEven% = TRUE
Else
IsEven% = FALSE
End If
End Function ' IsEven%
' /////////////////////////////////////////////////////////////////////////////
' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
Function IsOdd% (n)
If n Mod 2 = 1 Then
IsOdd% = TRUE
Else
IsOdd% = FALSE
End If
End Function ' IsOdd%
' /////////////////////////////////////////////////////////////////////////////
' 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%
' /////////////////////////////////////////////////////////////////////////////
' Re: Does a Is Number function exist in QB64?
' https://www.qb64.org/forum/index.php?topic=896.15
' MWheatley
' « Reply #18 on: January 01, 2019, 11:24:30 AM »
' returns 1 if string is an integer, 0 if not
Function IsNumber (text$)
Dim i As Integer
IsNumber = 1
For i = 1 To Len(text$)
If Asc(Mid$(text$, i, 1)) < 45 Or Asc(Mid$(text$, i, 1)) >= 58 Then
IsNumber = 0
Exit For
ElseIf Asc(Mid$(text$, i, 1)) = 47 Then
IsNumber = 0
Exit For
End If
Next i
End Function ' IsNumber
' /////////////////////////////////////////////////////////////////////////////
' 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$
' /////////////////////////////////////////////////////////////////////////////
' 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&
' /////////////////////////////////////////////////////////////////////////////
' Writes sText to a debug file in the EXE folder.
' Debug file is named the same thing as the program EXE name with ".txt" at the end.
' For example the program "C:\QB64\MyProgram.BAS" running as
' "C:\QB64\MyProgram.EXE" would have an output file "C:\QB64\MyProgram.EXE.txt".
' If the file doesn't exist, it is created, otherwise it is appended to.
Sub DebugPrintFile (sText As String)
Dim sFileName As String
Dim sError As String
Dim sOut As String
sFileName = ProgramPath$ + ProgramName$ + ".txt"
sError = ""
If _FileExists(sFileName) = FALSE Then
sOut = ""
sOut = sOut + "++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" + Chr$(13) + Chr$(10)
sOut = sOut + "PROGRAM : " + ProgramName$ + Chr$(13) + Chr$(10)
sOut = sOut + "RUN DATE: " + CurrentDateTime$ + Chr$(13) + Chr$(10)
sOut = sOut + "++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" + Chr$(13) + Chr$(10)
sError = PrintFile$(sFileName, sOut, FALSE)
End If
If Len(sError) = 0 Then
sError = PrintFile$(sFileName, sText, TRUE)
End If
If Len(sError) <> 0 Then
Print CurrentDateTime$ + " DebugPrintFile FAILED: " + sError
End If
End Sub ' DebugPrintFile
' /////////////////////////////////////////////////////////////////////////////
Function IntPadRight$ (iValue As Integer, iWidth As Integer)
IntPadRight$ = Left$(_Trim$(Str$(iValue)) + String$(iWidth, " "), iWidth)
End Function ' IntPadRight$
' /////////////////////////////////////////////////////////////////////////////
' Returns blank if successful else returns error message.
Function PrintFile$ (sFileName As String, sText As String, bAppend As Integer)
'x = 1: y = 2: z$ = "Three"
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
' 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
'PRINT "File created with data. Press a key!"
'K$ = INPUT$(1) 'press a key
'OPEN sFileName FOR INPUT AS #2 ' opens a file to read it
'INPUT #2, a, b, c$
'CLOSE #2
'PRINT a, b, c$
'WRITE a, b, c$
End If
PrintFile$ = sError
End Function ' PrintFile$
' /////////////////////////////////////////////////////////////////////////////
' 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%
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))))
' Return the substring:
Text2 = strBefore + Add2 + strAfter
' Locate the next instance of [Find2]:
lngLocation = InStr(1, Text2, Find2)
' Next instance of [Find2]...
Wend
' OUTPUT:
Replace$ = Text2
End Function ' Replace$
' /////////////////////////////////////////////////////////////////////////////
Sub ReplaceTest
Dim in$
Print "-------------------------------------------------------------------------------"
Print "ReplaceTest"
Print
Print "Original value"
in$ = "Thiz iz a teZt."
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print
Print "Replacing lowercase " + Chr$(34) + "z" + Chr$(34) + " with " + Chr$(34) + "s" + Chr$(34) + "..."
in$ = Replace$(in$, "z", "s")
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print
Print "Replacing uppercase " + Chr$(34) + "Z" + Chr$(34) + " with " + Chr$(34) + "s" + Chr$(34) + "..."
in$ = Replace$(in$, "Z", "s")
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print
Print "ReplaceTest finished."
End Sub ' ReplaceTest
' /////////////////////////////////////////////////////////////////////////////
' 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.
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 Round_Scientific## (num##, digits%)
Round_Scientific## = _Round(num## * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundUpDouble# (num#, digits%)
RoundUpDouble# = _Ceil(num# * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundUpSingle! (num!, digits%)
RoundUpSingle! = _Ceil(num! * 10 ^ digits%) / 10 ^ digits%
End Function
' /////////////////////////////////////////////////////////////////////////////
' fantastically inefficient way to set a bit
' example use: arrMaze(iX, iY) = SetBit256%(arrMaze(iX, iY), cS, FALSE)
' See also: GetBit256%, SetBit256%
' newint=SetBit256%(oldint, int containing the bits we want to set, value to set them to)
Function SetBit256% (iNum1 As Integer, iBit1 As Integer, bVal1 As Integer)
Dim sNum As String
Dim sBit As String
Dim sVal As String
Dim iLoop As Integer
Dim strResult As String
Dim iResult As Integer
Dim iNum As Integer: iNum = iNum1
Dim iBit As Integer: iBit = iBit1
Dim bVal As Integer: bVal = bVal1
If iNum < 256 And iBit <= 128 Then
sNum = GetBinary$(iNum)
sBit = GetBinary$(iBit)
If bVal = TRUE Then
sVal = "1"
Else
sVal = "0"
End If
strResult = ""
For iLoop = 1 To 8
If Mid$(sBit, iLoop, 1) = "1" Then
strResult = strResult + sVal
Else
strResult = strResult + Mid$(sNum, iLoop, 1)
End If
Next iLoop
iResult = GetIntegerFromBinary%(strResult)
Else
iResult = iNum
End If
SetBit256% = iResult
End Function ' SetBit256%
' /////////////////////////////////////////////////////////////////////////////
' 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!)
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")
If expo% < 0 Then min$ = String$(Abs(expo%) - (dot% - 1), "0"): DP$ = "."
For n = 1 To L%
If Mid$(valu$, n, 1) <> "." Then num$ = num$ + Mid$(valu$, n, 1)
Next
Else SngToStr$ = value$: Exit Function
End If
SngToStr$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
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
' /////////////////////////////////////////////////////////////////////////////
Sub SplitTest
Dim in$
Dim delim$
ReDim arrTest$(0)
Dim iLoop%
delim$ = Chr$(10)
in$ = "this" + delim$ + "is" + delim$ + "a" + delim$ + "test"
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print "delim$ = " + Chr$(34) + delim$ + Chr$(34)
split in$, delim$, arrTest$()
For iLoop% = LBound(arrTest$) To UBound(arrTest$)
Print "arrTest$(" + LTrim$(RTrim$(Str$(iLoop%))) + ") = " + Chr$(34) + arrTest$(iLoop%) + Chr$(34)
Next iLoop%
Print
Print "Split test finished."
End Sub ' SplitTest
' /////////////////////////////////////////////////////////////////////////////
Sub SplitAndReplaceTest
Dim in$
Dim out$
Dim iLoop%
ReDim arrTest$(0)
Print "-------------------------------------------------------------------------------"
Print "SplitAndReplaceTest"
Print
Print "Original value"
in$ = "This line 1 " + Chr$(13) + Chr$(10) + "and line 2" + Chr$(10) + "and line 3 " + Chr$(13) + "finally THE END."
out$ = in$
out$ = Replace$(out$, Chr$(13), "\r")
out$ = Replace$(out$, Chr$(10), "\n")
out$ = Replace$(out$, Chr$(9), "\t")
Print "in$ = " + Chr$(34) + out$ + Chr$(34)
Print
Print "Fixing linebreaks..."
in$ = Replace$(in$, Chr$(13) + Chr$(10), Chr$(13))
in$ = Replace$(in$, Chr$(10), Chr$(13))
out$ = in$
out$ = Replace$(out$, Chr$(13), "\r")
out$ = Replace$(out$, Chr$(10), "\n")
out$ = Replace$(out$, Chr$(9), "\t")
Print "in$ = " + Chr$(34) + out$ + Chr$(34)
Print
Print "Splitting up..."
split in$, Chr$(13), arrTest$()
For iLoop% = LBound(arrTest$) To UBound(arrTest$)
out$ = arrTest$(iLoop%)
out$ = Replace$(out$, Chr$(13), "\r")
out$ = Replace$(out$, Chr$(10), "\n")
out$ = Replace$(out$, Chr$(9), "\t")
Print "arrTest$(" + cstr$(iLoop%) + ") = " + Chr$(34) + out$ + Chr$(34)
Next iLoop%
Print
Print "SplitAndReplaceTest finished."
End Sub ' SplitAndReplaceTest
' /////////////////////////////////////////////////////////////////////////////
Function StrPadRight$ (sValue As String, iWidth As Integer)
StrPadRight$ = Left$(sValue + String$(iWidth, " "), iWidth)
End Function ' StrPadRight$
' /////////////////////////////////////////////////////////////////////////////
Function TrueFalse$ (myValue)
If myValue = TRUE Then
TrueFalse$ = "TRUE"
Else
TrueFalse$ = "FALSE"
End If
End Function ' TrueFalse$
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GENERAL PURPOSE ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' #END
' ################################################################################################################################################################