+- 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 v2.0 for gamepad+keyboard (upto 8 players)(WIP) (/showthread.php?tid=1679)
game input mapping system v2.0 for gamepad+keyboard (upto 8 players)(WIP) - madscijr - 05-12-2023
This is the second version of my joystick & keyboard mapping + input library (original post), which added a simple GUI (what a pain and interesting project THAT was!).
Version 1 was simpler but used a clunky text-based menu.
(I'm currently working on Version 3 which removes the GUI abomination and simplifies things.)
madscijr
game input mapping system v2.0 for gamepad+keyboard (upto 8 players)(WIP)
« on: January 26, 2022, 05:27:52 am »
This version adds a simple GUI to the mapping screen.
Supports upto 8 controllers with up/down/left/right + 4 buttons each, and whether each of those is auto-repeating or not.
Tested with Windows, not sure about Mac or Linux.
Code: (Select All)
' ################################################################################################################################################################
' #TOP
' Basic Input Mapper, Barebones Octo edition.
' Version 2.00 by madscijr
' CHANGE LOG:
' Date Who What
' 12/16/2020 madscijr detect keys 0.70
' 02/17/2021 madscijr basic game controller test
' 01/08/2022 madscijr input mapping v1.0
' keyboard + game controllers
' text menu driven (no GUI)
' 01/21/2022 madscijr input mapping v2.0 with simple GUI
' DESCRIPTION:
' A way to map input controls (gamepad + keyboard)
' load/save mapping to a file, and read the input,
' that you can use in your own games.
' ################################################################################################################################################################
' BASIC SETTINGS
DefLng A-Z
' ################################################################################################################################################################
' #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
' BEGIN TEXT GUI CONSTANTS
Const cTextGuiSection = 1
Const cTextGuiButton = 2
Const cTextGuiUnknown = 0
Const cJustifyLeft = 1
Const cJustifyRight = 2
Const cJustifyCenter = 3
Const cJustifyNone = 4
Const cJustifyUnknown = 0
' END TEXT GUI 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
' UDT TO HOLD COLOR CODE INFO
Type ColorType
name As String
value As _Unsigned Long
End Type ' ColorType
' UDT TO HOLD TEXT GUI
Type ScreenAreaType
name As String
typ As Integer ' cTextGuiSection, cTextGuiButton
item As String
player As Integer
x1 As Integer
y1 As Integer
x2 As Integer
y2 As Integer
'index as integer
End Type ' ScreenAreaType
' DEFINES CLICKABLE BUTTON BOUNDARIES
Type TextButtonType
item As String
typ As Integer ' cInputUp, cInputDown, cInputLeft, cInputRight, cInputButton1, cInputButton2, cInputButton3, cInputButton4
x1 As Integer
y1 As Integer
x2 As Integer
y2 As Integer
'index as integer
End Type ' TextButtonType
' DEFINES TEXT LABELS
Type TextLabelType
item As String ' "Section", "Up", "Down"
name As String ' "caption", "type", "device", "code", "repeat", "value"
row As Integer ' row (relative to section y1)
column As Integer ' column (relative to section x1)
width As Integer ' needed for cJustifyRight, cJustifyCenter
justify As Integer ' cJustifyLeft, cJustifyRight, cJustifyCenter, cJustifyUnknown
caption As String ' holds the label text
fgcolor As _Unsigned Long
bgcolor As _Unsigned Long
'index as integer
End Type ' TextLabelType
' DEFINES TEXT FIELDS
Type TextFieldType
item As String ' "Section", "Up", "Down"
name As String ' "caption", "type", "device", "code", "repeat", "value"
row As Integer ' row (relative to section y1)
column As Integer ' column (relative to section x1)
width As Integer ' pad values to this width
justify As Integer ' cJustifyLeft, cJustifyRight, cJustifyCenter, cJustifyUnknown
value As String ' holds the formatted value as text
fgcolor As _Unsigned Long
bgcolor As _Unsigned Long
'index as integer
End Type ' TextFieldType
' FOR TEXT SCREEN
Type TextCellType
value As String
fgColor As _Unsigned Long
bgcolor As _Unsigned Long
End Type ' TextCellType
' ################################################################################################################################################################
' #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)
Dim Shared m_VersionInfo$: m_VersionInfo$ = "2.00"
' 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
ReDim Shared m_arrButtonKeyShortDesc(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
' VARIABLES FOR TEXT GUI
ReDim Shared m_arrScreenArea(-1) As ScreenAreaType
ReDim Shared m_arrButton(-1) As TextButtonType
ReDim Shared m_arrTextLabel(-1) As TextLabelType
ReDim Shared m_arrTextField(-1) As TextFieldType
' 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(1024, 768, 32): _ScreenMove 0, 0
Do
If Len(result$) = 0 Then
Cls
Else
Print
End If
Print m_ProgramName$
Print
Print "Game Input Mapping Test " + m_VersionInfo$
Print "by Softintheheadware (Jan, 2022)"
Print
Print "1. Basic controller test"
Print "2. Load controller mapping"
Print "3. View controller mapping"
Print "4. Dump controller mappings to console window"
Print "5. Edit controller mapping for 1 or more players"
Print "6. Reset controller mapping for 1 or more players"
Print "7. Map controllers for 1-8 players (no GUI)"
Print "8. Map / edit controllers for 1-8 players (GUI)"
Print "9. Test controller mappings to move around screen"
Print "10. Save controller mappings"
Print "What to do? ('q' to exit)"
Input in$: in$ = _Trim$(in$) ' in$ = LCase$(Left$(in$, 1))
If in$ = "1" Then
result$ = TestJoysticks1$
ElseIf in$ = "2" Then
result$ = LoadMappings1$
If Len(result$) = 0 Then result$ = "Loaded mappings."
ElseIf in$ = "3" Then
result$ = ViewMappings2$
ElseIf in$ = "4" Then
DumpControllerMap1
ElseIf in$ = "5" Then
result$ = EditMappings1$
ElseIf in$ = "6" Then
result$ = ResetMapping1$
ElseIf in$ = "7" Then
result$ = MapInput1$
ElseIf in$ = "8" Then
result$ = MapInput2$
ElseIf in$ = "9" Then
result$ = TestMappings1$
ElseIf in$ = "10" Then
result$ = SaveMappings1$
End If
If Len(result$) > 0 Then
Print result$
End If
Loop Until in$ = "q"
' RETURN TO TEXT SCREEN
Screen 0
End Sub ' main
' /////////////////////////////////////////////////////////////////////////////
' Just a little test to verify _DEFAULTCOLOR and _BACKGROUNDCOLOR work.
Function DetectColor1$
Dim sResult As String: sResult = ""
ReDim arrColor(-1) As ColorType
Dim ScreenArray(1 To 48, 1 To 128) As String
Dim iRow As Integer
Dim iCol As Integer
Dim iForeColor As _Unsigned Long
Dim iBackColor As _Unsigned Long
Dim iY As Integer
Dim iX As Integer
Dim in$
Dim iLoop1 As Integer
Dim iLoop2 As Integer
Dim sInfo As String
Dim sNext As String
Dim sData As String
Dim sTest As String
Dim iMaxLen As Integer
Dim sValue1 As String
Dim sValue2 As String
' INITIALIZE
'AddColors arrColor()
'StringToArray ScreenArray(), GetMap$
ReDim _Preserve arrColor(1 To UBound(arrColor) + 1) As ColorType
arrColor(UBound(arrColor)).name = "cRed"
arrColor(UBound(arrColor)).value = cRed
ReDim _Preserve arrColor(1 To UBound(arrColor) + 1) As ColorType
arrColor(UBound(arrColor)).name = "cWhite"
arrColor(UBound(arrColor)).value = cWhite
ReDim _Preserve arrColor(1 To UBound(arrColor) + 1) As ColorType
arrColor(UBound(arrColor)).name = "cBlue"
arrColor(UBound(arrColor)).value = cBlue
' GET LEN
iMaxLen = 0
For iLoop1 = lbound(arrColor) to ubound(arrColor)
if len(arrColor(iLoop1).name) > iMaxLen then
iMaxLen = len(arrColor(iLoop1).name)
end if
Next iLoop1
' SET UP SCREEN
Screen _NewImage(1280, 1024, 32): _ScreenMove 0, 0
'Screen _NewImage(1024, 768, 32): _ScreenMove 0, 0
' DISPLAY GRAPHICALLY
Cls
'For iY = LBound(ScreenArray, 1) To UBound(ScreenArray, 1)
' For iX = LBound(ScreenArray, 2) To UBound(ScreenArray, 2)
' iRow = iY - 1: iCol = iX - 1
' Color cRed, cBlack
' PrintString iRow, iCol, ScreenArray(iY, iX)
' Next iX
'Next iY
iRow = 0
iCol = 0
For iLoop1 = lbound(arrColor) to ubound(arrColor)
For iLoop2 = lbound(arrColor) to ubound(arrColor)
if iLoop1 <> iLoop2 then
iCol = 0
iForeColor = arrColor(iLoop1).value
iBackColor = arrColor(iLoop2).value
'sInfo = "Color " + _Trim$(Str$(iForeColor)) + ", " + _Trim$(Str$(iBackColor))
sInfo = "Color " + _
GetColorName$(arrColor(), iForeColor, _Trim$(Str$(iForeColor))) + _
", " + _
GetColorName$(arrColor(), iBackColor, _Trim$(Str$(iBackColor)))
Color cWhite, cBlack : PrintString iRow, iCol, sInfo
sValue1 = arrColor(iLoop1).name + string$(iMaxLen, " ")
sValue1 = left$(svalue1, iMaxLen)
sValue2 = arrColor(iLoop2).name + string$(iMaxLen, " ")
sValue2 = left$(svalue2, iMaxLen)
sNext = sValue1 + " on " + sValue2
iCol = len(sInfo) + 1
Color iForeColor, iBackColor: PrintString iRow, iCol, sNext
'sData = "_DEFAULTCOLOR = " + _Trim$(Str$(_DEFAULTCOLOR)) + ", " + "_BACKGROUNDCOLOR = " + _Trim$(Str$(_BACKGROUNDCOLOR))
'sTest = "_DEFAULTCOLOR " + IIFSTR$(_DEFAULTCOLOR = arrColor(iLoop1).value, "=", "!=") + " fgcolor" + _
' ", " + _
' "_BACKGROUNDCOLOR " + IIFSTR$(_BACKGROUNDCOLOR = arrColor(iLoop2).value, "=", "!=") + " bgcolor"
'iCol = iCol + len(sNext) + 1
'Color cWhite, cBlack : PrintString iRow, iCol, sData
'iCol = iCol + len(sData) + 1
'Color cWhite, cBlack : PrintString iRow, iCol, sTest
sData = "_DEFAULTCOLOR = " + _
GetColorName$(arrColor(), _DEFAULTCOLOR, _Trim$(Str$(_DEFAULTCOLOR))) + _
", " + _
"_BACKGROUNDCOLOR = " + _
GetColorName$(arrColor(), _BACKGROUNDCOLOR, _Trim$(Str$(_BACKGROUNDCOLOR)))
iCol = iCol + len(sNext) + 1
Color cWhite, cBlack : PrintString iRow, iCol, sData
end if
iRow = iRow + 1
Next iLoop2
Next iLoop1
'' Get color
'iForeColor = _DEFAULTCOLOR
'iBackColor = _BACKGROUNDCOLOR
' Show results
'Cls
Color cWhite, cBlack
'print "Color cRed, cBlack"
'print "Color " + _Trim$(Str$(cRed)) + ", " + _Trim$(Str$(cBlack))
'print "_DEFAULTCOLOR=" + _Trim$(Str$(iForeColor))
'print "_BACKGROUNDCOLOR=" + _Trim$(Str$(iBackColor))
locate iRow+1, 1
Input "PRESS <ENTER> TO CONTINUE"; in$
' RETURN RESULT
DetectColor1$ = sResult
End Function ' DetectColor1$
' /////////////////////////////////////////////////////////////////////////////
' sName = GetColorName$(arrColor(), ColorValue, DefaultName)
Function GetColorName$(arrColor() As ColorType, ColorValue As _Unsigned Long, DefaultName As String)
Dim sResult As String
Dim iLoop As Long
sResult = DefaultName
For iLoop = lbound(arrColor) to ubound(arrColor)
If arrColor(iLoop).value = ColorValue Then
sResult = arrColor(iLoop).name
Exit For
End If
Next iLoop
GetColorName$ = sResult
End Function ' GetColorName$
' /////////////////////////////////////////////////////////////////////////////
' TODO: get keyboard input working
' TODO: get continuous movement working for digital joysticks
' TODO: adjust analog joystick sensitivity
Function TestMappings1$
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
InitKeyboardButtonCodes
iCols = _Width(0) \ _FontWidth
iRows = _Height(0) \ _FontHeight
iMinX = 1: iMaxX = iCols
iMinY = 1: iMaxY = iRows
Cls
PrintStringCR1 10, 20, "Test control mapping:"
PrintStringCR1 10, 22, "1. Directional controls move letters around screen."
PrintStringCR1 10, 23, "2. Buttons make sounds."
PrintStringCR1 10, 25, "Press <ESC> to exit."
' 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)
PrintStringCR1 m_arrPlayer(iPlayer).xOld, m_arrPlayer(iPlayer).yOld, " "
PrintStringCR1 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
TestMappings1$ = sResult
End Function ' TestMappings1$
' /////////////////////////////////////////////////////////////////////////////
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.
' A total kludge!
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 = 60
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 Rep"
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, 8)
sLine = sLine + StrPadRight$(InputToString$(iWhichInput), 10)
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 = GetKeyboardButtonCodeShortText$(m_arrControlMap(iPlayer, iWhichInput).code)
sValue = StrPadRight$(sValue, 13)
Else
sValue = IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).code, 13)
End If
sLine = sLine + sValue
sLine = sLine + IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).value, 6)
'sValue = TrueFalse$(m_arrControlMap(iPlayer, iWhichInput).repeat)
sValue = IIFSTR$ (m_arrControlMap(iPlayer, iWhichInput).repeat, "Y", "N")
sLine = sLine + StrPadRight$(sValue, 3)
'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 Rep"
sColumn2 = sColumn2 + StrPadRight$(sLine, iColWidth) + Chr$(13)
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, 8)
sLine = sLine + StrPadRight$(InputToString$(iWhichInput), 10)
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 = GetKeyboardButtonCodeShortText$(m_arrControlMap(iPlayer, iWhichInput).code)
sValue = StrPadRight$(sValue, 13)
Else
sValue = IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).code, 13)
End If
sLine = sLine + sValue
sLine = sLine + IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).value, 6)
'sValue = TrueFalse$(m_arrControlMap(iPlayer, iWhichInput).repeat)
sValue = IIFSTR$ (m_arrControlMap(iPlayer, iWhichInput).repeat, "Y", "N")
sLine = sLine + StrPadRight$(sValue, 3)
'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
' /////////////////////////////////////////////////////////////////////////////
' Simple routine
' enables debugging, prints to debug window
' when done disables debugging (if it was disabled to begin with)
Sub DumpControllerMap1
Dim RoutineName As String:: RoutineName = "DumpControllerMap1"
Dim iPlayer As Integer
Dim iWhichInput As Integer
Dim sLine As String
Dim iCount As Integer
Dim in$
Dim bTesting As Integer
' ENABLE DEEBUGGING (IF NOT ENABLED)
bTesting = m_bTesting
' ACTIVATE DEBUGGING WINDOW (IF NOT ACTIVATED)
If m_bTesting = FALSE Then
m_bTesting = TRUE
$Console
_Delay 4
_Console On
_Echo "Started " + m_ProgramName$
_Echo "Debugging on..."
End If
' INITIALIZE
InitKeyboardButtonCodes
' OUTPUT MAPPING
DebugPrint "Controller mapping:"
DebugPrint "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)
DebugPrint sLine
End If
Next iWhichInput
Else
sLine = IntPadRight$(iPlayer, 9) + "(NONE)"
DebugPrint sLine
End If
Next iPlayer
' WAIT FOR USER
Cls
Print "Controller mapping written to console window."
Input "PRESS <ENTER> TO CONTINUE"; in$
' DEACTIVATE DEBUGGING WINDOW (IF IT WAS NOT ACTIVATED BEFORE)
If bTesting = FALSE Then
m_bTesting = FALSE
_Console Off
End If
End Sub ' DumpControllerMap1
' /////////////////////////////////////////////////////////////////////////////
Function LoadMappings1$
Dim sResult As String: sResult = ""
' INITIALIZE
InitKeyboardButtonCodes
' Try loading map
sResult = LoadControllerMap1$
LoadMappings1$ = sResult
End Function ' LoadMappings1$
' /////////////////////////////////////////////////////////////////////////////
Function SaveMappings1$
Dim sResult As String: sResult = ""
Dim sError As String: sError = ""
' INITIALIZE
InitKeyboardButtonCodes
' Try saving map
sResult = SaveControllerMap1$
SaveMappings1$ = sResult
End Function ' SaveMappings1$
' /////////////////////////////////////////////////////////////////////////////
Function ViewMappings2$
' INITIALIZE
InitKeyboardButtonCodes
PrintControllerMap2
Print
Input "PRESS <ENTER> TO CONTINUE", in$
Print
ViewMappings2$ = ""
End Function ' ViewMappings2$
' /////////////////////////////////////////////////////////////////////////////
' TODO: test this
Function EditMappings1$
Dim RoutineName As String: RoutineName = "EditMappings1$"
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
EditMappings1$ = sResult
End Function ' EditMappings1$
' /////////////////////////////////////////////////////////////////////////////
Function ResetMapping1$
Dim RoutineName As String: RoutineName = "ResetMapping1$"
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
ResetMapping1$ = sResult
End Function ' ResetMapping1$
' /////////////////////////////////////////////////////////////////////////////
' Usage:
' Dim StringArray(1 To 48, 1 To 128) As String
' StringToArray StringArray(), GetMap$
' version 2 with indexed array(row, columm)
Sub StringToArray (MyArray() As String, MyString As String)
Dim sDelim As String
ReDim arrLines(0) As String
Dim iRow As Integer
Dim iCol As Integer
Dim sChar As String
Dim iDim1 As Integer
Dim iDim2 As Integer
Dim iIndex1 As Integer
Dim iIndex2 As Integer
iDim1 = LBound(MyArray, 1)
iDim2 = LBound(MyArray, 2)
sDelim = Chr$(13)
split MyString, sDelim, arrLines()
For iRow = LBound(arrLines) To UBound(arrLines)
If iRow <= UBound(MyArray, 1) Then
For iCol = 1 To Len(arrLines(iRow))
If iCol <= UBound(MyArray, 2) Then
sChar = Mid$(arrLines(iRow), iCol, 1)
If Len(sChar) > 1 Then
sChar = Left$(sChar, 1)
Else
If Len(sChar) = 0 Then
sChar = "."
End If
End If
iIndex1 = iRow + iDim1
iIndex2 = (iCol - 1) + iDim2
MyArray(iIndex1, iIndex2) = sChar
'DebugPrint "MyArray(" + cstr$(iIndex1) + ", " + cstr$(iIndex2) + " = " + chr$(34) + sChar + chr$(34)
Else
' Exit if out of bounds
Exit For
End If
Next iCol
Else
' Exit if out of bounds
Exit For
End If
Next iRow
End Sub ' StringToArray
' /////////////////////////////////////////////////////////////////////////////
' Size of array:
'
' Resolution Cols Rows
' 1024 x 768 128 48
' 48 total available # of rows
' -2 rows for title
' -1 row for headings
' -1 for player #1 info
' -1 for player #2 info
' -1 for player #3 info
' -1 for player #4 info
' -- --------------------------
' 41 rows available
Function GetMap$
Dim m$
m$ = ""
' 11111111111111111111111111111
' 11111111112222222222333333333344444444445555555555666666666677777777778888888888999999999900000000001111111111222222222
' 12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678
m$ = m$ + " CONTROLLER #1 # # # X" + Chr$(13) ' 1
m$ = m$ + " UP # # # #" + Chr$(13) ' 2
m$ = m$ + " button dev 10 # # # #" + Chr$(13) ' 3
m$ = m$ + " code 329 rep=Y # # # #" + Chr$(13) ' 4
m$ = m$ + " value -1 # # # #" + Chr$(13) ' 5
m$ = m$ + " LEFT RIGHT # # # #" + Chr$(13) ' 6
m$ = m$ + " button dev 10 button dev 10 # # # #" + Chr$(13) ' 7
m$ = m$ + " code 332 rep=N code 334 rep=N # # # #" + Chr$(13) ' 8
m$ = m$ + " value -1 value -1 # # # #" + Chr$(13) ' 9
m$ = m$ + " DOWN # # # #" + Chr$(13) ' 10
m$ = m$ + " button dev= 10 # # # #" + Chr$(13) ' 11
m$ = m$ + " code 337 rep=Y # # # #" + Chr$(13) ' 12
m$ = m$ + " value= -1 # # # #" + Chr$(13) ' 13
m$ = m$ + " # # # #" + Chr$(13) ' 14
m$ = m$ + " BUTTON #1 BUTTON #3 # # # #" + Chr$(13) ' 15
m$ = m$ + " button dev 1 none dev 0 # # # #" + Chr$(13) ' 16
m$ = m$ + " code 286 rep=N code rep=N # # # #" + Chr$(13) ' 17
m$ = m$ + " value -1 value 0 # # # #" + Chr$(13) ' 18
m$ = m$ + " # # # #" + Chr$(13) ' 19
m$ = m$ + " BUTTON #2 BUTTON #4 # # # #" + Chr$(13) ' 20
m$ = m$ + " none dev 0 none dev 0 # # # #" + Chr$(13) ' 21
m$ = m$ + " code rep=N code rep=N # # # #" + Chr$(13) ' 22
m$ = m$ + " value 0 value 0 # # # #" + Chr$(13) ' 23
m$ = m$ + "################################################################################################################################" + Chr$(13) ' 24
m$ = m$ + " # # # #" + Chr$(13) ' 25
m$ = m$ + " # # # #" + Chr$(13) ' 26
m$ = m$ + " # # # #" + Chr$(13) ' 27
m$ = m$ + " # # # #" + Chr$(13) ' 28
m$ = m$ + " # # # #" + Chr$(13) ' 29
m$ = m$ + " # # # #" + Chr$(13) ' 30
m$ = m$ + " # # # #" + Chr$(13) ' 31
m$ = m$ + " # # # #" + Chr$(13) ' 32
m$ = m$ + " # # # #" + Chr$(13) ' 33
m$ = m$ + " # # # #" + Chr$(13) ' 34
m$ = m$ + " # # # #" + Chr$(13) ' 35
m$ = m$ + " # # # #" + Chr$(13) ' 36
m$ = m$ + " # # # #" + Chr$(13) ' 37
m$ = m$ + " # # # #" + Chr$(13) ' 38
m$ = m$ + " # # # #" + Chr$(13) ' 39
m$ = m$ + " # # # #" + Chr$(13) ' 40
m$ = m$ + " # # # #" + Chr$(13) ' 41
m$ = m$ + " # # # #" + Chr$(13) ' 42
m$ = m$ + " # # # #" + Chr$(13) ' 43
m$ = m$ + " # # # #" + Chr$(13) ' 44
m$ = m$ + " # # # #" + Chr$(13) ' 45
m$ = m$ + " # # # #" + Chr$(13) ' 46
m$ = m$ + "c # # # #" + Chr$(13) ' 47
m$ = m$ + "################################################################################################################################" + Chr$(13) ' 48
' 12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678
' 11111111112222222222333333333344444444445555555555666666666677777777778888888888999999999900000000001111111111222222222
' 11111111111111111111111111111
GetMap$ = m$
End Function ' GetMap$
Function GetMap2$
Dim m$
m$ = ""
' 11111111111111111111111111111
' 11111111112222222222333333333344444444445555555555666666666677777777778888888888999999999900000000001111111111222222222
' 12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678
m$ = m$ + " CONTROLLER #1 # # # #" + Chr$(13) ' 1
m$ = m$ + " UP # # # #" + Chr$(13) ' 2
m$ = m$ + " button dev 10 # # # #" + Chr$(13) ' 3
m$ = m$ + " code 329 rep=Y # # # #" + Chr$(13) ' 4
m$ = m$ + " value -1 # # # #" + Chr$(13) ' 5
m$ = m$ + " LEFT RIGHT # # # #" + Chr$(13) ' 6
m$ = m$ + " button dev 10 button dev 10 # # # #" + Chr$(13) ' 7
m$ = m$ + " code 332 rep=N code 334 rep=N # # # #" + Chr$(13) ' 8
m$ = m$ + " value -1 value -1 # # # #" + Chr$(13) ' 9
m$ = m$ + " DOWN # # # #" + Chr$(13) ' 10
m$ = m$ + " button dev= 10 # # # #" + Chr$(13) ' 11
m$ = m$ + " code 337 rep=Y # # # #" + Chr$(13) ' 12
m$ = m$ + " value= -1 # # # #" + Chr$(13) ' 13
m$ = m$ + " # # # #" + Chr$(13) ' 14
m$ = m$ + " BUTTON #1 BUTTON #3 # # # #" + Chr$(13) ' 15
m$ = m$ + " button dev 1 none dev 0 # # # #" + Chr$(13) ' 16
m$ = m$ + " code 286 rep=N code rep=N # # # #" + Chr$(13) ' 17
m$ = m$ + " value -1 value 0 # # # #" + Chr$(13) ' 18
m$ = m$ + " # # # #" + Chr$(13) ' 19
m$ = m$ + " BUTTON #2 BUTTON #4 # # # #" + Chr$(13) ' 20
m$ = m$ + " none dev 0 none dev 0 # # # #" + Chr$(13) ' 21
m$ = m$ + " code rep=N code rep=N # # # #" + Chr$(13) ' 22
m$ = m$ + " value 0 value 0 # # # #" + Chr$(13) ' 23
m$ = m$ + "################################################################################################################################" + Chr$(13) ' 24
m$ = m$ + " # # # #" + Chr$(13) ' 25
m$ = m$ + " # # # #" + Chr$(13) ' 26
m$ = m$ + " # # # #" + Chr$(13) ' 27
m$ = m$ + " # # # #" + Chr$(13) ' 28
m$ = m$ + " # # # #" + Chr$(13) ' 29
m$ = m$ + " # # # #" + Chr$(13) ' 30
m$ = m$ + " # # # #" + Chr$(13) ' 31
m$ = m$ + " # # # #" + Chr$(13) ' 32
m$ = m$ + " # # # #" + Chr$(13) ' 33
m$ = m$ + " # # # #" + Chr$(13) ' 34
m$ = m$ + " # # # #" + Chr$(13) ' 35
m$ = m$ + " # # # #" + Chr$(13) ' 36
m$ = m$ + " # # # #" + Chr$(13) ' 37
m$ = m$ + " # # # #" + Chr$(13) ' 38
m$ = m$ + " # # # #" + Chr$(13) ' 39
m$ = m$ + " # # # #" + Chr$(13) ' 40
m$ = m$ + " # # # #" + Chr$(13) ' 41
m$ = m$ + " # # # #" + Chr$(13) ' 42
m$ = m$ + " # # # #" + Chr$(13) ' 43
m$ = m$ + " # # # #" + Chr$(13) ' 44
m$ = m$ + " # # # #" + Chr$(13) ' 45
m$ = m$ + " # # # #" + Chr$(13) ' 46
m$ = m$ + " # # # #" + Chr$(13) ' 47
m$ = m$ + "################################################################################################################################" + Chr$(13) ' 48
' 12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678
' 11111111112222222222333333333344444444445555555555666666666677777777778888888888999999999900000000001111111111222222222
' 11111111111111111111111111111
GetMap2$ = m$
End Function ' GetMap2$
Function GetMap1$
Dim m$
m$ = ""
' 11111111111111111111111111111
' 11111111112222222222333333333344444444445555555555666666666677777777778888888888999999999900000000001111111111222222222
' 12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678
m$ = m$ + ".........CONTROLLER.#1.........#...............................#...............................#...............................#" + Chr$(13) ' 1
m$ = m$ + ".............UP................#...............................#...............................#...............................#" + Chr$(13) ' 2
m$ = m$ + "......button.dev..10...........#...............................#...............................#...............................#" + Chr$(13) ' 3
m$ = m$ + "......code.329.rep=Y...........#...............................#...............................#...............................#" + Chr$(13) ' 4
m$ = m$ + "......value.......-1...........#...............................#...............................#...............................#" + Chr$(13) ' 5
m$ = m$ + ".LEFT...........RIGHT..........#...............................#...............................#...............................#" + Chr$(13) ' 6
m$ = m$ + ".button.dev..10.button.dev..10.#...............................#...............................#...............................#" + Chr$(13) ' 7
m$ = m$ + ".code.332.rep=N.code.334.rep=N.#...............................#...............................#...............................#" + Chr$(13) ' 8
m$ = m$ + ".value.......-1.value.......-1.#...............................#...............................#...............................#" + Chr$(13) ' 9
m$ = m$ + "............DOWN...............#...............................#...............................#...............................#" + Chr$(13) ' 10
m$ = m$ + "......button.dev=.10...........#...............................#...............................#...............................#" + Chr$(13) ' 11
m$ = m$ + "......code.337.rep=Y...........#...............................#...............................#...............................#" + Chr$(13) ' 12
m$ = m$ + "......value=......-1...........#...............................#...............................#...............................#" + Chr$(13) ' 13
m$ = m$ + "...............................#...............................#...............................#...............................#" + Chr$(13) ' 14
m$ = m$ + ".BUTTON.#1......BUTTON.#3......#...............................#...............................#...............................#" + Chr$(13) ' 15
m$ = m$ + ".button.dev...1.none...dev...0.#...............................#...............................#...............................#" + Chr$(13) ' 16
m$ = m$ + ".code.286.rep=N.code.....rep=N.#...............................#...............................#...............................#" + Chr$(13) ' 17
m$ = m$ + ".value.......-1.value........0.#...............................#...............................#...............................#" + Chr$(13) ' 18
m$ = m$ + "...............................#...............................#...............................#...............................#" + Chr$(13) ' 19
m$ = m$ + ".BUTTON.#2......BUTTON.#4......#...............................#...............................#...............................#" + Chr$(13) ' 20
m$ = m$ + ".none...dev...0.none...dev...0.#...............................#...............................#...............................#" + Chr$(13) ' 21
m$ = m$ + ".code.....rep=N.code.....rep=N.#...............................#...............................#...............................#" + Chr$(13) ' 22
m$ = m$ + ".value........0.value........0.#...............................#...............................#...............................#" + Chr$(13) ' 23
m$ = m$ + "################################################################################################################################" + Chr$(13) ' 24
m$ = m$ + "...............................#...............................#...............................#...............................#" + Chr$(13) ' 25
m$ = m$ + "...............................#...............................#...............................#...............................#" + Chr$(13) ' 26
m$ = m$ + "...............................#...............................#...............................#...............................#" + Chr$(13) ' 27
m$ = m$ + "...............................#...............................#...............................#...............................#" + Chr$(13) ' 28
m$ = m$ + "...............................#...............................#...............................#...............................#" + Chr$(13) ' 29
m$ = m$ + "...............................#...............................#...............................#...............................#" + Chr$(13) ' 30
m$ = m$ + "...............................#...............................#...............................#...............................#" + Chr$(13) ' 31
m$ = m$ + "...............................#...............................#...............................#...............................#" + Chr$(13) ' 32
m$ = m$ + "...............................#...............................#...............................#...............................#" + Chr$(13) ' 33
m$ = m$ + "...............................#...............................#...............................#...............................#" + Chr$(13) ' 34
m$ = m$ + "...............................#...............................#...............................#...............................#" + Chr$(13) ' 35
m$ = m$ + "...............................#...............................#...............................#...............................#" + Chr$(13) ' 36
m$ = m$ + "...............................#...............................#...............................#...............................#" + Chr$(13) ' 37
m$ = m$ + "...............................#...............................#...............................#...............................#" + Chr$(13) ' 38
m$ = m$ + "...............................#...............................#...............................#...............................#" + Chr$(13) ' 39
m$ = m$ + "...............................#...............................#...............................#...............................#" + Chr$(13) ' 40
m$ = m$ + "...............................#...............................#...............................#...............................#" + Chr$(13) ' 41
m$ = m$ + "...............................#...............................#...............................#...............................#" + Chr$(13) ' 42
m$ = m$ + "...............................#...............................#...............................#...............................#" + Chr$(13) ' 43
m$ = m$ + "...............................#...............................#...............................#...............................#" + Chr$(13) ' 44
m$ = m$ + "...............................#...............................#...............................#...............................#" + Chr$(13) ' 45
m$ = m$ + "...............................#...............................#...............................#...............................#" + Chr$(13) ' 46
m$ = m$ + "...............................#...............................#...............................#...............................#" + Chr$(13) ' 47
m$ = m$ + "################################################################################################################################" + Chr$(13) ' 48
' 12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678
' 11111111112222222222333333333344444444445555555555666666666677777777778888888888999999999900000000001111111111222222222
' 11111111111111111111111111111
GetMap1$ = m$
End Function ' GetMap1$
' /////////////////////////////////////////////////////////////////////////////
Function ArrayToString$ (MyArray( 1 To 32 , 1 To 32) As String)
Dim MyString As String
Dim iY As Integer
Dim iX As Integer
Dim sLine As String
MyString = ""
For iY = LBound(MyArray, 1) To UBound(MyArray, 1)
sLine = ""
For iX = LBound(MyArray, 2) To UBound(MyArray, 2)
sLine = sLine + MyArray(iY, iX)
Next iX
MyString = MyString + sLine + Chr$(13)
Next iY
ArrayToString$ = MyString
End Function ' ArrayToString$
' /////////////////////////////////////////////////////////////////////////////
Function ArrayToStringTest$ (MyArray() As String)
Dim MyString As String
Dim iY As Integer
Dim iX As Integer
Dim sLine As String
MyString = ""
MyString = MyString + " 11111111112222222222333" + Chr$(13)
MyString = MyString + " 12345678901234567890123456789012" + Chr$(13)
For iY = LBound(MyArray, 1) To UBound(MyArray, 1)
sLine = ""
sLine = sLine + Right$(" " + cstr$(iY), 2)
For iX = LBound(MyArray, 2) To UBound(MyArray, 2)
sLine = sLine + MyArray(iY, iX)
Next iX
sLine = sLine + Right$(" " + cstr$(iY), 2)
MyString = MyString + sLine + Chr$(13)
Next iY
MyString = MyString + " 12345678901234567890123456789012" + Chr$(13)
MyString = MyString + " 11111111112222222222333" + Chr$(13)
ArrayToStringTest$ = MyString
End Function ' ArrayToStringTest$
' /////////////////////////////////////////////////////////////////////////////
Sub AddScreenArea (NewValue As ScreenAreaType, MyArray() As ScreenAreaType)
ReDim _Preserve MyArray(1 To UBound(MyArray) + 1) As ScreenAreaType
MyArray(UBound(MyArray)).item = NewValue.item
MyArray(UBound(MyArray)).name = NewValue.name
MyArray(UBound(MyArray)).typ = NewValue.typ
MyArray(UBound(MyArray)).player = NewValue.player
MyArray(UBound(MyArray)).x1 = NewValue.x1
MyArray(UBound(MyArray)).y1 = NewValue.y1
MyArray(UBound(MyArray)).x2 = NewValue.x2
MyArray(UBound(MyArray)).y2 = NewValue.y2
'MyArray(ubound(MyArray)).index = NewValue.index
End Sub ' AddScreenArea
' /////////////////////////////////////////////////////////////////////////////
Sub AddTextButton (NewValue As TextButtonType, MyArray() As TextButtonType)
ReDim _Preserve MyArray(1 To UBound(MyArray) + 1) As TextButtonType
MyArray(UBound(MyArray)).item = NewValue.item
MyArray(UBound(MyArray)).typ = NewValue.typ
MyArray(UBound(MyArray)).x1 = NewValue.x1
MyArray(UBound(MyArray)).y1 = NewValue.y1
MyArray(UBound(MyArray)).x2 = NewValue.x2
MyArray(UBound(MyArray)).y2 = NewValue.y2
'MyArray(ubound(MyArray)).index = NewValue.index
End Sub ' AddTextButton
' /////////////////////////////////////////////////////////////////////////////
Sub AddTextLabel (NewValue As TextLabelType, MyArray() As TextLabelType)
ReDim _Preserve MyArray(1 To UBound(MyArray) + 1) As TextLabelType
MyArray(UBound(MyArray)).item = NewValue.item
MyArray(UBound(MyArray)).name = NewValue.name
MyArray(UBound(MyArray)).row = NewValue.row
MyArray(UBound(MyArray)).column = NewValue.column
MyArray(UBound(MyArray)).width = NewValue.width
MyArray(UBound(MyArray)).justify = NewValue.justify
MyArray(UBound(MyArray)).caption = NewValue.caption
MyArray(UBound(MyArray)).fgcolor = NewValue.fgcolor
MyArray(UBound(MyArray)).bgcolor = NewValue.bgcolor
'MyArray(ubound(MyArray)).index = NewValue.index
End Sub ' AddTextLabel
' /////////////////////////////////////////////////////////////////////////////
Sub AddTextField (NewValue As TextFieldType, MyArray() As TextFieldType)
ReDim _Preserve MyArray(1 To UBound(MyArray) + 1) As TextFieldType
MyArray(UBound(MyArray)).item = NewValue.item
MyArray(UBound(MyArray)).name = NewValue.name
MyArray(UBound(MyArray)).row = NewValue.row
MyArray(UBound(MyArray)).column = NewValue.column
MyArray(UBound(MyArray)).width = NewValue.width
MyArray(UBound(MyArray)).justify = NewValue.justify
MyArray(UBound(MyArray)).value = NewValue.value
MyArray(UBound(MyArray)).fgcolor = NewValue.fgcolor
MyArray(UBound(MyArray)).bgcolor = NewValue.bgcolor
'MyArray(ubound(MyArray)).index = NewValue.index
End Sub ' AddTextField
' /////////////////////////////////////////////////////////////////////////////
Sub SetupScreenAreas
Dim NewScreenArea As ScreenAreaType
Dim x1 As Integer
Dim y1 As Integer
Dim x2 As Integer
Dim y2 As Integer
x1 = 1
y1 = 1
NewScreenArea.item = "Control1"
NewScreenArea.name = "Controller #1"
NewScreenArea.typ = cTextGuiSection
NewScreenArea.player = 1
NewScreenArea.x1 = x1
NewScreenArea.y1 = y1
NewScreenArea.x2 = x1 + 30
NewScreenArea.y2 = y1 + 22
AddScreenArea NewScreenArea, m_arrScreenArea()
x1 = x1 + 32
NewScreenArea.item = "Control2"
NewScreenArea.name = "Controller #2"
NewScreenArea.typ = cTextGuiSection
NewScreenArea.player = 2
NewScreenArea.x1 = x1
NewScreenArea.y1 = y1
NewScreenArea.x2 = x1 + 30
NewScreenArea.y2 = y1 + 22
AddScreenArea NewScreenArea, m_arrScreenArea()
x1 = x1 + 32
NewScreenArea.item = "Control3"
NewScreenArea.name = "Controller #3"
NewScreenArea.typ = cTextGuiSection
NewScreenArea.player = 3
NewScreenArea.x1 = x1
NewScreenArea.y1 = y1
NewScreenArea.x2 = x1 + 30
NewScreenArea.y2 = y1 + 22
AddScreenArea NewScreenArea, m_arrScreenArea()
x1 = x1 + 32
NewScreenArea.item = "Control4"
NewScreenArea.name = "Controller #4"
NewScreenArea.typ = cTextGuiSection
NewScreenArea.player = 4
NewScreenArea.x1 = x1
NewScreenArea.y1 = y1
NewScreenArea.x2 = x1 + 30
NewScreenArea.y2 = y1 + 22
AddScreenArea NewScreenArea, m_arrScreenArea()
x1 = 1
y1 = y1 + 24
NewScreenArea.item = "Control5"
NewScreenArea.name = "Controller #5"
NewScreenArea.typ = cTextGuiSection
NewScreenArea.player = 5
NewScreenArea.x1 = x1
NewScreenArea.y1 = y1
NewScreenArea.x2 = x1 + 30
NewScreenArea.y2 = y1 + 22
AddScreenArea NewScreenArea, m_arrScreenArea()
x1 = x1 + 32
NewScreenArea.item = "Control6"
NewScreenArea.name = "Controller #6"
NewScreenArea.typ = cTextGuiSection
NewScreenArea.player = 6
NewScreenArea.x1 = x1
NewScreenArea.y1 = y1
NewScreenArea.x2 = x1 + 30
NewScreenArea.y2 = y1 + 22
AddScreenArea NewScreenArea, m_arrScreenArea()
x1 = x1 + 32
NewScreenArea.item = "Control7"
NewScreenArea.name = "Controller #7"
NewScreenArea.typ = cTextGuiSection
NewScreenArea.player = 7
NewScreenArea.x1 = x1
NewScreenArea.y1 = y1
NewScreenArea.x2 = x1 + 30
NewScreenArea.y2 = y1 + 22
AddScreenArea NewScreenArea, m_arrScreenArea()
x1 = x1 + 32
NewScreenArea.item = "Control8"
NewScreenArea.name = "Controller #8"
NewScreenArea.typ = cTextGuiSection
NewScreenArea.player = 8
NewScreenArea.x1 = x1
NewScreenArea.y1 = y1
NewScreenArea.x2 = x1 + 30
NewScreenArea.y2 = y1 + 22
AddScreenArea NewScreenArea, m_arrScreenArea()
End Sub ' SetupScreenAreas
' /////////////////////////////////////////////////////////////////////////////
Sub SetupButtons
Dim NewTextButton As TextButtonType
NewTextButton.item = "Up"
NewTextButton.typ = cInputUp ' cInputUp, cInputDown, cInputLeft, cInputRight, cInputButton1, cInputButton2, cInputButton3, cInputButton4
NewTextButton.x1 = 9
NewTextButton.y1 = 2
NewTextButton.x2 = 22
NewTextButton.y2 = 5
AddTextButton NewTextButton, m_arrButton()
NewTextButton.item = "Down"
NewTextButton.typ = cInputDown ' cInputUp, cInputDown, cInputLeft, cInputRight, cInputButton1, cInputButton2, cInputButton3, cInputButton4
NewTextButton.x1 = 9
NewTextButton.y1 = 10
NewTextButton.x2 = 22
NewTextButton.y2 = 13
AddTextButton NewTextButton, m_arrButton()
NewTextButton.item = "Left"
NewTextButton.typ = cInputLeft ' cInputUp, cInputDown, cInputLeft, cInputRight, cInputButton1, cInputButton2, cInputButton3, cInputButton4
NewTextButton.x1 = 2
NewTextButton.y1 = 6
NewTextButton.x2 = 15
NewTextButton.y2 = 9
AddTextButton NewTextButton, m_arrButton()
NewTextButton.item = "Right"
NewTextButton.typ = cInputRight ' cInputUp, cInputDown, cInputLeft, cInputRight, cInputButton1, cInputButton2, cInputButton3, cInputButton4
NewTextButton.x1 = 17
NewTextButton.y1 = 6
NewTextButton.x2 = 30
NewTextButton.y2 = 9
AddTextButton NewTextButton, m_arrButton()
NewTextButton.item = "Button1"
NewTextButton.typ = cInputButton1 ' cInputUp, cInputDown, cInputLeft, cInputRight, cInputButton1, cInputButton2, cInputButton3, cInputButton4
NewTextButton.x1 = 2
NewTextButton.y1 = 15
NewTextButton.x2 = 15
NewTextButton.y2 = 18
AddTextButton NewTextButton, m_arrButton()
NewTextButton.item = "Button2"
NewTextButton.typ = cInputButton2 ' cInputUp, cInputDown, cInputLeft, cInputRight, cInputButton1, cInputButton2, cInputButton3, cInputButton4
NewTextButton.x1 = 2
NewTextButton.y1 = 20
NewTextButton.x2 = 15
NewTextButton.y2 = 23
AddTextButton NewTextButton, m_arrButton()
NewTextButton.item = "Button3"
NewTextButton.typ = cInputButton3 ' cInputUp, cInputDown, cInputLeft, cInputRight, cInputButton1, cInputButton2, cInputButton3, cInputButton4
NewTextButton.x1 = 17
NewTextButton.y1 = 15
NewTextButton.x2 = 30
NewTextButton.y2 = 18
AddTextButton NewTextButton, m_arrButton()
NewTextButton.item = "Button4"
NewTextButton.typ = cInputButton4 ' cInputUp, cInputDown, cInputLeft, cInputRight, cInputButton1, cInputButton2, cInputButton3, cInputButton4
NewTextButton.x1 = 17
NewTextButton.y1 = 20
NewTextButton.x2 = 30
NewTextButton.y2 = 23
AddTextButton NewTextButton, m_arrButton()
End Sub ' SetupButtons
' /////////////////////////////////////////////////////////////////////////////
Sub SetupTextLabels
Dim NewLabel As TextLabelType
' -----------------------------------------------------------------------------
NewLabel.item = "Section"
NewLabel.name = "caption"
NewLabel.row = 1
NewLabel.column = 1
NewLabel.width = 31
NewLabel.justify = cJustifyCenter
NewLabel.caption = "CONTROLLER #{p}"
NewLabel.fgcolor = cCyan
NewLabel.bgcolor = cBlack
AddTextLabel NewLabel, m_arrTextLabel()
' -----------------------------------------------------------------------------
NewLabel.item = "Up"
NewLabel.name = "caption"
NewLabel.row = 2
NewLabel.column = 9
NewLabel.width = 14
NewLabel.justify = cJustifyCenter
NewLabel.caption = "UP"
NewLabel.fgcolor = cYellow
NewLabel.bgcolor = cRed
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Up"
NewLabel.name = "type"
NewLabel.row = 3
NewLabel.column = 0
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = ""
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cRed
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Up"
NewLabel.name = "device"
NewLabel.row = 3
NewLabel.column = 16
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = "dev "
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cRed
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Up"
NewLabel.name = "code"
NewLabel.row = 4
NewLabel.column = 9
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = "code "
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cRed
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Up"
NewLabel.name = "repeat"
NewLabel.row = 4
NewLabel.column = 17
NewLabel.width = -1
NewLabel.justify = cJustifyNone
NewLabel.caption = " rep="
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cRed
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Up"
NewLabel.name = "value"
NewLabel.row = 5
NewLabel.column = 9
NewLabel.width = -1
NewLabel.justify = cJustifyNone
NewLabel.caption = "value "
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cRed
AddTextLabel NewLabel, m_arrTextLabel()
' -----------------------------------------------------------------------------
NewLabel.item = "Down"
NewLabel.name = "caption"
NewLabel.row = 10
NewLabel.column = 9
NewLabel.width = 14
NewLabel.justify = cJustifyCenter
NewLabel.caption = "DOWN"
NewLabel.fgcolor = cYellow
NewLabel.bgcolor = cGreen
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Down"
NewLabel.name = "type"
NewLabel.row = 11
NewLabel.column = 0
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = ""
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cGreen
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Down"
NewLabel.name = "device"
NewLabel.row = 11
NewLabel.column = 16
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = "dev "
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cGreen
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Down"
NewLabel.name = "code"
NewLabel.row = 12
NewLabel.column = 9
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = "code "
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cGreen
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Down"
NewLabel.name = "repeat"
NewLabel.row = 12
NewLabel.column = 17
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = " rep="
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cGreen
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Down"
NewLabel.name = "value"
NewLabel.row = 13
NewLabel.column = 9
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = "value "
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cGreen
AddTextLabel NewLabel, m_arrTextLabel()
' -----------------------------------------------------------------------------
NewLabel.item = "Left"
NewLabel.name = "caption"
NewLabel.row = 6
NewLabel.column = 2
NewLabel.width = 14
NewLabel.justify = cJustifyCenter
NewLabel.caption = "LEFT"
NewLabel.fgcolor = cYellow
NewLabel.bgcolor = cBlue
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Left"
NewLabel.name = "type"
NewLabel.row = 7
NewLabel.column = 0
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = ""
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cBlue
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Left"
NewLabel.name = "device"
NewLabel.row = 7
NewLabel.column = 9
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = "dev "
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cBlue
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Left"
NewLabel.name = "code"
NewLabel.row = 8
NewLabel.column = 2
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = "code "
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cBlue
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Left"
NewLabel.name = "repeat"
NewLabel.row = 8
NewLabel.column = 10
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = " rep="
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cBlue
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Left"
NewLabel.name = "value"
NewLabel.row = 9
NewLabel.column = 2
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = "value "
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cBlue
AddTextLabel NewLabel, m_arrTextLabel()
' -----------------------------------------------------------------------------
NewLabel.item = "Right"
NewLabel.name = "caption"
NewLabel.row = 6
NewLabel.column = 17
NewLabel.width = 14
NewLabel.justify = cJustifyCenter
NewLabel.caption = "RIGHT"
NewLabel.fgcolor = cYellow
NewLabel.bgcolor = cOrange
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Right"
NewLabel.name = "type"
NewLabel.row = 7
NewLabel.column = 0
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = ""
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cOrange
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Right"
NewLabel.name = "device"
NewLabel.row = 7
NewLabel.column = 24
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = "dev "
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cOrange
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Right"
NewLabel.name = "code"
NewLabel.row = 8
NewLabel.column = 17
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = "code "
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cOrange
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Right"
NewLabel.name = "repeat"
NewLabel.row = 8
NewLabel.column = 25
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = " rep="
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cOrange
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Right"
NewLabel.name = "value"
NewLabel.row = 9
NewLabel.column = 17
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = "value "
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cOrange
AddTextLabel NewLabel, m_arrTextLabel()
' -----------------------------------------------------------------------------
NewLabel.item = "Button1"
NewLabel.name = "caption"
NewLabel.row = 15
NewLabel.column = 2
NewLabel.width = 14
NewLabel.justify = cJustifyCenter
NewLabel.caption = "BUTTON #1"
NewLabel.fgcolor = cYellow
NewLabel.bgcolor = cRed
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Button1"
NewLabel.name = "type"
NewLabel.row = 16
NewLabel.column = 0
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = ""
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cRed
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Button1"
NewLabel.name = "device"
NewLabel.row = 16
NewLabel.column = 9
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = "dev "
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cRed
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Button1"
NewLabel.name = "code"
NewLabel.row = 17
NewLabel.column = 2
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = "code "
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cRed
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Button1"
NewLabel.name = "repeat"
NewLabel.row = 17
NewLabel.column = 10
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = " rep="
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cRed
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Button1"
NewLabel.name = "value"
NewLabel.row = 18
NewLabel.column = 2
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = "value "
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cRed
AddTextLabel NewLabel, m_arrTextLabel()
' -----------------------------------------------------------------------------
NewLabel.item = "Button2"
NewLabel.name = "caption"
NewLabel.row = 20
NewLabel.column = 2
NewLabel.width = 14
NewLabel.justify = cJustifyCenter
NewLabel.caption = "BUTTON #2"
NewLabel.fgcolor = cYellow
NewLabel.bgcolor = cGreen
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Button2"
NewLabel.name = "type"
NewLabel.row = 21
NewLabel.column = 0
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = ""
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cGreen
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Button2"
NewLabel.name = "device"
NewLabel.row = 21
NewLabel.column = 9
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = "dev "
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cGreen
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Button2"
NewLabel.name = "code"
NewLabel.row = 22
NewLabel.column = 2
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = "code "
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cGreen
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Button2"
NewLabel.name = "repeat"
NewLabel.row = 22
NewLabel.column = 10
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = " rep="
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cGreen
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Button2"
NewLabel.name = "value"
NewLabel.row = 23
NewLabel.column = 2
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = "value "
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cGreen
AddTextLabel NewLabel, m_arrTextLabel()
' -----------------------------------------------------------------------------
NewLabel.item = "Button3"
NewLabel.name = "caption"
NewLabel.row = 15
NewLabel.column = 17
NewLabel.width = 14
NewLabel.justify = cJustifyCenter
NewLabel.caption = "BUTTON #3"
NewLabel.fgcolor = cYellow
NewLabel.bgcolor = cBlue
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Button3"
NewLabel.name = "type"
NewLabel.row = 16
NewLabel.column = 0
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = ""
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cBlue
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Button3"
NewLabel.name = "device"
NewLabel.row = 16
NewLabel.column = 24
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = "dev "
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cBlue
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Button3"
NewLabel.name = "code"
NewLabel.row = 17
NewLabel.column = 17
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = "code "
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cBlue
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Button3"
NewLabel.name = "repeat"
NewLabel.row = 17
NewLabel.column = 25
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = " rep="
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cBlue
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Button3"
NewLabel.name = "value"
NewLabel.row = 18
NewLabel.column = 17
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = "value "
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cBlue
AddTextLabel NewLabel, m_arrTextLabel()
' -----------------------------------------------------------------------------
NewLabel.item = "Button4"
NewLabel.name = "caption"
NewLabel.row = 20
NewLabel.column = 17
NewLabel.width = 14
NewLabel.justify = cJustifyCenter
NewLabel.caption = "BUTTON #4"
NewLabel.fgcolor = cYellow
NewLabel.bgcolor = cOrange
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Button4"
NewLabel.name = "type"
NewLabel.row = 21
NewLabel.column = 0
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = ""
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cOrange
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Button4"
NewLabel.name = "device"
NewLabel.row = 21
NewLabel.column = 24
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = "dev "
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cOrange
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Button4"
NewLabel.name = "code"
NewLabel.row = 22
NewLabel.column = 17
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = "code "
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cOrange
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Button4"
NewLabel.name = "repeat"
NewLabel.row = 22
NewLabel.column = 25
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = " rep="
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cOrange
AddTextLabel NewLabel, m_arrTextLabel()
NewLabel.item = "Button4"
NewLabel.name = "value"
NewLabel.row = 23
NewLabel.column = 17
NewLabel.width = -1
NewLabel.justify = cJustifyLeft
NewLabel.caption = "value "
NewLabel.fgcolor = cBlack
NewLabel.bgcolor = cOrange
AddTextLabel NewLabel, m_arrTextLabel()
End Sub ' SetupTextLabels
' /////////////////////////////////////////////////////////////////////////////
Sub SetupTextFields
Dim NewField As TextFieldType
' -----------------------------------------------------------------------------
NewField.item = "Up"
NewField.name = "type"
NewField.row = 3
NewField.column = 9
NewField.width = 7
NewField.justify = cJustifyLeft
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cRed
AddTextField NewField, m_arrTextField()
NewField.item = "Up"
NewField.name = "device"
NewField.row = 3
NewField.column = 20
NewField.width = 3
NewField.justify = cJustifyRight
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cRed
AddTextField NewField, m_arrTextField()
NewField.item = "Up"
NewField.name = "code"
NewField.row = 4
NewField.column = 14
NewField.width = 3
NewField.justify = cJustifyLeft
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cRed
AddTextField NewField, m_arrTextField()
NewField.item = "Up"
NewField.name = "repeat"
NewField.row = 4
NewField.column = 22
NewField.width = 1
NewField.justify = cJustifyLeft
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cRed
AddTextField NewField, m_arrTextField()
NewField.item = "Up"
NewField.name = "value"
NewField.row = 5
NewField.column = 16
NewField.width = 7
NewField.justify = cJustifyRight
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cRed
AddTextField NewField, m_arrTextField()
' -----------------------------------------------------------------------------
NewField.item = "Down"
NewField.name = "type"
NewField.row = 11
NewField.column = 9
NewField.width = 7
NewField.justify = cJustifyLeft
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cGreen
AddTextField NewField, m_arrTextField()
NewField.item = "Down"
NewField.name = "device"
NewField.row = 11
NewField.column = 20
NewField.width = 3
NewField.justify = cJustifyRight
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cGreen
AddTextField NewField, m_arrTextField()
NewField.item = "Down"
NewField.name = "code"
NewField.row = 12
NewField.column = 14
NewField.width = 3
NewField.justify = cJustifyLeft
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cGreen
AddTextField NewField, m_arrTextField()
NewField.item = "Down"
NewField.name = "repeat"
NewField.row = 12
NewField.column = 22
NewField.width = 1
NewField.justify = cJustifyLeft
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cGreen
AddTextField NewField, m_arrTextField()
NewField.item = "Down"
NewField.name = "value"
NewField.row = 13
NewField.column = 16
NewField.width = 7
NewField.justify = cJustifyRight
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cGreen
AddTextField NewField, m_arrTextField()
' -----------------------------------------------------------------------------
NewField.item = "Left"
NewField.name = "type"
NewField.row = 7
NewField.column = 2
NewField.width = 7
NewField.justify = cJustifyLeft
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cBlue
AddTextField NewField, m_arrTextField()
NewField.item = "Left"
NewField.name = "device"
NewField.row = 7
NewField.column = 13
NewField.width = 3
NewField.justify = cJustifyRight
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cBlue
AddTextField NewField, m_arrTextField()
NewField.item = "Left"
NewField.name = "code"
NewField.row = 8
NewField.column = 7
NewField.width = 3
NewField.justify = cJustifyLeft
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cBlue
AddTextField NewField, m_arrTextField()
NewField.item = "Left"
NewField.name = "repeat"
NewField.row = 8
NewField.column = 15
NewField.width = 1
NewField.justify = cJustifyLeft
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cBlue
AddTextField NewField, m_arrTextField()
NewField.item = "Left"
NewField.name = "value"
NewField.row = 9
NewField.column = 9
NewField.width = 7
NewField.justify = cJustifyRight
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cBlue
AddTextField NewField, m_arrTextField()
' -----------------------------------------------------------------------------
NewField.item = "Right"
NewField.name = "type"
NewField.row = 7
NewField.column = 17
NewField.width = 7
NewField.justify = cJustifyLeft
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cOrange
AddTextField NewField, m_arrTextField()
NewField.item = "Right"
NewField.name = "device"
NewField.row = 7
NewField.column = 28
NewField.width = 3
NewField.justify = cJustifyRight
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cOrange
AddTextField NewField, m_arrTextField()
NewField.item = "Right"
NewField.name = "code"
NewField.row = 8
NewField.column = 22
NewField.width = 3
NewField.justify = cJustifyLeft
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cOrange
AddTextField NewField, m_arrTextField()
NewField.item = "Right"
NewField.name = "repeat"
NewField.row = 8
NewField.column = 30
NewField.width = 1
NewField.justify = cJustifyLeft
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cOrange
AddTextField NewField, m_arrTextField()
NewField.item = "Right"
NewField.name = "value"
NewField.row = 9
NewField.column = 24
NewField.width = 7
NewField.justify = cJustifyRight
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cOrange
AddTextField NewField, m_arrTextField()
' -----------------------------------------------------------------------------
NewField.item = "Button1"
NewField.name = "type"
NewField.row = 16
NewField.column = 2
NewField.width = 7
NewField.justify = cJustifyLeft
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cRed
AddTextField NewField, m_arrTextField()
NewField.item = "Button1"
NewField.name = "device"
NewField.row = 16
NewField.column = 13
NewField.width = 3
NewField.justify = cJustifyRight
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cRed
AddTextField NewField, m_arrTextField()
NewField.item = "Button1"
NewField.name = "code"
NewField.row = 17
NewField.column = 7
NewField.width = 3
NewField.justify = cJustifyLeft
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cRed
AddTextField NewField, m_arrTextField()
NewField.item = "Button1"
NewField.name = "repeat"
NewField.row = 17
NewField.column = 15
NewField.width = 1
NewField.justify = cJustifyLeft
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cRed
AddTextField NewField, m_arrTextField()
NewField.item = "Button1"
NewField.name = "value"
NewField.row = 18
NewField.column = 9
NewField.width = 7
NewField.justify = cJustifyRight
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cRed
AddTextField NewField, m_arrTextField()
' -----------------------------------------------------------------------------
NewField.item = "Button2"
NewField.name = "type"
NewField.row = 21
NewField.column = 2
NewField.width = 7
NewField.justify = cJustifyLeft
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cGreen
AddTextField NewField, m_arrTextField()
NewField.item = "Button2"
NewField.name = "device"
NewField.row = 21
NewField.column = 13
NewField.width = 3
NewField.justify = cJustifyRight
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cGreen
AddTextField NewField, m_arrTextField()
NewField.item = "Button2"
NewField.name = "code"
NewField.row = 22
NewField.column = 7
NewField.width = 3
NewField.justify = cJustifyLeft
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cGreen
AddTextField NewField, m_arrTextField()
NewField.item = "Button2"
NewField.name = "repeat"
NewField.row = 22
NewField.column = 15
NewField.width = 1
NewField.justify = cJustifyLeft
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cGreen
AddTextField NewField, m_arrTextField()
NewField.item = "Button2"
NewField.name = "value"
NewField.row = 23
NewField.column = 9
NewField.width = 7
NewField.justify = cJustifyRight
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cGreen
AddTextField NewField, m_arrTextField()
' -----------------------------------------------------------------------------
NewField.item = "Button3"
NewField.name = "type"
NewField.row = 16
NewField.column = 17
NewField.width = 7
NewField.justify = cJustifyLeft
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cBlue
AddTextField NewField, m_arrTextField()
NewField.item = "Button3"
NewField.name = "device"
NewField.row = 16
NewField.column = 28
NewField.width = 3
NewField.justify = cJustifyRight
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cBlue
AddTextField NewField, m_arrTextField()
NewField.item = "Button3"
NewField.name = "code"
NewField.row = 17
NewField.column = 22
NewField.width = 3
NewField.justify = cJustifyLeft
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cBlue
AddTextField NewField, m_arrTextField()
NewField.item = "Button3"
NewField.name = "repeat"
NewField.row = 17
NewField.column = 30
NewField.width = 1
NewField.justify = cJustifyLeft
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cBlue
AddTextField NewField, m_arrTextField()
NewField.item = "Button3"
NewField.name = "value"
NewField.row = 18
NewField.column = 24
NewField.width = 7
NewField.justify = cJustifyRight
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cBlue
AddTextField NewField, m_arrTextField()
' -----------------------------------------------------------------------------
NewField.item = "Button4"
NewField.name = "type"
NewField.row = 21
NewField.column = 17
NewField.width = 7
NewField.justify = cJustifyLeft
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cOrange
AddTextField NewField, m_arrTextField()
NewField.item = "Button4"
NewField.name = "device"
NewField.row = 21
NewField.column = 28
NewField.width = 3
NewField.justify = cJustifyRight
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cOrange
AddTextField NewField, m_arrTextField()
NewField.item = "Button4"
NewField.name = "code"
NewField.row = 22
NewField.column = 22
NewField.width = 3
NewField.justify = cJustifyLeft
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cOrange
AddTextField NewField, m_arrTextField()
NewField.item = "Button4"
NewField.name = "repeat"
NewField.row = 22
NewField.column = 30
NewField.width = 1
NewField.justify = cJustifyLeft
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cOrange
AddTextField NewField, m_arrTextField()
NewField.item = "Button4"
NewField.name = "value"
NewField.row = 23
NewField.column = 24
NewField.width = 7
NewField.justify = cJustifyRight
NewField.value = ""
NewField.fgcolor = cWhite
NewField.bgcolor = cOrange
AddTextField NewField, m_arrTextField()
End Sub ' SetupTextFields
' /////////////////////////////////////////////////////////////////////////////
' Looks in MyArray for the first element
' whose .item matches sItem and .name matches sName
' and returns the index, or MyArray's lbound-1 if not found.
Function GetTextLabel% (MyArray() As TextLabelType, sItem As String, sName As String)
Dim iResult As Integer: iResult = LBound(MyArray) - 1
Dim iLoop As Integer
For iLoop = LBound(MyArray) To UBound(MyArray)
If MyArray(iLoop).item = sItem Then
If MyArray(iLoop).name = sName Then
iResult = iLoop
Exit For
End If
End If
Next iLoop
GetTextLabel% = iResult
End Function ' GetTextLabel%
' /////////////////////////////////////////////////////////////////////////////
' Looks in MyArray for the first element
' whose .item matches sItem and .name matches sName
' and returns the index, or MyArray's lbound-1 if not found.
Function GetTextField% (MyArray() As TextFieldType, sItem As String, sName As String)
Dim iResult As Integer: iResult = LBound(MyArray) - 1
Dim iLoop As Integer
For iLoop = LBound(MyArray) To UBound(MyArray)
If MyArray(iLoop).item = sItem Then
If MyArray(iLoop).name = sName Then
iResult = iLoop
Exit For
End If
End If
Next iLoop
GetTextField% = iResult
End Function ' GetTextField%
' /////////////////////////////////////////////////////////////////////////////
' The following must be initialized and populated before calling:
' ReDim arrColor(-1) As ColorType
' Dim MapArray(1 To 48, 1 To 128) As String ' FOR SCREEN 1024 x 768: 128 x 48
' ReDim ScreenArray(1 To 48, 1 To 128) As TextCellType ' FOR SCREEN 1024 x 768: 128 x 48
' This was an experiment in rolling your own "GUI",
' - what a pain it turned out to be
' - next time maybe we would use InForm and be done with it!
' TODO:
' * clean up and remove all the variable definitions left over
' from the main routine MapInput2$ this was moved out of.
Sub UpdateDisplayMapInput2( _
arrColor() As ColorType, _
MapArray() As String, _
ScreenArray() As TextCellType _
)
Dim RoutineName As String: RoutineName = "UpdateDisplayMapInput2"
Dim iDeviceCount As Integer ' count # of devices connected to system (keyboard, mouse, game controllers)
Dim iPlayer As Integer ' same as iController, which of the 8 controllers
Dim iWhichInput As Integer ' one of: cInputUp, cInputDown, cInputLeft, cInputRight, cInputButton1, cInputButton2, cInputButton3, cInputButton4
Dim iCount As Integer
Dim sResult As String
Dim sError As String
Dim sLine As String
Dim iForeColor As Integer
Dim iBackColor As Integer
Dim sName As String
Dim sItem As String
Dim iLoop As Integer
Dim iX As Integer
Dim iY As Integer
Dim iCol As Integer
Dim iRow As Integer
Dim iStartX As Integer
Dim iStartY As Integer
Dim iEndX As Integer
Dim iEndY As Integer
Dim iLabel As Integer
Dim iField As Integer
Dim iButton As Integer
Dim iWidth As Integer
Dim bContinue As Integer
Dim sValue As String
Dim iNextWidth As Integer
Dim iType As Integer
Dim iIndex As Integer
Dim in$
' MOUSE VARIABLES
Dim iX1 As Integer: iX1 = 0
Dim iY1 As Integer: iY1 = 0
Dim iOldX1 As Integer: iOldX1 = 0
Dim iOldY1 As Integer: iOldY1 = 0
Dim bLeftClick As Integer: bLeftClick = FALSE
Dim bOldLeftClick As Integer: bOldLeftClick = FALSE
Dim sZone1 As String ' text description of which controller
Dim sZone2 As String ' text description of which input
Dim iMapPlayer As Integer ' like iController, which of the 8 controllers
' WHICH PORTION OF THE SCREEN USER CLICKED ON
Dim iTempX As Integer
Dim iTempY As Integer
Dim iTextX As Integer
Dim iTextY As Integer
Dim iOffsetX As Integer
Dim iOffsetY As Integer
' BOUNDARIES OF BUTTON CLICKED ON
Dim iMapX1 As Integer
Dim iMapX2 As Integer
Dim iMapY1 As Integer
Dim iMapY2 As Integer
' FOR MAPPING CONTROLLER INPUT
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 iPlayer As Integer
Dim iController As Integer ' to loop through devices
Dim iDevice As Integer
Dim iValue As Integer
Dim bMoveNext As Integer
'Dim iLoop As Integer
Dim iCode As Integer
Dim bHaveInput As Integer
'Dim iWhichInput As Integer
Dim iNextInput As Integer
Dim sPrompt As String
Dim dblNextAxis As Double
Dim ExitX As Integer
Dim ExitY As Integer
' DISPLAY BORDERS
Cls
For iRow = LBound(MapArray, 1) To UBound(MapArray, 1)
For iCol = LBound(MapArray, 2) To UBound(MapArray, 2)
Color cRed, cBlack
PrintString2 iRow, iCol, MapArray(iRow, iCol), ScreenArray()
Next iCol
Next iRow
' DISPLAY CONTROL MAPPINGS
For iPlayer = LBound(m_arrControlMap, 1) To UBound(m_arrControlMap, 1)
' Get top left screen coordinates for this controller
iStartX = m_arrScreenArea(iPlayer).x1
iStartY = m_arrScreenArea(iPlayer).y1
iEndX = m_arrScreenArea(iPlayer).x2
iEndY = m_arrScreenArea(iPlayer).y2
iWidth = (iEndX - iStartX) + 1
sItem = "Section"
iIndex = GetTextLabel%(m_arrTextLabel(), sItem, "caption")
If iIndex >= LBound(m_arrTextLabel) Then
iRow = (iStartY + m_arrTextLabel(iIndex).row) - 1
iCol = (iStartX + m_arrTextLabel(iIndex).column) - 1
sValue = m_arrTextLabel(iIndex).caption
sValue = Replace$(sValue, "{p}", cstr$(iPlayer))
iNextWidth = m_arrTextLabel(iIndex).width
If iNextWidth > 0 Then
Select Case m_arrTextLabel(iIndex).justify
Case cJustifyLeft:
sValue = StrJustifyLeft$(sValue, iNextWidth)
Case cJustifyRight:
sValue = StrJustifyRight$(sValue, iNextWidth)
Case cJustifyCenter:
sValue = StrJustifyCenter$(sValue, iNextWidth)
Case Else:
' (DO NOTHING)
End Select
Color m_arrTextLabel(iIndex).fgcolor, m_arrTextLabel(iIndex).bgcolor
PrintString2 iRow, iCol, sValue, ScreenArray()
ElseIf iNextWidth < 0 Then
Color m_arrTextLabel(iIndex).fgcolor, m_arrTextLabel(iIndex).bgcolor
PrintString2 iRow, iCol, sValue, ScreenArray()
Else
' (IGNORE)
End If
End If
' POPULATE EACH INPUT FOR THIS PLAYER/CONTROLLER:
' up,down,left,right,button #1,button #2,button #3,button #4
' iWhichInput is one of: cInputUp, cInputDown, cInputLeft, cInputRight, cInputButton1, cInputButton2, cInputButton3, cInputButton4
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
' +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN ITEM
' get value to match against m_arrTextField(iField).item
sItem = InputToItem$(iWhichInput)
'InputToString$(iWhichInput) returns up,down,left,right,button #1,button #2,button #3,button #4
' find the layout for each field for this input
' m_arrTextField(iField).name = type,device,code,repeat,value
' END ITEM
' +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN CAPTION
' LABEL
iIndex = GetTextLabel%(m_arrTextLabel(), sItem, "caption")
If iIndex >= LBound(m_arrTextLabel) Then
iRow = (iStartY + m_arrTextLabel(iIndex).row) - 1
iCol = (iStartX + m_arrTextLabel(iIndex).column) - 1
sValue = m_arrTextLabel(iIndex).caption
sValue = Replace$(sValue, "{p}", cstr$(iPlayer))
iNextWidth = m_arrTextLabel(iIndex).width
If iNextWidth > 0 Then
Select Case m_arrTextLabel(iIndex).justify
Case cJustifyLeft:
sValue = StrJustifyLeft$(sValue, iNextWidth)
Case cJustifyRight:
sValue = StrJustifyRight$(sValue, iNextWidth)
Case cJustifyCenter:
sValue = StrJustifyCenter$(sValue, iNextWidth)
Case Else:
' (DO NOTHING)
End Select
Color m_arrTextLabel(iIndex).fgcolor, m_arrTextLabel(iIndex).bgcolor
PrintString2 iRow, iCol, sValue, ScreenArray()
ElseIf iNextWidth < 0 Then
Color m_arrTextLabel(iIndex).fgcolor, m_arrTextLabel(iIndex).bgcolor
PrintString2 iRow, iCol, sValue, ScreenArray()
Else
' (IGNORE)
End If
End If
' END CAPTION
' +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN TYPE
' values are cInputNone,cInputKey,cInputButton,cInputAxis
' InputTypeToString$ returns none,key,button,axis,unknown
' VALUE
iIndex = GetTextField%(m_arrTextField(), sItem, "type")
If iIndex >= LBound(m_arrTextField) Then
iRow = (iStartY + m_arrTextField(iIndex).row) - 1
iCol = (iStartX + m_arrTextField(iIndex).column) - 1
sValue = InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ)
iNextWidth = m_arrTextField(iIndex).width
Select Case m_arrTextField(iIndex).justify
Case cJustifyLeft:
sValue = StrJustifyLeft$(sValue, iNextWidth)
Case cJustifyRight:
sValue = StrJustifyRight$(sValue, iNextWidth)
Case cJustifyCenter:
sValue = StrJustifyCenter$(sValue, iNextWidth)
Case Else:
' (DO NOTHING)
End Select
Color m_arrTextField(iIndex).fgcolor, m_arrTextField(iIndex).bgcolor
PrintString2 iRow, iCol, sValue, ScreenArray()
End If
' LABEL
iIndex = GetTextLabel%(m_arrTextLabel(), sItem, "type")
If iIndex >= LBound(m_arrTextLabel) Then
iRow = (iStartY + m_arrTextLabel(iIndex).row) - 1
iCol = (iStartX + m_arrTextLabel(iIndex).column) - 1
sValue = m_arrTextLabel(iIndex).caption
sValue = Replace$(sValue, "{p}", cstr$(iPlayer))
iNextWidth = m_arrTextLabel(iIndex).width
If iNextWidth > 0 Then
Select Case m_arrTextLabel(iIndex).justify
Case cJustifyLeft:
sValue = StrJustifyLeft$(sValue, iNextWidth)
Case cJustifyRight:
sValue = StrJustifyRight$(sValue, iNextWidth)
Case cJustifyCenter:
sValue = StrJustifyCenter$(sValue, iNextWidth)
Case Else:
' (DO NOTHING)
End Select
Color m_arrTextLabel(iIndex).fgcolor, m_arrTextLabel(iIndex).bgcolor
PrintString2 iRow, iCol, sValue, ScreenArray()
ElseIf iNextWidth < 0 Then
Color m_arrTextLabel(iIndex).fgcolor, m_arrTextLabel(iIndex).bgcolor
PrintString2 iRow, iCol, sValue, ScreenArray()
Else
' (IGNORE)
End If
End If
' END TYPE
' +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN DEVICE
' VALUE
iIndex = GetTextField%(m_arrTextField(), sItem, "device")
If iIndex >= LBound(m_arrTextField) Then
iRow = (iStartY + m_arrTextField(iIndex).row) - 1
iCol = (iStartX + m_arrTextField(iIndex).column) - 1
sValue = cstr$(m_arrControlMap(iPlayer, iWhichInput).device)
iNextWidth = m_arrTextField(iIndex).width
Select Case m_arrTextField(iIndex).justify
Case cJustifyLeft:
sValue = StrJustifyLeft$(sValue, iNextWidth)
Case cJustifyRight:
sValue = StrJustifyRight$(sValue, iNextWidth)
Case cJustifyCenter:
sValue = StrJustifyCenter$(sValue, iNextWidth)
Case Else:
' (DO NOTHING)
End Select
Color m_arrTextField(iIndex).fgcolor, m_arrTextField(iIndex).bgcolor
PrintString2 iRow, iCol, sValue, ScreenArray()
End If
' LABEL
iIndex = GetTextLabel%(m_arrTextLabel(), sItem, "device")
If iIndex >= LBound(m_arrTextLabel) Then
iRow = (iStartY + m_arrTextLabel(iIndex).row) - 1
iCol = (iStartX + m_arrTextLabel(iIndex).column) - 1
sValue = m_arrTextLabel(iIndex).caption
sValue = Replace$(sValue, "{p}", cstr$(iPlayer))
iNextWidth = m_arrTextLabel(iIndex).width
If iNextWidth > 0 Then
Select Case m_arrTextLabel(iIndex).justify
Case cJustifyLeft:
sValue = StrJustifyLeft$(sValue, iNextWidth)
Case cJustifyRight:
sValue = StrJustifyRight$(sValue, iNextWidth)
Case cJustifyCenter:
sValue = StrJustifyCenter$(sValue, iNextWidth)
Case Else:
' (DO NOTHING)
End Select
Color m_arrTextLabel(iIndex).fgcolor, m_arrTextLabel(iIndex).bgcolor
PrintString2 iRow, iCol, sValue, ScreenArray()
ElseIf iNextWidth < 0 Then
Color m_arrTextLabel(iIndex).fgcolor, m_arrTextLabel(iIndex).bgcolor
PrintString2 iRow, iCol, sValue, ScreenArray()
Else
' (IGNORE)
End If
End If
' END DEVICE
' +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN CODE
' VALUE
iIndex = GetTextField%(m_arrTextField(), sItem, "code")
If iIndex >= LBound(m_arrTextField) Then
iRow = (iStartY + m_arrTextField(iIndex).row) - 1
iCol = (iStartX + m_arrTextField(iIndex).column) - 1
If m_arrControlMap(iPlayer, iWhichInput).typ = cInputKey Then
sValue = GetKeyboardButtonCodeText$(m_arrControlMap(iPlayer, iWhichInput).code)
Else
sValue = cstr$(m_arrControlMap(iPlayer, iWhichInput).code)
End If
iNextWidth = m_arrTextField(iIndex).width
Select Case m_arrTextField(iIndex).justify
Case cJustifyLeft:
sValue = StrJustifyLeft$(sValue, iNextWidth)
Case cJustifyRight:
sValue = StrJustifyRight$(sValue, iNextWidth)
Case cJustifyCenter:
sValue = StrJustifyCenter$(sValue, iNextWidth)
Case Else:
' (DO NOTHING)
End Select
Color m_arrTextField(iIndex).fgcolor, m_arrTextField(iIndex).bgcolor
PrintString2 iRow, iCol, sValue, ScreenArray()
End If
' LABEL
iIndex = GetTextLabel%(m_arrTextLabel(), sItem, "code")
If iIndex >= LBound(m_arrTextLabel) Then
iRow = (iStartY + m_arrTextLabel(iIndex).row) - 1
iCol = (iStartX + m_arrTextLabel(iIndex).column) - 1
sValue = m_arrTextLabel(iIndex).caption
sValue = Replace$(sValue, "{p}", cstr$(iPlayer))
iNextWidth = m_arrTextLabel(iIndex).width
If iNextWidth > 0 Then
Select Case m_arrTextLabel(iIndex).justify
Case cJustifyLeft:
sValue = StrJustifyLeft$(sValue, iNextWidth)
Case cJustifyRight:
sValue = StrJustifyRight$(sValue, iNextWidth)
Case cJustifyCenter:
sValue = StrJustifyCenter$(sValue, iNextWidth)
Case Else:
' (DO NOTHING)
End Select
Color m_arrTextLabel(iIndex).fgcolor, m_arrTextLabel(iIndex).bgcolor
PrintString2 iRow, iCol, sValue, ScreenArray()
ElseIf iNextWidth < 0 Then
Color m_arrTextLabel(iIndex).fgcolor, m_arrTextLabel(iIndex).bgcolor
PrintString2 iRow, iCol, sValue, ScreenArray()
Else
' (IGNORE)
End If
End If
' END CODE
' +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN VALUE
' VALUE
iIndex = GetTextField%(m_arrTextField(), sItem, "value")
If iIndex >= LBound(m_arrTextField) Then
iRow = (iStartY + m_arrTextField(iIndex).row) - 1
iCol = (iStartX + m_arrTextField(iIndex).column) - 1
sValue = cstr$(m_arrControlMap(iPlayer, iWhichInput).value)
iNextWidth = m_arrTextField(iIndex).width
Select Case m_arrTextField(iIndex).justify
Case cJustifyLeft:
sValue = StrJustifyLeft$(sValue, iNextWidth)
Case cJustifyRight:
sValue = StrJustifyRight$(sValue, iNextWidth)
Case cJustifyCenter:
sValue = StrJustifyCenter$(sValue, iNextWidth)
Case Else:
' (DO NOTHING)
End Select
Color m_arrTextField(iIndex).fgcolor, m_arrTextField(iIndex).bgcolor
PrintString2 iRow, iCol, sValue, ScreenArray()
End If
' LABEL
iIndex = GetTextLabel%(m_arrTextLabel(), sItem, "value")
If iIndex >= LBound(m_arrTextLabel) Then
iRow = (iStartY + m_arrTextLabel(iIndex).row) - 1
iCol = (iStartX + m_arrTextLabel(iIndex).column) - 1
sValue = m_arrTextLabel(iIndex).caption
sValue = Replace$(sValue, "{p}", cstr$(iPlayer))
iNextWidth = m_arrTextLabel(iIndex).width
If iNextWidth > 0 Then
Select Case m_arrTextLabel(iIndex).justify
Case cJustifyLeft:
sValue = StrJustifyLeft$(sValue, iNextWidth)
Case cJustifyRight:
sValue = StrJustifyRight$(sValue, iNextWidth)
Case cJustifyCenter:
sValue = StrJustifyCenter$(sValue, iNextWidth)
Case Else:
' (DO NOTHING)
End Select
Color m_arrTextLabel(iIndex).fgcolor, m_arrTextLabel(iIndex).bgcolor
PrintString2 iRow, iCol, sValue, ScreenArray()
ElseIf iNextWidth < 0 Then
Color m_arrTextLabel(iIndex).fgcolor, m_arrTextLabel(iIndex).bgcolor
PrintString2 iRow, iCol, sValue, ScreenArray()
Else
' (IGNORE)
End If
End If
' END VALUE
' +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN REPEAT
' VALUE
iIndex = GetTextField%(m_arrTextField(), sItem, "repeat")
If iIndex >= LBound(m_arrTextField) Then
iRow = (iStartY + m_arrTextField(iIndex).row) - 1
iCol = (iStartX + m_arrTextField(iIndex).column) - 1
sValue = IIFSTR$(m_arrControlMap(iPlayer, iWhichInput).repeat, "Y", "N")
iNextWidth = m_arrTextField(iIndex).width
Select Case m_arrTextField(iIndex).justify
Case cJustifyLeft:
sValue = StrJustifyLeft$(sValue, iNextWidth)
Case cJustifyRight:
sValue = StrJustifyRight$(sValue, iNextWidth)
Case cJustifyCenter:
sValue = StrJustifyCenter$(sValue, iNextWidth)
Case Else:
' (DO NOTHING)
End Select
Color m_arrTextField(iIndex).fgcolor, m_arrTextField(iIndex).bgcolor
PrintString2 iRow, iCol, sValue, ScreenArray()
End If
' LABEL
iIndex = GetTextLabel%(m_arrTextLabel(), sItem, "repeat")
If iIndex >= LBound(m_arrTextLabel) Then
iRow = (iStartY + m_arrTextLabel(iIndex).row) - 1
iCol = (iStartX + m_arrTextLabel(iIndex).column) - 1
sValue = m_arrTextLabel(iIndex).caption
sValue = Replace$(sValue, "{p}", cstr$(iPlayer))
iNextWidth = m_arrTextLabel(iIndex).width
If iNextWidth > 0 Then
Select Case m_arrTextLabel(iIndex).justify
Case cJustifyLeft:
sValue = StrJustifyLeft$(sValue, iNextWidth)
Case cJustifyRight:
sValue = StrJustifyRight$(sValue, iNextWidth)
Case cJustifyCenter:
sValue = StrJustifyCenter$(sValue, iNextWidth)
Case Else:
' (DO NOTHING)
End Select
Color m_arrTextLabel(iIndex).fgcolor, m_arrTextLabel(iIndex).bgcolor
PrintString2 iRow, iCol, sValue, ScreenArray()
ElseIf iNextWidth < 0 Then
Color m_arrTextLabel(iIndex).fgcolor, m_arrTextLabel(iIndex).bgcolor
PrintString2 iRow, iCol, sValue, ScreenArray()
Else
' (IGNORE)
End If
End If
' END REPEAT
' +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Next iWhichInput
Next iPlayer
' ADD CLOSE BUTTON
ExitX = (_Width(0) \ _FontWidth) - 4
ExitY = 1 ' _Height(0) \ _FontHeight
Color cBlack, cRed
PrintString2 ExitY, ExitX+0, "C", ScreenArray()
PrintString2 ExitY, ExitX+1, "L", ScreenArray()
PrintString2 ExitY, ExitX+2, "O", ScreenArray()
PrintString2 ExitY, ExitX+3, "S", ScreenArray()
PrintString2 ExitY, ExitX+4, "E", ScreenArray()
End Sub ' UpdateDisplayMapInput2
' /////////////////////////////////////////////////////////////////////////////
Function MapInput2$
Dim RoutineName As String: RoutineName = "MapInput2$"
Dim iDeviceCount As Integer ' count # of devices connected to system (keyboard, mouse, game controllers)
Dim iPlayer As Integer ' same as iController, which of the 8 controllers
Dim iWhichInput As Integer ' one of: cInputUp, cInputDown, cInputLeft, cInputRight, cInputButton1, cInputButton2, cInputButton3, cInputButton4
Dim bFinished As Integer
Dim iCount As Integer
Dim sResult As String
Dim sError As String : sError = ""
Dim sLine As String
ReDim arrColor(-1) As ColorType
Dim iForeColor As Integer
Dim iBackColor As Integer
' VARIABLES FOR SCREEN
' 1024 x 768: 128 x 48
Dim MapArray(1 To 48, 1 To 128) As String
ReDim ScreenArray(1 To 48, 1 To 128) As TextCellType
Dim sName As String
Dim sItem As String
Dim iLoop As Integer
Dim iX As Integer
Dim iY As Integer
Dim iCol As Integer
Dim iRow As Integer
Dim iStartX As Integer
Dim iStartY As Integer
Dim iEndX As Integer
Dim iEndY As Integer
Dim iLabel As Integer
Dim iField As Integer
Dim iButton As Integer
Dim iWidth As Integer
Dim bContinue As Integer
Dim sValue As String
Dim iNextWidth As Integer
Dim iType As Integer
Dim iIndex As Integer
Dim in$
' MOUSE VARIABLES
Dim iX1 As Integer: iX1 = 0
Dim iY1 As Integer: iY1 = 0
Dim iOldX1 As Integer: iOldX1 = 0
Dim iOldY1 As Integer: iOldY1 = 0
Dim bLeftClick As Integer: bLeftClick = FALSE
Dim bOldLeftClick As Integer: bOldLeftClick = FALSE
Dim sZone1 As String ' text description of which controller
Dim sZone2 As String ' text description of which input
Dim iMapPlayer As Integer ' like iController, which of the 8 controllers
' WHICH PORTION OF THE SCREEN USER CLICKED ON
Dim iTempX As Integer
Dim iTempY As Integer
Dim iTextX As Integer
Dim iTextY As Integer
Dim iOffsetX As Integer
Dim iOffsetY As Integer
' BOUNDARIES OF BUTTON CLICKED ON
Dim iMapX1 As Integer
Dim iMapX2 As Integer
Dim iMapY1 As Integer
Dim iMapY2 As Integer
' FOR MAPPING CONTROLLER INPUT
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 iPlayer As Integer
Dim iController As Integer ' to loop through devices
Dim iDevice As Integer
Dim iValue As Integer
Dim bMoveNext As Integer
'Dim iLoop As Integer
Dim iCode As Integer
Dim bHaveInput As Integer
'Dim iWhichInput As Integer
Dim iNextInput As Integer
Dim sCaption As String
Dim sPrompt As String
Dim CloseX As Integer
Dim CloseY As Integer
Dim dblNextAxis As Double
Dim bHitEsc As Integer
Dim bHitEnter As Integer
Dim bMapMode As Integer ' if TRUE then look for control mapping input
Dim ExitX As Integer
Dim ExitY As Integer
' =============================================================================
' INITIALIZE
if len(sError)=0 then
InitKeyboardButtonCodes
AddColors arrColor()
StringToArray MapArray(), GetMap$
SetupScreenAreas
SetupButtons
SetupTextLabels
SetupTextFields
end if
' =============================================================================
' MAKE SURE WE HAVE DEVICES
if len(sError)=0 then
' 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 < 3 Then
If iDeviceCount < 1 Then
sError = "Enough devices not found."
End If
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."
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
' =============================================================================
' INIT SCREEN
if len(sError)=0 then
Screen _NewImage(1024, 768, 32): _ScreenMove 0, 0
UpdateDisplayMapInput2 arrColor(), MapArray(), ScreenArray()
end if
' =============================================================================
' MAIN LOOP
if len(sError)=0 then
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN MOUSE #MOUSE
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
bFinished = FALSE
bHitEsc = FALSE
bHitEnter = FALSE
bMapMode = FALSE
CloseX = 0
CloseY = 0
ExitX = (_Width(0) \ _FontWidth) -4
ExitY = 1 ' _Height(0) \ _FontHeight
_MouseHide ' hide OS mouse pointer
Do
' READ MOUSE
Do While _MouseInput: Loop
' ERASE CURSOR
If iOldX1 <> iX1 Or iOldY1 <> iY1 Then
if iOldX1 > 0 and iOldY1 > 0 then
iTextY = iOldY1 \ _FontHeight
iTextX = iOldX1 \ _FontWidth
Color ScreenArray(iTextY, iTextX).fgColor, ScreenArray(iTextY, iTextX).bgColor
PrintString1 iTextY, iTextX, ScreenArray(iTextY, iTextX).value
end if
End If
' SAVE OLD POSITION
iOldY1 = iY1
iOldX1 = iX1
iTempY = iOldY1 \ _FontHeight
iTempX = iOldX1 \ _FontWidth
' GET NEW POSITION
iY1 = ((_MouseY \ _FontHeight)+1) * _FontHeight
iX1 = ((_MouseX \ _FontWidth)+1) * _FontWidth
iTextY = iY1 \ _FontHeight
iTextX = iX1 \ _FontWidth
' DRAW CURSOR
Color cBlack, cMagenta
PrintString1 iTextY, iTextX, " "
' LEFT CLICK
bLeftClick = _MouseButton(1)
If bLeftClick Then
If bOldLeftClick = FALSE Then
' (CLICK ACTION HERE)
' IS SELECTING A CONTROL TO MAP, OR MAPPING A CONTROL?
If CloseX=0 Or CloseY=0 Then
' DID THEY CLOSE?
If (iTextY = ExitY) And (iTextX >= ExitX) Then
' @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
' USER CLICKED EXIT SCREEN
bFinished = True
' @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
Else
' @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
' BEGIN USER IS SELECTING A CONTROL TO MAP
' WHICH CONTROLLER?
for iIndex = lbound(m_arrScreenArea) to ubound(m_arrScreenArea)
if iTextY >= m_arrScreenArea(iIndex).y1 then
if iTextY <= m_arrScreenArea(iIndex).y2 then
if iTextX >= m_arrScreenArea(iIndex).x1 then
if iTextX <= m_arrScreenArea(iIndex).x2 then
iMapPlayer = m_arrScreenArea(iIndex).player
sZone1 = m_arrScreenArea(iIndex).item
iOffsetX = m_arrScreenArea(iIndex).x1 - 1
iOffsetY = m_arrScreenArea(iIndex).y1 - 1
exit for
end if
end if
end if
end if
next iIndex
' WHICH BUTTON?
for iIndex = lbound(m_arrButton) to ubound(m_arrButton)
if iTextY >= m_arrButton(iIndex).y1+iOffsetY then
if iTextY <= m_arrButton(iIndex).y2+iOffsetY then
if iTextX >= m_arrButton(iIndex).x1+iOffsetX then
if iTextX <= m_arrButton(iIndex).x2+iOffsetX then
iWhichInput = m_arrButton(iIndex).typ ' cInputUp, cInputDown, cInputLeft, cInputRight, cInputButton1, cInputButton2, cInputButton3, cInputButton4
sZone2 = m_arrButton(iIndex).item
DebugPrint "clicked " + sZone1 + ", " + sZone2
'iMapX1 = m_arrButton(iIndex).x1+iOffsetX
'iMapX2 = m_arrButton(iIndex).x2+iOffsetX
'iMapY1 = m_arrButton(iIndex).y1+iOffsetY
'iMapY2 = m_arrButton(iIndex).y2+iOffsetY
'
'sPrompt = ""
'sPrompt = sPrompt + "Move control" + chr$(13)
'sPrompt = sPrompt + "or press key " + chr$(13)
'sPrompt = sPrompt + "for " + InputToString$(iWhichInput) + chr$(13)
'sPrompt = sPrompt + "<ESC> + <ENTER>" + chr$(13)
'sPrompt = sPrompt + "to cancel."
'MapInputPrompt sPrompt, iMapX1, iMapX2, iMapY1, iMapY2, cBlack, cWhite
sCaption = "Map " + InputToString$(iWhichInput) + " for " + cstr$(iMapPlayer)
sPrompt = ""
sPrompt = sPrompt + "Move controller or press key" + chr$(13)
sPrompt = sPrompt + "or click close 'x' to cancel."
MapInputPopup sCaption, cWhite, cGray, sPrompt, cBlack, cWhite, CloseX, CloseY, ScreenArray()
end if
end if
end if
end if
next iIndex
' END USER IS SELECTING A CONTROL TO MAP
' @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
End If
Else
' @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
' BEGIN USER CLICKED TO CANCEL MAP MODE
If iTextY = ExitY And iTextX = ExitX Then
' @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
' USER CLICKED EXIT SCREEN
bFinished = True
' @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
ElseIf iTextY = CloseY And iTextX = CloseX Then
' USER CLICKED "CANCEL"
' EXIT MAP MODE
CloseX = 0
CloseY = 0
' REFRESH SCREEN
UpdateDisplayMapInput2 arrColor(), MapArray(), ScreenArray()
End If
' END USER CLICKED TO CANCEL MAP MODE
' @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
End If
bOldLeftClick = TRUE
End If
Else
' USER RELEASED MOUSE BUTTON
bOldLeftClick = FALSE
sZone1 = ""
sZone2 = ""
iOffsetX = 0
iOffsetY = 0
End If
' @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
' BEGIN LOOK FOR MAPPING INPUT
If CloseX > 0 And CloseY > 0 Then
' =============================================================================
' BEGIN LOOK FOR NEXT INPUT
bMoveNext = FALSE
' -----------------------------------------------------------------------------
' 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(iMapPlayer, iNextInput).device = iDevice Then
If m_arrControlMap(iMapPlayer, iNextInput).typ = cInputButton Then
If m_arrControlMap(iMapPlayer, iNextInput).code = iLoop Then
If m_arrControlMap(iMapPlayer, iNextInput).value = iValue Then
bHaveInput = FALSE
End If
End If
End If
End If
Next iNextInput
End If
If bHaveInput Then
m_arrControlMap(iMapPlayer, iWhichInput).device = iDevice
m_arrControlMap(iMapPlayer, iWhichInput).typ = cInputButton
m_arrControlMap(iMapPlayer, iWhichInput).code = iLoop
m_arrControlMap(iMapPlayer, iWhichInput).value = iValue
bMoveNext = TRUE
Exit For
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(iMapPlayer, iNextInput).device = iDevice Then
If m_arrControlMap(iMapPlayer, iNextInput).typ = cInputAxis Then
If m_arrControlMap(iMapPlayer, iNextInput).code = iLoop Then
If m_arrControlMap(iMapPlayer, iNextInput).value = iValue Then
bHaveInput = FALSE
End If
End If
End If
End If
Next iNextInput
End If
If bHaveInput Then
m_arrControlMap(iMapPlayer, iWhichInput).device = iDevice
m_arrControlMap(iMapPlayer, iWhichInput).typ = cInputAxis
m_arrControlMap(iMapPlayer, iWhichInput).code = iLoop
m_arrControlMap(iMapPlayer, iWhichInput).value = iValue
bMoveNext = TRUE
Exit For
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(iMapPlayer, iNextInput).device = 1 Then ' .device 1 = keyboard
If m_arrControlMap(iMapPlayer, iNextInput).typ = cInputKey Then
If m_arrControlMap(iMapPlayer, iNextInput).code = iCode Then
'if m_arrControlMap(iMapPlayer, iNextInput).value = TRUE then
bHaveInput = FALSE
'end if
End If
End If
End If
Next iNextInput
End If
If bHaveInput Then
m_arrControlMap(iMapPlayer, iWhichInput).device = 1 ' .device 1 = keyboard
m_arrControlMap(iMapPlayer, iWhichInput).typ = cInputKey
m_arrControlMap(iMapPlayer, iWhichInput).code = iCode
m_arrControlMap(iMapPlayer, iWhichInput).value = TRUE
bMoveNext = TRUE
' CLEAR KEYBOARD BUFFER
_KEYCLEAR: _DELAY 1
Exit For
End If
End If
Next iLoop
End If
' END CHECK FOR KEYBOARD INPUT #1
' -----------------------------------------------------------------------------
If bMoveNext = TRUE Then
' WE HAVE MAPPED SOMETHING
m_bHaveMapping = TRUE
' EXIT MAPPING MODE
CloseX = 0
CloseY = 0
iOffsetX = 0
iOffsetY = 0
' REFRESH SCREEN
UpdateDisplayMapInput2 arrColor(), MapArray(), ScreenArray()
End If
' END LOOK FOR NEXT INPUT
' =============================================================================
End If
' END LOOK FOR MAPPING INPUT
' @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
_Limit 30
Loop Until bFinished
_MouseShow "default": _Delay 0.5
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END MOUSE @MOUSE
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
End If
' CLEAR KEYBOARD BUFFER
_KeyClear
' CLEAR SCREEN
Color cWhite, cBlack
Cls
' DONE
MapInput2$ = sResult
End Function ' MapInput2$
' /////////////////////////////////////////////////////////////////////////////
' Displays a popup with a close button "X" in the upper right,
' with text in MyString.
' Returns the x,y position of the close button in parameters CloseX, CloseY.
' Resolution Cols Rows
' 1024 x 768 128 48
' MapInputPopup sCaption, cBlack, cGray, sText, cBlack, cWhite, CloseX, CloseY
Sub MapInputPopup( _
sCaption2 As String, fgCaptionColor As _Unsigned Long, bgCaptionColor As _Unsigned Long, _
sText As String, fgTextColor As _Unsigned Long, bgTextColor As _Unsigned Long, _
CloseX As Integer, CloseY As Integer, ScreenArray() As TextCellType _
)
ReDim arrLines(-1) As String
Dim sCaption As String
Dim iCols As Integer
Dim iRows As Integer
Dim iColCount As Integer
Dim iRowCount As Integer
Dim iLoopRows As Integer
Dim iWidth As Integer
Dim x1 As Integer
Dim x2 As Integer
Dim y1 As Integer
Dim y2 As Integer
Dim iY As Integer
' Figure out window size
sCaption = sCaption2
iCols = _Width(0) \ _FontWidth
iRows = _Height(0) \ _FontHeight
iColCount = len(sCaption)+1
iRowCount = 0
split sText, chr$(13), arrLines()
For iLoopRows = lbound(arrLines) to ubound(arrLines)
iRowCount = iRowCount + 1
if len(arrLines(iLoopRows)) > iColCount then
iColCount = len(arrLines(iLoopRows))
end if
Next iLoopRows
' Draw window as long as there is text
If iColCount > 0 Then
' Make sure popup is not wider than screen
If iColCount > iCols Then iColCount = iCols
If iRowCount > iRows Then iRowCount = iRows
If len(sCaption) > (iCols-1) Then sCaption = left$(sCaption, iCols-1)
' Center the popup
x1 = (iCols - iColCount) \ 2
y1 = (iRows - iRowCount) \ 2
x2 = x1 + (iColCount - 1)
y2 = y1 + (iRowCount - 1)
' Draw the caption
Color fgCaptionColor, bgCaptionColor
'PrintString1 y1, x1, left$(sCaption + string$(iColCount, " "), iColCount)
PrintString2 y1, x1, left$(sCaption + string$(iColCount, " "), iColCount), ScreenArray()
' Draw the close button
Color fgTextColor, bgTextColor
'PrintString1 y1, x2, "X"
PrintString2 y1, x2, "X", ScreenArray()
CloseX = x2 :CloseY = y1
' Get width
iWidth = (x2 - x1) + 1
' Draw the popup
iY = y1
Color fgTextColor, bgTextColor
For iLoopRows = lbound(arrLines) to ubound(arrLines)
iY = iY + 1 : if iY > y2 then exit for
PrintString2 iY, x1, left$(arrLines(iLoopRows) + String$(iWidth, " "), iWidth), ScreenArray()
Next iLoopRows
For iLoopRows = iY to y2
'PrintString1 iY, x1, String$(iColCount, " ")
PrintString2 iLoopRows, x1, String$(iWidth, " "), ScreenArray()
Next iLoopRows
Else
CloseX = 0 : CloseY = 0
End If
End Sub ' MapInputPopup
' /////////////////////////////////////////////////////////////////////////////
' MapInputPrompt MyString, iMapX1, iMapX2, iMapY1, iMapY2, cBlack, cWhite
Sub MapInputPrompt(MyString As String, x1 As Integer, x2 As Integer, y1 As Integer, y2 As Integer, fgColor As _Unsigned Long, bgColor As _Unsigned Long)
ReDim arrLines(-1) As String
Dim iLoopRows As Integer
Dim iMaxLen As Integer
Dim iY As Integer
if x2 >= x1 then
if y2 >= y1 then
iMaxLen = (x2 - x1)+1
split MyString, chr$(13), arrLines()
iLine = 0
iY = y1
For iLoopRows = lbound(arrLines) to ubound(arrLines)
Color fgColor, bgColor
if len(arrLines(iLoopRows)) > iMaxLen then
PrintString1 iY, x1, left$(arrLines(iLoopRows), iMaxLen)
else
PrintString1 iY, x1, left$(arrLines(iLoopRows) + String$(iMaxLen, " "), iMaxLen)
end if
iY = iY + 1
if iY > y2 then
exit for
end if
Next iLoopRows
For iLoopRows = iY to y2
PrintString1 iY, x1, String$(iMaxLen, " ")
Next iLoopRows
end if
end if
End Sub ' MapInputPrompt
' /////////////////////////////////////////////////////////////////////////////
Sub DebugPause (sPrompt As String, iRow As Integer, iColumn As Integer, fgColor As _Unsigned Long, bgColor As _Unsigned Long)
Color fgColor, bgColor
PrintString iRow, iColumn, String$(128, " ")
PrintString iRow, iColumn, sPrompt
Sleep
'_KEYCLEAR: _DELAY 1
'DO
'LOOP UNTIL _KEYDOWN(13) ' leave loop when ENTER key pressed
'_KEYCLEAR: _DELAY 1
End Sub ' DebugPause
' /////////////////////////////////////////////////////////////////////////////
Sub DebugOut (sPrompt As String, iRow As Integer, iColumn As Integer, fgColor As _Unsigned Long, bgColor As _Unsigned Long)
Color fgColor, bgColor
PrintString iRow, iColumn, String$(128, " ")
PrintString iRow, iColumn, sPrompt
End Sub ' DebugOut
' /////////////////////////////////////////////////////////////////////////////
Function TestMouseXYButton$
Dim RoutineName As String: RoutineName = "TestMouseXYButton$"
Dim iX1 As Integer: iX1 = 0
Dim iY1 As Integer: iY1 = 0
Dim iOldX1 As Integer: iOldX1 = 0
Dim iOldY1 As Integer: iOldY1 = 0
Dim bLeftClick As Integer: bLeftClick = FALSE
Dim bRightClick As Integer: bRightClick = FALSE
Dim bMiddleClick As Integer: bMiddleClick = FALSE
Dim bOldLeftClick As Integer: bOldLeftClick = FALSE
Dim bOldRightClick As Integer: bOldRightClick = FALSE
Dim bOldMiddleClick As Integer: bOldMiddleClick = FALSE
Dim iX2 As Integer: iX2 = _Width / 2
Dim iY2 As Integer: iY2 = _Height / 2
Dim iOldX2 As Integer: iOldX2 = 0
Dim iOldY2 As Integer: iOldY2 = 0
Dim iColor1 As _Unsigned Long: iColor1 = cRed
Dim iColor2 As _Unsigned Long: iColor2 = cLime
Screen _NewImage(1280, 1024, 32): _ScreenMove 0, 0
Cls
_MouseHide ' hide OS mouse pointer
Do While _MouseInput: Loop
Do
Color cWhite, cBlack
If iOldX1 <> iX1 Or iOldY1 <> iY1 Then _PrintString (iOldX1, iOldY1), " "
If iOldX2 <> iX2 Or iOldY2 <> iY2 Then _PrintString (iOldX2, iOldY2), " "
Color cWhite, cEmpty
PrintString 0, 0, "_MOUSEX ="
PrintString 1, 0, "_MOUSEY ="
PrintString 2, 0, "_MOUSEBUTTON(1)="
PrintString 3, 0, "_MOUSEBUTTON(2)="
PrintString 4, 0, "_MOUSEBUTTON(3)="
PrintString 5, 0, "_MOUSEWHEEL X ="
PrintString 6, 0, "_MOUSEWHEEL Y ="
PrintString 8, 0, "PRESS <ESC> TO EXIT"
Color cWhite, cBlack
PrintString 0, 16, Left$(cstr$(iX1) + " ", 5)
PrintString 1, 16, Left$(cstr$(iY1) + " ", 5)
PrintString 2, 16, Left$(TrueFalse$(bLeftClick) + " ", 5)
PrintString 3, 16, Left$(TrueFalse$(bRightClick) + " ", 5)
PrintString 4, 16, Left$(TrueFalse$(bMiddleClick) + " ", 5)
PrintString 5, 16, Left$(cstr$(iX2) + " ", 5)
PrintString 6, 16, Left$(cstr$(iY2) + " ", 5)
Color cBlack, iColor1: _PrintString (iX1, iY1), " "
iOldX1 = iX1: iOldY1 = iY1
Color cBlack, iColor2: _PrintString (iX2, iY2), " "
iOldX2 = iX2: iOldY2 = iY2
iX1 = (_MouseX \ _FontWidth) * _FontWidth
iY1 = (_MouseY \ _FontHeight) * _FontHeight
bLeftClick = _MouseButton(1)
If bLeftClick Then
If bOldLeftClick = FALSE Then
If iColor1 = cOrangeRed Then
iColor1 = cRed
ElseIf iColor1 = cRed Then
iColor1 = cMagenta
Else
iColor1 = cOrangeRed
End If
bOldLeftClick = TRUE
End If
Else
bOldLeftClick = FALSE
End If
bRightClick = _MouseButton(2)
If bRightClick Then
If bOldRightClick = FALSE Then
If iColor2 = cBlue Then
iColor2 = cLime
ElseIf iColor2 = cLime Then
iColor2 = cYellow
Else
iColor2 = cBlue
End If
bOldRightClick = TRUE
End If
Else
bOldRightClick = FALSE
End If
bMiddleClick = _MouseButton(3)
Do While _MouseInput
If bMiddleClick Then
iY2 = iY2 + (_MouseWheel * _FontHeight) ' -1 up, 0 no movement, 1 down
Else
iX2 = iX2 + (_MouseWheel * _FontWidth) ' -1 up, 0 no movement, 1 down
End If
Loop
If iY2 < 1 Then iY2 = 1
If iY2 > (_Height - _FontHeight) Then iY2 = (HEIGHT - _FontHeight)
Loop Until _KeyDown(27)
_KeyClear
_MouseShow "default": _Delay 0.5
Screen 0
TestMouseXYButton$ = ""
End Function ' TestMouseXYButton$
' /////////////////////////////////////////////////////////////////////////////
Function MapInput1$
Dim RoutineName As String: RoutineName = "MapInput1$"
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 = LoadControllerMap1$
'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 = MapInput1b$(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
MapInput1$ = sResult
End Function ' MapInput1$
' /////////////////////////////////////////////////////////////////////////////
' 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 MapInput1b$ (iPlayer As Integer)
Dim RoutineName As String:: RoutineName = "MapInput1b$"
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 As Double
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
MapInput1b$ = sResult
End Function ' MapInput1b$
' /////////////////////////////////////////////////////////////////////////////
' 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 a text description
' that matches the TextFieldType and TextLabelType ".item" member.
Function InputToItem$ (iWhich As Integer)
Select Case iWhich
Case cInputUp:
InputToItem$ = "Up"
Case cInputDown:
InputToItem$ = "Down"
Case cInputLeft:
InputToItem$ = "Left"
Case cInputRight:
InputToItem$ = "Right"
Case cInputButton1:
InputToItem$ = "Button1"
Case cInputButton2:
InputToItem$ = "Button2"
Case cInputButton3:
InputToItem$ = "Button3"
Case cInputButton4:
InputToItem$ = "Button4"
Case Else:
InputToItem$ = ""
End Select
End Function ' InputToItem$
' /////////////////////////////////////////////////////////////////////////////
' 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
Function GetKeyboardButtonCodeShortText$ (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
GetKeyboardButtonCodeShortText$ = 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
' ReDim Shared m_arrButtonKeyShortDesc(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"
' SHORT DESCRIPTIONS BY KEYCODE
For iLoop = LBound(m_arrButtonKeyShortDesc) To UBound(m_arrButtonKeyShortDesc)
m_arrButtonKeyShortDesc(iLoop) = ""
Next iLoop
m_arrButtonKeyShortDesc(2) = "Esc"
m_arrButtonKeyShortDesc(60) = "F1"
m_arrButtonKeyShortDesc(61) = "F2"
m_arrButtonKeyShortDesc(62) = "F3"
m_arrButtonKeyShortDesc(63) = "F4"
m_arrButtonKeyShortDesc(64) = "F5"
m_arrButtonKeyShortDesc(65) = "F6"
m_arrButtonKeyShortDesc(66) = "F7"
m_arrButtonKeyShortDesc(67) = "F8"
m_arrButtonKeyShortDesc(68) = "F9"
m_arrButtonKeyShortDesc(88) = "F11"
m_arrButtonKeyShortDesc(89) = "F12"
m_arrButtonKeyShortDesc(42) = "Tilde"
m_arrButtonKeyShortDesc(3) = "1"
m_arrButtonKeyShortDesc(4) = "2"
m_arrButtonKeyShortDesc(5) = "3"
m_arrButtonKeyShortDesc(6) = "4"
m_arrButtonKeyShortDesc(7) = "5"
m_arrButtonKeyShortDesc(8) = "6"
m_arrButtonKeyShortDesc(9) = "7"
m_arrButtonKeyShortDesc(10) = "8"
m_arrButtonKeyShortDesc(11) = "9"
m_arrButtonKeyShortDesc(12) = "0"
m_arrButtonKeyShortDesc(13) = "Minus"
m_arrButtonKeyShortDesc(14) = "Equal"
m_arrButtonKeyShortDesc(15) = "BkSp"
m_arrButtonKeyShortDesc(16) = "Tab"
m_arrButtonKeyShortDesc(17) = "Q"
m_arrButtonKeyShortDesc(18) = "W"
m_arrButtonKeyShortDesc(19) = "E"
m_arrButtonKeyShortDesc(20) = "R"
m_arrButtonKeyShortDesc(21) = "T"
m_arrButtonKeyShortDesc(22) = "Y"
m_arrButtonKeyShortDesc(23) = "U"
m_arrButtonKeyShortDesc(24) = "I"
m_arrButtonKeyShortDesc(25) = "O"
m_arrButtonKeyShortDesc(26) = "P"
m_arrButtonKeyShortDesc(27) = "BrktLeft"
m_arrButtonKeyShortDesc(28) = "BrktRight"
m_arrButtonKeyShortDesc(44) = "Backslash"
m_arrButtonKeyShortDesc(59) = "CapsLock"
m_arrButtonKeyShortDesc(31) = "A"
m_arrButtonKeyShortDesc(32) = "S"
m_arrButtonKeyShortDesc(33) = "D"
m_arrButtonKeyShortDesc(34) = "F"
m_arrButtonKeyShortDesc(35) = "G"
m_arrButtonKeyShortDesc(36) = "H"
m_arrButtonKeyShortDesc(37) = "J"
m_arrButtonKeyShortDesc(38) = "K"
m_arrButtonKeyShortDesc(39) = "L"
m_arrButtonKeyShortDesc(40) = "Semicolon"
m_arrButtonKeyShortDesc(41) = "Apostrophe"
m_arrButtonKeyShortDesc(29) = "Enter"
m_arrButtonKeyShortDesc(43) = "ShiftLeft"
m_arrButtonKeyShortDesc(45) = "Z"
m_arrButtonKeyShortDesc(46) = "X"
m_arrButtonKeyShortDesc(47) = "C"
m_arrButtonKeyShortDesc(48) = "V"
m_arrButtonKeyShortDesc(49) = "B"
m_arrButtonKeyShortDesc(50) = "N"
m_arrButtonKeyShortDesc(51) = "M"
m_arrButtonKeyShortDesc(52) = "Comma"
m_arrButtonKeyShortDesc(53) = "Period"
m_arrButtonKeyShortDesc(54) = "Slash"
m_arrButtonKeyShortDesc(55) = "ShiftRight"
m_arrButtonKeyShortDesc(30) = "CtrlLeft"
m_arrButtonKeyShortDesc(348) = "WinLeft"
m_arrButtonKeyShortDesc(58) = "Spacebar"
m_arrButtonKeyShortDesc(349) = "WinRight"
m_arrButtonKeyShortDesc(350) = "Menu"
m_arrButtonKeyShortDesc(286) = "CtrlRight"
m_arrButtonKeyShortDesc(339) = "Ins"
m_arrButtonKeyShortDesc(328) = "Home"
m_arrButtonKeyShortDesc(330) = "PgUp"
m_arrButtonKeyShortDesc(340) = "Del"
m_arrButtonKeyShortDesc(336) = "End"
m_arrButtonKeyShortDesc(338) = "PgDn"
m_arrButtonKeyShortDesc(329) = "Up"
m_arrButtonKeyShortDesc(332) = "Left"
m_arrButtonKeyShortDesc(337) = "Down"
m_arrButtonKeyShortDesc(334) = "Right"
m_arrButtonKeyShortDesc(71) = "ScrollLock"
m_arrButtonKeyShortDesc(326) = "NumLock"
m_arrButtonKeyShortDesc(310) = "KeypadSlash"
m_arrButtonKeyShortDesc(56) = "KeypadMult"
m_arrButtonKeyShortDesc(75) = "KeypadMinus"
m_arrButtonKeyShortDesc(72) = "Keypad7Home"
m_arrButtonKeyShortDesc(73) = "Keypad8Up"
m_arrButtonKeyShortDesc(74) = "Keypad9PgUp"
m_arrButtonKeyShortDesc(79) = "KeypadPlus"
m_arrButtonKeyShortDesc(76) = "Keypad4Lf"
m_arrButtonKeyShortDesc(77) = "Keypad5"
m_arrButtonKeyShortDesc(78) = "Keypad6Rt"
m_arrButtonKeyShortDesc(80) = "Keypad1End"
m_arrButtonKeyShortDesc(81) = "Keypad2Dn"
m_arrButtonKeyShortDesc(82) = "Keypad3PgDn"
m_arrButtonKeyShortDesc(285) = "KeypadEnter"
m_arrButtonKeyShortDesc(83) = "Keypad0Ins"
m_arrButtonKeyShortDesc(84) = "KeypadPerDel"
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 TestJoysticks1$
Dim RoutineName As String: RoutineName = "TestJoysticks1$"
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
TestJoysticks1b
sResult = ""
Else
sResult = "No joysticks found."
End If
_KeyClear
TestJoysticks1$ = sResult
End Function ' TestJoysticks1$
' /////////////////////////////////////////////////////////////////////////////
' 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
' 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
Sub TestJoysticks1b ()
Dim RoutineName As String:: RoutineName = "TestJoysticks1b"
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 As Double
'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
PrintStringCR1 1, 1, "Game controller test program."
PrintStringCR1 1, 2, "This program is free to use and distribute per GNU GPLv3 license."
PrintStringCR1 1, 3, "Tests up to 4 controllers with 2 axes / 2 buttons each."
PrintStringCR1 1, 4, "Plug in controllers and move them & press buttons."
PrintStringCR1 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
PrintStringCR1 1, iRows - 1, "-------------------------------------------------------------------------------"
PrintStringCR1 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 ' TestJoysticks1b
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 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 SaveControllerMap1$
Dim RoutineName As String:: RoutineName = "SaveControllerMap1$"
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
SaveControllerMap1$ = sResult
End Function ' SaveControllerMap1$
' /////////////////////////////////////////////////////////////////////////////
Function LoadControllerMap1$
Dim RoutineName As String:: RoutineName = "LoadControllerMap1$"
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
LoadControllerMap1$ = sResult
End Function ' LoadControllerMap1$
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END FILE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GRAPHIC PRINTING ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' 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
' /////////////////////////////////////////////////////////////////////////////
' 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
' /////////////////////////////////////////////////////////////////////////////
' 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 PrintStringCR1 (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 ' PrintStringCR1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 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$
' /////////////////////////////////////////////////////////////////////////////
' Does a _PrintString at the specified row+column.
' iRow and iCol are 0-based.
Sub PrintString (iRow As Integer, iCol As Integer, MyString As String)
Dim iX As Integer
Dim iY As Integer
iX = _FontWidth * iCol
iY = _FontHeight * iRow ' (iRow + 1)
_PrintString (iX, iY), MyString
End Sub ' PrintString
' /////////////////////////////////////////////////////////////////////////////
' Does a _PrintString at the specified row+column.
' iRow and iCol are 1-based.
Sub PrintString1 (iRow As Integer, iCol As Integer, MyString As String)
Dim iX As Integer
Dim iY As Integer
iX = _FontWidth * (iCol-1)
iY = _FontHeight * (iRow-1)
_PrintString (iX, iY), MyString
End Sub ' PrintString1
' /////////////////////////////////////////////////////////////////////////////
' Does a _PrintString at the specified row+column,
' and saves value and color info to ScreenArray.
' PrintString2 iRow, iCol, MyString, ScreenArray()
' iRow and iCol are 1-based.
Sub PrintString2 (iRow As Integer, iCol As Integer, MyString As String, ScreenArray() As TextCellType)
Dim iX As Integer
Dim iY As Integer
Dim iLoop As Integer
iX = _FontWidth * (iCol-1)
iY = _FontHeight * (iRow-1)
_PrintString (iX, iY), MyString
if (iRow >= lbound(ScreenArray, 1) ) then
if (iRow <= ubound(ScreenArray, 1) ) then
if (iCol >= lbound(ScreenArray, 2) ) then
if (iCol <= ubound(ScreenArray, 2) ) then
iX = iCol
iY = iRow
for iLoop = 1 to len(MyString)
if iX > ubound(ScreenArray, 2) then
exit for
else
ScreenArray(iY, iX).value = mid$(MyString, iLoop, 1)
ScreenArray(iY, iX).fgColor = _DEFAULTCOLOR
ScreenArray(iY, iX).bgColor = _BACKGROUNDCOLOR
iX = iX + 1
end if
next iLoop
end if
end if
end if
end if
End Sub ' PrintString2
' /////////////////////////////////////////////////////////////////////////////
' 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 StrPadLeft$ (sValue As String, iWidth As Integer)
StrPadLeft$ = Right$(String$(iWidth, " ") + sValue, iWidth)
End Function ' StrPadLeft$
' /////////////////////////////////////////////////////////////////////////////
Function StrJustifyRight$ (sValue As String, iWidth As Integer)
StrJustifyRight$ = Right$(String$(iWidth, " ") + sValue, iWidth)
End Function ' StrJustifyRight$
' /////////////////////////////////////////////////////////////////////////////
Function StrPadRight$ (sValue As String, iWidth As Integer)
StrPadRight$ = Left$(sValue + String$(iWidth, " "), iWidth)
End Function ' StrPadRight$
' /////////////////////////////////////////////////////////////////////////////
Function StrJustifyLeft$ (sValue As String, iWidth As Integer)
StrJustifyLeft$ = Left$(sValue + String$(iWidth, " "), iWidth)
End Function ' StrJustifyLeft$
' /////////////////////////////////////////////////////////////////////////////
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%
Function StrJustifyCenter$ (sValue As String, iWidth As Integer)
Dim iLen0 As Integer
Dim iLen1 As Integer
Dim iLen2 As Integer
Dim iExtra As Integer
iLen0 = Len(sValue)
If iWidth = iLen0 Then
' no extra space: return unchanged
StrJustifyCenter$ = sValue
ElseIf iWidth > iLen0 Then
If IsOdd%(iWidth) Then
iWidth = iWidth - 1
End If
' center
iExtra = iWidth - iLen0
iLen1 = iExtra \ 2
iLen2 = iLen1 + (iExtra Mod 2)
StrJustifyCenter$ = String$(iLen1, " ") + sValue + String$(iLen2, " ")
Else
' string is too long: truncate
StrJustifyCenter$ = Left$(sValue, iWidth)
End If
End Function ' StrJustifyCenter$
' /////////////////////////////////////////////////////////////////////////////
Function TrueFalse$ (myValue)
If myValue = TRUE Then
TrueFalse$ = "TRUE"
Else
TrueFalse$ = "FALSE"
End If
End Function ' TrueFalse$
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GENERAL PURPOSE ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN COLOR ARRAY FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
Sub AddColor (ColorValue As _Unsigned Long, ColorName As String, arrColor() As ColorType)
ReDim _Preserve arrColor(0 To UBound(arrColor) + 1) As ColorType
arrColor(UBound(arrColor)).name = ColorName
arrColor(UBound(arrColor)).value = ColorValue
End Sub ' AddColor
' /////////////////////////////////////////////////////////////////////////////
Sub AddColors (arrColor() As ColorType)
AddColor cBlack, "cBlack", arrColor()
''AddColor cDarkGray, "cDarkGray", arrColor()
''AddColor cDimGray, "cDimGray", arrColor()
AddColor cGray, "cGray", arrColor()
AddColor cSilver, "cSilver", arrColor()
''AddColor cLightGray, "cLightGray", arrColor()
AddColor cWhite, "cWhite", arrColor()
AddColor cRed, "cRed", arrColor()
AddColor cOrangeRed, "cOrangeRed", arrColor()
'AddColor cDarkOrange, "cDarkOrange", arrColor()
'AddColor cOrange, "cOrange", arrColor()
'AddColor cGold, "cGold", arrColor()
AddColor cYellow, "cYellow", arrColor()
'AddColor cOliveDrab1, "cOliveDrab1", arrColor()
AddColor cLime, "cLime", arrColor()
'AddColor cMediumSpringGreen, "cMediumSpringGreen", arrColor()
AddColor cCyan, "cCyan", arrColor()
'AddColor cDeepSkyBlue, "cDeepSkyBlue", arrColor()
AddColor cDodgerBlue, "cDodgerBlue", arrColor()
'AddColor cSeaBlue, "cSeaBlue", arrColor()
AddColor cBlue, "cBlue", arrColor()
'AddColor cBluePurple, "cBluePurple", arrColor()
AddColor cDeepPurple, "cDeepPurple", arrColor()
'AddColor cPurple, "cPurple", arrColor()
'AddColor cPurpleRed, "cPurpleRed", arrColor()
''AddColor cGainsboro, "cGainsboro", arrColor()
''AddColor cWhiteSmoke, "cWhiteSmoke", arrColor()
'AddColor cDarkRed, "cDarkRed", arrColor()
''AddColor cBrickRed, "cBrickRed", arrColor()
AddColor cDarkGreen, "cDarkGreen", arrColor()
'AddColor cGreen, "cGreen", arrColor()
''AddColor cOliveDrab, "cOliveDrab", arrColor()
''AddColor cLightPink, "cLightPink", arrColor()
AddColor cMagenta, "cMagenta", arrColor()
AddColor cHotPink, "cHotPink", arrColor()
'AddColor cDeepPink, "cDeepPink", arrColor()
AddColor cDarkBrown, "cDarkBrown", arrColor()
'AddColor cLightBrown, "cLightBrown", arrColor()
'AddColor cKhaki, "cKhaki", arrColor()
AddColor cEmpty, "cEmpty", arrColor()
End Sub ' AddColors
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END COLOR ARRAY FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN COLOR FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' NOTE: these are mostly negative numbers
' and have to be forced to positive
' when stored in the dictionary
' (only cEmpty should be negative)
Function cRed~& ()
cRed = _RGB32(255, 0, 0)
End Function
Function cOrangeRed~& ()
cOrangeRed = _RGB32(255, 69, 0)
End Function ' cOrangeRed~&
Function cDarkOrange~& ()
cDarkOrange = _RGB32(255, 140, 0)
End Function ' cDarkOrange~&
Function cOrange~& ()
cOrange = _RGB32(255, 165, 0)
End Function ' cOrange~&
Function cGold~& ()
cGold = _RGB32(255, 215, 0)
End Function ' cGold~&
Function cYellow~& ()
cYellow = _RGB32(255, 255, 0)
End Function ' cYellow~&
' LONG-HAIRED FRIENDS OF JESUS OR NOT,
' THIS IS NOT YELLOW ENOUGH (TOO CLOSE TO LIME)
' TO USE FOR OUR COMPLEX RAINBOW SEQUENCE:
Function cChartreuse~& ()
cChartreuse = _RGB32(127, 255, 0)
End Function ' cChartreuse~&
' WE SUBSTITUTE THIS CSS3 COLOR FOR INBETWEEN LIME AND YELLOW:
Function cOliveDrab1~& ()
cOliveDrab1 = _RGB32(192, 255, 62)
End Function ' cOliveDrab1~&
Function cLime~& ()
cLime = _RGB32(0, 255, 0)
End Function ' cLime~&
Function cMediumSpringGreen~& ()
cMediumSpringGreen = _RGB32(0, 250, 154)
End Function ' cMediumSpringGreen~&
Function cCyan~& ()
cCyan = _RGB32(0, 255, 255)
End Function ' cCyan~&
Function cDeepSkyBlue~& ()
cDeepSkyBlue = _RGB32(0, 191, 255)
End Function ' cDeepSkyBlue~&
Function cDodgerBlue~& ()
cDodgerBlue = _RGB32(30, 144, 255)
End Function ' cDodgerBlue~&
Function cSeaBlue~& ()
cSeaBlue = _RGB32(0, 64, 255)
End Function ' cSeaBlue~&
Function cBlue~& ()
cBlue = _RGB32(0, 0, 255)
End Function ' cBlue~&
Function cBluePurple~& ()
cBluePurple = _RGB32(64, 0, 255)
End Function ' cBluePurple~&
Function cDeepPurple~& ()
cDeepPurple = _RGB32(96, 0, 255)
End Function ' cDeepPurple~&
Function cPurple~& ()
cPurple = _RGB32(128, 0, 255)
End Function ' cPurple~&
Function cPurpleRed~& ()
cPurpleRed = _RGB32(128, 0, 192)
End Function ' cPurpleRed~&
Function cDarkRed~& ()
cDarkRed = _RGB32(160, 0, 64)
End Function ' cDarkRed~&
Function cBrickRed~& ()
cBrickRed = _RGB32(192, 0, 32)
End Function ' cBrickRed~&
Function cDarkGreen~& ()
cDarkGreen = _RGB32(0, 100, 0)
End Function ' cDarkGreen~&
Function cGreen~& ()
cGreen = _RGB32(0, 128, 0)
End Function ' cGreen~&
Function cOliveDrab~& ()
cOliveDrab = _RGB32(107, 142, 35)
End Function ' cOliveDrab~&
Function cLightPink~& ()
cLightPink = _RGB32(255, 182, 193)
End Function ' cLightPink~&
Function cHotPink~& ()
cHotPink = _RGB32(255, 105, 180)
End Function ' cHotPink~&
Function cDeepPink~& ()
cDeepPink = _RGB32(255, 20, 147)
End Function ' cDeepPink~&
Function cMagenta~& ()
cMagenta = _RGB32(255, 0, 255)
End Function ' cMagenta~&
Function cBlack~& ()
cBlack = _RGB32(0, 0, 0)
End Function ' cBlack~&
Function cDimGray~& ()
cDimGray = _RGB32(105, 105, 105)
End Function ' cDimGray~&
Function cGray~& ()
cGray = _RGB32(128, 128, 128)
End Function ' cGray~&
Function cDarkGray~& ()
cDarkGray = _RGB32(169, 169, 169)
End Function ' cDarkGray~&
Function cSilver~& ()
cSilver = _RGB32(192, 192, 192)
End Function ' cSilver~&
Function cLightGray~& ()
cLightGray = _RGB32(211, 211, 211)
End Function ' cLightGray~&
Function cGainsboro~& ()
cGainsboro = _RGB32(220, 220, 220)
End Function ' cGainsboro~&
Function cWhiteSmoke~& ()
cWhiteSmoke = _RGB32(245, 245, 245)
End Function ' cWhiteSmoke~&
Function cWhite~& ()
cWhite = _RGB32(255, 255, 255)
'cWhite = _RGB32(254, 254, 254)
End Function ' cWhite~&
Function cDarkBrown~& ()
cDarkBrown = _RGB32(128, 64, 0)
End Function ' cDarkBrown~&
Function cLightBrown~& ()
cLightBrown = _RGB32(196, 96, 0)
End Function ' cLightBrown~&
Function cKhaki~& ()
cKhaki = _RGB32(240, 230, 140)
End Function ' cKhaki~&
Function cEmpty~& ()
'cEmpty~& = -1
cEmpty = _RGB32(0, 0, 0, 0)
End Function ' cEmpty~&
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END COLOR FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' #END
' ################################################################################################################################################################« Last Edit: January 28, 2022, 04:06:02 pm by madscijr »