| Welcome, Guest |
You have to register before you can post on our site.
|
| Forum Statistics |
» Members: 323
» Latest member: Frankvab
» Forum threads: 1,745
» Forum posts: 17,906
Full Statistics
|
| Latest Threads |
astuce pour survivre fina...
Forum: Utilities
Last Post: coletteleger
05-14-2025, 04:47 AM
» Replies: 0
» Views: 48
|
trouver permis de conduir...
Forum: Utilities
Last Post: nicolasrene
05-05-2025, 05:24 AM
» Replies: 0
» Views: 56
|
LIGHTBAR Menu
Forum: Programs
Last Post: nicolasrene
05-05-2025, 05:08 AM
» Replies: 15
» Views: 1,067
|
Learning Pallet Rack Safe...
Forum: Utilities
Last Post: Sandrapew
04-03-2025, 09:36 AM
» Replies: 0
» Views: 62
|
Choosing New Versus or Pr...
Forum: Utilities
Last Post: Sandrapew
03-18-2025, 01:11 AM
» Replies: 0
» Views: 63
|
The QB64 IDE shell
Forum: Utilities
Last Post: JasonPag
09-16-2024, 05:37 PM
» Replies: 9
» Views: 1,154
|
Importance regarding Ches...
Forum: Utilities
Last Post: JasonPag
09-01-2024, 06:34 PM
» Replies: 0
» Views: 91
|
Chess and Analysis and En...
Forum: Utilities
Last Post: JasonPag
08-28-2024, 02:37 PM
» Replies: 0
» Views: 93
|
DAY 009:_PutImage
Forum: Keyword of the Day!
Last Post: grymmjack
09-02-2023, 02:57 PM
» Replies: 54
» Views: 3,789
|
Fall Banner Contest?
Forum: Site Suggestions
Last Post: grymmjack
08-31-2023, 11:50 PM
» Replies: 36
» Views: 2,412
|
|
|
| game input mapping system v1.0 for gamepad, keyboard |
|
Posted by: madscijr - 05-12-2023, 03:20 PM - Forum: madscijr
- No Replies
|
 |
This is the first version of my joystick & keyboard mapping + input library (original post).
Version 2 followed, which added a simple GUI (what a pain and interesting project THAT was!)
(I'm currently working on Version 3 which removes the GUI abomination and simplifies things.)
madscijr
game input mapping system v1.0 for gamepad, keyboard
« on: January 07, 2022, 06:43:22 pm »
I needed some basic reusable functionality to map game input from USB game controllers and the keyboard, which could be saved to a config file and reused.
Everything is working now, you can map controls, load/save/edit mappings, test the mapping, or test game controllers.
The input is menu driven, and the menus are very rudimentary, text-based, but it works (at least as far as I can tell).
1. Basic controller test
2. Load controller mapping
3. View controller mapping
4. Edit controller mapping for 1 or more players
5. Reset controller mapping for 1 or more players
6. Map controllers for 1 or more players
7. Test controller mappings to move around screen
8. Save controller mappings
Code is below and fully self-contained.
Enjoy.
Code: (Select All) ' ################################################################################################################################################################
' #TOP
' Game Input Mapping Test
' Version 1.0 by madscijr
' BASED ON CODE BY SMcNeill FROM:
' Simple Joystick Detection and Interaction (Read 316 times)
' https://www.qb64.org/forum/index.php?topic=2160.msg129051#msg129051
' https://qb64forum.alephc.xyz/index.php?topic=2160.msg129083#msg129083
' and others (sources cited throughout).
' ################################################################################################################################################################
' #CONSTANTS = GLOBAL CONSTANTS
' boolean constants:
Const FALSE = 0
Const TRUE = Not FALSE
' BEGIN GAME CONTROLLER MAPPING CONSTANTS
Const cInputNone = 0
Const cInputKey = 1
Const cInputButton = 2
Const cInputAxis = 3
Const cMaxButtons = 12
Const cMaxAxis = 8
Const cMaxControllers = 8
Const cMaxPlayers = 8
' Use as index for array of ControlInputType
Const cInputUp = 1
Const cInputDown = 2
Const cInputLeft = 3
Const cInputRight = 4
Const cInputButton1 = 5
Const cInputButton2 = 6
Const cInputButton3 = 7
Const cInputButton4 = 8
Const c_iKeyDown_F10 = 17408
Const c_iKeyHit_AltLeft = -30764
Const c_iKeyHit_AltRight = -30765
' END GAME CONTROLLER MAPPING CONSTANTS
' ################################################################################################################################################################
' #UDT #TYPES = USER DEFINED TYPES
' UDT TO HOLD THE INFO FOR A PLAYER
Type PlayerType
x As Integer ' player x position
y As Integer ' player y position
c As Integer ' character to display on screen
xOld As Integer
yOld As Integer
' control buffer
moveX As Integer
moveY As Integer
moveUp As Integer
moveDown As Integer
moveLeft As Integer
moveRight As Integer
button1 As Integer
button2 As Integer
button3 As Integer
button4 As Integer
' control previous move
'lastMoveX As Integer
'lastMoveY As Integer
lastMoveUp As Integer
lastMoveDown As Integer
lastMoveLeft As Integer
lastMoveRight As Integer
lastButton1 As Integer
lastButton2 As Integer
lastButton3 As Integer
lastButton4 As Integer
'repeat As Integer
End Type ' PlayerType
' UDT TO HOLD THE INFO FOR A GAME CONTROLLER
Type ControllerType
buttonCount As Integer
axisCount As Integer
End Type ' ControllerType
' UDT TO HOLD THE INFO FOR A GAME CONTROLLER
Type ControlInputType
device As Integer
typ As Integer ' cInputKey, cInputButton, cInputAxis
code As Integer
value As Integer
repeat As Integer
End Type ' ControlInputType
' ################################################################################################################################################################
' #VARS = GLOBAL VARIABLES
' ENABLE / DISABLE DEBUG CONSOLE
Dim Shared m_bTesting As Integer: m_bTesting = TRUE
' BASIC PROGRAM METADATA
Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' GAME CONTROLLER MAPPING
Dim Shared m_ControlMapFileName$: m_ControlMapFileName$ = Left$(m_ProgramName$, _InStrRev(m_ProgramName$, ".")) + "map.txt"
ReDim Shared m_arrControlMap(1 To 8, 1 To 8) As ControlInputType ' holds control mapping for each player (player #, direction)
ReDim Shared m_arrController(1 To 8) As ControllerType ' holds info for each game controller
ReDim Shared m_arrButtonCode(1 To 99) As Integer ' Long
ReDim Shared m_arrButtonKey(1 To 99) As String
ReDim Shared m_arrButtonKeyDesc(0 To 512) As String
Dim Shared m_bInitialized As Integer: m_bInitialized = FALSE
Dim Shared m_bHaveMapping As Integer: m_bHaveMapping = FALSE
' USE TO GLOBALLY ENABLE/DISABLE REPEATING INPUT PER FUNCTION
' To enable override set m_bRepeatOverride=TRUE,
' otherwise this can be configured for each individual controller
' when you map the functions.
Dim Shared m_bRepeatOverride As Integer: m_bRepeatOverride = TRUE
Dim Shared m_bRepeatUp As Integer: m_bRepeatUp = TRUE
Dim Shared m_bRepeatDown As Integer: m_bRepeatDown = TRUE
Dim Shared m_bRepeatLeft As Integer: m_bRepeatLeft = FALSE
Dim Shared m_bRepeatRight As Integer: m_bRepeatRight = FALSE
Dim Shared m_bRepeatButton1 As Integer: m_bRepeatButton1 = TRUE
Dim Shared m_bRepeatButton2 As Integer: m_bRepeatButton2 = TRUE
Dim Shared m_bRepeatButton3 As Integer: m_bRepeatButton3 = FALSE
Dim Shared m_bRepeatButton4 As Integer: m_bRepeatButton4 = FALSE
' VARIABLES FOR GRAPHIC PRINTING ROUTINES
Dim Shared m_NumColumns As Integer: m_NumColumns = 1
Dim Shared m_PrintRow As Integer: m_PrintRow = 0
Dim Shared m_PrintCol As Integer: m_PrintCol = 0
Dim Shared m_StartRow As Integer: m_StartRow = 0
Dim Shared m_EndRow As Integer: m_EndRow = 0
Dim Shared m_StartCol As Integer: m_StartCol = 0
Dim Shared m_EndCol As Integer: m_EndCol = 0
' DEMO GAME / TESTING
ReDim Shared m_arrPlayer(1 To 8) As PlayerType ' holds info for each player
' =============================================================================
' LOCAL VARIABLES
Dim in$
' ****************************************************************************************************************************************************************
' ACTIVATE DEBUGGING WINDOW
If m_bTesting = TRUE Then
$Console
_Delay 4
_Console On
_Echo "Started " + m_ProgramName$
_Echo "Debugging on..."
End If
' ****************************************************************************************************************************************************************
' =============================================================================
' START THE MAIN ROUTINE
main
' =============================================================================
' FINISH
Screen 0
Print m_ProgramName$ + " finished."
Input "Press <ENTER> to continue", in$
' ****************************************************************************************************************************************************************
' DEACTIVATE DEBUGGING WINDOW
If m_bTesting = TRUE Then
_Console Off
End If
' ****************************************************************************************************************************************************************
System ' return control to the operating system
End
' /////////////////////////////////////////////////////////////////////////////
Sub main
Dim RoutineName As String: RoutineName = "main"
Dim in$
Dim result$: result$ = ""
' SET UP SCREEN
Screen _NewImage(1280, 1024, 32): _ScreenMove 0, 0
Do
If Len(result$) = 0 Then
Cls
Else
Print
End If
Print m_ProgramName$
Print
Print "Game Input Mapping Test"
Print "v1.0, by Softintheheadware (Jan, 2022)"
Print
Print "1. Basic controller test"
Print "2. Load controller mapping"
Print "3. View controller mapping"
Print "4. Edit controller mapping for 1 or more players"
Print "5. Reset controller mapping for 1 or more players"
Print "6. Map controllers for 1 or more players"
Print "7. Test controller mappings to move around screen"
Print "8. Save controller mappings"
Print
Print "What to do? ('q' to exit)"
Input in$: in$ = LCase$(Left$(in$, 1))
If in$ = "1" Then
result$ = TestJoysticks$
ElseIf in$ = "2" Then
result$ = LoadMappings$
If Len(result$) = 0 Then result$ = "Loaded mappings."
ElseIf in$ = "3" Then
result$ = ViewMappings$
ElseIf in$ = "4" Then
result$ = EditMappings$
ElseIf in$ = "5" Then
result$ = ResetMapping$
ElseIf in$ = "6" Then
result$ = MapInput$
ElseIf in$ = "7" Then
result$ = TestMappings$
ElseIf in$ = "8" Then
result$ = SaveMappings$
End If
If Len(result$) > 0 Then
Print result$
End If
Loop Until in$ = "q"
' RETURN TO TEXT SCREEN
Screen 0
End Sub ' main
' /////////////////////////////////////////////////////////////////////////////
' TODO: get keyboard input working
' TODO: get continuous movement working for digital joysticks
' TODO: adjust analog joystick sensitivity
Function TestMappings$
Dim sResult As String: sResult = ""
Dim sError As String: sError = ""
Dim iDeviceCount As Integer
Dim iDevice As Integer
Dim iNumControllers As Integer
Dim iController As Integer
Dim iValue As Integer
Dim iWhichInput As Integer
Dim arrButton(32, 16) As Integer ' number of buttons on the joystick
Dim arrButtonNew(32, 16) As Integer ' tracks when to initialize values
Dim arrAxis(32, 16) As Double ' number of axis on the joystick
Dim arrAxisNew(32, 16) As Integer ' tracks when to initialize values
Dim iCols As Integer
Dim iRows As Integer
Dim iPlayer As Integer
Dim iNextY As Integer
Dim iNextX As Integer
Dim iNextC As Integer
Dim iMinX As Integer
Dim iMaxX As Integer
Dim iMinY As Integer
Dim iMaxY As Integer
Dim bHaveInput As Integer
Dim bFinished As Integer
Dim bFoundWho As Integer
Dim bRepeat As Integer
Dim in$
' MAKE SURE WE HAVE MAPPING
If m_bHaveMapping = TRUE Then
' INITIALIZE
Cls
InitKeyboardButtonCodes
iCols = _Width(0) \ _FontWidth
iRows = _Height(0) \ _FontHeight
iMinX = 0: iMaxX = iCols
iMinY = 0: iMaxY = iRows
' INITIALIZE PLAYER COORDINATES AND SCREEN CHARACTERS
iNextY = 1
iNextX = -3
iNextC = 64
For iPlayer = LBound(m_arrControlMap, 1) To UBound(m_arrControlMap, 1)
iNextX = iNextX + 4
If iNextX >= iMaxX Then
iNextX = iMinX
iNextY = iNextY + 4
If iNextY > iMaxY Then
iNextY = iMinY
End If
End If
iNextC = iNextC + 1
m_arrPlayer(iPlayer).x = iNextX
m_arrPlayer(iPlayer).y = iNextY
m_arrPlayer(iPlayer).c = iNextC
m_arrPlayer(iPlayer).xOld = iNextX
m_arrPlayer(iPlayer).yOld = iNextY
m_arrPlayer(iPlayer).moveX = 0
m_arrPlayer(iPlayer).moveY = 0
m_arrPlayer(iPlayer).moveUp = FALSE
m_arrPlayer(iPlayer).moveDown = FALSE
m_arrPlayer(iPlayer).moveLeft = FALSE
m_arrPlayer(iPlayer).moveRight = FALSE
m_arrPlayer(iPlayer).button1 = FALSE
m_arrPlayer(iPlayer).button2 = FALSE
m_arrPlayer(iPlayer).button3 = FALSE
m_arrPlayer(iPlayer).button4 = FALSE
m_arrPlayer(iPlayer).lastMoveUp = FALSE
m_arrPlayer(iPlayer).lastMoveDown = FALSE
m_arrPlayer(iPlayer).lastMoveLeft = FALSE
m_arrPlayer(iPlayer).lastMoveRight = FALSE
m_arrPlayer(iPlayer).lastButton1 = FALSE
m_arrPlayer(iPlayer).lastButton2 = FALSE
m_arrPlayer(iPlayer).lastButton3 = FALSE
m_arrPlayer(iPlayer).lastButton4 = FALSE
Next iPlayer
' COUNT # OF JOYSTICKS
' TODO: find out the right way to count joysticks
If Len(sError) = 0 Then
' D= _DEVICES ' MUST be read in order for other 2 device functions to work!
iDeviceCount = _Devices ' Find the number of devices on someone's system
If iDeviceCount > 2 Then
' LIMIT # OF DEVICES, IF THERE IS A LIMIT DEFINED
iNumControllers = iDeviceCount - 2
If cMaxControllers > 0 Then
If iNumControllers > cMaxControllers Then
iNumControllers = cMaxControllers
End If
End If
Else
' ONLY 2 FOUND (KEYBOARD, MOUSE)
'sError = "No game controllers found."
iNumControllers = 0
End If
End If
' INITIALIZE CONTROLLER DATA
If Len(sError) = 0 Then
For iController = 1 To iNumControllers
m_arrController(iController).buttonCount = cMaxButtons
m_arrController(iController).axisCount = cMaxAxis
For iLoop = 1 To cMaxButtons
arrButtonNew(iController, iLoop) = TRUE
Next iLoop
For iLoop = 1 To cMaxAxis
arrAxisNew(iController, iLoop) = TRUE
Next iLoop
Next iController
End If
' INITIALIZE CONTROLLER INPUT
If Len(sError) = 0 Then
_KeyClear: _Delay 1
For iController = 1 To iNumControllers
iDevice = iController + 2
While _DeviceInput(iDevice) ' clear and update the device buffer
For iLoop = 1 To _LastButton(iDevice)
If (iLoop > cMaxButtons) Then Exit For
m_arrController(iController).buttonCount = iLoop
arrButton(iController, iLoop) = FALSE
Next iLoop
For iLoop = 1 To _LastAxis(iDevice) ' this loop checks all my axis
If (iLoop > cMaxAxis) Then Exit For
m_arrController(iController).axisCount = iLoop
arrAxis(iController, iLoop) = 0
Next iLoop
Wend ' clear and update the device buffer
Next iController
End If
' GET INPUT AND MOVE PLAYERS AROUND ON SCREEN
_KeyClear: _Delay 1
bFinished = FALSE
Do
' Clear control buffer for players
For iPlayer = LBound(m_arrControlMap, 1) To UBound(m_arrControlMap, 1)
m_arrPlayer(iPlayer).moveUp = FALSE
m_arrPlayer(iPlayer).moveDown = FALSE
m_arrPlayer(iPlayer).moveLeft = FALSE
m_arrPlayer(iPlayer).moveRight = FALSE
m_arrPlayer(iPlayer).button1 = FALSE
m_arrPlayer(iPlayer).button2 = FALSE
m_arrPlayer(iPlayer).button3 = FALSE
m_arrPlayer(iPlayer).button4 = FALSE
Next iPlayer
' -----------------------------------------------------------------------------
' BEGIN CHECK FOR CONTROLLER INPUT
If iNumControllers > 0 Then
For iController = 1 To iNumControllers
iDevice = iController + 2
' Check all devices
While _DeviceInput(iDevice)
Wend ' clear and update the device buffer
' Check each button
For iLoop = 1 To _LastButton(iDevice)
If (iLoop > cMaxButtons) Then Exit For
' update button array to indicate if a button is up or down currently.
'if TRUE=TRUE then
If _ButtonChange(iLoop) Then
iValue = _Button(iLoop)
If iValue <> arrButton(iController, iLoop) Then
' *****************************************************************************
' PRESSED BUTTON
' BEGIN find who this is mapped for
bFoundWho = FALSE
For iPlayer = LBound(m_arrControlMap, 1) To UBound(m_arrControlMap, 1)
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
If m_arrControlMap(iPlayer, iWhichInput).device = iDevice Then
If m_arrControlMap(iPlayer, iWhichInput).typ = cInputButton Then
If m_arrControlMap(iPlayer, iWhichInput).code = iLoop Then
'if m_arrControlMap(iPlayer, iWhichInput).value = iValue then
bFoundWho = TRUE
Select Case iWhichInput
Case cInputUp:
m_arrPlayer(iPlayer).moveUp = TRUE
Case cInputDown:
m_arrPlayer(iPlayer).moveDown = TRUE
Case cInputLeft:
m_arrPlayer(iPlayer).moveLeft = TRUE
Case cInputRight:
m_arrPlayer(iPlayer).moveRight = TRUE
Case cInputButton1:
m_arrPlayer(iPlayer).button1 = TRUE
Case cInputButton2:
m_arrPlayer(iPlayer).button2 = TRUE
Case cInputButton3:
m_arrPlayer(iPlayer).button3 = TRUE
Case cInputButton4:
m_arrPlayer(iPlayer).button4 = TRUE
Case Else:
'(IGNORE)
End Select
Exit For
'end if
End If
End If
End If
Next iWhichInput
If bFoundWho = TRUE Then Exit For
Next iPlayer
' END find who this is mapped for
End If
End If
Next iLoop
' Check each axis
For iLoop = 1 To _LastAxis(iDevice)
If (iLoop > cMaxAxis) Then Exit For
dblNextAxis = _Axis(iLoop)
dblNextAxis = RoundUpDouble#(dblNextAxis, 3)
' I like to give a little "jiggle" resistance to my controls, as I have an old joystick
' which is prone to always give minute values and never really center on true 0.
' A value of 1 means my axis is pushed fully in one direction.
' A value greater than 0.1 means it's been partially pushed in a direction (such as at a 45 degree diagional angle).
' A value of less than 0.1 means we count it as being centered. (As if it was 0.)
' Set sensitivity:
'These are way too sensitive for analog:
'IF ABS(_AXIS(iLoop)) <= 1 AND ABS(_AXIS(iLoop)) >= .1 THEN
'IF ABS(dblNextAxis) <= 1 AND ABS(dblNextAxis) >= .01 THEN
'IF ABS(dblNextAxis) <= 1 AND ABS(dblNextAxis) >= .001 THEN
''For digital input, we'll use a big picture:
'IF ABS(dblNextAxis) <= 1 AND ABS(dblNextAxis) >= 0.75 THEN
If Abs(dblNextAxis) <= 1 And Abs(dblNextAxis) >= 0.5 Then
' WE WANT CONTINUOUS MOVEMENT (DISABLE FOR NOT)
'if TRUE=TRUE then
If dblNextAxis <> arrAxis(iController, iLoop) Then
' *****************************************************************************
' MOVED STICK
' convert to a digital value
If dblNextAxis < 0 Then
iValue = -1
Else
iValue = 1
End If
' BEGIN find who this is mapped for
bFoundWho = FALSE
For iPlayer = LBound(m_arrControlMap, 1) To UBound(m_arrControlMap, 1)
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
If m_arrControlMap(iPlayer, iWhichInput).device = iDevice Then
If m_arrControlMap(iPlayer, iWhichInput).typ = cInputAxis Then
If m_arrControlMap(iPlayer, iWhichInput).code = iLoop Then
If m_arrControlMap(iPlayer, iWhichInput).value = iValue Then
bFoundWho = TRUE
Select Case iWhichInput
Case cInputUp:
m_arrPlayer(iPlayer).moveUp = TRUE
Case cInputDown:
m_arrPlayer(iPlayer).moveDown = TRUE
Case cInputLeft:
m_arrPlayer(iPlayer).moveLeft = TRUE
Case cInputRight:
m_arrPlayer(iPlayer).moveRight = TRUE
Case cInputButton1:
m_arrPlayer(iPlayer).button1 = TRUE
Case cInputButton2:
m_arrPlayer(iPlayer).button2 = TRUE
Case cInputButton3:
m_arrPlayer(iPlayer).button3 = TRUE
Case cInputButton4:
m_arrPlayer(iPlayer).button4 = TRUE
Case Else:
'(IGNORE)
End Select
Exit For
End If
End If
End If
End If
Next iWhichInput
If bFoundWho = TRUE Then Exit For
Next iPlayer
' END find who this is mapped for
End If
End If
Next iLoop
Next iController
End If
' END CHECK FOR CONTROLLER INPUT
' -----------------------------------------------------------------------------
' -----------------------------------------------------------------------------
' BEGIN CHECK FOR KEYBOARD INPUT #1
'_KEYCLEAR: _DELAY 1
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
' Detect changed key state
iDevice = 1 ' keyboard
For iLoop = LBound(m_arrButtonCode) To UBound(m_arrButtonCode)
iCode = m_arrButtonCode(iLoop)
If _Button(iCode) <> FALSE Then
' *****************************************************************************
' PRESSED KEYBOARD
'PRINT "PRESSED " + m_arrButtonKey(iLoop)
' BEGIN find who this is mapped for
bFoundWho = FALSE
For iPlayer = LBound(m_arrControlMap, 1) To UBound(m_arrControlMap, 1)
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
If m_arrControlMap(iPlayer, iWhichInput).device = iDevice Then
If m_arrControlMap(iPlayer, iWhichInput).typ = cInputKey Then
'if m_arrControlMap(iPlayer, iWhichInput).code = iLoop then
If m_arrControlMap(iPlayer, iWhichInput).code = iCode Then
'if m_arrControlMap(iPlayer, iWhichInput).value = iValue then
bFoundWho = TRUE
Select Case iWhichInput
Case cInputUp:
m_arrPlayer(iPlayer).moveUp = TRUE
Case cInputDown:
m_arrPlayer(iPlayer).moveDown = TRUE
Case cInputLeft:
m_arrPlayer(iPlayer).moveLeft = TRUE
Case cInputRight:
m_arrPlayer(iPlayer).moveRight = TRUE
Case cInputButton1:
m_arrPlayer(iPlayer).button1 = TRUE
Case cInputButton2:
m_arrPlayer(iPlayer).button2 = TRUE
Case cInputButton3:
m_arrPlayer(iPlayer).button3 = TRUE
Case cInputButton4:
m_arrPlayer(iPlayer).button4 = TRUE
Case Else:
'(IGNORE)
End Select
Exit For
'end if
End If
End If
End If
Next iWhichInput
If bFoundWho = TRUE Then Exit For
Next iPlayer
' END find who this is mapped for
End If
Next iLoop
' END CHECK FOR KEYBOARD INPUT #1
' -----------------------------------------------------------------------------
' NOW DRAW PLAYERS ON SCREEN
For iPlayer = LBound(m_arrControlMap, 1) To UBound(m_arrControlMap, 1)
' -----------------------------------------------------------------------------
' BEGIN UPDATE MOVEMENT CONTROL STATES
' If repeating keys are disabled then
' disable until the key has been released
If m_arrControlMap(iPlayer, cInputUp).repeat = FALSE Then
If m_arrPlayer(iPlayer).moveUp = TRUE Then
If m_arrPlayer(iPlayer).lastMoveUp = TRUE Then
m_arrPlayer(iPlayer).moveUp = FALSE
End If
Else
m_arrPlayer(iPlayer).lastMoveUp = FALSE
End If
End If
If m_arrControlMap(iPlayer, cInputDown).repeat = FALSE Then
If m_arrPlayer(iPlayer).moveDown = TRUE Then
If m_arrPlayer(iPlayer).lastMoveDown = TRUE Then
m_arrPlayer(iPlayer).moveDown = FALSE
End If
Else
m_arrPlayer(iPlayer).lastMoveDown = FALSE
End If
End If
If m_arrControlMap(iPlayer, cInputLeft).repeat = FALSE Then
If m_arrPlayer(iPlayer).moveLeft = TRUE Then
If m_arrPlayer(iPlayer).lastMoveLeft = TRUE Then
m_arrPlayer(iPlayer).moveLeft = FALSE
End If
Else
m_arrPlayer(iPlayer).lastMoveLeft = FALSE
End If
End If
If m_arrControlMap(iPlayer, cInputRight).repeat = FALSE Then
If m_arrPlayer(iPlayer).moveRight = TRUE Then
If m_arrPlayer(iPlayer).lastMoveRight = TRUE Then
m_arrPlayer(iPlayer).moveRight = FALSE
End If
Else
m_arrPlayer(iPlayer).lastMoveRight = FALSE
End If
End If
' END UPDATE MOVEMENT CONTROL STATES
' -----------------------------------------------------------------------------
' -----------------------------------------------------------------------------
' BEGIN MOVEMENT ACTIONS
m_arrPlayer(iPlayer).moveY = 0
m_arrPlayer(iPlayer).moveX = 0
If m_arrPlayer(iPlayer).moveUp = TRUE Then
m_arrPlayer(iPlayer).moveY = -1
m_arrPlayer(iPlayer).lastMoveUp = TRUE
End If
If m_arrPlayer(iPlayer).moveDown = TRUE Then
m_arrPlayer(iPlayer).moveY = 1
m_arrPlayer(iPlayer).lastMoveDown = TRUE
End If
If m_arrPlayer(iPlayer).moveLeft = TRUE Then
m_arrPlayer(iPlayer).moveX = -1
m_arrPlayer(iPlayer).lastMoveLeft = TRUE
End If
If m_arrPlayer(iPlayer).moveRight = TRUE Then
m_arrPlayer(iPlayer).moveX = 1
m_arrPlayer(iPlayer).lastMoveRight = TRUE
End If
' END MOVEMENT ACTIONS
' -----------------------------------------------------------------------------
' -----------------------------------------------------------------------------
' BEGIN MOVEMENT
' MOVE RIGHT/LEFT
m_arrPlayer(iPlayer).x = m_arrPlayer(iPlayer).x + m_arrPlayer(iPlayer).moveX
If m_arrPlayer(iPlayer).x < iMinX Then
m_arrPlayer(iPlayer).x = m_arrPlayer(iPlayer).xOld ' iMinX
ElseIf m_arrPlayer(iPlayer).x > iMaxX Then
m_arrPlayer(iPlayer).x = m_arrPlayer(iPlayer).xOld ' iMaxX
End If
' MOVE UP/DOWN
m_arrPlayer(iPlayer).y = m_arrPlayer(iPlayer).y + m_arrPlayer(iPlayer).moveY
If m_arrPlayer(iPlayer).y < iMinY Then
m_arrPlayer(iPlayer).y = m_arrPlayer(iPlayer).yOld ' iMinY
ElseIf m_arrPlayer(iPlayer).y > iMaxY Then
m_arrPlayer(iPlayer).y = m_arrPlayer(iPlayer).yOld ' iMaxY
End If
' UPDATE SCREEN
'_PRINTSTRING (m_arrPlayer(iPlayer).xOld, m_arrPlayer(iPlayer).yOld), " "
'_PRINTSTRING (m_arrPlayer(iPlayer).x, m_arrPlayer(iPlayer).y), CHR$(m_arrPlayer(iPlayer).c)
PrintString m_arrPlayer(iPlayer).xOld, m_arrPlayer(iPlayer).yOld, " "
PrintString m_arrPlayer(iPlayer).x, m_arrPlayer(iPlayer).y, Chr$(m_arrPlayer(iPlayer).c)
m_arrPlayer(iPlayer).xOld = m_arrPlayer(iPlayer).x
m_arrPlayer(iPlayer).yOld = m_arrPlayer(iPlayer).y
' END MOVEMENT
' -----------------------------------------------------------------------------
' -----------------------------------------------------------------------------
' BEGIN UPDATE BUTTON STATES
' If repeating keys are disabled then
' disable until the key has been released
'if m_bRepeatButton1 = FALSE then
If m_arrControlMap(iPlayer, cInputButton1).repeat = FALSE Then
If m_arrPlayer(iPlayer).button1 = TRUE Then
If m_arrPlayer(iPlayer).lastButton1 = TRUE Then
m_arrPlayer(iPlayer).button1 = FALSE
End If
Else
m_arrPlayer(iPlayer).lastButton1 = FALSE
End If
End If
If m_arrControlMap(iPlayer, cInputButton2).repeat = FALSE Then
If m_arrPlayer(iPlayer).button2 = TRUE Then
If m_arrPlayer(iPlayer).lastButton2 = TRUE Then
m_arrPlayer(iPlayer).button2 = FALSE
End If
Else
m_arrPlayer(iPlayer).lastButton2 = FALSE
End If
End If
If m_arrControlMap(iPlayer, cInputButton3).repeat = FALSE Then
If m_arrPlayer(iPlayer).button3 = TRUE Then
If m_arrPlayer(iPlayer).lastButton3 = TRUE Then
m_arrPlayer(iPlayer).button3 = FALSE
End If
Else
m_arrPlayer(iPlayer).lastButton3 = FALSE
End If
End If
If m_arrControlMap(iPlayer, cInputButton4).repeat = FALSE Then
If m_arrPlayer(iPlayer).button4 = TRUE Then
If m_arrPlayer(iPlayer).lastButton4 = TRUE Then
m_arrPlayer(iPlayer).button4 = FALSE
End If
Else
m_arrPlayer(iPlayer).lastButton4 = FALSE
End If
End If
' END UPDATE BUTTON STATES
' -----------------------------------------------------------------------------
' -----------------------------------------------------------------------------
' BEGIN BUTTON ACTIONS
If m_arrPlayer(iPlayer).button1 = TRUE Then
MakeSound iPlayer, 1
m_arrPlayer(iPlayer).lastButton1 = TRUE
End If
If m_arrPlayer(iPlayer).button2 = TRUE Then
MakeSound iPlayer, 2
m_arrPlayer(iPlayer).lastButton2 = TRUE
End If
If m_arrPlayer(iPlayer).button3 = TRUE Then
MakeSound iPlayer, 3
m_arrPlayer(iPlayer).lastButton3 = TRUE
End If
If m_arrPlayer(iPlayer).button4 = TRUE Then
MakeSound iPlayer, 4
m_arrPlayer(iPlayer).lastButton4 = TRUE
End If
' END BUTTON ACTIONS
' -----------------------------------------------------------------------------
Next iPlayer
_Limit 30
Loop Until _KeyHit = 27 ' ESCAPE to quit
_KeyClear: _Delay 1
sResult = sError
Else
sResult = "No mapping loaded. Please load a mapping or map keys."
End If
TestMappings$ = sResult
End Function ' TestMappings$
' /////////////////////////////////////////////////////////////////////////////
Sub MakeSound (iPlayer As Integer, iButton As Integer)
Dim note%
If iPlayer < 1 Then
iPlayer = 1
ElseIf iPlayer > 8 Then
iPlayer = 8
End If
If iButton < 1 Then
iButton = 1
ElseIf iButton > 4 Then
iButton = 4
End If
note% = iPlayer * 100 + (iButton * 25)
If note% > 4186 Then
note% = 4186
End If
Sound note%, .75
End Sub ' MakeSound
' /////////////////////////////////////////////////////////////////////////////
' V2 prints in 2 columns.
Sub PrintControllerMap2
Dim RoutineName As String:: RoutineName = "PrintControllerMap2"
Dim iPlayer As Integer
Dim iWhichInput As Integer
Dim iCount As Integer
Dim sLine As String
Dim iHalf As Integer
Dim sColumn1 As String: sColumn1 = ""
Dim sColumn2 As String: sColumn2 = ""
ReDim arrColumn1(-1) As String
ReDim arrColumn2(-1) As String
Dim iLoop As Integer
Dim iColWidth As Integer: iColWidth = 75
Dim sValue As String
Dim in$
' INITIALIZE
InitKeyboardButtonCodes
' START OUTPUT
Print "Controller mapping:"
'Print "Player# Input Device# Type Code Value"
' 1 button #2 x unknown x x
' 9 11 9 9 18 9
' 12345678912345678901123456789123456789123456789012345678123456789
' 12345678901234567890123456789012345678901234567890123456789012345678901234567890
' 00000000011111111112222222222333333333344444444445555555555666666666677777777778
If m_bHaveMapping = TRUE Then
' THIS IS A LAZY WAY TO GET 2 COLUMNS!
iHalf = UBound(m_arrControlMap, 1) / 2
sLine = "Player# Input Device# Type Code Value Repeat"
sColumn1 = sColumn1 + StrPadRight$(sLine, iColWidth) + Chr$(13)
sLine = "-----------------------------------------------------------------------"
sColumn1 = sColumn1 + StrPadRight$(sLine, iColWidth) + Chr$(13)
For iPlayer = LBound(m_arrControlMap, 1) To iHalf
iCount = 0
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
If InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ) <> "unknown" Then
iCount = iCount + 1
End If
Next iWhichInput
If iCount > 0 Then
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
If InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ) <> "unknown" Then
sLine = IntPadRight$(iPlayer, 9)
sLine = sLine + StrPadRight$(InputToString$(iWhichInput), 11)
sLine = sLine + IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).device, 9)
sLine = sLine + StrPadRight$(InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ), 9)
'sLine = sLine + IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).code, 9)
If m_arrControlMap(iPlayer, iWhichInput).typ = cInputKey Then
sValue = GetKeyboardButtonCodeText$(m_arrControlMap(iPlayer, iWhichInput).code)
sValue = StrPadRight$(sValue, 18)
Else
sValue = IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).code, 18)
End If
sLine = sLine + sValue
sLine = sLine + IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).value, 9)
sValue = TrueFalse$(m_arrControlMap(iPlayer, iWhichInput).repeat)
sLine = sLine + StrPadRight$(sValue, 6)
'Print sLine
sLine = StrPadRight$(sLine, iColWidth)
sColumn1 = sColumn1 + sLine + Chr$(13)
End If
Next iWhichInput
Else
sLine = IntPadRight$(iPlayer, 9) + "(NONE)"
'Print sLine
sLine = StrPadRight$(sLine, iColWidth)
sColumn1 = sColumn1 + sLine + Chr$(13)
End If
Next iPlayer
'sLine = "Player# Input Device# Type Code Value"
sLine = "Player# Input Device# Type Code Value Repeat"
sColumn2 = sColumn2 + StrPadRight$(sLine, iColWidth) + Chr$(13)
'sLine = "-------------------------------------------------------------"
sLine = "-----------------------------------------------------------------------"
sColumn2 = sColumn2 + StrPadRight$(sLine, iColWidth) + Chr$(13)
For iPlayer = iHalf + 1 To UBound(m_arrControlMap, 1)
iCount = 0
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
If InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ) <> "unknown" Then
iCount = iCount + 1
End If
Next iWhichInput
If iCount > 0 Then
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
If InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ) <> "unknown" Then
sLine = IntPadRight$(iPlayer, 9)
sLine = sLine + StrPadRight$(InputToString$(iWhichInput), 11)
sLine = sLine + IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).device, 9)
sLine = sLine + StrPadRight$(InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ), 9)
'sLine = sLine + IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).code, 9)
If m_arrControlMap(iPlayer, iWhichInput).typ = cInputKey Then
sValue = GetKeyboardButtonCodeText$(m_arrControlMap(iPlayer, iWhichInput).code)
sValue = StrPadRight$(sValue, 18)
Else
sValue = IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).code, 18)
End If
sLine = sLine + sValue
sLine = sLine + IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).value, 9)
sValue = TrueFalse$(m_arrControlMap(iPlayer, iWhichInput).repeat)
sLine = sLine + StrPadRight$(sValue, 6)
'Print sLine
sLine = StrPadRight$(sLine, iColWidth)
sColumn2 = sColumn2 + sLine + Chr$(13)
End If
Next iWhichInput
Else
sLine = IntPadRight$(iPlayer, 9) + "(NONE)"
'Print sLine
sLine = StrPadRight$(sLine, iColWidth)
sColumn2 = sColumn2 + sLine + Chr$(13)
End If
Next iPlayer
split sColumn1, Chr$(13), arrColumn1()
split sColumn2, Chr$(13), arrColumn2()
If UBound(arrColumn1) > UBound(arrColumn2) Then
iCount = UBound(arrColumn1)
Else
iCount = UBound(arrColumn2)
End If
For iLoop = 0 To iCount
sLine = ""
If UBound(arrColumn1) >= iLoop Then
sLine = sLine + arrColumn1(iLoop)
Else
sLine = sLine + String$(iColWidth, " ")
End If
sLine = sLine + " "
If UBound(arrColumn2) >= iLoop Then
sLine = sLine + arrColumn2(iLoop)
Else
sLine = sLine + String$(iColWidth, " ")
End If
Print sLine
Next iLoop
Else
Print "No mapping loaded. Please load a mapping or map keys."
End If
End Sub ' PrintControllerMap2
' /////////////////////////////////////////////////////////////////////////////
' Original (simple) routine
Sub PrintControllerMap1
Dim RoutineName As String:: RoutineName = "PrintControllerMap1"
Dim iPlayer As Integer
Dim iWhichInput As Integer
Dim sLine As String
Dim iCount As Integer
Dim in$
' INITIALIZE
InitKeyboardButtonCodes
' OUTPUT MAPPING
Print "Controller mapping:"
Print "Player# Input Device# Type Code Value"
' 1 button #2 x unknown x x
' 9 11 9 9 9 9
' 12345678912345678901123456789123456789123456789123456789
' 12345678901234567890123456789012345678901234567890123456789012345678901234567890
For iPlayer = LBound(m_arrControlMap, 1) To UBound(m_arrControlMap, 1)
iCount = 0
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
If InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ) <> "unknown" Then
iCount = iCount + 1
End If
Next iWhichInput
If iCount > 0 Then
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
If InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ) <> "unknown" Then
sLine = IntPadRight$(iPlayer, 9)
sLine = sLine + StrPadRight$(InputToString$(iWhichInput), 11)
sLine = sLine + IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).device, 9)
sLine = sLine + StrPadRight$(InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ), 9)
sLine = sLine + IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).code, 9)
sLine = sLine + IntPadRight$(m_arrControlMap(iPlayer, iWhichInput).value, 9)
Print sLine
End If
Next iWhichInput
Else
sLine = IntPadRight$(iPlayer, 9) + "(NONE)"
Print sLine
End If
Next iPlayer
End Sub ' PrintControllerMap1
' /////////////////////////////////////////////////////////////////////////////
Function LoadMappings$
Dim sResult As String: sResult = ""
' INITIALIZE
InitKeyboardButtonCodes
' Try loading map
sResult = LoadControllerMap$
LoadMappings$ = sResult
End Function ' LoadMappings$
' /////////////////////////////////////////////////////////////////////////////
Function SaveMappings$
Dim sResult As String: sResult = ""
Dim sError As String: sError = ""
' INITIALIZE
InitKeyboardButtonCodes
' Try saving map
sResult = SaveControllerMap$
SaveMappings$ = sResult
End Function ' SaveMappings$
' /////////////////////////////////////////////////////////////////////////////
Function ViewMappings$
' INITIALIZE
InitKeyboardButtonCodes
PrintControllerMap2
Print
Input "PRESS <ENTER> TO CONTINUE", in$
Print
ViewMappings$ = ""
End Function ' ViewMappings$
' /////////////////////////////////////////////////////////////////////////////
' TODO: test this
Function EditMappings$
Dim RoutineName As String: RoutineName = "EditMappings$"
Dim in$
Dim iPlayer As Integer
Dim iWhichInput As Integer
Dim iDevice As Integer
Dim iType As Integer
Dim iCode As Integer
Dim iValue As Integer
Dim iRepeat As Integer
Dim iItem As Integer
Dim sResult As String: sResult = ""
Dim bContinue1 As Integer: bContinue1 = TRUE
Dim bContinue2 As Integer: bContinue2 = TRUE
Dim bContinue3 As Integer: bContinue3 = TRUE
Dim bContinue4 As Integer: bContinue4 = TRUE
' INITIALIZE
InitKeyboardButtonCodes
' EDIT
Do
PrintControllerMap2
Print "To edit a mapping, enter a player number: " _
"1-" + cstr$(cMaxPlayers) + ", " + _
cstr$(cMaxPlayers+1) + ") or q to exit."
Input "Edit mapping for player"; in$
If IsNum%(in$) Then
iPlayer = Val(in$)
If iPlayer > 0 And iPlayer <= cMaxPlayers Then
bContinue2 = TRUE
Do
Print "Editing mappings for player " + cstr$(iPlayer) + "."
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
'Print right$(" " + cstr$(iWhichInput), 2) + ". " + InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ)
Print Right$(" " + cstr$(iWhichInput), 2) + ". " + InputToString$(iWhichInput)
Next iWhichInput
Input "Type # of control to edit or q to quit editing player"; in$
If IsNum%(in$) Then
iWhichInput = Val(in$)
If iWhichInput >= LBound(m_arrControlMap, 2) And m_arrControlMap <= UBound(m_arrControlMap, 2) Then
bContinue3 = TRUE
Do
Print "Settings for " + InputToString$(iWhichInput) + ":"
Print "1. Device # : " + cstr$(m_arrControlMap(iPlayer, iWhichInput).device)
Print "2. Device type : " + InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ)
If m_arrControlMap(iPlayer, iWhichInput).typ = cInputKey Then
Print "3. Input code : " + GetKeyboardButtonCodeText$(m_arrControlMap(iPlayer, iWhichInput).code) + _
" (" + _Trim$(Str$(m_arrControlMap(iPlayer, iWhichInput).code)) + ")"
Else
Print "3. Input code : " + _Trim$(Str$(m_arrControlMap(iPlayer, iWhichInput).code))
End If
Print "4. Input value : " + _Trim$(Str$(m_arrControlMap(iPlayer, iWhichInput).value))
Print "5. Enable repeat: " + TrueFalse$(m_arrControlMap(iPlayer, iWhichInput).repeat)
Input "Change item? (1-5 or q to quit editing control)"; in$
If IsNum%(in$) Then
iItem = Val(in$)
Select Case iItem
Case 1:
Print "Change the device number."
Input "Type a new device #, 0 for none (disabled), or blank to leave it unchanged"; in$
If IsNum%(in$) Then
iDevice = Val(in$)
m_arrControlMap(iPlayer, iWhichInput).device = iDevice
Print "Updated device number. Remember to save mappings when done."
Else
Print "(No change.)"
End If
Case 2:
bContinue4 = TRUE
Do
Print "Change the device type."
Print cstr$(cInputKey) + "=keyboard"
Print cstr$(cInputButton) + "=game controller button"
Print cstr$(cInputAxis) + "=game controller joystick/axis"
Print cstr$(cInputNone) + "=none"
Input "Device type or blank to leave it unchanged"; in$
If IsNum%(in$) Then
iType = Val(in$)
if iType=cInputKey or iType=cInputButton or _
iType=cInputAxis or iType=cInputNone then
m_arrControlMap(iPlayer, iWhichInput).typ = iType
Print "Updated device type. Remember to save mappings when done."
bContinue4 = FALSE: Exit Do
Else
Print "Please choose one of the listed values."
End If
Else
Print "(No change.)"
bContinue4 = FALSE: Exit Do
End If
Loop Until bContinue4 = FALSE
Case 3:
Print "Change the input code."
Input "Type a new input code, or blank to leave it unchanged"; in$
If IsNum%(in$) Then
iCode = Val(in$)
m_arrControlMap(iPlayer, iWhichInput).code = iCode
Print "Updated input code. Remember to save mappings when done."
Else
Print "(No change.)"
End If
Case 4:
Print "Change the input value."
Input "Type a new input value, or blank to leave it unchanged"; in$
If IsNum%(in$) Then
iValue = Val(in$)
m_arrControlMap(iPlayer, iWhichInput).value = iValue
Print "Updated input value. Remember to save mappings when done."
Else
Print "(No change.)"
End If
Case 5:
Print "Change the repeat setting."
Input "Type 1 to enable or 0 to disable, or blank to leave it unchanged"; in$
If IsNum%(in$) Then
iRepeat = Val(in$)
If iRepeat = 0 Then
m_arrControlMap(iPlayer, iWhichInput).repeat = FALSE
Print "Repeat disabled. Remember to save mappings when done."
ElseIf iRepeat = 1 Then
m_arrControlMap(iPlayer, iWhichInput).repeat = TRUE
Print "Repeat enabled. Remember to save mappings when done."
Else
Print "(No change.)"
End If
Else
Print "(No change.)"
End If
Case Else:
Print "Please choose a number between 1 and 4."
End Select
Else
bContinue3 = FALSE: Exit Do
End If
Loop Until bContinue3 = FALSE
Else
Print "Please choose a number between " + cstr$(LBound(m_arrControlMap, 2)) + " and " + cstr$(UBound(m_arrControlMap, 2)) + "."
End If
Else
bContinue2 = FALSE: Exit Do
End If
Loop Until bContinue2 = FALSE
If bContinue1 = FALSE Then Exit Do
Else
Print "Please choose a number between 1 and " + cstr$(cMaxPlayers) + "."
End If
Else
If Len(sResult) = 0 Then sResult = "(Cancelled.)"
bContinue1 = FALSE: Exit Do
End If
Loop Until bContinue1 = FALSE
_KeyClear: _Delay 1
EditMappings$ = sResult
End Function ' EditMappings$
' /////////////////////////////////////////////////////////////////////////////
Function ResetMapping$
Dim RoutineName As String: RoutineName = "ResetMapping$"
Dim in$
Dim iPlayer As Integer
Dim sResult As String: sResult = ""
' INITIALIZE
InitKeyboardButtonCodes
' RESET
Do
PrintControllerMap2
Print "To delete mapping, enter a player number: " _
"1-" + cstr$(cMaxPlayers) + ", " + _
cstr$(cMaxPlayers+1) + " for all, or 0 to exit."
Input "Delete mapping for player? "; iPlayer
If iPlayer > 0 And iPlayer <= cMaxPlayers Then
Print "Delete mappings for player " + cstr$(iPlayer) + "."
Input "Delete (y/n)"; in$: in$ = LCase$(_Trim$(in$))
If in$ = "y" Then
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
If InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ) <> "unknown" Then
m_arrControlMap(iPlayer, iWhichInput).device = 0
m_arrControlMap(iPlayer, iWhichInput).typ = 0
m_arrControlMap(iPlayer, iWhichInput).code = 0
m_arrControlMap(iPlayer, iWhichInput).value = 0
m_arrControlMap(iPlayer, iWhichInput).repeat = 0 ' GetGlobalInputRepeatSetting%(iWhichInput)
End If
Next iWhichInput
sResult = "Mappings deleted for player " + cstr$(iPlayer) + "."
Print sResult
End If
ElseIf iPlayer = (cMaxPlayers + 1) Then
Input "Delete all mappings (y/n)"; in$: in$ = LCase$(_Trim$(in$))
If in$ = "y" Then
For iPlayer = 1 To cMaxPlayers
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
If InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ) <> "unknown" Then
m_arrControlMap(iPlayer, iWhichInput).device = 0
m_arrControlMap(iPlayer, iWhichInput).typ = 0
m_arrControlMap(iPlayer, iWhichInput).code = 0
m_arrControlMap(iPlayer, iWhichInput).value = 0
m_arrControlMap(iPlayer, iWhichInput).repeat = 0 ' GetGlobalInputRepeatSetting%(iWhichInput)
End If
Next iWhichInput
Next iPlayer
sResult = "All mappings deleted."
Print sResult
End If
Else
If Len(sResult) = 0 Then sResult = "(Cancelled.)"
Exit Do
End If
Loop
ResetMapping$ = sResult
End Function ' ResetMapping$
' /////////////////////////////////////////////////////////////////////////////
Function MapInput$
Dim RoutineName As String: RoutineName = "MapInput$"
Dim in$
Dim iDeviceCount As Integer
Dim iPlayer As Integer
Dim sResult As String
Dim sError As String
' INITIALIZE
InitKeyboardButtonCodes
' SET UP SCREEN
Screen _NewImage(1280, 1024, 32): _ScreenMove 0, 0
' MAKE SURE WE HAVE DEVICES
' 1 is the keyboard
' 2 is the mouse
' 3 is the joystick
' unless someone has a strange setup with multiple mice/keyboards/ect...
' In that case, you can use _DEVICE$(i) to look for "KEYBOARD", "MOUSE", "JOYSTICK", if necessary.
' I've never actually found it necessary, but I figure it's worth mentioning, just in case...
iDeviceCount = _Devices ' Find the number of devices on someone's system
If iDeviceCount > 2 Then
'' Try loading map
'sError = LoadControllerMap$
'if len(sError) = 0 then
' print "Previous controller mapping loaded."
'else
' print "*******************************************************************************"
' print "There were errors loading the controller mapping file:"
' print sError
' print
' print "Try remapping - a new file will be created."
' print "*******************************************************************************"
'end if
Do
PrintControllerMap2
Print "To edit mapping, enter a player number (1-" + cstr$(cMaxPlayers) + ") or 0 to exit."
Input "Get input for player? "; iPlayer
If iPlayer > 0 And iPlayer <= cMaxPlayers Then
sResult = MapInput1$(iPlayer)
If Len(sResult) = 0 Then
Print "Remember to save mappings when done."
Else
Print sResult
End If
Else
sResult = "(Cancelled.)"
Exit Do
End If
Loop
Else
sResult = "No controller devices found."
Input "PRESS <ENTER> TO CONTINUE", in$
End If
MapInput$ = sResult
End Function ' MapInput$
' /////////////////////////////////////////////////////////////////////////////
' Detect controls
' THIS VERSION SUPPORTS UPTO 8 JOYSTICKS, WITH UPTO 2 BUTTONS AND 2 AXES EACH
' (THIS IS FOR ATARI 2600 JOYSTICKS)
' The following shared arrays must be declared:
' ReDim Shared m_arrButtonCode(1 To 99) As Long
' ReDim Shared m_arrButtonKey(1 To 99) As String
Function MapInput1$ (iPlayer As Integer)
Dim RoutineName As String:: RoutineName = "MapInput1$"
Dim sResult As String: sResult = ""
Dim sError As String: sError = ""
Dim in$
Dim iDeviceCount As Integer
Dim iDevice As Integer
Dim iNumControllers As Integer
Dim iController As Integer
Dim iLoop As Integer
Dim strValue As String
Dim strAxis As String
Dim dblNextAxis
Dim iCount As Long
Dim iValue As Integer
Dim iCode As Integer
Dim arrButton(32, 16) As Integer ' number of buttons on the joystick
Dim arrButtonNew(32, 16) As Integer ' tracks when to initialize values
Dim arrAxis(32, 16) As Double ' number of axis on the joystick
Dim arrAxisNew(32, 16) As Integer ' tracks when to initialize values
'Dim arrInput(1 To 8) As ControlInputType
Dim iWhichInput As Integer
Dim bFinished As Integer
Dim bHaveInput As Integer
Dim bMoveNext As Integer
Dim bCancel As Integer
Dim iNextInput As Integer
' FOR PRINTING OUTPUT
Dim iDigits As Integer ' # digits to display (values are truncated to this length)
Dim iColCount As Integer
Dim iGroupCount As Integer
Dim sLine As String
Dim iCols As Integer
Dim iRows As Integer
Dim iMaxCols As Integer
' INITIALIZE
If Len(sError) = 0 Then
iDigits = 4 ' 11
iColCount = 3
iGroupCount = 0 ' re-initialized at the top of every loop
iCols = _Width(0) \ _FontWidth
iRows = _Height(0) \ _FontHeight
End If
' COUNT # OF JOYSTICKS
' TODO: find out the right way to count joysticks
If Len(sError) = 0 Then
' D= _DEVICES ' MUST be read in order for other 2 device functions to work!
iDeviceCount = _Devices ' Find the number of devices on someone's system
If iDeviceCount > 2 Then
' LIMIT # OF DEVICES, IF THERE IS A LIMIT DEFINED
iNumControllers = iDeviceCount - 2
If cMaxControllers > 0 Then
If iNumControllers > cMaxControllers Then
iNumControllers = cMaxControllers
End If
End If
Else
' ONLY 2 FOUND (KEYBOARD, MOUSE)
sError = "No game controllers found."
End If
End If
' INITIALIZE CONTROLLER DATA
If Len(sError) = 0 Then
For iController = 1 To iNumControllers
m_arrController(iController).buttonCount = cMaxButtons
m_arrController(iController).axisCount = cMaxAxis
For iLoop = 1 To cMaxButtons
arrButtonNew(iController, iLoop) = TRUE
Next iLoop
For iLoop = 1 To cMaxAxis
arrAxisNew(iController, iLoop) = TRUE
Next iLoop
Next iController
End If
' INITIALIZE CONTROLLER INPUT
If Len(sError) = 0 Then
Cls
Print "We will now detect controllers."
Print "Do not touch any keys or game controllers during detection."
Input "Press <ENTER> to begin"; in$
_KeyClear: Print
sLine = "Initializing controllers": Print sLine;
iMaxCols = (iCols - Len(sLine)) - 1
iCount = 0
Do
iCount = iCount + 1
If iCount < iMaxCols Then
Print ".";
Else
Print ".": Print sLine: iCount = 0
End If
For iController = 1 To iNumControllers
iDevice = iController + 2
While _DeviceInput(iDevice) ' clear and update the device buffer
For iLoop = 1 To _LastButton(iDevice)
If (iLoop > cMaxButtons) Then Exit For
m_arrController(iController).buttonCount = iLoop
'IF _BUTTONCHANGE(iLoop) THEN
' arrButton(iController, iLoop) = _BUTTON(iLoop)
'END IF
arrButton(iController, iLoop) = FALSE
Next iLoop
For iLoop = 1 To _LastAxis(iDevice) ' this loop checks all my axis
If (iLoop > cMaxAxis) Then Exit For
m_arrController(iController).axisCount = iLoop
arrAxis(iController, iLoop) = 0
Next iLoop
Wend ' clear and update the device buffer
Next iController
_Limit 30
Loop Until iCount > 60 ' quit after 2 seconds
Print: Print
End If
' WAIT FOR INPUT
If Len(sError) = 0 Then
Cls
Print "Press <ESCAPE> to cancel at any time."
Print
_KeyClear: _Delay 1
bCancel = FALSE
bFinished = FALSE
iLastPressed = 0
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
'print "iWhichInput=" + cstr$(iWhichInput)
Print "Player #" + cstr$(iPlayer) + " press control for " + InputToString$(iWhichInput) + " or ESC to skip: ";
' =============================================================================
' BEGIN LOOK FOR NEXT INPUT
bMoveNext = FALSE
Do
' -----------------------------------------------------------------------------
' BEGIN CHECK FOR CONTROLLER INPUT
For iController = 1 To iNumControllers
iDevice = iController + 2
' Check all devices
While _DeviceInput(iDevice)
' Check each button
If bMoveNext = FALSE Then
For iLoop = 1 To _LastButton(iDevice)
If (iLoop > cMaxButtons) Then Exit For
'm_arrController(iController).buttonCount = iLoop
' update button array to indicate if a button is up or down currently.
If _ButtonChange(iLoop) Then
iValue = _Button(iLoop)
If iValue <> arrButton(iController, iLoop) Then
' *****************************************************************************
' PRESSED BUTTON
' make sure this isn't already mapped
bHaveInput = TRUE
If iWhichInput > LBound(m_arrControlMap, 2) Then
' is input unique?
For iNextInput = LBound(m_arrControlMap, 2) To iWhichInput - 1
If m_arrControlMap(iPlayer, iNextInput).device = iDevice Then
If m_arrControlMap(iPlayer, iNextInput).typ = cInputButton Then
If m_arrControlMap(iPlayer, iNextInput).code = iLoop Then
If m_arrControlMap(iPlayer, iNextInput).value = iValue Then
bHaveInput = FALSE
End If
End If
End If
End If
Next iNextInput
End If
If bHaveInput Then
m_arrControlMap(iPlayer, iWhichInput).device = iDevice
m_arrControlMap(iPlayer, iWhichInput).typ = cInputButton
m_arrControlMap(iPlayer, iWhichInput).code = iLoop
m_arrControlMap(iPlayer, iWhichInput).value = iValue
bMoveNext = TRUE
End If
End If
End If
Next iLoop
End If
' Check each axis
If bMoveNext = FALSE Then
For iLoop = 1 To _LastAxis(iDevice)
If (iLoop > cMaxAxis) Then Exit For
'm_arrController(iController).axisCount = iLoop
dblNextAxis = _Axis(iLoop)
dblNextAxis = RoundUpDouble#(dblNextAxis, 3)
' I like to give a little "jiggle" resistance to my controls, as I have an old joystick
' which is prone to always give minute values and never really center on true 0.
' A value of 1 means my axis is pushed fully in one direction.
' A value greater than 0.1 means it's been partially pushed in a direction (such as at a 45 degree diagional angle).
' A value of less than 0.1 means we count it as being centered. (As if it was 0.)
'These are way too sensitive for analog:
'IF ABS(_AXIS(iLoop)) <= 1 AND ABS(_AXIS(iLoop)) >= .1 THEN
'IF ABS(dblNextAxis) <= 1 AND ABS(dblNextAxis) >= .01 THEN
'IF ABS(dblNextAxis) <= 1 AND ABS(dblNextAxis) >= .001 THEN
'For digital input, we'll use a big picture:
If Abs(dblNextAxis) <= 1 And Abs(dblNextAxis) >= 0.75 Then
If dblNextAxis <> arrAxis(iController, iLoop) Then
' *****************************************************************************
' MOVED STICK
' convert to a digital value
If dblNextAxis < 0 Then
iValue = -1
Else
iValue = 1
End If
' make sure this isn't already mapped
bHaveInput = TRUE
If iWhichInput > LBound(m_arrControlMap, 2) Then
' is input unique?
For iNextInput = LBound(m_arrControlMap, 2) To iWhichInput - 1
If m_arrControlMap(iPlayer, iNextInput).device = iDevice Then
If m_arrControlMap(iPlayer, iNextInput).typ = cInputAxis Then
If m_arrControlMap(iPlayer, iNextInput).code = iLoop Then
If m_arrControlMap(iPlayer, iNextInput).value = iValue Then
bHaveInput = FALSE
End If
End If
End If
End If
Next iNextInput
End If
If bHaveInput Then
m_arrControlMap(iPlayer, iWhichInput).device = iDevice
m_arrControlMap(iPlayer, iWhichInput).typ = cInputAxis
m_arrControlMap(iPlayer, iWhichInput).code = iLoop
m_arrControlMap(iPlayer, iWhichInput).value = iValue
bMoveNext = TRUE
End If
End If
End If
Next iLoop
End If
Wend ' clear and update the device buffer
Next iController
' END CHECK FOR CONTROLLER INPUT
' -----------------------------------------------------------------------------
' -----------------------------------------------------------------------------
' BEGIN CHECK FOR KEYBOARD INPUT #1
If bMoveNext = FALSE Then
'_KEYCLEAR: _DELAY 1
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
' Detect changed key state
For iLoop = LBound(m_arrButtonCode) To UBound(m_arrButtonCode)
iCode = m_arrButtonCode(iLoop)
If _Button(iCode) <> FALSE Then
' *****************************************************************************
' PRESSED KEYBOARD
'PRINT "PRESSED " + m_arrButtonKey(iLoop)
' make sure this isn't already mapped
bHaveInput = TRUE
If iWhichInput > LBound(m_arrControlMap, 2) Then
' is input unique?
For iNextInput = LBound(m_arrControlMap, 2) To iWhichInput - 1
If m_arrControlMap(iPlayer, iNextInput).device = 1 Then ' .device 1 = keyboard
If m_arrControlMap(iPlayer, iNextInput).typ = cInputKey Then
If m_arrControlMap(iPlayer, iNextInput).code = iCode Then
'if m_arrControlMap(iPlayer, iNextInput).value = TRUE then
bHaveInput = FALSE
'end if
End If
End If
End If
Next iNextInput
End If
If bHaveInput Then
m_arrControlMap(iPlayer, iWhichInput).device = 1 ' .device 1 = keyboard
m_arrControlMap(iPlayer, iWhichInput).typ = cInputKey
m_arrControlMap(iPlayer, iWhichInput).code = iCode
m_arrControlMap(iPlayer, iWhichInput).value = TRUE
bMoveNext = TRUE
End If
End If
Next iLoop
End If
' END CHECK FOR KEYBOARD INPUT #1
' -----------------------------------------------------------------------------
If bMoveNext = TRUE Then Exit Do
_Limit 30
Loop Until _KeyHit = 27 ' ESCAPE to quit
' END LOOK FOR NEXT INPUT
' =============================================================================
If bMoveNext = TRUE Then
Print "Device #" + cstr$(m_arrControlMap(iPlayer, iWhichInput).device) + " " + _
InputTypeToString$(m_arrControlMap(iPlayer, iWhichInput).typ) + " " + _
cstr$(m_arrControlMap(iPlayer, iWhichInput).code) + " = " + _
cstr$(m_arrControlMap(iPlayer, iWhichInput).value)
' Only ask user to select repeat if no override.
If m_bRepeatOverride = FALSE Then
Input "Enable repeat (y/n)"; in$: in$ = LCase$(_Trim$(in$))
If in$ = "y" Then
m_arrControlMap(iPlayer, iWhichInput).repeat = TRUE
Else
m_arrControlMap(iPlayer, iWhichInput).repeat = FALSE
End If
Else
m_arrControlMap(iPlayer, iWhichInput).repeat = GetGlobalInputRepeatSetting%(iWhichInput)
End If
Else
Print "(Skipped)"
bCancel = TRUE
bFinished = TRUE
End If
If bFinished = TRUE Then Exit For
Next iWhichInput
End If
If Len(sError) = 0 Then
m_bHaveMapping = TRUE
Else
sResult = "ERRORS: " + sError
End If
_KeyClear: _Delay 1
MapInput1$ = sResult
End Function ' MapInput1$
' /////////////////////////////////////////////////////////////////////////////
' Receives which input contstant and returns a text description
Function InputToString$ (iWhich As Integer)
Select Case iWhich
Case cInputUp:
InputToString$ = "up"
Case cInputDown:
InputToString$ = "down"
Case cInputLeft:
InputToString$ = "left"
Case cInputRight:
InputToString$ = "right"
Case cInputButton1:
InputToString$ = "button #1"
Case cInputButton2:
InputToString$ = "button #2"
Case cInputButton3:
InputToString$ = "button #3"
Case cInputButton4:
InputToString$ = "button #4"
Case Else:
InputToString$ = "unknown"
End Select
End Function ' InputToString$
' /////////////////////////////////////////////////////////////////////////////
' Receives which input contstant and returns its global "repeat" setting
' usage:
' m_arrControlMap(iPlayer, iWhichInput).repeat = GetGlobalInputRepeatSetting%(cInputUp)
Function GetGlobalInputRepeatSetting% (iWhich As Integer)
Select Case iWhich
Case cInputUp:
GetGlobalInputRepeatSetting% = m_bRepeatUp
Case cInputDown:
GetGlobalInputRepeatSetting% = m_bRepeatDown
Case cInputLeft:
GetGlobalInputRepeatSetting% = m_bRepeatLeft
Case cInputRight:
GetGlobalInputRepeatSetting% = m_bRepeatRight
Case cInputButton1:
GetGlobalInputRepeatSetting% = m_bRepeatButton1
Case cInputButton2:
GetGlobalInputRepeatSetting% = m_bRepeatButton2
Case cInputButton3:
GetGlobalInputRepeatSetting% = m_bRepeatButton3
Case cInputButton4:
GetGlobalInputRepeatSetting% = m_bRepeatButton4
Case Else:
GetGlobalInputRepeatSetting% = FALSE
End Select
End Function ' GetGlobalInputRepeatSetting%
' /////////////////////////////////////////////////////////////////////////////
Function InputTypeToString$ (iCode As Integer)
Select Case iCode
Case cInputNone:
InputTypeToString$ = "none"
Case cInputKey:
InputTypeToString$ = "key"
Case cInputButton:
InputTypeToString$ = "button"
Case cInputAxis:
InputTypeToString$ = "axis"
Case Else:
InputTypeToString$ = "unknown"
End Select
End Function ' InputTypeToString$
' /////////////////////////////////////////////////////////////////////////////
' METHOD v2 = faster
Function GetKeyboardButtonCodeText$ (iCode As Integer)
Dim sResult As String: sResult = ""
If LBound(m_arrButtonKeyDesc) <= iCode Then
If UBound(m_arrButtonKeyDesc) >= iCode Then
sResult = m_arrButtonKeyDesc(iCode)
End If
End If
If Len(sResult) = 0 Then
sResult = _Trim$(Str$(iCode)) + " (?)"
End If
GetKeyboardButtonCodeText$ = sResult
End Function ' GetKeyboardButtonCodeText$
' /////////////////////////////////////////////////////////////////////////////
' METHOD v2
' Faster lookup - a dictionary with a hash lookup would be best
' but this is a quick way to do it since the values never change.
' The following shared arrays must be declared:
' ReDim Shared m_arrButtonCode(1 To 99) As Long
' ReDim Shared m_arrButtonKey(1 To 99) As String
' ReDim Shared m_arrButtonKeyDesc(0 To 512) As String
Sub InitKeyboardButtonCodes ()
Dim iLoop As Integer
If m_bInitialized = FALSE Then
' CODE(S) DETECTED WITH _BUTTON:
m_arrButtonCode(1) = 2: m_arrButtonKey(1) = "Esc"
m_arrButtonCode(2) = 60: m_arrButtonKey(2) = "F1"
m_arrButtonCode(3) = 61: m_arrButtonKey(3) = "F2"
m_arrButtonCode(4) = 62: m_arrButtonKey(4) = "F3"
m_arrButtonCode(5) = 63: m_arrButtonKey(5) = "F4"
m_arrButtonCode(6) = 64: m_arrButtonKey(6) = "F5"
m_arrButtonCode(7) = 65: m_arrButtonKey(7) = "F6"
m_arrButtonCode(8) = 66: m_arrButtonKey(8) = "F7"
m_arrButtonCode(9) = 67: m_arrButtonKey(9) = "F8"
m_arrButtonCode(10) = 68: m_arrButtonKey(10) = "F9"
m_arrButtonCode(11) = 88: m_arrButtonKey(11) = "F11"
m_arrButtonCode(12) = 89: m_arrButtonKey(12) = "F12"
m_arrButtonCode(13) = 42: m_arrButtonKey(13) = "Tilde"
m_arrButtonCode(14) = 3: m_arrButtonKey(14) = "1"
m_arrButtonCode(15) = 4: m_arrButtonKey(15) = "2"
m_arrButtonCode(16) = 5: m_arrButtonKey(16) = "3"
m_arrButtonCode(17) = 6: m_arrButtonKey(17) = "4"
m_arrButtonCode(18) = 7: m_arrButtonKey(18) = "5"
m_arrButtonCode(19) = 8: m_arrButtonKey(19) = "6"
m_arrButtonCode(20) = 9: m_arrButtonKey(20) = "7"
m_arrButtonCode(21) = 10: m_arrButtonKey(21) = "8"
m_arrButtonCode(22) = 11: m_arrButtonKey(22) = "9"
m_arrButtonCode(23) = 12: m_arrButtonKey(23) = "0"
m_arrButtonCode(24) = 13: m_arrButtonKey(24) = "Minus"
m_arrButtonCode(25) = 14: m_arrButtonKey(25) = "Equal"
m_arrButtonCode(26) = 15: m_arrButtonKey(26) = "BkSp"
m_arrButtonCode(27) = 16: m_arrButtonKey(27) = "Tab"
m_arrButtonCode(28) = 17: m_arrButtonKey(28) = "Q"
m_arrButtonCode(29) = 18: m_arrButtonKey(29) = "W"
m_arrButtonCode(30) = 19: m_arrButtonKey(30) = "E"
m_arrButtonCode(31) = 20: m_arrButtonKey(31) = "R"
m_arrButtonCode(32) = 21: m_arrButtonKey(32) = "T"
m_arrButtonCode(33) = 22: m_arrButtonKey(33) = "Y"
m_arrButtonCode(34) = 23: m_arrButtonKey(34) = "U"
m_arrButtonCode(35) = 24: m_arrButtonKey(35) = "I"
m_arrButtonCode(36) = 25: m_arrButtonKey(36) = "O"
m_arrButtonCode(37) = 26: m_arrButtonKey(37) = "P"
m_arrButtonCode(38) = 27: m_arrButtonKey(38) = "BracketLeft"
m_arrButtonCode(39) = 28: m_arrButtonKey(39) = "BracketRight"
m_arrButtonCode(40) = 44: m_arrButtonKey(40) = "Backslash"
m_arrButtonCode(41) = 59: m_arrButtonKey(41) = "CapsLock"
m_arrButtonCode(42) = 31: m_arrButtonKey(42) = "A"
m_arrButtonCode(43) = 32: m_arrButtonKey(43) = "S"
m_arrButtonCode(44) = 33: m_arrButtonKey(44) = "D"
m_arrButtonCode(45) = 34: m_arrButtonKey(45) = "F"
m_arrButtonCode(46) = 35: m_arrButtonKey(46) = "G"
m_arrButtonCode(47) = 36: m_arrButtonKey(47) = "H"
m_arrButtonCode(48) = 37: m_arrButtonKey(48) = "J"
m_arrButtonCode(49) = 38: m_arrButtonKey(49) = "K"
m_arrButtonCode(50) = 39: m_arrButtonKey(50) = "L"
m_arrButtonCode(51) = 40: m_arrButtonKey(51) = "Semicolon"
m_arrButtonCode(52) = 41: m_arrButtonKey(52) = "Apostrophe"
m_arrButtonCode(53) = 29: m_arrButtonKey(53) = "Enter"
m_arrButtonCode(54) = 43: m_arrButtonKey(54) = "ShiftLeft"
m_arrButtonCode(55) = 45: m_arrButtonKey(55) = "Z"
m_arrButtonCode(56) = 46: m_arrButtonKey(56) = "X"
m_arrButtonCode(57) = 47: m_arrButtonKey(57) = "C"
m_arrButtonCode(58) = 48: m_arrButtonKey(58) = "V"
m_arrButtonCode(59) = 49: m_arrButtonKey(59) = "B"
m_arrButtonCode(60) = 50: m_arrButtonKey(60) = "N"
m_arrButtonCode(61) = 51: m_arrButtonKey(61) = "M"
m_arrButtonCode(62) = 52: m_arrButtonKey(62) = "Comma"
m_arrButtonCode(63) = 53: m_arrButtonKey(63) = "Period"
m_arrButtonCode(64) = 54: m_arrButtonKey(64) = "Slash"
m_arrButtonCode(65) = 55: m_arrButtonKey(65) = "ShiftRight"
m_arrButtonCode(66) = 30: m_arrButtonKey(66) = "CtrlLeft"
m_arrButtonCode(67) = 348: m_arrButtonKey(67) = "WinLeft"
m_arrButtonCode(68) = 58: m_arrButtonKey(68) = "Spacebar"
m_arrButtonCode(69) = 349: m_arrButtonKey(69) = "WinRight"
m_arrButtonCode(70) = 350: m_arrButtonKey(70) = "Menu"
m_arrButtonCode(71) = 286: m_arrButtonKey(71) = "CtrlRight"
m_arrButtonCode(72) = 339: m_arrButtonKey(72) = "Ins"
m_arrButtonCode(73) = 328: m_arrButtonKey(73) = "Home"
m_arrButtonCode(74) = 330: m_arrButtonKey(74) = "PgUp"
m_arrButtonCode(75) = 340: m_arrButtonKey(75) = "Del"
m_arrButtonCode(76) = 336: m_arrButtonKey(76) = "End"
m_arrButtonCode(77) = 338: m_arrButtonKey(77) = "PgDn"
m_arrButtonCode(78) = 329: m_arrButtonKey(78) = "Up"
m_arrButtonCode(79) = 332: m_arrButtonKey(79) = "Left"
m_arrButtonCode(80) = 337: m_arrButtonKey(80) = "Down"
m_arrButtonCode(81) = 334: m_arrButtonKey(81) = "Right"
m_arrButtonCode(82) = 71: m_arrButtonKey(82) = "ScrollLock"
m_arrButtonCode(83) = 326: m_arrButtonKey(83) = "NumLock"
m_arrButtonCode(84) = 310: m_arrButtonKey(84) = "KeypadSlash"
m_arrButtonCode(85) = 56: m_arrButtonKey(85) = "KeypadMultiply"
m_arrButtonCode(86) = 75: m_arrButtonKey(86) = "KeypadMinus"
m_arrButtonCode(87) = 72: m_arrButtonKey(87) = "Keypad7Home"
m_arrButtonCode(88) = 73: m_arrButtonKey(88) = "Keypad8Up"
m_arrButtonCode(89) = 74: m_arrButtonKey(89) = "Keypad9PgUp"
m_arrButtonCode(90) = 79: m_arrButtonKey(90) = "KeypadPlus"
m_arrButtonCode(91) = 76: m_arrButtonKey(91) = "Keypad4Left"
m_arrButtonCode(92) = 77: m_arrButtonKey(92) = "Keypad5"
m_arrButtonCode(93) = 78: m_arrButtonKey(93) = "Keypad6Right"
m_arrButtonCode(94) = 80: m_arrButtonKey(94) = "Keypad1End"
m_arrButtonCode(95) = 81: m_arrButtonKey(95) = "Keypad2Down"
m_arrButtonCode(96) = 82: m_arrButtonKey(96) = "Keypad3PgDn"
m_arrButtonCode(97) = 285: m_arrButtonKey(97) = "KeypadEnter"
m_arrButtonCode(98) = 83: m_arrButtonKey(98) = "Keypad0Ins"
m_arrButtonCode(99) = 84: m_arrButtonKey(99) = "KeypadPeriodDel"
' not sure if this works:
'' CODE(S) DETECTED WITH _KEYDOWN:
'm_arrButtonCode(100) = -1 : m_arrButtonCode(100) = "F10"
' not sure if this works:
'' CODE(S) DETECTED WITH _KEYHIT:
'm_arrButtonCode(101) = -2 : m_arrButtonCode(101) = "AltLeft"
'm_arrButtonCode(102) = -3 : m_arrButtonCode(102) = "AltRight"
' DESCRIPTIONS BY KEYCODE
For iLoop = LBound(m_arrButtonKeyDesc) To UBound(m_arrButtonKeyDesc)
m_arrButtonKeyDesc(iLoop) = ""
Next iLoop
m_arrButtonKeyDesc(2) = "Esc"
m_arrButtonKeyDesc(60) = "F1"
m_arrButtonKeyDesc(61) = "F2"
m_arrButtonKeyDesc(62) = "F3"
m_arrButtonKeyDesc(63) = "F4"
m_arrButtonKeyDesc(64) = "F5"
m_arrButtonKeyDesc(65) = "F6"
m_arrButtonKeyDesc(66) = "F7"
m_arrButtonKeyDesc(67) = "F8"
m_arrButtonKeyDesc(68) = "F9"
m_arrButtonKeyDesc(88) = "F11"
m_arrButtonKeyDesc(89) = "F12"
m_arrButtonKeyDesc(42) = "Tilde"
m_arrButtonKeyDesc(3) = "1"
m_arrButtonKeyDesc(4) = "2"
m_arrButtonKeyDesc(5) = "3"
m_arrButtonKeyDesc(6) = "4"
m_arrButtonKeyDesc(7) = "5"
m_arrButtonKeyDesc(8) = "6"
m_arrButtonKeyDesc(9) = "7"
m_arrButtonKeyDesc(10) = "8"
m_arrButtonKeyDesc(11) = "9"
m_arrButtonKeyDesc(12) = "0"
m_arrButtonKeyDesc(13) = "Minus"
m_arrButtonKeyDesc(14) = "Equal"
m_arrButtonKeyDesc(15) = "BkSp"
m_arrButtonKeyDesc(16) = "Tab"
m_arrButtonKeyDesc(17) = "Q"
m_arrButtonKeyDesc(18) = "W"
m_arrButtonKeyDesc(19) = "E"
m_arrButtonKeyDesc(20) = "R"
m_arrButtonKeyDesc(21) = "T"
m_arrButtonKeyDesc(22) = "Y"
m_arrButtonKeyDesc(23) = "U"
m_arrButtonKeyDesc(24) = "I"
m_arrButtonKeyDesc(25) = "O"
m_arrButtonKeyDesc(26) = "P"
m_arrButtonKeyDesc(27) = "BracketLeft"
m_arrButtonKeyDesc(28) = "BracketRight"
m_arrButtonKeyDesc(44) = "Backslash"
m_arrButtonKeyDesc(59) = "CapsLock"
m_arrButtonKeyDesc(31) = "A"
m_arrButtonKeyDesc(32) = "S"
m_arrButtonKeyDesc(33) = "D"
m_arrButtonKeyDesc(34) = "F"
m_arrButtonKeyDesc(35) = "G"
m_arrButtonKeyDesc(36) = "H"
m_arrButtonKeyDesc(37) = "J"
m_arrButtonKeyDesc(38) = "K"
m_arrButtonKeyDesc(39) = "L"
m_arrButtonKeyDesc(40) = "Semicolon"
m_arrButtonKeyDesc(41) = "Apostrophe"
m_arrButtonKeyDesc(29) = "Enter"
m_arrButtonKeyDesc(43) = "ShiftLeft"
m_arrButtonKeyDesc(45) = "Z"
m_arrButtonKeyDesc(46) = "X"
m_arrButtonKeyDesc(47) = "C"
m_arrButtonKeyDesc(48) = "V"
m_arrButtonKeyDesc(49) = "B"
m_arrButtonKeyDesc(50) = "N"
m_arrButtonKeyDesc(51) = "M"
m_arrButtonKeyDesc(52) = "Comma"
m_arrButtonKeyDesc(53) = "Period"
m_arrButtonKeyDesc(54) = "Slash"
m_arrButtonKeyDesc(55) = "ShiftRight"
m_arrButtonKeyDesc(30) = "CtrlLeft"
m_arrButtonKeyDesc(348) = "WinLeft"
m_arrButtonKeyDesc(58) = "Spacebar"
m_arrButtonKeyDesc(349) = "WinRight"
m_arrButtonKeyDesc(350) = "Menu"
m_arrButtonKeyDesc(286) = "CtrlRight"
m_arrButtonKeyDesc(339) = "Ins"
m_arrButtonKeyDesc(328) = "Home"
m_arrButtonKeyDesc(330) = "PgUp"
m_arrButtonKeyDesc(340) = "Del"
m_arrButtonKeyDesc(336) = "End"
m_arrButtonKeyDesc(338) = "PgDn"
m_arrButtonKeyDesc(329) = "Up"
m_arrButtonKeyDesc(332) = "Left"
m_arrButtonKeyDesc(337) = "Down"
m_arrButtonKeyDesc(334) = "Right"
m_arrButtonKeyDesc(71) = "ScrollLock"
m_arrButtonKeyDesc(326) = "NumLock"
m_arrButtonKeyDesc(310) = "KeypadSlash"
m_arrButtonKeyDesc(56) = "KeypadMultiply"
m_arrButtonKeyDesc(75) = "KeypadMinus"
m_arrButtonKeyDesc(72) = "Keypad7Home"
m_arrButtonKeyDesc(73) = "Keypad8Up"
m_arrButtonKeyDesc(74) = "Keypad9PgUp"
m_arrButtonKeyDesc(79) = "KeypadPlus"
m_arrButtonKeyDesc(76) = "Keypad4Left"
m_arrButtonKeyDesc(77) = "Keypad5"
m_arrButtonKeyDesc(78) = "Keypad6Right"
m_arrButtonKeyDesc(80) = "Keypad1End"
m_arrButtonKeyDesc(81) = "Keypad2Down"
m_arrButtonKeyDesc(82) = "Keypad3PgDn"
m_arrButtonKeyDesc(285) = "KeypadEnter"
m_arrButtonKeyDesc(83) = "Keypad0Ins"
m_arrButtonKeyDesc(84) = "KeypadPeriodDel"
m_bInitialized = TRUE
End If
End Sub ' InitKeyboardButtonCodes
' /////////////////////////////////////////////////////////////////////////////
' not sure if this works
' Returns TRUE if the F10 key is held down.
' We use _KEYDOWN for this because _BUTTON doesn't detect F10.
' Constant must be declared globally:
' Const c_iKeyDown_F10 = 17408
Function KeydownF10%
Dim iCode As Long
'_KEYCLEAR: _DELAY 1
If _KeyDown(c_iKeyDown_F10) = TRUE Then
KeydownF10% = TRUE
Else
KeydownF10% = FALSE
End If
'_KEYCLEAR
End Function ' KeydownF10%
' /////////////////////////////////////////////////////////////////////////////
' not sure if this works
' Returns TRUE if the left ALT key is held down.
' We use _KEYHIT for this because _BUTTON doesn't detect ALT.
' Constant must be declared globally:
' Const c_iKeyHit_AltLeft = -30764
Function KeyhitAltLeft%
'_KEYCLEAR: _DELAY 1
If _KeyHit = c_iKeyHit_AltLeft Then
KeyhitAltLeft% = TRUE
Else
KeyhitAltLeft% = FALSE
End If
'_KEYCLEAR
End Function ' KeyhitAltLeft%
' /////////////////////////////////////////////////////////////////////////////
' not sure if this works
' Returns TRUE if the right ALT key is held down.
' We use _KEYHIT for this because _BUTTON doesn't detect ALT.
' Constant must be declared globally:
' Const c_iKeyHit_AltRight = -30765
Function KeyhitAltRight%
'_KEYCLEAR: _DELAY 1
If _KeyHit = c_iKeyHit_AltRight Then
KeyhitAltRight% = TRUE
Else
KeyhitAltRight% = FALSE
End If
'_KEYCLEAR
End Function ' KeyhitAltRight%
' /////////////////////////////////////////////////////////////////////////////
' DEVICES Button
' _LASTBUTTON(1) keyboards will normally return 512 buttons. One button is read per loop through all numbers.
' _BUTTONCHANGE(number) returns -1 when pressed, 1 when released and 0 when there is no event since the last read.
' _BUTTON(number) returns -1 when a button is pressed and 0 when released
' Detects most keys (where the codes are documented?)
' However, does not seem to detect:
' Key Use
' --- ---
' F10 Function KeydownF10%
' Left Alt Function KeyhitAltLeft%
' Right Alt Function KeyhitAltRight%
' Print Screen (system API call?)
' Pause/Break (system API call?)
Function KeyPressed% (iCode As Integer)
'_KEYCLEAR: _DELAY 1
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
If _Button(iCode) <> FALSE Then
KeyPressed% = TRUE
Else
KeyPressed% = FALSE
End If
'_KEYCLEAR
End Function ' KeyPressed%
' /////////////////////////////////////////////////////////////////////////////
Function TestJoysticks$
Dim RoutineName As String: RoutineName = "TestJoysticks$"
Dim iDeviceCount As Integer
Dim sResult As String
' 1 is the keyboard
' 2 is the mouse
' 3 is the joystick
' unless someone has a strange setup with multiple mice/keyboards/ect...
' In that case, you can use _DEVICE$(i) to look for "KEYBOARD", "MOUSE", "JOYSTICK", if necessary.
' I've never actually found it necessary, but I figure it's worth mentioning, just in case...
iDeviceCount = _Devices ' Find the number of devices on someone's system
If iDeviceCount > 2 Then
TestJoysticks1
sResult = ""
Else
sResult = "No joysticks found."
End If
_KeyClear
TestJoysticks$ = sResult
End Function ' TestJoysticks$
' /////////////////////////////////////////////////////////////////////////////
' Reads controllers and displays values on screen.
' Currently this is set up to support up to 8 joysticks,
' with upto 4 buttons and 2 axes each
' Testing with an old USB Logitech RumblePad 2
' and Atari 2600 joysticks plugged into using
' iCode Atari Joystick, Paddle, Driving to USB Adapter 4 ports
Sub TestJoysticks1 ()
Dim RoutineName As String:: RoutineName = "TestJoysticks1"
Dim in$
Dim iDeviceCount As Integer
Dim iDevice As Integer
Dim arrButton(32, 16) As Integer ' number of buttons on the joystick
Dim arrButtonMin(32, 16) As Integer ' stores the minimum value read
Dim arrButtonMax(32, 16) As Integer ' stores the maximum value read
Dim arrAxis(32, 16) As Double ' number of axis on the joystick
Dim arrAxisMin(32, 16) As Double ' stores the minimum value read
Dim arrAxisMax(32, 16) As Double ' stores the maximum value read
Dim arrAxisAvg(32, 16) As Double ' stores the average value read in the last few measurements
Dim arrButtonNew(32, 16) As Integer ' tracks when to initialize values
Dim arrAxisNew(32, 16) As Integer ' tracks when to initialize values
Dim arrController(8) As ControllerType ' holds info for each player
Dim iNumControllers As Integer
Dim iController As Integer
Dim iNextY As Integer
Dim iNextX As Integer
Dim iNextC As Integer
Dim iLoop As Integer
Dim iDigits As Integer ' # digits to display (values are truncated to this length)
Dim strValue As String
Dim strAxis As String
Dim dblNextAxis
'DIM iMeasureCount AS INTEGER
Dim dblAverage As Double
Dim sngAverage As Single
Dim sLine As String
Dim iX As Integer
Dim iY As Integer
Dim iCol As Integer
Dim iRow As Integer
Dim iCols As Integer
Dim iRows As Integer
Dim iColWidth As Integer
Dim iColCount As Integer
Dim iGroupCount As Integer
' SET UP SCREEN
Screen _NewImage(1280, 1024, 32): _ScreenMove 0, 0
' INITIALIZE
iDigits = 4 ' 11
iColCount = 3
iCols = _Width(0) \ _FontWidth
iRows = _Height(0) \ _FontHeight
iColWidth = iCols \ iColCount
' COUNT # OF JOYSTICKS
' D= _DEVICES ' MUST be read in order for other 2 device functions to work!
iDeviceCount = _Devices ' Find the number of devices on someone's system
If iDeviceCount < 3 Then
Cls
Print "NO JOYSTICKS FOUND, EXITING..."
Input "PRESS <ENTER>"; in$
Exit Sub
End If
' BASE # OF PLAYERS ON HOW MANY CONTROLLERS FOUND
iNumControllers = iDeviceCount - 2 ' TODO: find out the right way to count joysticks
If iNumControllers > cMaxControllers Then
iNumControllers = cMaxControllers
End If
' INITIALIZE PLAYER COORDINATES AND SCREEN CHARACTERS
iNextY = 1
iNextX = -3
iNextC = 64
For iController = 1 To iNumControllers
iNextX = iNextX + 4
If iNextX > 80 Then
iNextX = 1
iNextY = iNextY + 4
End If
iNextC = iNextC + 1
arrController(iController).buttonCount = cMaxButtons
arrController(iController).axisCount = cMaxAxis
For iLoop = 1 To cMaxButtons
arrButtonNew(iController, iLoop) = TRUE
Next iLoop
For iLoop = 1 To cMaxAxis
arrAxisNew(iController, iLoop) = TRUE
arrAxisAvg(iController, iLoop) = 0
Next iLoop
Next iController
' CLEAR THE SCREEN
'iMeasureCount = 0
Do
For iController = 1 To iNumControllers
iDevice = iController + 2
While _DeviceInput(iDevice) ' clear and update the device buffer
''IF _DEVICEINPUT = 3 THEN ' this says we only care about joystick input values
' check all the buttons
For iLoop = 1 To _LastButton(iDevice)
If (iLoop > cMaxButtons) Then
Exit For
End If
arrController(iController).buttonCount = iLoop
' update button array to indicate if a button is up or down currently.
If _ButtonChange(iLoop) Then
'' _BUTTON(number) returns -1 when a button is pressed and 0 when released.
''arrButton(iLoop) = NOT arrButton(iLoop)
arrButton(iController, iLoop) = _Button(iLoop)
End If
'' SAVE MINIMUM VALUE
'if arrButton(iController, iLoop) < arrButtonMin(iController, iLoop) then
' arrButtonMin(iController, iLoop) = arrButton(iController, iLoop)
'
' ' INITIALIZE THE MAX TO THE MINIMUM VALUE
' IF arrButtonNew(iController, iLoop) = TRUE THEN
' arrButtonMax(iController, iLoop) = arrButtonMin(iController, iLoop)
' arrButtonNew(iController, iLoop) = FALSE
' END IF
'end if
'
'' SAVE MAXIMUM VALUE
'if arrButton(iController, iLoop) > arrButtonMax(iController, iLoop) then
' arrButtonMax(iController, iLoop) = arrButton(iController, iLoop)
'end if
Next iLoop
For iLoop = 1 To _LastAxis(iDevice) ' this loop checks all my axis
If (iLoop > cMaxAxis) Then
Exit For
End If
arrController(iController).axisCount = iLoop
' I like to give a little "jiggle" resistance to my controls, as I have an old joystick
' which is prone to always give minute values and never really center on true 0.
' A value of 1 means my axis is pushed fully in one direction.
' A value greater than 0.1 means it's been partially pushed in a direction (such as at a 45 degree diagional angle).
' A value of less than 0.1 means we count it as being centered. (As if it was 0.)
'IF ABS(_AXIS(iLoop)) <= 1 AND ABS(_AXIS(iLoop)) >= .1 THEN
dblNextAxis = _Axis(iLoop)
dblNextAxis = RoundUpDouble#(dblNextAxis, 3)
'IF ABS(dblNextAxis) <= 1 AND ABS(dblNextAxis) >= .01 THEN
If Abs(dblNextAxis) <= 1 And Abs(dblNextAxis) >= .001 Then
arrAxis(iController, iLoop) = dblNextAxis
Else
arrAxis(iController, iLoop) = 0
End If
'' SAVE MINIMUM VALUE
'if arrAxis(iController, iLoop) < arrAxisMin(iController, iLoop) then
' arrAxisMin(iController, iLoop) = arrAxis(iController, iLoop)
'
' ' INITIALIZE THE MAX TO THE MINIMUM VALUE
' IF arrAxisNew(iController, iLoop) = TRUE THEN
' arrAxisMax(iController, iLoop) = arrAxisMin(iController, iLoop)
' arrAxisNew(iController, iLoop) = FALSE
' END IF
'end if
'
'' SAVE MAXIMUM VALUE
'if arrAxis(iController, iLoop) > arrAxisMax(iController, iLoop) then
' arrAxisMax(iController, iLoop) = arrAxis(iController, iLoop)
'end if
'
'' ADD CURRENT VALUE TO AVERAGE SUM
'arrAxisAvg(iController, iLoop) = arrAxisAvg(iController, iLoop) + arrAxis(iController, iLoop)
Next iLoop
Wend ' clear and update the device buffer
Next iController
'PRINT "*** iNumControllers=" + cstr$(iNumControllers) + " ***"
'iMeasureCount = iMeasureCount + 1
'if iMeasureCount = 10 then
'iMeasureCount = 0
' And below here is just the simple display routine which displays our values.
' If this was for a game, I'd choose something like arrAxis(1) = -1 for a left arrow style input,
' arrAxis(1) = 1 for a right arrow style input, rather than just using _KEYHIT or INKEY$.
InitColumns iColCount
m_StartRow = 6
m_EndRow = iRows - 2
'm_StartCol
'm_EndCol
Cls
PrintString 1, 1, "Game controller test program."
PrintString 1, 2, "This program is free to use and distribute per GNU GPLv3 license."
PrintString 1, 3, "Tests up to 4 controllers with 2 axes / 2 buttons each."
PrintString 1, 4, "Plug in controllers and move them & press buttons."
PrintString 1, 5, "-------------------------------------------------------------------------------"
iGroupCount = 0
For iController = 1 To iNumControllers
For iLoop = 1 To arrController(iController).axisCount ' A loop for each axis
strAxis = Right$(" " + cstr$(iLoop), 2)
sLine = ""
' display their status to the screen
sLine = sLine + "Player " + cstr$(iController)
strValue = FormatNumber$(arrAxis(iController, iLoop), iDigits)
sLine = sLine + ", Axis #" + strAxis + " = " + strValue
'strValue = FormatNumber$(arrAxisMin(iController, iLoop), iDigits)
'sLine = sLine + ", Min=" + strValue
'
'strValue = FormatNumber$(arrAxisMax(iController, iLoop), iDigits)
'sLine = sLine + ", Max=" + strValue
'
'' COMPUTE AVERAGE
'dblAverage = arrAxisAvg(iController, iLoop) / 10
'dblAverage = RoundUpDouble# (dblAverage, 3)
'strValue = FormatNumber$(dblAverage, iDigits)
'sLine = sLine + ", Avg=" + strValue
'
'' CLEAR THE AVERAGE
'arrAxisAvg(iController, iLoop) = 0
PrintColumn sLine
Next iLoop
For iLoop = 1 To arrController(iController).buttonCount ' A loop for each button
strAxis = Right$(" " + cstr$(iLoop), 2)
sLine = ""
' display their status to the screen
sLine = sLine + "Player " + cstr$(iController)
strValue = FormatNumber$(arrButton(iController, iLoop), iDigits)
sLine = sLine + ", Button #" + strAxis + " = " + strValue
'strValue = FormatNumber$(arrButtonMin(iController, iLoop), iDigits)
'sLine = sLine + ", Min=" + strValue
'
'strValue = FormatNumber$(arrButtonMax(iController, iLoop), iDigits)
'sLine = sLine + ", Max=" + strValue
PrintColumn sLine
Next iLoop
iGroupCount = iGroupCount + 1
If iGroupCount = 2 Then
ColumnBreak
iGroupCount = 0
End If
Next iController
PrintString 1, iRows - 1, "-------------------------------------------------------------------------------"
PrintString 1, iRows - 0, "PRESS <ESC> TO EXIT"
'end if
_Limit 30
Loop Until _KeyHit = 27 ' ESCAPE to quit
' RETURN TO TEXT SCREEN
Screen 0
End Sub ' TestJoysticks1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN FILE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' File format is comma-delimited
' containing controller info for one action per line
' where each line contains the following in this order:
' TAB ORDER INFO TYPE DESCRIPTION
' 1 {player #} Integer player # this mapping is for
' 2 {which action} Integer which action this mapping is for (up/down/right/left/button 1/button 2, etc.)
' 3 {device #} Integer number of the device this is mapped to
' 4 {type} Integer type of input (one of: cInputKey, cInputButton, cInputAxis)
' 5 {code} Integer if button the _BUTTON #, if axis the _AXIS #, if keyboard the _BUTTON #
' 6 {value} Integer if axis, the value (-1 or 1), else can be ignored
' 7 {repeat} Integer if TRUE, and repeating keys not controlled by global values (when m_bRepeatOverride=TRUE), controls repeating keys for this control
' These need to be declared globally and populated:
' ReDim Shared m_arrControlMap(1 To 8, 1 To 8) As ControlInputType
' Dim Shared m_ControlMapFileName$: m_ControlMapFileName$ = Left$(m_ProgramName$, _InStrRev(m_ProgramName$, ".")) + "map.txt"
' Dim Shared m_bRepeatOverride As Integer
' If there is an error, returns error message,
' else returns blank string.
Function SaveControllerMap$
Dim RoutineName As String:: RoutineName = "SaveControllerMap$"
Dim sResult As String: sResult = ""
Dim sError As String: sError = ""
Dim sFile As String
Dim in$
Dim iPlayer As Integer
Dim iWhichInput As Integer
Dim sLine As String
Dim iCount As Long: iCount = 0
'Dim iError As Long: iError = 0
Dim sDelim As String: sDelim = "," ' CHR$(9)
'DebugPrint "--------------------------------------------------------------------------------"
'DebugPrint "Started " + RoutineName
'DebugPrint "--------------------------------------------------------------------------------"
' Get file name
If Len(m_ControlMapFileName$) = 0 Then
m_ControlMapFileName$ = Left$(m_ProgramName$, _InStrRev(m_ProgramName$, ".")) + "map.txt"
End If
sFile = Mid$(m_ControlMapFileName$, _InStrRev(m_ControlMapFileName$, "\") + 1)
'_KeyClear
'Cls
'Print "SAVE CONTROLLER MAPPING:"
'Print "Default file name is " + Chr$(34) + m_ControlMapFileName$ + Chr$(34) + "."
'Input "Type save file name, or blank for default: ", in$
'in$ = _Trim$(in$)
'If Len(in$) > 0 Then
' m_ControlMapFileName$ = in$
'End If
'sFile = m_ProgramPath$ + m_ControlMapFileName$
'DebugPrint "m_ControlMapFileName$=" + CHR$(34) + m_ControlMapFileName$ + CHR$(34)
' Save mapping to file
Open m_ControlMapFileName$ For Output As #1
For iPlayer = LBound(m_arrControlMap, 1) To UBound(m_arrControlMap, 1)
For iWhichInput = LBound(m_arrControlMap, 2) To UBound(m_arrControlMap, 2)
sLine = ""
sLine = sLine + _Trim$(Str$(iPlayer))
sLine = sLine + sDelim
sLine = sLine + _Trim$(Str$(iWhichInput))
sLine = sLine + sDelim
sLine = sLine + _Trim$(Str$(m_arrControlMap(iPlayer, iWhichInput).device))
sLine = sLine + sDelim
sLine = sLine + _Trim$(Str$(m_arrControlMap(iPlayer, iWhichInput).typ))
sLine = sLine + sDelim
sLine = sLine + _Trim$(Str$(m_arrControlMap(iPlayer, iWhichInput).code))
sLine = sLine + sDelim
sLine = sLine + _Trim$(Str$(m_arrControlMap(iPlayer, iWhichInput).value))
sLine = sLine + sDelim
sLine = sLine + _Trim$(Str$(m_arrControlMap(iPlayer, iWhichInput).repeat))
Print #1, sLine
iCount = iCount + 1
Next iWhichInput
Next iPlayer
Close #1
'DebugPrint "Wrote " + _Trim$(Str$(iCount)) + " lines."
'Print "Skipped " + _Trim$(Str$(iError)) + " lines."
'DebugPrint ""
'Input "PRESS <ENTER> TO CONTINUE", in$
If Len(sError) = 0 Then
sResult = "Saved mapping file " + Chr$(34) + sFile + Chr$(34) + "."
Else
sResult = "ERRORS: " + sError
End If
SaveControllerMap$ = sResult
End Function ' SaveControllerMap$
' /////////////////////////////////////////////////////////////////////////////
Function LoadControllerMap$
Dim RoutineName As String:: RoutineName = "LoadControllerMap$"
Dim sResult As String: sResult = ""
Dim sError As String: sError = ""
Dim sNextErr As String
Dim sFile As String
Dim sText As String
Dim iTotal As Long: iTotal = 0
Dim iRead As Long: iRead = 0
Dim iValid As Long: iValid = 0
Dim iBad As Long: iBad = 0
Dim iBlank As Long: iBlank = 0
Dim sLine As String
ReDim arrNextLine(-1) As String
Dim iNumValues As Integer
Dim iAdjust As Integer
Dim iPlayer As Integer
Dim iWhichInput As Integer
Dim iDevice As Integer
Dim iType As Integer
Dim iCode As Integer
Dim iValue As Integer
Dim bRepeat As Integer
'Dim sDebugLine As String
'DebugPrint "--------------------------------------------------------------------------------"
'DebugPrint "Started " + RoutineName
'DebugPrint "--------------------------------------------------------------------------------"
' Get file name
If Len(sError) = 0 Then
If Len(m_ControlMapFileName$) = 0 Then
m_ControlMapFileName$ = Left$(m_ProgramName$, _InStrRev(m_ProgramName$, ".")) + "map.txt"
End If
sFile = Mid$(m_ControlMapFileName$, _InStrRev(m_ControlMapFileName$, "\") + 1)
End If
'' Get file name
'If Len(sError) = 0 Then
' Cls
' If Len(m_ControlMapFileName$) = 0 Then
' m_ControlMapFileName$ = Left$(m_ProgramName$, _InStrRev(m_ProgramName$, ".")) + "map.txt"
' End If
' Print "LOAD CONTROLLER MAPPING:"
' Print "Default file name is " + Chr$(34) + m_ControlMapFileName$ + Chr$(34) + "."
' Input "Type name of file to open, or blank for default: ", in$
' in$ = _Trim$(in$)
' If Len(in$) > 0 Then
' m_ControlMapFileName$ = in$
' End If
' sFile = m_ProgramPath$ + m_ControlMapFileName$
'End If
' Make sure file exists
If Len(sError) = 0 Then
If _FileExists(m_ControlMapFileName$) = FALSE Then
sError = "File not found: " + Chr$(34) + m_ControlMapFileName$ + Chr$(34)
Else
'DebugPrint "Found file: " + chr$(34) + m_ControlMapFileName$ + chr$(34)
End If
End If
' Read data from file
If Len(sError) = 0 Then
'DebugPrint "OPEN m_ControlMapFileName$ FOR BINARY AS #1"
Open m_ControlMapFileName$ For Binary As #1
sText = Space$(LOF(1))
Get #1, , sText
Close #1
iTotal = Len(sText) - Len(Replace$(sText, Chr$(13), ""))
sText = ""
Open m_ControlMapFileName$ For Input As #1
While Not EOF(1)
'INPUT #1, sLine
Line Input #1, sLine ' read entire text file line
iRead = iRead + 1
'DebugPrint "Parsing line " + _Trim$(Str$(iRead)) + _
' " of " + _Trim$(Str$(iTotal))
sLine = Replace$(sLine, " ", "") ' Remove spaces
sLine = Replace$(sLine, Chr$(9), "") ' Remove tabs
sLine = Replace$(sLine, Chr$(10), "") ' Remove line breaks
sLine = Replace$(sLine, Chr$(13), "") ' Remove carriage returns
'DebugPrint " Trimmed=" + chr$(34) + sLine + chr$(34)
If Len(sLine) > 0 Then
split sLine, ",", arrNextLine()
'DebugPrint "split into arrNextLine()"
'DebugPrint " lbound =" + _Trim$(Str$(lbound(arrNextLine))) '+ CHR$(10)
'DebugPrint " ubound =" + _Trim$(Str$(ubound(arrNextLine))) '+ CHR$(10)
iNumValues = (UBound(arrNextLine) - LBound(arrNextLine)) + 1
If iNumValues > 5 Then
iAdjust = -1 '- lbound(arrNextLine)
If Len(sNextErr) = 0 Then
If IsNum%(arrNextLine(1 + iAdjust)) = TRUE Then
iPlayer = Val(arrNextLine(1 + iAdjust))
Else
sNextErr = "Error on line " + cstr$(iRead) + ", value 1: not a number"
End If
End If
If Len(sNextErr) = 0 Then
If IsNum%(arrNextLine(2 + iAdjust)) = TRUE Then
iWhichInput = Val(arrNextLine(2 + iAdjust))
Else
sNextErr = "Error on line " + cstr$(iRead) + ", value 2: not a number"
End If
End If
If Len(sNextErr) = 0 Then
If IsNum%(arrNextLine(3 + iAdjust)) = TRUE Then
iDevice = Val(arrNextLine(3 + iAdjust))
Else
sNextErr = "Error on line " + cstr$(iRead) + ", value 3: not a number"
End If
End If
If Len(sNextErr) = 0 Then
If IsNum%(arrNextLine(4 + iAdjust)) = TRUE Then
iType = Val(arrNextLine(4 + iAdjust))
Else
sNextErr = "Error on line " + cstr$(iRead) + ", value 4: not a number"
End If
End If
If Len(sNextErr) = 0 Then
If IsNum%(arrNextLine(5 + iAdjust)) = TRUE Then
iCode = Val(arrNextLine(5 + iAdjust))
Else
sNextErr = "Error on line " + cstr$(iRead) + ", value 5: not a number"
End If
End If
If Len(sNextErr) = 0 Then
If IsNum%(arrNextLine(6 + iAdjust)) = TRUE Then
iValue = Val(arrNextLine(6 + iAdjust))
Else
sNextErr = "Error on line " + cstr$(iRead) + ", value 6: not a number"
End If
End If
' validate iPlayer
If Len(sNextErr) = 0 Then
If iPlayer < LBound(m_arrControlMap, 1) Then
sNextErr = "Player value " + _Trim$(Str$(iPlayer)) + _
" is outside lbound(m_arrControlMap, 1) " + _
" which is " + _Trim$(Str$(lbound(m_arrControlMap, 1))) + "."
ElseIf iPlayer > UBound(m_arrControlMap, 1) Then
sNextErr = "Player value " + _Trim$(Str$(iPlayer)) + _
" is outside ubound(m_arrControlMap, 1) " + _
" which is " + _Trim$(Str$(ubound(m_arrControlMap, 1))) + "."
End If
End If
' validate iWhichInput
If Len(sNextErr) = 0 Then
If iWhichInput < LBound(m_arrControlMap, 2) Then
sNextErr = "WhichInput value " + _Trim$(Str$(iWhichInput)) + _
" is outside lbound(m_arrControlMap, 2) " + _
" which is " + _Trim$(Str$(lbound(m_arrControlMap, 2))) + "."
ElseIf iWhichInput > UBound(m_arrControlMap, 2) Then
sNextErr = "WhichInput value " + _Trim$(Str$(iWhichInput)) + _
" is outside ubound(m_arrControlMap, 2) " + _
" which is " + _Trim$(Str$(ubound(m_arrControlMap, 2))) + "."
End If
End If
' validate repeat setting
If iNumValues > 6 Then
If Len(sNextErr) = 0 Then
If IsNum%(arrNextLine(7 + iAdjust)) = TRUE Then
bRepeat = Val(arrNextLine(7 + iAdjust))
Else
sNextErr = "Error on line " + cstr$(iRead) + ", value 7: not a number"
End If
End If
Else
' get values from global
'if m_bRepeatOverride = TRUE then
bRepeat = GetGlobalInputRepeatSetting%(iWhichInput)
'end if
End If
Else
sNextErr = "Error on line " + cstr$(iRead) + ": detected " + cstr$(iNumValues) + " values, expected 6."
End If
If Len(sNextErr) = 0 Then
iValid = iValid + 1
m_arrControlMap(iPlayer, iWhichInput).device = iDevice
m_arrControlMap(iPlayer, iWhichInput).typ = iType
m_arrControlMap(iPlayer, iWhichInput).code = iCode
m_arrControlMap(iPlayer, iWhichInput).value = iValue
m_arrControlMap(iPlayer, iWhichInput).repeat = bRepeat
Else
iBad = iBad + 1
DebugPrint sNextErr
End If
Else
'DebugPrint " Line is blank: skipped"
iBlank = iBlank + 1
End If ' LEN(sLine) > 0
Wend
Close #1
End If
'DebugPrint ""
'DebugPrint "Lines read: " + _Trim$(Str$(iRead))
'DebugPrint "Valid : " + _Trim$(Str$(iValid))
'DebugPrint "Invalid : " + _Trim$(Str$(iErrors))
'DebugPrint "Blank : " + _Trim$(Str$(iBlank))
'DebugPrint ""
'Input "PRESS <ENTER> TO CONTINUE", in$
If Len(sError) = 0 Then
sResult = "Loaded mapping file " + Chr$(34) + sFile + Chr$(34) + "."
m_bHaveMapping = TRUE
Else
sResult = "ERRORS: " + sError
End If
LoadControllerMap$ = sResult
End Function ' LoadControllerMap$
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END FILE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GRAPHIC PRINTING ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Eliminates the math.
' Text resolution:
' 648 x 480: 80 x 30
' 720 x 480: 90 x 30
' 800 x 600: 100 x 37
' 1024 x 768: 128 x 48
' 1280 x 1024: 160 x 64
' 1920 x 1080: 240 x 67
' 2048 x 1152: 256 x 72 (truncated after 70 rows, 255 columns)
' 3840 x 2160: 480 x135 (truncated after 133 rows, 479 columns)
Sub PrintString (iCol As Integer, iRow As Integer, MyString As String)
Dim iCols As Integer
Dim iRows As Integer
Dim iX As Integer
Dim iY As Integer
iCols = _Width(0) \ _FontWidth
iRows = _Height(0) \ _FontHeight
iX = _FontWidth * (iCol - 1)
iY = _FontHeight * (iRow - 1)
_PrintString (iX, iY), MyString
End Sub ' PrintString
' /////////////////////////////////////////////////////////////////////////////
' A way to automatically print to columns.
' Depends on the following shared variables:
' Dim Shared m_NumColumns As Integer : m_NumColumns = 1
' Dim Shared m_PrintRow As Integer : m_PrintRow = 0
' Dim Shared m_PrintCol As Integer : m_PrintCol = 0
' Dim Shared m_StartRow As Integer : m_StartRow = 0
' Dim Shared m_EndRow As Integer : m_EndRow = 0
' Dim Shared m_StartCol As Integer : m_StartCol = 0
' Dim Shared m_EndCol As Integer : m_EndCol = 0
' InitColumns 2
' m_PrintRow = 5
' m_PrintCol = 2
' PrintColumn "Col 2, Row 5"
' PrintColumn "m_NumColumns=" + cstr$(m_NumColumns)
Sub PrintColumn (MyString As String)
Dim iCols As Integer
Dim iRows As Integer
Dim iX As Integer
Dim iY As Integer
ReDim arrLines(-1) As String
Dim iRow As Integer
Dim iCol As Integer
Dim sChar As String
Dim sLine As String
Dim iColWidth As Integer
iCols = _Width(0) \ _FontWidth
iRows = _Height(0) \ _FontHeight
If m_NumColumns < 1 Or m_NumColumns > iCols Then
m_NumColumns = 1
End If
If m_StartRow < 1 Or m_StartRow > iRows Then
m_StartRow = 1
End If
If m_EndRow < m_StartRow Or m_EndRow > iRows Then
m_EndRow = iRows
End If
If m_StartCol < 1 Or m_StartCol > m_NumColumns Then
m_StartCol = 1
End If
If m_EndCol < m_StartCol Or m_EndCol > m_NumColumns Then
m_EndCol = m_NumColumns
End If
If m_PrintRow < m_StartRow Then
m_PrintRow = m_StartRow
End If
If m_PrintCol < m_StartCol Then
m_PrintCol = m_StartCol
End If
iColWidth = iCols \ m_NumColumns
If m_PrintRow <= m_EndRow Then
If m_PrintCol <= m_EndCol Then
split MyString, Chr$(13), arrLines()
For iRow = 0 To UBound(arrlines)
sLine = Left$(arrLines(iRow), iColWidth)
'TODO: wrap remaining text
iX = _FontWidth * ((m_PrintCol - 1) * iColWidth)
iY = _FontHeight * (m_PrintRow - 1)
_PrintString (iX, iY), sLine
m_PrintRow = m_PrintRow + 1
If m_PrintRow > m_EndRow Then
m_PrintRow = m_StartRow
m_PrintCol = m_PrintCol + 1
If m_PrintCol > m_NumColumns Then
'TODO: options for when we reach the bottom of the last column (stop printing, wrap around)
m_PrintCol = 1
End If
End If
Next iRow
End If
End If
End Sub ' PrintColumn
' /////////////////////////////////////////////////////////////////////////////
' A way to automatically print to columns.
Sub ColumnBreak ()
m_PrintRow = m_StartRow
m_PrintCol = m_PrintCol + 1
If m_PrintCol > m_NumColumns Then
'TODO: options for when we go past the last column (stop printing, wrap around)
End If
End Sub ' ColumnBreak
' /////////////////////////////////////////////////////////////////////////////
' A way to automatically print to columns.
Sub InitColumns (iNumColumns As Integer)
Dim iCols As Integer
Dim iRows As Integer
iCols = _Width(0) \ _FontWidth
iRows = _Height(0) \ _FontHeight
If iNumColumns < 1 Or iNumColumns > iCols Then
m_NumColumns = 1
Else
m_NumColumns = iNumColumns
End If
If m_StartRow < 1 Or m_StartRow > iRows Then
m_StartRow = 1
End If
If m_EndRow < m_StartRow Or m_EndRow > iRows Then
m_EndRow = iRows
End If
If m_StartCol < 1 Or m_StartCol > m_NumColumns Then
m_StartCol = 1
End If
If m_EndCol < m_StartCol Or m_EndCol > m_NumColumns Then
m_EndCol = m_NumColumns
End If
m_PrintRow = 1
m_PrintCol = 1
End Sub ' InitColumns
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GRAPHIC PRINTING ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN DEBUGGING ROUTINES #DEBUGGING
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub DebugPrint (s$)
If m_bTesting = TRUE Then
_Echo s$
'ReDim arrLines$(0)
'dim delim$ : delim$ = Chr$(13)
'split MyString, delim$, arrLines$()
End If
End Sub ' DebugPrint
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END DEBUGGING ROUTINES @DEBUGGING
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GENERAL PURPOSE ROUTINES #GEN
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Convert a value to string and trim it (because normal Str$ adds spaces)
Function cstr$ (myValue)
'cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
cstr$ = _Trim$(Str$(myValue))
End Function ' cstr$
' /////////////////////////////////////////////////////////////////////////////
' Convert a Long value to string and trim it (because normal Str$ adds spaces)
Function cstrl$ (myValue As Long)
cstrl$ = _Trim$(Str$(myValue))
End Function ' cstrl$
' /////////////////////////////////////////////////////////////////////////////
' Convert a Single value to string and trim it (because normal Str$ adds spaces)
Function cstrs$ (myValue As Single)
''cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
cstrs$ = _Trim$(Str$(myValue))
End Function ' cstrs$
' /////////////////////////////////////////////////////////////////////////////
' Convert an unsigned Long value to string and trim it (because normal Str$ adds spaces)
Function cstrul$ (myValue As _Unsigned Long)
cstrul$ = _Trim$(Str$(myValue))
End Function ' cstrul$
' /////////////////////////////////////////////////////////////////////////////
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
Function DblToStr$ (n#)
value$ = UCase$(LTrim$(Str$(n#)))
Xpos% = InStr(value$, "D") + InStr(value$, "E") 'only D or E can be present
If Xpos% Then
expo% = Val(Mid$(value$, Xpos% + 1))
If Val(value$) < 0 Then
sign$ = "-": valu$ = Mid$(value$, 2, Xpos% - 2)
Else valu$ = Mid$(value$, 1, Xpos% - 1)
End If
dot% = InStr(valu$, "."): L% = Len(valu$)
If expo% > 0 Then add$ = String$(expo% - (L% - dot%), "0")
If expo% < 0 Then min$ = String$(Abs(expo%) - (dot% - 1), "0"): DP$ = "."
For n = 1 To L%
If Mid$(valu$, n, 1) <> "." Then num$ = num$ + Mid$(valu$, n, 1)
Next
Else DblToStr$ = value$: Exit Function
End If
DblToStr$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
End Function ' DblToStr$
' /////////////////////////////////////////////////////////////////////////////
Function FormatNumber$ (myValue, iDigits As Integer)
Dim strValue As String
strValue = DblToStr$(myValue) + String$(iDigits, " ")
If myValue < 1 Then
If myValue < 0 Then
strValue = Replace$(strValue, "-.", "-0.")
ElseIf myValue > 0 Then
strValue = "0" + strValue
End If
End If
FormatNumber$ = Left$(strValue, iDigits)
End Function ' FormatNumber$
' /////////////////////////////////////////////////////////////////////////////
' From: Bitwise Manipulations By Steven Roman
' http://www.romanpress.com/Articles/Bitwise_R/Bitwise.htm
' Returns the 8-bit binary representation
' of an integer iInput where 0 <= iInput <= 255
Function GetBinary$ (iInput1 As Integer)
Dim sResult As String
Dim iLoop As Integer
Dim iInput As Integer: iInput = iInput1
sResult = ""
If iInput >= 0 And iInput <= 255 Then
For iLoop = 1 To 8
sResult = LTrim$(RTrim$(Str$(iInput Mod 2))) + sResult
iInput = iInput \ 2
'If iLoop = 4 Then sResult = " " + sResult
Next iLoop
End If
GetBinary$ = sResult
End Function ' GetBinary$
' /////////////////////////////////////////////////////////////////////////////
' wonderfully inefficient way to read if a bit is set
' ival = GetBit256%(int we are comparing, int containing the bits we want to read)
' See also: GetBit256%, SetBit256%
Function GetBit256% (iNum1 As Integer, iBit1 As Integer)
Dim iResult As Integer
Dim sNum As String
Dim sBit As String
Dim iLoop As Integer
Dim bContinue As Integer
'DIM iTemp AS INTEGER
Dim iNum As Integer: iNum = iNum1
Dim iBit As Integer: iBit = iBit1
iResult = FALSE
bContinue = TRUE
If iNum < 256 And iBit <= 128 Then
sNum = GetBinary$(iNum)
sBit = GetBinary$(iBit)
For iLoop = 1 To 8
If Mid$(sBit, iLoop, 1) = "1" Then
'if any of the bits in iBit are false, return false
If Mid$(sNum, iLoop, 1) = "0" Then
iResult = FALSE
bContinue = FALSE
Exit For
End If
End If
Next iLoop
If bContinue = TRUE Then
iResult = TRUE
End If
End If
GetBit256% = iResult
End Function ' GetBit256%
' /////////////////////////////////////////////////////////////////////////////
' From: Bitwise Manipulations By Steven Roman
' http://www.romanpress.com/Articles/Bitwise_R/Bitwise.htm
' Returns the integer that corresponds to a binary string of length 8
Function GetIntegerFromBinary% (sBinary1 As String)
Dim iResult As Integer
Dim iLoop As Integer
Dim strBinary As String
Dim sBinary As String: sBinary = sBinary1
iResult = 0
strBinary = Replace$(sBinary, " ", "") ' Remove any spaces
For iLoop = 0 To Len(strBinary) - 1
iResult = iResult + 2 ^ iLoop * Val(Mid$(strBinary, Len(strBinary) - iLoop, 1))
Next iLoop
GetIntegerFromBinary% = iResult
End Function ' GetIntegerFromBinary%
' /////////////////////////////////////////////////////////////////////////////
Function IIF (Condition, IfTrue, IfFalse)
If Condition Then IIF = IfTrue Else IIF = IfFalse
End Function
' /////////////////////////////////////////////////////////////////////////////
Function IIFSTR$ (Condition, IfTrue$, IfFalse$)
If Condition Then IIFSTR$ = IfTrue$ Else IIFSTR$ = IfFalse$
End Function
' /////////////////////////////////////////////////////////////////////////////
' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
Function IsEven% (n)
If n Mod 2 = 0 Then
IsEven% = TRUE
Else
IsEven% = FALSE
End If
End Function ' IsEven%
' /////////////////////////////////////////////////////////////////////////////
' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
Function IsOdd% (n)
If n Mod 2 = 1 Then
IsOdd% = TRUE
Else
IsOdd% = FALSE
End If
End Function ' IsOdd%
' /////////////////////////////////////////////////////////////////////////////
' By sMcNeill from https://www.qb64.org/forum/index.php?topic=896.0
Function IsNum% (text$)
Dim a$
Dim b$
a$ = _Trim$(text$)
b$ = _Trim$(Str$(Val(text$)))
If a$ = b$ Then
IsNum% = TRUE
Else
IsNum% = FALSE
End If
End Function ' IsNum%
' /////////////////////////////////////////////////////////////////////////////
' Re: Does a Is Number function exist in QB64?
' https://www.qb64.org/forum/index.php?topic=896.15
' MWheatley
' « Reply #18 on: January 01, 2019, 11:24:30 AM »
' returns 1 if string is an integer, 0 if not
Function IsNumber (text$)
Dim i As Integer
IsNumber = 1
For i = 1 To Len(text$)
If Asc(Mid$(text$, i, 1)) < 45 Or Asc(Mid$(text$, i, 1)) >= 58 Then
IsNumber = 0
Exit For
ElseIf Asc(Mid$(text$, i, 1)) = 47 Then
IsNumber = 0
Exit For
End If
Next i
End Function ' IsNumber
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'Combine all elements of in$() into a single string with delimiter$ separating the elements.
Function join$ (in$(), delimiter$)
Dim result$
Dim i As Long
result$ = in$(LBound(in$))
For i = LBound(in$) + 1 To UBound(in$)
result$ = result$ + delimiter$ + in$(i)
Next i
join$ = result$
End Function ' join$
' /////////////////////////////////////////////////////////////////////////////
' ABS was returning strange values with type LONG
' so I created this which does not.
Function LongABS& (lngValue As Long)
If Sgn(lngValue) = -1 Then
LongABS& = 0 - lngValue
Else
LongABS& = lngValue
End If
End Function ' LongABS&
' /////////////////////////////////////////////////////////////////////////////
' Writes sText to a debug file in the EXE folder.
' Debug file is named the same thing as the program EXE name with ".txt" at the end.
' For example the program "C:\QB64\MyProgram.BAS" running as
' "C:\QB64\MyProgram.EXE" would have an output file "C:\QB64\MyProgram.EXE.txt".
' If the file doesn't exist, it is created, otherwise it is appended to.
Sub DebugPrintFile (sText As String)
Dim sFileName As String
Dim sError As String
Dim sOut As String
sFileName = ProgramPath$ + ProgramName$ + ".txt"
sError = ""
If _FileExists(sFileName) = FALSE Then
sOut = ""
sOut = sOut + "++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" + Chr$(13) + Chr$(10)
sOut = sOut + "PROGRAM : " + ProgramName$ + Chr$(13) + Chr$(10)
sOut = sOut + "RUN DATE: " + CurrentDateTime$ + Chr$(13) + Chr$(10)
sOut = sOut + "++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" + Chr$(13) + Chr$(10)
sError = PrintFile$(sFileName, sOut, FALSE)
End If
If Len(sError) = 0 Then
sError = PrintFile$(sFileName, sText, TRUE)
End If
If Len(sError) <> 0 Then
Print CurrentDateTime$ + " DebugPrintFile FAILED: " + sError
End If
End Sub ' DebugPrintFile
' /////////////////////////////////////////////////////////////////////////////
Function IntPadRight$ (iValue As Integer, iWidth As Integer)
IntPadRight$ = Left$(_Trim$(Str$(iValue)) + String$(iWidth, " "), iWidth)
End Function ' IntPadRight$
' /////////////////////////////////////////////////////////////////////////////
' Returns blank if successful else returns error message.
Function PrintFile$ (sFileName As String, sText As String, bAppend As Integer)
'x = 1: y = 2: z$ = "Three"
Dim sError As String: sError = ""
If Len(sError) = 0 Then
If (bAppend = TRUE) Then
If _FileExists(sFileName) Then
Open sFileName For Append As #1 ' opens an existing file for appending
Else
sError = "Error in PrintFile$ : File not found. Cannot append."
End If
Else
Open sFileName For Output As #1 ' opens and clears an existing file or creates new empty file
End If
End If
If Len(sError) = 0 Then
' WRITE places text in quotes in the file
'WRITE #1, x, y, z$
'WRITE #1, sText
' PRINT does not put text inside quotes
Print #1, sText
Close #1
'PRINT "File created with data. Press a key!"
'K$ = INPUT$(1) 'press a key
'OPEN sFileName FOR INPUT AS #2 ' opens a file to read it
'INPUT #2, a, b, c$
'CLOSE #2
'PRINT a, b, c$
'WRITE a, b, c$
End If
PrintFile$ = sError
End Function ' PrintFile$
' /////////////////////////////////////////////////////////////////////////////
' Generate random value between Min and Max.
Function RandomNumber% (Min%, Max%)
Dim NumSpread%
' SET RANDOM SEED
'Randomize ' Initialize random-number generator.
Randomize Timer
' GET RANDOM # Min%-Max%
'RandomNumber = Int((Max * Rnd) + Min) ' generate number
NumSpread% = (Max% - Min%) + 1
RandomNumber% = Int(Rnd * NumSpread%) + Min% ' GET RANDOM # BETWEEN Max% AND Min%
End Function ' RandomNumber%
' /////////////////////////////////////////////////////////////////////////////
Sub RandomNumberTest
Dim iCols As Integer: iCols = 10
Dim iRows As Integer: iRows = 20
Dim iLoop As Integer
Dim iX As Integer
Dim iY As Integer
Dim sError As String
Dim sFileName As String
Dim sText As String
Dim bAppend As Integer
Dim iMin As Integer
Dim iMax As Integer
Dim iNum As Integer
Dim iErrorCount As Integer
Dim sInput$
sFileName = "c:\temp\maze_test_1.txt"
sText = "Count" + Chr$(9) + "Min" + Chr$(9) + "Max" + Chr$(9) + "Random"
bAppend = FALSE
sError = PrintFile$(sFileName, sText, bAppend)
If Len(sError) = 0 Then
bAppend = TRUE
iErrorCount = 0
iMin = 0
iMax = iCols - 1
For iLoop = 1 To 100
iNum = RandomNumber%(iMin, iMax)
sText = Str$(iLoop) + Chr$(9) + Str$(iMin) + Chr$(9) + Str$(iMax) + Chr$(9) + Str$(iNum)
sError = PrintFile$(sFileName, sText, bAppend)
If Len(sError) > 0 Then
iErrorCount = iErrorCount + 1
Print Str$(iLoop) + ". ERROR"
Print " " + "iMin=" + Str$(iMin)
Print " " + "iMax=" + Str$(iMax)
Print " " + "iNum=" + Str$(iNum)
Print " " + "Could not write to file " + Chr$(34) + sFileName + Chr$(34) + "."
Print " " + sError
End If
Next iLoop
iMin = 0
iMax = iRows - 1
For iLoop = 1 To 100
iNum = RandomNumber%(iMin, iMax)
sText = Str$(iLoop) + Chr$(9) + Str$(iMin) + Chr$(9) + Str$(iMax) + Chr$(9) + Str$(iNum)
sError = PrintFile$(sFileName, sText, bAppend)
If Len(sError) > 0 Then
iErrorCount = iErrorCount + 1
Print Str$(iLoop) + ". ERROR"
Print " " + "iMin=" + Str$(iMin)
Print " " + "iMax=" + Str$(iMax)
Print " " + "iNum=" + Str$(iNum)
Print " " + "Could not write to file " + Chr$(34) + sFileName + Chr$(34) + "."
Print " " + sError
End If
Next iLoop
Print "Finished generating numbers. Errors: " + Str$(iErrorCount)
Else
Print "Error creating file " + Chr$(34) + sFileName + Chr$(34) + "."
Print sError
End If
Input "Press <ENTER> to continue", sInput$
End Sub ' RandomNumberTest
' /////////////////////////////////////////////////////////////////////////////
' FROM: String Manipulation
' found at abandoned, outdated and now likely malicious qb64 dot net website
' http://www.qb64.[net]/forum/index_topic_5964-0/
'
'SUMMARY:
' Purpose: A library of custom functions that transform strings.
' Author: Dustinian Camburides (dustinian@gmail.com)
' Platform: QB64 (www.qb64.org)
' Revision: 1.6
' Updated: 5/28/2012
'SUMMARY:
'[Replace$] replaces all instances of the [Find] sub-string with the [Add] sub-string within the [Text] string.
'INPUT:
'Text: The input string; the text that's being manipulated.
'Find: The specified sub-string; the string sought within the [Text] string.
'Add: The sub-string that's being added to the [Text] string.
Function Replace$ (Text1 As String, Find1 As String, Add1 As String)
' VARIABLES:
Dim Text2 As String
Dim Find2 As String
Dim Add2 As String
Dim lngLocation As Long ' The address of the [Find] substring within the [Text] string.
Dim strBefore As String ' The characters before the string to be replaced.
Dim strAfter As String ' The characters after the string to be replaced.
' INITIALIZE:
' MAKE COPIESSO THE ORIGINAL IS NOT MODIFIED (LIKE ByVal IN VBA)
Text2 = Text1
Find2 = Find1
Add2 = Add1
lngLocation = InStr(1, Text2, Find2)
' PROCESSING:
' While [Find2] appears in [Text2]...
While lngLocation
' Extract all Text2 before the [Find2] substring:
strBefore = Left$(Text2, lngLocation - 1)
' Extract all text after the [Find2] substring:
strAfter = Right$(Text2, ((Len(Text2) - (lngLocation + Len(Find2) - 1))))
' Return the substring:
Text2 = strBefore + Add2 + strAfter
' Locate the next instance of [Find2]:
lngLocation = InStr(1, Text2, Find2)
' Next instance of [Find2]...
Wend
' OUTPUT:
Replace$ = Text2
End Function ' Replace$
' /////////////////////////////////////////////////////////////////////////////
Sub ReplaceTest
Dim in$
Print "-------------------------------------------------------------------------------"
Print "ReplaceTest"
Print
Print "Original value"
in$ = "Thiz iz a teZt."
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print
Print "Replacing lowercase " + Chr$(34) + "z" + Chr$(34) + " with " + Chr$(34) + "s" + Chr$(34) + "..."
in$ = Replace$(in$, "z", "s")
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print
Print "Replacing uppercase " + Chr$(34) + "Z" + Chr$(34) + " with " + Chr$(34) + "s" + Chr$(34) + "..."
in$ = Replace$(in$, "Z", "s")
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print
Print "ReplaceTest finished."
End Sub ' ReplaceTest
' /////////////////////////////////////////////////////////////////////////////
' https://www.qb64.org/forum/index.php?topic=3605.0
' Quote from: SMcNeill on Today at 03:53:48 PM
'
' Sometimes, you guys make things entirely too complicated.
' There ya go! Three functions to either round naturally,
' always round down, or always round up, to whatever number of digits you desire.
' EDIT: Modified to add another option to round scientific,
' since you had it's description included in your example.
Function Round## (num##, digits%)
Round## = Int(num## * 10 ^ digits% + .5) / 10 ^ digits%
End Function
Function RoundUp## (num##, digits%)
RoundUp## = _Ceil(num## * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundDown## (num##, digits%)
RoundDown## = Int(num## * 10 ^ digits%) / 10 ^ digits%
End Function
Function Round_Scientific## (num##, digits%)
Round_Scientific## = _Round(num## * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundUpDouble# (num#, digits%)
RoundUpDouble# = _Ceil(num# * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundUpSingle! (num!, digits%)
RoundUpSingle! = _Ceil(num! * 10 ^ digits%) / 10 ^ digits%
End Function
' /////////////////////////////////////////////////////////////////////////////
' fantastically inefficient way to set a bit
' example use: arrMaze(iX, iY) = SetBit256%(arrMaze(iX, iY), cS, FALSE)
' See also: GetBit256%, SetBit256%
' newint=SetBit256%(oldint, int containing the bits we want to set, value to set them to)
Function SetBit256% (iNum1 As Integer, iBit1 As Integer, bVal1 As Integer)
Dim sNum As String
Dim sBit As String
Dim sVal As String
Dim iLoop As Integer
Dim strResult As String
Dim iResult As Integer
Dim iNum As Integer: iNum = iNum1
Dim iBit As Integer: iBit = iBit1
Dim bVal As Integer: bVal = bVal1
If iNum < 256 And iBit <= 128 Then
sNum = GetBinary$(iNum)
sBit = GetBinary$(iBit)
If bVal = TRUE Then
sVal = "1"
Else
sVal = "0"
End If
strResult = ""
For iLoop = 1 To 8
If Mid$(sBit, iLoop, 1) = "1" Then
strResult = strResult + sVal
Else
strResult = strResult + Mid$(sNum, iLoop, 1)
End If
Next iLoop
iResult = GetIntegerFromBinary%(strResult)
Else
iResult = iNum
End If
SetBit256% = iResult
End Function ' SetBit256%
' /////////////////////////////////////////////////////////////////////////////
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
Function SngToStr$ (n!)
value$ = UCase$(LTrim$(Str$(n!)))
Xpos% = InStr(value$, "D") + InStr(value$, "E") 'only D or E can be present
If Xpos% Then
expo% = Val(Mid$(value$, Xpos% + 1))
If Val(value$) < 0 Then
sign$ = "-": valu$ = Mid$(value$, 2, Xpos% - 2)
Else valu$ = Mid$(value$, 1, Xpos% - 1)
End If
dot% = InStr(valu$, "."): L% = Len(valu$)
If expo% > 0 Then add$ = String$(expo% - (L% - dot%), "0")
If expo% < 0 Then min$ = String$(Abs(expo%) - (dot% - 1), "0"): DP$ = "."
For n = 1 To L%
If Mid$(valu$, n, 1) <> "." Then num$ = num$ + Mid$(valu$, n, 1)
Next
Else SngToStr$ = value$: Exit Function
End If
SngToStr$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
End Function ' SngToStr$
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'
' FROM luke, QB64 Developer
' Date: February 15, 2019, 04:11:07 AM »
'
' Given a string of words separated by spaces (or any other character),
' splits it into an array of the words. I've no doubt many people have
' written a version of this over the years and no doubt there's a million
' ways to do it, but I thought I'd put mine here so we have at least one
' version. There's also a join function that does the opposite
' array -> single string.
'
' Code is hopefully reasonably self explanatory with comments and a little demo.
' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.
'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences
'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$().
'
'delimiter$ must be one character long.
'result$() must have been REDIMmed previously.
' Modified to handle multi-character delimiters
Sub split (in$, delimiter$, result$())
Dim start As Integer
Dim finish As Integer
Dim iDelimLen As Integer
ReDim result$(-1)
iDelimLen = Len(delimiter$)
start = 1
Do
'While Mid$(in$, start, 1) = delimiter$
While Mid$(in$, start, iDelimLen) = delimiter$
'start = start + 1
start = start + iDelimLen
If start > Len(in$) Then
Exit Sub
End If
Wend
finish = InStr(start, in$, delimiter$)
If finish = 0 Then
finish = Len(in$) + 1
End If
ReDim _Preserve result$(0 To UBound(result$) + 1)
result$(UBound(result$)) = Mid$(in$, start, finish - start)
start = finish + 1
Loop While start <= Len(in$)
End Sub ' split
' /////////////////////////////////////////////////////////////////////////////
Sub SplitTest
Dim in$
Dim delim$
ReDim arrTest$(0)
Dim iLoop%
delim$ = Chr$(10)
in$ = "this" + delim$ + "is" + delim$ + "a" + delim$ + "test"
Print "in$ = " + Chr$(34) + in$ + Chr$(34)
Print "delim$ = " + Chr$(34) + delim$ + Chr$(34)
split in$, delim$, arrTest$()
For iLoop% = LBound(arrTest$) To UBound(arrTest$)
Print "arrTest$(" + LTrim$(RTrim$(Str$(iLoop%))) + ") = " + Chr$(34) + arrTest$(iLoop%) + Chr$(34)
Next iLoop%
Print
Print "Split test finished."
End Sub ' SplitTest
' /////////////////////////////////////////////////////////////////////////////
Sub SplitAndReplaceTest
Dim in$
Dim out$
Dim iLoop%
ReDim arrTest$(0)
Print "-------------------------------------------------------------------------------"
Print "SplitAndReplaceTest"
Print
Print "Original value"
in$ = "This line 1 " + Chr$(13) + Chr$(10) + "and line 2" + Chr$(10) + "and line 3 " + Chr$(13) + "finally THE END."
out$ = in$
out$ = Replace$(out$, Chr$(13), "\r")
out$ = Replace$(out$, Chr$(10), "\n")
out$ = Replace$(out$, Chr$(9), "\t")
Print "in$ = " + Chr$(34) + out$ + Chr$(34)
Print
Print "Fixing linebreaks..."
in$ = Replace$(in$, Chr$(13) + Chr$(10), Chr$(13))
in$ = Replace$(in$, Chr$(10), Chr$(13))
out$ = in$
out$ = Replace$(out$, Chr$(13), "\r")
out$ = Replace$(out$, Chr$(10), "\n")
out$ = Replace$(out$, Chr$(9), "\t")
Print "in$ = " + Chr$(34) + out$ + Chr$(34)
Print
Print "Splitting up..."
split in$, Chr$(13), arrTest$()
For iLoop% = LBound(arrTest$) To UBound(arrTest$)
out$ = arrTest$(iLoop%)
out$ = Replace$(out$, Chr$(13), "\r")
out$ = Replace$(out$, Chr$(10), "\n")
out$ = Replace$(out$, Chr$(9), "\t")
Print "arrTest$(" + cstr$(iLoop%) + ") = " + Chr$(34) + out$ + Chr$(34)
Next iLoop%
Print
Print "SplitAndReplaceTest finished."
End Sub ' SplitAndReplaceTest
' /////////////////////////////////////////////////////////////////////////////
Function StrPadRight$ (sValue As String, iWidth As Integer)
StrPadRight$ = Left$(sValue + String$(iWidth, " "), iWidth)
End Function ' StrPadRight$
' /////////////////////////////////////////////////////////////////////////////
Function TrueFalse$ (myValue)
If myValue = TRUE Then
TrueFalse$ = "TRUE"
Else
TrueFalse$ = "FALSE"
End If
End Function ' TrueFalse$
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GENERAL PURPOSE ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' #END
' ################################################################################################################################################################
|
|
|
| Ascii Dice |
|
Posted by: James D Jarvis - 05-12-2023, 01:52 PM - Forum: Programs
- Replies (9)
|
 |
Display dice rolls with ascii output.
asciidie and box are the most important routines here. rolld6 does a very simple "graphical" demonstration of rolling.
Code: (Select All) 'ASCII DICE DEMO
'by James D. Jarvis, 5/12/2023 , use as you wish
'
'demo of asciidie routine rolls 3 dice 6 times and displays total of each roll of the 3 dice
Screen _NewImage(45, 36, 0)
_Title "ASCII DICE DEMO"
_Font 8 'using font 8 so dice faces show as true squares
_ControlChr Off
Randomize Timer
'-------- need these pre-defined for box subroutine
Dim Shared trc$, tlc$, brc$, blc$, hzb$, vrb$ 'strings to keep track of ascii values to display dice face
trc$ = Chr$(191) 'top right corner
tlc$ = Chr$(218) 'top left corner
brc$ = Chr$(217) 'botton right corner
blc$ = Chr$(192) 'bottom left corner
hzb$ = Chr$(196) 'horitzontal bar
vrb$ = Chr$(179) 'vertical bar
'----------------------------------------------------
Color 15, 0
Do 'demo rolling 3d6 6 times
For r = 1 To 6
d1 = rolld6(3, r * 6 - 5): d2 = rolld6(9, r * 6 - 5): d3 = rolld6(15, r * 6 - 5)
_PrintString (21, r * 6 - 3), "Total Roll = "
_PrintString (36, r * 6 - 3), Str$(d1 + d2 + d3)
Next r
Beep
kk$ = waitanykey$
Loop Until kk$ = Chr$(27)
Function waitanykey$ 'uses inkey$ but waits for a return value
Do
_Limit 60
ik$ = InKey$
Loop Until ik$ <> ""
_KeyClear
waitanykey$ = ik$
End Function
Function rolld6 (px, py)
'simulate "rolling" a die by calling asciidie repeatedly
dr = Int(1 + Rnd * 6)
For x = 1 To 6
_Limit 100
dr = Int(1 + Rnd * 6)
asciidie px, py, dr 'displays score dr as a die starting at px,py
Next x
rolld6 = dr
End Function
Sub asciidie (px, py, roll)
'display die face of roll at location px,py
box px, py, 5, 5, " " 'draws a box 5 characters by 5 charcters for display of dice face
Select EveryCase roll
Case 1, 3, 5
_PrintString (px + 2, py + 2), Chr$(7)
Case 2, 3, 4, 5, 6
_PrintString (px + 1, py + 1), Chr$(7)
_PrintString (px + 3, py + 3), Chr$(7)
Case 4, 5, 6
_PrintString (px + 3, py + 1), Chr$(7)
_PrintString (px + 1, py + 3), Chr$(7)
Case 6
_PrintString (px + 1, py + 2), Chr$(7)
_PrintString (px + 3, py + 2), Chr$(7)
End Select
Color 15, 0
End Sub
Sub box (bx, by, ww, hh, ff$)
'draws a box, strings are defined in main program (so they can be changed prior to calling routine)
t$ = tlc$ + String$(ww - 2, hzb$) + trc$
m$ = vrb$ + String$(ww - 2, ff$) + vrb$
b$ = blc$ + String$(ww - 2, hzb$) + brc$
_PrintString (bx, by), t$
For h = 1 To hh - 2
_PrintString (bx, by + h), m$
Next h
_PrintString (bx, by + hh - 1), b$
End Sub
|
|
|
|
| Pattern matching |
|
Posted by: eoredson - 05-11-2023, 06:08 AM - Forum: Programs
- No Replies
|
 |
This code sample contains a subroutine to match substrings similar to Instr but with ? and * characters:
Code: (Select All) ' function to match case-sensitive substring with ?, * characters in substring
' input: VarQ = -1 for case-sensitive
' Var1$ is search string
' Var2$ is string being searched
' output: Var = -1 search string matched
Sub InstrSUB1 (Var, Var1$, Var2$, VarQ)
' store case-sensitive string match variables
If VarQ Then
S2$ = Var1$
S3$ = Var2$
Else
S2$ = LCase$(Var1$)
S3$ = LCase$(Var2$)
End If
' check default instr
If InStr(S2$, "*") = 0 Then
If InStr(S2$, "?") = 0 Then
Var = InStr(S3$, S2$)
Exit Sub
End If
End If
Var = -1 ' assume match
' asterick always matches
If Var1$ = "*" Then
Exit Sub
End If
' see if S2$ matches in S3$ with substrings
For S3 = 1 To Len(S3$)
S1$ = Mid$(S3$, S3)
P1 = 1 ' pointer to S1$
P2 = 1 ' pointer to S2$
Do
' check match
If P2 > Len(S2$) Then
Exit Sub
End If
' check character in S2$ at P2
V$ = Mid$(S2$, P2, 1)
Select Case V$
Case "*" ' global character
' scan to next char
If P2 > Len(S2$) Then
Exit Do
End If
S4$ = Mid$(S2$, P2 + 1, 1)
Select Case S4$
Case "*", "?"
P2 = P2 + 1
Case Else
Do
If Mid$(S1$, P1, 1) = S4$ Then
Exit Do
End If
If P1 >= Len(S1$) Then
Exit Do
End If
P1 = P1 + 1
Loop
P2 = P2 + 1
End Select
Case "?" ' wildcard character
P1 = P1 + 1
P2 = P2 + 1
Case Else ' ascii character
If Mid$(S1$, P1, 1) <> V$ Then ' no match
Exit Do
End If
P1 = P1 + 1
P2 = P2 + 1
End Select
Loop
Next
Var = 0 ' no match
End Sub
However, this code matches filenames with ?, *, and ^ characters;
Code: (Select All) ' routine compares occurrence of filename1$ in filename2$
' with pattern matching.
Function CheckExcluded (Filename1$, Filename2$)
Print "Compare "; Filename1$; " to "; Filename2$
CheckExcluded = -1 ' assume mask matches filename2.
Length1 = 1
Length2 = 1
Do
' global replacement.
If Mid$(Filename1$, Length1, 1) = "*" Then
Do
Length1 = Length1 + 1
If Length1 > Len(Filename1$) Then
Exit Function
End If
' global replacement followed by exclusion character.
' searches remaining string until exclusion character found or not.
If Mid$(Filename1$, Length1, 1) = "^" Then
Length1 = Length1 + 1
Not.Include$ = Mid$(Filename1$, Length1, 1)
Do
If Not.Include$ <> Mid$(Filename2$, Length2, 1) Then
Length2 = Length2 + 1
Else
CheckExcluded = False
Exit Function
End If
If Length2 > Len(Filename2$) Then
Exit Function
End If
Loop
End If
' global replacement followed by ? or another *
' skips to next character.
If Mid$(Filename1$, Length1, 1) <> "*" Then
If Mid$(Filename1$, Length1, 1) <> "?" Then
Exit Do
End If
End If
Loop
' global replacement.
' searches for next matching character.
Do
If Mid$(Filename1$, Length1, 1) = Mid$(Filename2$, Length2, 1) Then
Exit Do
Else
Length2 = Length2 + 1
End If
If Length2 > Len(Filename2$) Then
Exit Do
End If
Loop
Else
' character replacement.
' matches any next character.
If Mid$(Filename1$, Length1, 1) = "?" Then
Length1 = Length1 + 1
Length2 = Length2 + 1
Else
' exclusion character.
' checks next character unmatched.
If Mid$(Filename1$, Length1, 1) = "^" Then
Length1 = Length1 + 1
Not.Include$ = Mid$(Filename1$, Length1, 1)
If Not.Include$ <> Mid$(Filename2$, Length2, 1) Then
Length1 = Length1 + 1
Length2 = Length2 + 1
Else
CheckExcluded = False
Exit Do
End If
Else
' matches next character.
If Mid$(Filename1$, Length1, 1) = Mid$(Filename2$, Length2, 1) Then
Length1 = Length1 + 1
Length2 = Length2 + 1
Else
CheckExcluded = False
Exit Do
End If
' check string lengths.
If Length1 > Len(Filename1$) Then
If Length2 <= Len(Filename2$) Then
CheckExcluded = False
End If
Exit Do
End If
End If
End If
End If
Loop
End Function
|
|
|
|
| Wiki Updates |
|
Posted by: TerryRitchie - 05-10-2023, 09:00 PM - Forum: Wiki Discussion
- Replies (5)
|
 |
I noticed _DEVICE$ now includes [DISCONNECTED] when a controller is disconnected but find no mention of this in the Wiki. When will the Wiki be updated with the new controller features offered by v3.7.0?
|
|
|
|
| A program to solve a problem: filter Linux/Unix 'ls' output |
|
Posted by: TDarcos - 05-10-2023, 08:58 PM - Forum: Programs
- Replies (1)
|
 |
This is my first program contribution, it worked so well I thought I'd pass it on.
Here is the backstory about why I wrote this program.
I had a problem. My Windows computer started BSODing during initial boot/startup. Since it was an actual BSOD with frowny face, this means it's a Windows problem, not a hardware one. After several attempts to use any of the recovery methods which would leave my files intact, I came to the conclusion that I am in a pickle. Then, I find the recovery partition no longer works. Now, I came to the condclusion that I was, quite frankly, screwed. So, I used the time-tested method of attacking a problem: I threw money at it.
I went on Amazon and purchased a refurbished machine. The new (to me) machine is actually better than the one I had. A "Dell OptiPlex 7020 Desktop Computer,Intel Quad Core i7 4790 3.6Ghz, 32GB Ram New 2TB SSD." After I received it, I discovered that while it has 4 cores (as I had expected) it has 8 threads (which i did not.) So the computer is actually better than what I thought I was buying. With that I purchased something I really needed: a 4 TB ruggedized external hard drive, so I can back up my computers without worrying about someone dropping it. I already have a 6 TB external, but I don't feel good about it being moved around.
The price was terrific: with Windows 10 Professional, it was $265.00. Add the external drive and sales tax, $401. So I set up the new computer, and have it build a Windows recovery SSD on an SD card. Plug the reader into the old computer, reset the BIOS to allow boot from an external drive, and I try again. Nothing works. So, from my new computer, I download a Linux distribution,Xubuntu. Repeat the process and it boots fine, file manager can see the internal drive, and it can even see the 6TB external, but not the 4TB ruggedized (even though the new machine does). So I copied my most recent files from my working directory to the 6 TB.
The Problem
I do have a backup of my huge collection of downloaded open-source software on the 6TB but it's old., from last year. It does not have local changes I made from writing programs. On Windows, I just have Free File Sync scan the work directory and mirror to backup. So that is out. I had, however, downloaded the Linux version of QB64PE, but attempt to install it fails because the Wifi adapter apparently is not recognized; it can't download required packages.
Well, I could just copy the new archive to replace the backup. About 1.3 million files, 100,000+ directories, 411 GB, and will take about 500 hours, So, that's not an answer. So how can I solve this problem? So, it hits me: run an 'ls' directory scan with recursive subdirectory search, piped to a file, then take that file over to my new computer and write a filtering program to run there. I had ls exclude owner and group, and list one file per line. Output from ls looks like this:
Output:
Code: (Select All) Paul (From LENOVO)/:
total 39638
drwxrwxrwx 1 163840 Apr 30 17:45 gatekeeper
drwxrwxrwx 1 20480 Feb 21 17:06 MERGER-raw
drwxrwxrwx 1 4096 Feb 21 16:49 cvs2svn
...
-rwxrwxrwx 1 631462 Nov 23 2017 .cardpeek.log
-rwxrwxrwx 1 52475 Aug 27 2017 reasonable-argument.png
Paul (From LENOVO)/gatekeeper:
total 604715
-rwxrwxrwx 1 527259 Apr 30 17:45 Marnie.odt
What can be determined from this is:
- The current directory is shown followed by a colon.
- The first letter of a file entry is 'd' for a directory. Ignore these; we get specific directories from the prior item.
- Size summary starts with "total ".
- There is a blank line before a new directory.
- Items from 2023 have a colon in the time field, older files have a year in the field.
- Entries are separated by one space, with the file name last.
I have one additional problem. Just the listing of files itself is an 88 megabyte text file!
The solution:
Code: (Select All) ' Process ls program output to exclude files before this year
FN$ = "k:\files.list"
outFile$ = "k:\keepfiles.list"
Print
Locate 5, 1
Print Time$
FF& = FreeFile
lc = 0
Total$ = "total "
Open FN$ For Input Access Read As #FF&
OutFile& = FreeFile
Open outFile$ For Output As #OutFile&
While Not EOF(FF&)
Line Input #FF&, Line$
Line$ = _Trim$(Line$)
LineEnd = Len(Line$)
If Line$ = "" Then GoTo SKIP
If Left$(Line$, 6) = "total " GoTo SKIP ' avoid summary
Colon = InStr(Line$, ":")
If Colon = Len(Line$) Then ' it's a directry being listed
Curdir$ = _Trim$(Left$(Line$, Colon - 1))
If Right$(Curdir$, 1) <> "/" Then Curdir$ = Curdir$ + "/"
Locate 9, 1: Print Space$(240): Locate 9, 1
Print "Current dir="; Curdir$
ListDir = ListDir + 1
GoTo SKIP
End If
If Left$(Line$, 1) = "d" Then
DirCount = DirCount + 1
GoTo SKIP
End If
FileCount = FileCount + 1
' First, skip attributes
SpacePos = InStr(1, Line$, " ")
'Skip over node count
SpacePos = InStr(SpacePos + 1, Line$, " ")
'Skip over file size
SpacePos = InStr(SpacePos + 1, Line$, " ")
' determine if current year
Colon = InStr(SpacePos, Line$, ":")
If Colon = 0 Then
skipFile = skipFile + 1
' Print "colon at "; Colon; " skipping "
' Print Line$
GoTo SKIP
End If
SpacePos = InStr(Colon + 1, Line$, " ")
Print #OutFile&, Curdir$ + Mid$(Line$, SpacePos + 1)
Chosen = Chosen + 1
SKIP: '
If FileCount Mod 5000 = 0 Then
Locate 2, 1
Print FileCount; " ";
Locate 5, 20
Print Time$
End If
Wend
Close #FF&
Close #OutFile&
Locate 6, 1
Print Time$
Print "Search directories "; ListDir
Print "Subdirectories "; DirCount
Print FileCount; " Files Found"
Print skipFile; " Files skipped"
Print Chosen; " Files chosen for review"
End
Result? Of more than 900,000 files scanned, I need to copy 53. That's all. The program took 5 minutes, processing an average of about 2500 items per second. A really satisfying conclusion, and should put paid to those who claim Basic, and specifically QuickBasic, is not relevant for solving real-world problems.
Paul
|
|
|
|
| Memory Leak |
|
Posted by: NasaCow - 05-10-2023, 02:27 AM - Forum: Help Me!
- Replies (12)
|
 |
Never noticed it before but my menu selection screens have a memory leak! It keeps adding about 8MB/s of system memory. It is a pretty forward loop and the MOUSE calls are not the source (they were all commented out when I was trying to locate the source of the leak). I am really at a loss here....
Code: (Select All) DO
LIMIT LIMITRATE
CLS
PUTIMAGE (0, 0), BGImage
MENUMAKER Menu()
SELECT CASE Pointer
CASE 0: PUTIMAGE (MenuPos(2).X1 - 50, MenuPos(2).Y1 + 10), CheckSelect
CASE 1: PUTIMAGE (MenuPos(3).X1 - 50, MenuPos(3).Y1 + 10), CheckSelect
CASE 2: PUTIMAGE (MenuPos(4).X1 - 50, MenuPos(4).Y1 + 10), CheckSelect
CASE 3: PUTIMAGE (MenuPos(5).X1 - 50, MenuPos(5).Y1 + 10), CheckSelect
END SELECT
DISPLAY
IF SelectFlag THEN PAUSE TIME 'Avoid double press delay
SelectFlag = FALSE 'reset input
'Checking for key press (keyboard)
IF KEYDOWN(CVI(CHR$(0) + "H")) THEN ' up case
IF Pointer = 0 THEN Pointer = 3 ELSE Pointer = Pointer - 1
SelectFlag = TRUE
END IF
IF KEYDOWN(CVI(CHR$(0) + "P")) THEN 'down case
IF Pointer = 3 THEN Pointer = 0 ELSE Pointer = Pointer + 1
SelectFlag = TRUE
END IF
'Checking for mouse input
MOUSE "Poll"
MOUSE "Release"
MOUSE "Action"
MOUSE "Loop"
LOOP UNTIL KEYDOWN(13) OR KEYDOWN(32) OR MFlag 'Return/space bar/mouse click to select
![[Image: image.png]](https://i.ibb.co/nbPP4j5/image.png)
(Using almost 3 times as Chrome after a few mins...)
It seems to only happen on Menu selection screens. The leak appears in all V4 releases from me but V3 does not have the leak. Any thoughts what it may be?
If any additional code is needed or anything else of the sort, please let me know!!
|
|
|
|
Linux only: random dark modes for KDE |
|
Posted by: mnrvovrfc - 05-09-2023, 11:10 PM - Forum: Programs
- No Replies
|
 |
This is a program that fabricates desktop environment color sets for KDE Plasma. :O
It creates a definition which changes the colors for the window title bar and stuff contained inside the window such as buttons and text fields. It also affects the "main" panel that contains the desktop menu, digital clock, notifications etc.
The random scheme could be improved. Especially for the window title bar. Generally dark has to contrast with light. It seems far too often it creates bright pink as foreground color, but the important thing is that it could be seen. The color settings for the tooltip are not touched. The original definition was from "Oxygen Cold".
This program creates only "dark" modes. To get light ones might have to tone down what two of the functions do. Swap "lightcolor$" and "darkcolor$" assignments on RHS for starters. But something has to be done also about "twincolor$" so it returns dark colors, ie. the value is related to "darkcolor$".
The color definitions are dropped right into the area the System Settings/Appearance/Colors expects them so they could be viewed straight away. Otherwise it's clunky to load one definition at a time from disk only to see what it is. After all, they are harmless text files. (Um, for some people being unable to see anything on the screen clearly, because foreground and background colors are almost the same, counts as "causing harm" but anyway. Windows doesn't allow it, but also doesn't allow too many other combinations which could be sensible but could tire the eyes faster.)
The output example of this program will not change the position nor behavior of widgets or other screen elements, or any aspect of its appearance than the colors. This doesn't affect applications such as Kate and Konsole which have distinct settings, even if they were written by KDE. (Kate/KWrite does have a plethora of color settings and a program like this one could be created for it.) It might cause some "Plasmoids" and other widgets to look weird, and it might not work well with certain visual effects the young people love so well. It won't affect a bunch of other applications that keep their own settings such as Geany.
Code: (Select All) 'by mnrvovrfc 9-May-2023
'for Linux, and KDE Plasma v5.20 and later
$CONSOLE:ONLY
option _explicit
dim sco(1 to 12) as string
dim ani$, a$, lf$, u as long, ff as long
dim as integer rr, gg, bb, i, w
lf$ = chr$(10)
for w = 1 to 10
for i = 1 to 3
sco(i) = lightcolor$
sco(i + 5) = darkcolor$
next
sco(4) = sco(Random1(3))
sco(5) = sco(Random1(3))
sco(9) = sco(Random1(3) + 5)
sco(10) = sco(Random1(3) + 5)
a$ = twincolor$
u = instr(a$, "|")
sco(11) = left$(a$, u - 1)
sco(12) = mid$(a$, u + 1)
ani$ = "[ColorEffects:Disabled]" + lf$ +_
"ColorAmount=0" + lf$ +_
"ColorEffect=0" + lf$ +_
"ContrastAmount=0.65" + lf$ +_
"ContrastEffect=1" + lf$ +_
"IntensityAmount=0.1" + lf$ +_
"IntensityEffect=2" + lf$ +_
"" + lf$ +_
"[ColorEffects:Inactive]" + lf$ +_
"Color=112,111,110" + lf$ +_
"ColorAmount=0.025" + lf$ +_
"ColorEffect=2" + lf$ +_
"ContrastAmount=0.1" + lf$ +_
"ContrastEffect=2" + lf$ +_
"Enable=true" + lf$ +_
"IntensityAmount=0" + lf$ +_
"IntensityEffect=0" + lf$ + lf$
ani$ = ani$ + "[Colors:Button]" + lf$ +_
"BackgroundAlternate=" + sco(7) + lf$ +_
"BackgroundNormal=" + sco(6) + lf$ +_
"DecorationFocus=" + sco(11) + lf$ +_
"DecorationHover=" + sco(12) + lf$ +_
"ForegroundActive=" + sco(1) + lf$ +_
"ForegroundInactive=" + sco(11) + lf$ +_
"ForegroundLink=" + sco(5) + lf$ +_
"ForegroundNegative=" + sco(5) + lf$ +_
"ForegroundNeutral=" + sco(5) + lf$ +_
"ForegroundNormal=" + sco(5) + lf$ +_
"ForegroundPositive=" + sco(5) + lf$ +_
"ForegroundVisited=" + sco(5) + lf$ +_
"" + lf$ +_
"[Colors:Complementary]" + lf$ +_
"BackgroundAlternate=196,224,255" + lf$ +_
"BackgroundNormal=24,21,19" + lf$ +_
"DecorationFocus=58,167,221" + lf$ +_
"DecorationHover=110,214,255" + lf$ +_
"ForegroundActive=255,128,224" + lf$ +_
"ForegroundInactive=137,136,135" + lf$ +_
"ForegroundLink=88,172,255" + lf$ +_
"ForegroundNegative=191,3,3" + lf$ +_
"ForegroundNeutral=176,128,0" + lf$ +_
"ForegroundNormal=231,253,255" + lf$ +_
"ForegroundPositive=0,110,40" + lf$ +_
"ForegroundVisited=150,111,232" + lf$ +_
"" + lf$ +_
"[Colors:Selection]" + lf$ +_
"BackgroundAlternate=" + sco(3) + lf$ +_
"BackgroundNormal=" + sco(4) + lf$ +_
"DecorationFocus=" + sco(3) + lf$ +_
"DecorationHover=" + sco(4) + lf$ +_
"ForegroundActive=" + sco(10) + lf$ +_
"ForegroundInactive=" + sco(9) + lf$ +_
"ForegroundLink=" + sco(10) + lf$ +_
"ForegroundNegative=" + sco(10) + lf$ +_
"ForegroundNeutral=" + sco(8) + lf$ +_
"ForegroundNormal=" + sco(10) + lf$ +_
"ForegroundPositive=" + sco(10) + lf$ +_
"ForegroundVisited=" + sco(8) + lf$ +_
"" + lf$ +_
"[Colors:Tooltip]" + lf$ +_
"BackgroundAlternate=196,224,255" + lf$ +_
"BackgroundNormal=192,218,255" + lf$ +_
"DecorationFocus=43,116,199" + lf$ +_
"DecorationHover=119,183,255" + lf$ +_
"ForegroundActive=255,128,224" + lf$ +_
"ForegroundInactive=96,112,128" + lf$ +_
"ForegroundLink=0,87,174" + lf$ +_
"ForegroundNegative=191,3,3" + lf$ +_
"ForegroundNeutral=176,128,0" + lf$ +_
"ForegroundNormal=20,19,18" + lf$ +_
"ForegroundPositive=0,110,40" + lf$ +_
"ForegroundVisited=69,40,134" + lf$ +_
"" + lf$ +_
"[Colors:View]" + lf$ +_
"BackgroundAlternate=" + sco(7) + lf$ +_
"BackgroundNormal=" + sco(6) + lf$ +_
"DecorationFocus=" + sco(11) + lf$ +_
"DecorationHover=" + sco(12) + lf$ +_
"ForegroundActive=" + sco(1) + lf$ +_
"ForegroundInactive=" + sco(11) + lf$ +_
"ForegroundLink=" + sco(3) + lf$ +_
"ForegroundNegative" + sco(3) + lf$ +_
"ForegroundNeutral=" + sco(4) + lf$ +_
"ForegroundNormal=" + sco(1) + lf$ +_
"ForegroundPositive=" + sco(4) + lf$ +_
"ForegroundVisited=" + sco(5) + lf$ +_
"" + lf$ +_
"[Colors:Window]" + lf$ +_
"BackgroundAlternate=" + sco(7) + lf$ +_
"BackgroundNormal=" + sco(6) + lf$ +_
"DecorationFocus=" + sco(11) + lf$ +_
"DecorationHover=" + sco(12) + lf$ +_
"ForegroundActive=" + sco(1) + lf$ +_
"ForegroundInactive=" + sco(11) + lf$ +_
"ForegroundLink=" + sco(3) + lf$ +_
"ForegroundNegative" + sco(3) + lf$ +_
"ForegroundNeutral=" + sco(4) + lf$ +_
"ForegroundNormal=" + sco(1) + lf$ +_
"ForegroundPositive=" + sco(4) + lf$ +_
"ForegroundVisited=" + sco(5) + lf$ +_
"" + lf$ +_
"[General]" + lf$ +_
"Name=randomcolorscheme" + Zeroes$(w, 2) + lf$ +_
"shadeSortColumn=true" + lf$ + lf$ +_
"[KDE]" + lf$ +_
"contrast=4" + lf$ + lf$ +_
"[WM]" + lf$ +_
"activeBackground=" + sco(7) + lf$ +_
"activeForeground=" + sco(5) + lf$ +_
"inactiveBackground=224,223,222" + lf$ +_
"inactiveForeground=20,19,18" + lf$
a$ = environ$("HOME") + "/.local/share/color-schemes/randomcolorscheme" + Zeroes$(w, 2) + ".colors"
ff = freefile
open a$ for output as ff
print #ff, ani$
close ff
print w
next 'w
print "FINISHED"
system
'CHANGED: rr, gg, bb
function lightcolor$ ()
dim as integer rr, gg, bb
rr = Rand(192, 255)
gg = Rand(192, 223)
bb = Rand(224, 255)
if Random1(3) = 1 then gg = gg + 16
if Random1(3) = 1 then gg = gg + 16
if Random1(2) = 1 then swap rr, bb
if Random1(2) = 1 then swap gg, bb
if Random1(2) = 1 then swap rr, gg
if Random1(2) = 1 then swap rr, bb
if Random1(2) = 1 then swap gg, bb
lightcolor$ = _trim$(str$(rr)) + "," + _trim$(str$(gg)) + "," + _trim$(str$(bb))
end function
function darkcolor$ ()
dim as integer rr, gg, bb
rr = Random1(64)
gg = Rand(48, 79)
bb = Rand(48, 95)
if Random1(3) = 1 then gg = gg + 16
if Random1(4) = 1 then gg = gg + 32
if Random1(2) = 1 then swap rr, bb
if Random1(2) = 1 then swap gg, bb
if Random1(2) = 1 then swap rr, gg
darkcolor$ = _trim$(str$(rr)) + "," + _trim$(str$(gg)) + "," + _trim$(str$(bb))
end function
function twincolor$ ()
dim as integer rr, gg, bb, xx, yy
dim sret as string
rr = Rand(224, 255)
gg = Rand(224, 239)
bb = Rand(248, 255)
xx = Random1(80)
yy = Random1(80)
if Random1(3) = 1 then gg = gg + 16
if Random1(2) = 1 then swap rr, bb
if Random1(2) = 1 then swap gg, bb
if Random1(2) = 1 then swap rr, gg
if Random1(2) = 1 then swap rr, bb
if Random1(2) = 1 then swap gg, bb
sret$ = _trim$(str$(rr)) + "," + _trim$(str$(gg)) + "," + _trim$(str$(bb)) + "|"
select case Random1(6)
case 1 : rr = xx : gg = yy
case 2 : gg = xx : bb = yy
case 3 : rr = xx : bb = yy
case 4
swap rr, bb
rr = xx : gg = yy
case 5
swap rr, gg
gg = xx : bb = yy
case 6
swap gg, bb
rr = xx : bb = yy
end select
sret$ = sret$ + _trim$(str$(rr)) + "," + _trim$(str$(gg)) + "," + _trim$(str$(bb))
twincolor$ = sret$
end function
FUNCTION Random1& (maxvaluu&)
DIM sg%
sg% = SGN(maxvaluu&)
IF sg% = 0 THEN
Random1& = 0
ELSE
IF sg% = -1 THEN maxvaluu& = maxvaluu& * -1
Random1& = INT(RND * maxvaluu& + 1) * sg%
END IF
END FUNCTION
FUNCTION Rand& (fromval&, toval&)
DIM f&, t&, sg%
IF fromval& = toval& THEN
Rand& = fromval&
EXIT FUNCTION
END IF
f& = fromval&
t& = toval&
IF (f& < 0) AND (t& < 0) THEN
sg% = -1
f& = f& * -1
t& = t& * -1
ELSE
sg% = 1
END IF
IF f& > t& THEN SWAP f&, t&
Rand& = INT(RND * (t& - f& + 1) + f&) * sg%
END FUNCTION
FUNCTION Zeroes$ (num AS LONG, numdig AS INTEGER)
dim as _byte sg, hx
dim b$, v as long
IF num < 0 THEN sg = -1: num = num * -1
IF numdig < 0 THEN hx = 1: numdig = numdig * -1 ELSE hx = 0
IF hx THEN
b$ = HEX$(num)
ELSE
b$ = LTRIM$(STR$(num))
END IF
v = numdig - LEN(b$)
IF v > 0 THEN b$ = STRING$(v, 48) + b$
IF sg = -1 THEN b$ = "-" + b$
Zeroes$ = b$
END FUNCTION
![[Image: plasma-colors-bas-prog.png]](https://i.ibb.co/g79tfv0/plasma-colors-bas-prog.png)
|
|
|
|
| A little mod of a Love Song |
|
Posted by: bplus - 05-09-2023, 05:27 PM - Forum: Programs
- No Replies
|
 |
Silly Love Songs:
Code: (Select All) You'd think that people would've had enough of silly love songs
I look around me, and I see it isn't so
Some people want to fill the world with silly love songs
And what's wrong with that?
I'd like to know, 'cause here I go again
I love you
I love you
I love you
I love you
I can't explain, the feeling's plain to me (I love you)
Now can't you see?
Ah, she gave me more, she gave it all to me (I love you)
Now can't you see?
What's wrong with that?
I need to know, 'cause here I go again
I love you
I love you
Love doesn't come in a minute
Sometimes it doesn't come at all
I only know that when I'm in it
It isn't silly, love isn't silly, love isn't silly at all
How can I tell you about my loved one?
How can I tell you about my loved one?
How can I tell you about my loved one? (I love you)
How can I tell you about my loved one? (I love you)
I love you
I love you
I love you (I can't explain, the feeling's plain to me, say, can't you see?)
I love you (Ah, he gave me more, he gave it all to me, say, can't you see?)
I love you (I can't explain, the feeling's plain to me
Say, can't you see?)
{How can I tell you about my loved one?}
I love you (Ah, he gave me more, he gave it all to me
Say, can't you see?)
How can I tell you about my loved one?
I love you
I can't explain, the feeling's plain to me
(Say, can't you see?)
How can I tell you about my loved one?
I love you
Ah, he gave me more, he gave it all to me
(Say, can't you see?)
How can I tell you about my loved one?
You'd think that people would've had enough of silly love songs
I look around me and I see it isn't so, oh, no
Some people want to fill the world with silly love songs
And what's wrong with that?
modification code:
Code: (Select All) _Title "Silly Love Songs Rewrite" ' b+ 2023-05-09
Open "Silly Love Songs.txt" For Input As #1
Open "Silly Graph Apps.txt" For Output As #2
While EOF(1) = 0
Line Input #1, fl$
fl$ = strReplace$(fl$, "song", "app")
fl$ = strReplace$(fl$, "loved", "graphed")
fl$ = strReplace$(fl$, "love", "graph")
fl$ = strReplace$(fl$, "Love", "Graph")
fl$ = strReplace$(fl$, " he ", " e ")
fl$ = strReplace$(fl$, " she ", " e ")
Print fl$
Print #2, fl$
Wend
Close
Function strReplace$ (s$, replace$, new$) 'case sensitive 2020-07-28 version
Dim p As Long, sCopy$, LR As Long, lNew As Long
If Len(s$) = 0 Or Len(replace$) = 0 Then
strReplace$ = s$: Exit Function
Else
LR = Len(replace$): lNew = Len(new$)
End If
sCopy$ = s$ ' otherwise s$ would get changed
p = InStr(sCopy$, replace$)
While p
sCopy$ = Mid$(sCopy$, 1, p - 1) + new$ + Mid$(sCopy$, p + LR)
p = InStr(p + lNew, sCopy$, replace$)
Wend
strReplace$ = sCopy$
End Function
The rewrite, Silly Graph Apps.txt:
Code: (Select All) You'd think that people would've had enough of silly graph apps
I look around me, and I see it isn't so
Some people want to fill the world with silly graph apps
And what's wrong with that?
I'd like to know, 'cause here I go again
I graph you
I graph you
I graph you
I graph you
I can't explain, the feeling's plain to me (I graph you)
Now can't you see?
Ah, e gave me more, e gave it all to me (I graph you)
Now can't you see?
What's wrong with that?
I need to know, 'cause here I go again
I graph you
I graph you
Graph doesn't come in a minute
Sometimes it doesn't come at all
I only know that when I'm in it
It isn't silly, graph isn't silly, graph isn't silly at all
How can I tell you about my graphed one?
How can I tell you about my graphed one?
How can I tell you about my graphed one? (I graph you)
How can I tell you about my graphed one? (I graph you)
I graph you
I graph you
I graph you (I can't explain, the feeling's plain to me, say, can't you see?)
I graph you (Ah, e gave me more, e gave it all to me, say, can't you see?)
I graph you (I can't explain, the feeling's plain to me
Say, can't you see?)
{How can I tell you about my graphed one?}
I graph you (Ah, e gave me more, e gave it all to me
Say, can't you see?)
How can I tell you about my graphed one?
I graph you
I can't explain, the feeling's plain to me
(Say, can't you see?)
How can I tell you about my graphed one?
I graph you
Ah, e gave me more, e gave it all to me
(Say, can't you see?)
How can I tell you about my graphed one?
You'd think that people would've had enough of silly graph apps
I look around me and I see it isn't so, oh, no
Some people want to fill the world with silly graph apps
And what's wrong with that?
|
|
|
|
| Random Tessellations |
|
Posted by: bplus - 05-09-2023, 02:29 PM - Forum: Programs
- Replies (33)
|
|
Inspired by Charlie's BAM version I started from scratch for QB64 version with added full colorization mode.
Use b key to toggle color modes or esc to quit, any other key shows another random tile tessellated screen:
Code: (Select All) _Title "Tessellation use b to toggle to 1 color and black or full color"
' b+ 2023-05-09 - Tiling with a pattern
'
' Inspired by Charlie's BAM example:
' https://staging.qb64phoenix.com/showthread.php?tid=1646&pid=15772#pid15772
'
' But I also wanted to try a colorized version.
'
' So use b key to toggle between:
' 1. a mod of Charlies version with different pixel block size with black backgrounds
' 2. the colorized version which reminds me of Magic Eye Art
'
DefLng A-Z
Screen _NewImage(800, 600, 12) ' only 16 colors here
_ScreenMove 250, 50
Dim Shared Pix ' Pix is number of pixels to Tile side
Dim Shared Scale ' Change a pixel to a bigger square block for not so subtle patterns
Dim Shared Tile ' Handle that stores Tile Image in memory to call up with _PutImage
Dim Shared B ' Set color mode from Full 16 colors Rainbow to 1 like for printing a label
Do
If InKey$ = "b" Then B = 1 - B ' toggle coloring mode on a b keypress
MakeTile ' create a new random tiling pattern
Tessellate ' tile the screen with it
_PrintString (740, 580), "ZZZ..." ' Show user we are sleeping awaiting a key press
Sleep
Loop Until _KeyDown(27) ' quit when detect escape key on sleep
Sub MakeTile ' make a random tile to Tesselate according to B Mode coloring
Pix = Int(Rnd * 9) + 4 ' sets tile size: pix X pix or a 4X4 to 12X12 Tile coloring
Scale = Int(Rnd * 6) + 4 ' to change pixels to square blocks
If Tile Then _FreeImage Tile ' throw old image away
Tile = _NewImage(Scale * Pix - 1, Scale * Pix - 1) ' make new one
_Dest Tile ' draw in the memory area Tile not on screen
oneColor = Int(Rnd * 15) + 1 ' one color and black background for B Mode
For y = 0 To Scale * Pix - 1 Step Scale
For x = 0 To Scale * Pix - 1 Step Scale
If B Then
If Rnd < .5 Then c = 0 Else c = oneColor 'one color and black background for B Mode
Else
c = Int(Rnd * 16)
End If
Line (x, y)-Step(Scale, Scale), c, BF ' draw square that is scaled pixel
Next
Next
_Dest 0
End Sub
Sub Tessellate ' just covering the screen with our Tile
For y = 0 To _Height Step Scale * Pix
For x = 0 To _Width Step Scale * Pix
_PutImage (x, y)-Step(Scale * Pix - 1, Scale * Pix - 1), Tile, 0
Next
Next
End Sub
|
|
|
|
|
