I am writing a small sub to gather the available drives on a system (windows) and I am getting spurious items printed on to the console window. There are no print statements so the screen should be blank
Code: (Select All)
Dim Shared Drive$
Dim Shared DrvErr
Dim Shared DriveName$(27)
Dim Shared DriveNum%
DECLARE SUB FindDrives () '*** Find which drives are on the PC ***
DriveErr:
If Err = 68 Then ProgErr = 1
DrvErr = 1
Resume Next
End
Sub FindDrives
DriveNum% = 0
'*** Find what drives are present in the PC ***
Erase DriveName$
On Error GoTo DriveErr
For Count = 65 To 90
DrvErr = 0
Drive$ = Chr$(Count) + ":\"
Files Drive$
If DrvErr = 0 Then
DriveNum% = DriveNum% + 1
DriveName$(DriveNum%) = Chr$(Count)
End If
Next Count
End Sub
When using $Debug to watch execution, I get program crashes and windows messages that a problem has caused the program to stop working correctly.
Not sure what is happening here, but it looks like a memory issue.
Here's a menu system I developed for use in various programs.
It works, but I put it in WIP because there are some things I want to tweak, make easier to customize, etc.
Code: (Select All)
_Title "SimpleMenu"
' DESCRIPTION:
' Just a simple menu that displays choices in text, along with description,
' and lets the user navigate them with the cursor and page up/down keys.
' HOW TO USE:
' 1. Add your menu choices to the section:
' BEGIN ADD YOUR CUSTOM MENU ITEMS HERE
' 2. Add your code to the section:
' BEGIN YOUR CODE THAT THE MENU RUNS GOES HERE
' CHANGE LOG:
' Date Who What
' 01/26/2022 madscijr added friendlier menu system to "qb64_sound_examples_2-00.bas"
' 07/28/2022 madscijr stripped out the menu code into its own library (this)
' ################################################################################################################################################################
' #CONSTANTS = GLOBAL CONSTANTS
' ################################################################################################################################################################
' #UDT #TYPES = USER DEFINED TYPES
' UDT TO HOLD THE INFO FOR A GAME CONTROLLER
Type MenuType
Choice As String
Info As String
End Type ' MenuType
' ################################################################################################################################################################
' #VARS = GLOBAL VARIABLES
' ENABLE / DISABLE DEBUG CONSOLE
Dim Shared m_bTesting As Integer: m_bTesting = TRUE
' BASIC PROGRAM METADATA
Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
Dim Shared m_VersionInfo$: m_VersionInfo$ = "1.00"
' FOR MENU
ReDim Shared m_arrMenu(-1) As MenuType
' =============================================================================
' 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
' ****************************************************************************************************************************************************************
' DEACTIVATE DEBUGGING WINDOW
If m_bTesting = TRUE Then
_Console Off
End If
' ****************************************************************************************************************************************************************
System ' return control to the operating system
End
' ################################################################################################################################################################
' BEGIN ADD YOUR CUSTOM MENU ITEMS HERE
' ################################################################################################################################################################
Sub InitializeGlobal
' *****************************************************************************
' *** BEGIN ADD YOUR MENU CHOICES HERE ****************************************
AddNextMenuItem "Choice A", "Option A uses code 65 to do its thing."
AddNextMenuItem "Choice B", "Option B uses code 66 to do its thing."
AddNextMenuItem "Choice C", "Option C uses code 67 to do its thing."
AddNextMenuItem "Choice D", "Option D uses code 68 to do its thing."
AddNextMenuItem "Choice E", "Option E uses code 69 to do its thing."
AddNextMenuItem "Choice F", "Option F uses code 70 to do its thing."
AddNextMenuItem "Choice G", "Option G uses code 71 to do its thing."
AddNextMenuItem "Choice H", "Option H uses code 72 to do its thing."
AddNextMenuItem "Choice I", "Option I uses code 73 to do its thing."
AddNextMenuItem "Choice J", "Option J uses code 74 to do its thing."
AddNextMenuItem "Choice K", "Option K uses code 75 to do its thing."
AddNextMenuItem "Choice L", "Option L uses code 76 to do its thing."
AddNextMenuItem "Choice M", "Option M uses code 77 to do its thing."
AddNextMenuItem "Choice N", "Option N uses code 78 to do its thing."
AddNextMenuItem "Choice O", "Option O uses code 79 to do its thing."
AddNextMenuItem "Choice P", "Option P uses code 80 to do its thing."
AddNextMenuItem "Choice Q", "Option Q uses code 81 to do its thing."
AddNextMenuItem "Choice R", "Option R uses code 82 to do its thing."
AddNextMenuItem "Choice S", "Option S uses code 83 to do its thing."
AddNextMenuItem "Choice T", "Option T uses code 84 to do its thing."
AddNextMenuItem "Choice U", "Option U uses code 85 to do its thing."
AddNextMenuItem "Choice V", "Option V uses code 86 to do its thing."
AddNextMenuItem "Choice W", "Option W uses code 87 to do its thing."
AddNextMenuItem "Choice X", "Option X uses code 88 to do its thing."
AddNextMenuItem "Choice Y", "Option Y uses code 89 to do its thing."
AddNextMenuItem "Choice Z", "Option Z uses code 90 to do its thing."
' *** END ADD YOUR MENU CHOICES HERE ******************************************
' *****************************************************************************
End Sub ' InitializeGlobal
Sub DoMenuItem (iMenuPos As Integer)
Dim in$
ClearKeyboard 3
in$ = m_arrMenu(iMenuPos).Choice
If in$ = "" Then ' (DO NOTHING)
' *****************************************************************************
' *** BEGIN ADD YOUR MENU CHOICES AND WHAT CODE RUNS HERE *********************
ElseIf in$ = "Choice A" Then TestRoutineChoiceA: ClearKeyboard 3
ElseIf in$ = "Choice B" Then TestRoutineChoiceB: ClearKeyboard 3
ElseIf in$ = "Choice C" Then TestRoutineChoiceC: ClearKeyboard 3
ElseIf in$ = "Choice D" Then TestRoutineChoiceD: ClearKeyboard 3
ElseIf in$ = "Choice E" Then TestRoutineChoiceE: ClearKeyboard 3
ElseIf in$ = "Choice F" Then TestRoutineChoiceF: ClearKeyboard 3
ElseIf in$ = "Choice G" Then TestRoutineChoiceG: ClearKeyboard 3
ElseIf in$ = "Choice H" Then TestRoutineChoiceH: ClearKeyboard 3
ElseIf in$ = "Choice I" Then TestRoutineChoiceI: ClearKeyboard 3
ElseIf in$ = "Choice J" Then TestRoutineChoiceJ: ClearKeyboard 3
ElseIf in$ = "Choice K" Then TestRoutineChoiceK: ClearKeyboard 3
ElseIf in$ = "Choice L" Then TestRoutineChoiceL: ClearKeyboard 3
ElseIf in$ = "Choice M" Then TestRoutineChoiceM: ClearKeyboard 3
ElseIf in$ = "Choice N" Then TestRoutineChoiceN: ClearKeyboard 3
ElseIf in$ = "Choice O" Then TestRoutineChoiceO: ClearKeyboard 3
ElseIf in$ = "Choice P" Then TestRoutineChoiceP: ClearKeyboard 3
ElseIf in$ = "Choice Q" Then TestRoutineChoiceQ: ClearKeyboard 3
ElseIf in$ = "Choice R" Then TestRoutineChoiceR: ClearKeyboard 3
ElseIf in$ = "Choice S" Then TestRoutineChoiceS: ClearKeyboard 3
ElseIf in$ = "Choice T" Then TestRoutineChoiceT: ClearKeyboard 3
ElseIf in$ = "Choice U" Then TestRoutineChoiceU: ClearKeyboard 3
ElseIf in$ = "Choice V" Then TestRoutineChoiceV: ClearKeyboard 3
ElseIf in$ = "Choice W" Then TestRoutineChoiceW: ClearKeyboard 3
ElseIf in$ = "Choice X" Then TestRoutineChoiceX: ClearKeyboard 3
ElseIf in$ = "Choice Y" Then TestRoutineChoiceY: ClearKeyboard 3
ElseIf in$ = "Choice Z" Then TestRoutineChoiceZ: ClearKeyboard 3
' *** END ADD YOUR MENU CHOICES AND WHAT CODE RUNS HERE ***********************
' *****************************************************************************
Else
' (DO NOTHING)
End If
End Sub ' DoMenuItem
' ################################################################################################################################################################
' END ADD YOUR CUSTOM MENU ITEMS HERE
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN YOUR CODE THAT THE MENU RUNS GOES HERE
' ################################################################################################################################################################
Sub TestRoutineChoiceA
Dim in$
Cls
Print "This is TestRoutineChoiceA"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceA
Sub TestRoutineChoiceB
Dim in$
Cls
Print "This is TestRoutineChoiceB"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceB
Sub TestRoutineChoiceC
Dim in$
Cls
Print "This is TestRoutineChoiceC"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceC
Sub TestRoutineChoiceD
Dim in$
Cls
Print "This is TestRoutineChoiceD"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceD
Sub TestRoutineChoiceE
Dim in$
Cls
Print "This is TestRoutineChoiceE"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceE
Sub TestRoutineChoiceF
Dim in$
Cls
Print "This is TestRoutineChoiceF"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceF
Sub TestRoutineChoiceG
Dim in$
Cls
Print "This is TestRoutineChoiceG"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceG
Sub TestRoutineChoiceH
Dim in$
Cls
Print "This is TestRoutineChoiceH"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceH
Sub TestRoutineChoiceI
Dim in$
Cls
Print "This is TestRoutineChoiceI"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceI
Sub TestRoutineChoiceJ
Dim in$
Cls
Print "This is TestRoutineChoiceJ"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceJ
Sub TestRoutineChoiceK
Dim in$
Cls
Print "This is TestRoutineChoiceK"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceK
Sub TestRoutineChoiceL
Dim in$
Cls
Print "This is TestRoutineChoiceL"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceL
Sub TestRoutineChoiceM
Dim in$
Cls
Print "This is TestRoutineChoiceM"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceM
Sub TestRoutineChoiceN
Dim in$
Cls
Print "This is TestRoutineChoiceN"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceN
Sub TestRoutineChoiceO
Dim in$
Cls
Print "This is TestRoutineChoiceO"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceO
Sub TestRoutineChoiceP
Dim in$
Cls
Print "This is TestRoutineChoiceP"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceP
Sub TestRoutineChoiceQ
Dim in$
Cls
Print "This is TestRoutineChoiceQ"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceQ
Sub TestRoutineChoiceR
Dim in$
Cls
Print "This is TestRoutineChoiceR"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceR
Sub TestRoutineChoiceS
Dim in$
Cls
Print "This is TestRoutineChoiceS"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceS
Sub TestRoutineChoiceT
Dim in$
Cls
Print "This is TestRoutineChoiceT"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceT
Sub TestRoutineChoiceU
Dim in$
Cls
Print "This is TestRoutineChoiceU"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceU
Sub TestRoutineChoiceV
Dim in$
Cls
Print "This is TestRoutineChoiceV"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceV
Sub TestRoutineChoiceW
Dim in$
Cls
Print "This is TestRoutineChoiceW"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceW
Sub TestRoutineChoiceX
Dim in$
Cls
Print "This is TestRoutineChoiceX"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceX
Sub TestRoutineChoiceY
Dim in$
Cls
Print "This is TestRoutineChoiceY"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceY
Sub TestRoutineChoiceZ
Dim in$
Cls
Print "This is TestRoutineChoiceZ"
Input "PRESS ENTER TO RETURN TO MENU"; in$
End Sub ' TestRoutineChoiceZ
' ################################################################################################################################################################
' END YOUR CODE THAT THE MENU RUNS GOES HERE
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN GENERIC MENU CODE
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' TODO: remove unused variables
' TODO: use _Height(0) to automatically set height iMenuSize and iInfoSize
' TODO: use variables to make it easy to change placement and layout of title/instructions/description
' DONE: use _Width(0) to automatically limit # of text columns
Sub main
Dim RoutineName As String: RoutineName = "main"
Dim sResult As String
Dim sFileName As String
Dim vbCrLf As String: vbCrLf = Chr$(10) + Chr$(13)
Dim vbCr As String: vbCr = Chr$(13)
Dim vbLf As String: vbLf = Chr$(10)
Dim vbTab As String: vbTab = Chr$(9)
Dim quot As String: quot = Chr$(34)
Dim sTemp As String
Dim sTempHR As String: sTempHR = "++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++"
Dim sOut As String
Dim sComment As String
Dim sError As String
Dim bFinished As Integer
Dim bAppend As Integer
Dim iMenuSize As Integer ' how many items to display on screen
Dim iMenuPos As Integer ' where in the list we are
Dim iMenuStart As Integer ' first item to display on the list
Dim iMenuEnd As Integer ' last item to display on the list
Dim iMenuLoop As Integer
Dim iStartRow As Integer
Dim iRow As Integer
Dim iCol As Integer
Dim iColCount As Integer
Dim iRowCount As Integer
Dim iLastKey As Integer
Dim iPageSize As Integer
Dim iNudgeSize As Integer ' when cursor reaches bottom or top, how many lines to scroll
Dim bMoved As Integer
Dim bInitPage As Integer
Dim bInitInfo As Integer
Dim in$
ReDim arrInfo(-1) As String
Dim sInfoDelim As String: sInfoDelim = "\n"
Dim iInfoRow As Integer
Dim iInfoSize As Integer
Dim iNextRow As Integer
'Dim iLastInfoRow As Integer
Dim iBackColor~&: iBackColor~& = cBlack
Dim iTitleFgColor~&: iTitleFgColor~& = cBlack
Dim iTitleBgColor~&: iTitleBgColor~& = cDodgerBlue
Dim iInstructColor~&: iInstructColor~& = cCyan
Dim iMenuColor~&: iMenuColor~& = cWhite
Dim iRunColor~&: iRunColor~& = cYellow
Dim iInfoColor~&: iInfoColor~& = cSilver
Dim iMaxColumns As Integer
Dim iIndex As Integer
' SET UP SCREEN
' MAKE SCREEN BIG TO FIT A LOT OF TEXT: 1024x768=128cols,48rows and 1280x1024=160cols,64rows
Screen _NewImage(1024, 768, 32): _ScreenMove 0, 0
' MAIN MENU
bInitPage = TRUE
bInitInfo = TRUE
iLastKey = 0
bMoved = TRUE
bFinished = FALSE
Do
' SHOW INSTRUCTIONS
If bInitPage = TRUE Then
Cls , iBackColor~& ' makes the background opaque black
Color iTitleFgColor~&, iTitleBgColor~&
PrintString 0, 0, "SimpleMenu"
Color iInstructColor~&, iBackColor~&
PrintString 2, 0, "KEY(S) ACTION"
PrintString 3, 0, "----------------------------------- --------------------------------"
PrintString 4, 0, "Crsr Up/Down, PgUp/PgDown, Home/End Navigate/select item"
'PrintString 5, 0, "Crsr Left See description of current item"
PrintString 6, 0, "Crsr Right Run current item"
ClearKeyboard 1
bInitPage = FALSE
End If
If bInitInfo = TRUE Or bMoved = TRUE Then
' Clear old description
For iNextRow = iInfoRow To (iInfoRow + iInfoSize)
Locate iNextRow, 1
Color iBackColor~&, iBackColor~&
Print String$(iMaxColumns, " ");
Next iNextRow
' Show current item's description
If Len(m_arrMenu(iMenuPos).Choice) > 0 Then
If Len(m_arrMenu(iMenuPos).Info) > 0 Then
split m_arrMenu(iMenuPos).Info, sInfoDelim, arrInfo()
iRowCount = 0
iNextRow = iInfoRow
For iIndex = 0 To UBound(arrInfo)
iRowCount = iRowCount + 1
If iRowCount > iInfoSize Then Exit For
Locate iNextRow, 1
Color iInfoColor~&, iBackColor~&
Print Left$(arrInfo(iIndex), iMaxColumns);
iNextRow = iNextRow + 1
Next iIndex
End If
End If ' If Len(m_arrMenu(iMenuPos).Choice) > 0 Then
bInitInfo = FALSE
End If
' (RE)DISPLAY CURRENT SLICE OF THE MENU
If bMoved = TRUE Then
iRow = iStartRow
iCol = 0
If iMenuStart < LBound(m_arrMenu) Then
iMenuStart = LBound(m_arrMenu)
End If
iMenuEnd = (iMenuStart + iMenuSize) - 1
If iMenuEnd > UBound(m_arrMenu) Then
If iMenuSize >= UBound(m_arrMenu) Then
iMenuStart = UBound(m_arrMenu) - (iMenuSize - 1)
Else
iMenuStart = LBound(m_arrMenu)
iMenuEnd = UBound(m_arrMenu)
End If
End If
For iMenuLoop = iMenuStart To iMenuEnd
iRow = iRow + 1
If iMenuLoop = iMenuPos Then
Color iBackColor~&, iMenuColor~&
Else
Color iMenuColor~&, iBackColor~&
End If
PrintString iRow, iCol, right$(" " + cstr$(iMenuLoop), 3) + ". " + _
left$(m_arrMenu(iMenuLoop).Choice + string$(iColCount, " "), iColCount)
Next iMenuLoop
bMoved = FALSE
End If
' GET USER INPUT
While _DeviceInput(1): Wend ' Clear and update the keyboard buffer
' DON'T ACCEPT ANY MORE INPUT UNTIL THE LAST PRESSED KEY IS RELEASED
If iLastKey <> 0 Then
If _Button(iLastKey) = FALSE Then
iLastKey = 0
End If
End If
' READY TO ACCEPT MORE INPUT?
If iLastKey = 0 Or bInitInfo = TRUE Then
' DID PLAYER PRESS ANY KEYS WE KNOW?
If _Button(KeyCode_Home%) Then
in$ = "home"
iLastKey = KeyCode_Home%
ElseIf _Button(KeyCode_End%) Then
in$ = "end"
iLastKey = KeyCode_End%
ElseIf _Button(KeyCode_PgUp%) Then
in$ = "pgup"
iLastKey = KeyCode_PgUp%
ElseIf _Button(KeyCode_PgDn%) Then
in$ = "pgdn"
iLastKey = KeyCode_PgDn%
ElseIf _Button(KeyCode_Up%) Then
in$ = "up"
iLastKey = KeyCode_Up%
ElseIf _Button(KeyCode_Down%) Then
in$ = "down"
iLastKey = KeyCode_Down%
'ElseIf _Button(KeyCode_Left%) Then
' in$ = "info"
' iLastKey = KeyCode_Left%
ElseIf _Button(KeyCode_Right%) Then
in$ = "run"
iLastKey = KeyCode_Right%
'ElseIf _Button(KeyCode_Enter%) Then '<-- for some reason clearing the keyboard buffer doesn't stop the Enter key from being detected later, oh well
' in$ = "run"
' iLastKey = KeyCode_Enter%
ElseIf _Button(KeyCode_Escape%) Then
in$ = "esc"
iLastKey = KeyCode_Escape%
Else
in$ = ""
End If
' IF USER DID PRESS A KEY WE KNOW, PROCESS INPUT
If iLastKey <> 0 Or bInitInfo = TRUE Then
ClearKeyboard 0
If in$ = "" Then
' (DO NOTHING)
ElseIf in$ = "home" Then
iMenuPos = LBound(m_arrMenu)
bMoved = TRUE
ElseIf in$ = "end" Then
iMenuPos = UBound(m_arrMenu)
bMoved = TRUE
ElseIf in$ = "pgup" Then
iMenuPos = iMenuPos - iPageSize
bMoved = TRUE
ElseIf in$ = "pgdn" Then
iMenuPos = iMenuPos + iPageSize
bMoved = TRUE
ElseIf in$ = "up" Then
iMenuPos = iMenuPos - 1
bMoved = TRUE
ElseIf in$ = "down" Then
iMenuPos = iMenuPos + 1
bMoved = TRUE
ElseIf in$ = "run" Then
'' HIGHLIGHT NAME
'iRow = iStartRow
'For iMenuLoop = iMenuStart To iMenuEnd
' iRow = iRow + 1
' If iMenuLoop = iMenuPos Then
' Color iBackColor~&, iRunColor~&
' PrintString iRow, iCol, right$(" " + cstr$(iMenuLoop), 3) + ". " + _
' left$(m_arrMenu(iMenuLoop).Choice + string$(iColCount, " "), iColCount)
' Exit For
' End If
'Next iMenuLoop
' DO WHAT THE USER SELECTED
DoMenuItem iMenuPos
bMoved = TRUE
' FLAG TO REDRAW MENU
bInitPage = TRUE
bInitInfo = TRUE
ElseIf in$ = "esc" Then
bFinished = TRUE
Exit Do
End If
' HANDLE MOVE
If bMoved = TRUE Then
' MAKE SURE NOT OUT OF BOUNDS
If iMenuPos < LBound(m_arrMenu) Then
iMenuPos = LBound(m_arrMenu)
ElseIf iMenuPos > UBound(m_arrMenu) Then
iMenuPos = UBound(m_arrMenu)
End If
' DETERMINE WHAT RANGE TO DISPLAY
If iMenuPos < iMenuStart Then
iMenuStart = iMenuPos - iNudgeSize
If iMenuStart < LBound(m_arrMenu) Then
iMenuStart = LBound(m_arrMenu)
End If
iMenuEnd = iMenuStart + (iMenuSize - 1)
If iMenuEnd > UBound(m_arrMenu) Then
iMenuEnd = UBound(m_arrMenu)
End If
ElseIf iMenuPos > iMenuEnd Then
iMenuEnd = iMenuPos + iNudgeSize
If iMenuEnd > UBound(m_arrMenu) Then
iMenuEnd = UBound(m_arrMenu)
End If
iMenuStart = iMenuEnd - (iMenuSize - 1)
If iMenuStart < LBound(m_arrMenu) Then
iMenuStart = LBound(m_arrMenu)
End If
End If
End If ' HANDLE MOVE
End If ' iLastKey <> 0
End If ' IF iLastKey = 0
Loop Until bFinished = TRUE
While _DeviceInput(1): Wend ' Clear and update the keyboard buffer
ClearKeyboard 3
Sub AddNextMenuItem (sName As String, sInfo As String)
ReDim _Preserve m_arrMenu(1 To UBound(m_arrMenu) + 1) As MenuType
m_arrMenu(UBound(m_arrMenu)).Choice = sName
m_arrMenu(UBound(m_arrMenu)).Info = sInfo
End Sub ' AddNextMenuItem
' /////////////////////////////////////////////////////////////////////////////
' Tries to clear the keyboard buffer.
' In some places _KeyClear seems to work
' but in other situations While_DeviceInput(1):Wend works
' And in other situations k = _KeyHit works.
' So this handy dandy sub does it all:
' iDelay% VALUE FOR
' ------------- ---
' (any) _KeyClear
' 1 _Delay 1
' 2 While _DeviceInput(1): Wend
' 3 k = _KeyHit and the above methods
Sub ClearKeyboard (iDelay%)
Dim k As Integer
_KeyClear
If iDelay% = 1 Then
_Delay iDelay%
End If
If iDelay% > 1 Then
While _DeviceInput(1): Wend ' Clear and update the keyboard buffer
End If
If iDelay% > 2 Then
k = _KeyHit
End If
End Sub ' ClearKeyboard
' ################################################################################################################################################################
' END GENERIC MENU CODE
' ################################################################################################################################################################
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 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
'' /////////////////////////////////////////////////////////////////////////////
'
'Sub DebugPause (sPrompt As String, iRow As Integer, iColumn As Integer, fgColor As _Unsigned Long, bgColor As _Unsigned Long)
' Color fgColor, bgColor
'
' PrintString iRow, iColumn, String$(128, " ")
'
' PrintString iRow, iColumn, sPrompt
' Sleep
' '_KEYCLEAR: _DELAY 1
' 'DO
' 'LOOP UNTIL _KEYDOWN(13) ' leave loop when ENTER key pressed
' '_KEYCLEAR: _DELAY 1
'End Sub ' DebugPause
'
'' /////////////////////////////////////////////////////////////////////////////
'
'Sub DebugOut (sPrompt As String, iRow As Integer, iColumn As Integer, fgColor As _Unsigned Long, bgColor As _Unsigned Long)
' Color fgColor, bgColor
' PrintString iRow, iColumn, String$(128, " ")
' PrintString iRow, iColumn, sPrompt
'End Sub ' DebugOut
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END DEBUGGING ROUTINES @DEBUGGING
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GENERAL PURPOSE ROUTINES #GEN
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Function AppendString$ (MyString As String, NewString As String, MyDelimiter As String)
Dim sResult As String: sResult = MyString
If Len(MyString) > 0 Then
sResult = sResult + MyDelimiter
End If
sResult = sResult + NewString
AppendString$ = sResult
End Function ' AppendString$
Sub AppendToStringArray (MyStringArray$(), MyString$)
ReDim _Preserve MyStringArray$(LBound(MyStringArray$) To UBound(MyStringArray$) + 1)
MyStringArray$(UBound(MyStringArray$)) = MyString$
End Sub ' AppendToStringArray
' /////////////////////////////////////////////////////////////////////////////
' See also StringTo2dArray
Function Array2dToString$ (MyArray() As String)
Dim MyString As String
Dim iY As Integer
Dim iX As Integer
Dim sLine As String
MyString = ""
For iY = LBound(MyArray, 1) To UBound(MyArray, 1)
sLine = ""
For iX = LBound(MyArray, 2) To UBound(MyArray, 2)
sLine = sLine + MyArray(iY, iX)
Next iX
MyString = MyString + sLine + Chr$(13)
Next iY
Array2dToString$ = MyString
End Function ' Array2dToString$
'Function Array2dToStringTest$ (MyArray() As String)
' Dim MyString As String
' Dim iY As Integer
' Dim iX As Integer
' Dim sLine As String
' MyString = ""
' MyString = MyString + " 11111111112222222222333" + Chr$(13)
' MyString = MyString + " 12345678901234567890123456789012" + Chr$(13)
' For iY = LBound(MyArray, 1) To UBound(MyArray, 1)
' sLine = ""
' sLine = sLine + Right$(" " + cstr$(iY), 2)
' For iX = LBound(MyArray, 2) To UBound(MyArray, 2)
' sLine = sLine + MyArray(iY, iX)
' Next iX
' sLine = sLine + Right$(" " + cstr$(iY), 2)
' MyString = MyString + sLine + Chr$(13)
' Next iY
' MyString = MyString + " 12345678901234567890123456789012" + Chr$(13)
' MyString = MyString + " 11111111112222222222333" + Chr$(13)
' Array2dToStringTest$ = MyString
'End Function ' Array2dToStringTest$
' /////////////////////////////////////////////////////////////////////////////
' 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$
' /////////////////////////////////////////////////////////////////////////////
' Simple timestamp function
Function CurrentDateTime$
CurrentDateTime$ = Mid$(Date$, 7, 4) + "-" + _
Mid$(Date$, 1, 5) + " " + _
Time$
End Function ' CurrentDateTime$
' /////////////////////////////////////////////////////////////////////////////
' TODO: verify this works
' 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$
' /////////////////////////////////////////////////////////////////////////////
' Receives an {sDelim} delimited list {sInput}
' returns the list with all duplicate entries removed.
Function DedupeDelimList$ (sInput As String, sDelim As String)
ReDim arrLines(-1) As String
Dim sOutput As String
Dim iLoop As Integer
split sInput, sDelim, arrLines()
sOutput = sDelim
For iLoop = LBound(arrLines) To UBound(arrLines)
If InStr(1, sOutput, sDelim + arrLines(iLoop) + sDelim) = 0 Then
sOutput = sOutput + arrLines(iLoop) + sDelim
End If
Next iLoop
DedupeDelimList$ = sOutput
End Function ' DedupeDelimList$
' /////////////////////////////////////////////////////////////////////////////
' SMcNeill
' More efficient version of ExtendedTimer.
' This stores our day values and only updates them when necessary.
' We really don't need to figure out how many seconds are in today over and over endlessly
' -- just count them once, and when the clock swaps back to 0:0:0, add 24*60*60 seconds to the count.
' Re: how to time something (ie do loop for n seconds)
' https://forum.qb64.org/index.php?topic=4682.0
Function ExtendedTimer##
'modified extendedtimer to store the old day's count, and not have to recalculate it every time the routine is called.
Static olds As _Float, old_day As _Float
Dim m As Integer, d As Integer, y As Integer
Dim s As _Float, day As String
If olds = 0 Then 'calculate the day the first time the extended timer runs
day = Date$
m = Val(Left$(day, 2))
d = Val(Mid$(day, 4, 2))
y = Val(Right$(day, 4)) - 1970
Select Case m 'Add the number of days for each previous month passed
Case 2: d = d + 31
Case 3: d = d + 59
Case 4: d = d + 90
Case 5: d = d + 120
Case 6: d = d + 151
Case 7: d = d + 181
Case 8: d = d + 212
Case 9: d = d + 243
Case 10: d = d + 273
Case 11: d = d + 304
Case 12: d = d + 334
End Select
If (y Mod 4) = 2 And m > 2 Then d = d + 1 'add a day if this is leap year and we're past february
d = (d - 1) + 365 * y 'current month days passed + 365 days per each standard year
d = d + (y + 2) \ 4 'add in days for leap years passed
s = d * 24 * 60 * 60 'Seconds are days * 24 hours * 60 minutes * 60 seconds
old_day = s
End If
If Timer < oldt Then 'we went from 23:59:59 (a second before midnight) to 0:0:0 (midnight)
old_day = s + 83400 'add another worth of seconds to our counter
End If
oldt = Timer
olds = old_day + oldt
ExtendedTimer## = olds
End Function ' ExtendedTimer##
' /////////////////////////////////////////////////////////////////////////////
' TODO: find the newer formatting function?
Function FormatNumber$ (myValue, iDigits As Integer)
Dim strValue As String
strValue = DblToStr$(myValue) + String$(iDigits, " ")
If myValue < 1 Then
If myValue < 0 Then
strValue = Replace$(strValue, "-.", "-0.")
ElseIf myValue > 0 Then
strValue = "0" + strValue
End If
End If
FormatNumber$ = Left$(strValue, iDigits)
End Function ' FormatNumber$
' /////////////////////////////////////////////////////////////////////////////
' From: Bitwise Manipulations By Steven Roman
' http://www.romanpress.com/Articles/Bitwise_R/Bitwise.htm
' Returns the 8-bit binary representation
' of an integer iInput where 0 <= iInput <= 255
Function GetBinary$ (iInput1 As Integer)
Dim sResult As String
Dim iLoop As Integer
Dim iInput As Integer: iInput = iInput1
sResult = ""
If iInput >= 0 And iInput <= 255 Then
For iLoop = 1 To 8
sResult = LTrim$(RTrim$(Str$(iInput Mod 2))) + sResult
iInput = iInput \ 2
'If iLoop = 4 Then sResult = " " + sResult
Next iLoop
End If
GetBinary$ = sResult
End Function ' GetBinary$
' /////////////////////////////////////////////////////////////////////////////
' wonderfully inefficient way to read if a bit is set
' ival = GetBit256%(int we are comparing, int containing the bits we want to read)
' See also: GetBit256%, SetBit256%
Function GetBit256% (iNum1 As Integer, iBit1 As Integer)
Dim iResult As Integer
Dim sNum As String
Dim sBit As String
Dim iLoop As Integer
Dim bContinue As Integer
'DIM iTemp AS INTEGER
Dim iNum As Integer: iNum = iNum1
Dim iBit As Integer: iBit = iBit1
iResult = FALSE
bContinue = TRUE
If iNum < 256 And iBit <= 128 Then
sNum = GetBinary$(iNum)
sBit = GetBinary$(iBit)
For iLoop = 1 To 8
If Mid$(sBit, iLoop, 1) = "1" Then
'if any of the bits in iBit are false, return false
If Mid$(sNum, iLoop, 1) = "0" Then
iResult = FALSE
bContinue = FALSE
Exit For
End If
End If
Next iLoop
If bContinue = TRUE Then
iResult = TRUE
End If
End If
GetBit256% = iResult
End Function ' GetBit256%
' /////////////////////////////////////////////////////////////////////////////
' Returns the text character at positon x%, y%
' Does the same as:
' Locate y%, x%
' GetCharXY% = Screen(CsrLin, Pos(0))
' See also: GetColorXY&
Function GetCharXY% (x%, y%)
GetCharXY% = Screen(y%, x%, 0) ' when 3rd parameter = 0 returns character code
End Function ' GetCharXY%
' /////////////////////////////////////////////////////////////////////////////
' Returns the text color at positon x%, y%
' See also: GetCharXY%
Function GetColorXY& (x%, y%)
GetColorXY& = Screen(y%, x%, 1) ' when 3rd parameter = 1 returns character color
End Function ' GetColorXY
' /////////////////////////////////////////////////////////////////////////////
' Simple timestamp function
' Format: {YYYY}-{MM}-{DD} {hh}:[mm}:{ss}
' Uses:
' TIME$
' The TIME$ Function returns a STRING representation
' of the current computer time in a 24 hour format.
' https://qb64phoenix.com/qb64wiki/index.php/TIME$
' DATE$
' The DATE$ function returns the current computer date
' as a string in the format "mm-dd-yyyy".
' https://qb64phoenix.com/qb64wiki/index.php/DATE$
'
' TODO: support template where
' {yyyy} = 4 digit year
' {mm} = 2 digit month
' {dd} = 2 digit day
' {hh} = 2 digit hour (12-hour)
' {rr} = 2 digit hour (24-hour)
' {nn} = 2 digit minute
' {ss} = 2 digit second
' {ampm} = AM/PM
' We got the nn for minute from Microsoft > Office VBA Reference > DateDiff function
' https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/datediff-function
Function GetCurrentDateTime$ (sTemplate$)
Dim sDate$: sDate$ = Date$
Dim sTime$: sTime$ = Time$
Dim sYYYY$: sYYYY$ = Mid$(sDate$, 7, 4)
Dim sMM$: sMM$ = Mid$(sDate$, 1, 2)
Dim sDD$: sDD$ = Mid$(sDate$, 4, 2)
Dim sHH24$: sHH24$ = Mid$(sTime$, 1, 2)
Dim sHH$: sHH$ = ""
Dim sMI$: sMI$ = Mid$(sTime$, 4, 2)
Dim sSS$: sSS$ = Mid$(sTime$, 7, 2)
Dim iHour%: iHour% = Val(sHH24$)
Dim sAMPM$: sAMPM$ = ""
Dim result$: result$ = ""
' FIGURE OUT AM/PM
If InStr(sTemplate$, "{ampm}") > 0 Then
If iHour% = 0 Then
sAMPM$ = "AM"
iHour% = 12
ElseIf iHour% > 0 And iHour% < 12 Then
sAMPM$ = "AM"
ElseIf iHour% = 12 Then
sAMPM$ = "PM"
Else
sAMPM$ = "PM"
iHour% = iHour% - 12
End If
sHH$ = Right$("00" + _Trim$(Str$(iHour%)), 2)
End If
' RETURN RESULT
GetCurrentDateTime$ = result$
End Function ' GetCurrentDateTime$
' /////////////////////////////////////////////////////////////////////////////
' From: Bitwise Manipulations By Steven Roman
' http://www.romanpress.com/Articles/Bitwise_R/Bitwise.htm
' Returns the integer that corresponds to a binary string of length 8
Function GetIntegerFromBinary% (sBinary1 As String)
Dim iResult As Integer
Dim iLoop As Integer
Dim strBinary As String
Dim sBinary As String: sBinary = sBinary1
iResult = 0
strBinary = Replace$(sBinary, " ", "") ' Remove any spaces
For iLoop = 0 To Len(strBinary) - 1
iResult = iResult + 2 ^ iLoop * Val(Mid$(strBinary, Len(strBinary) - iLoop, 1))
Next iLoop
GetIntegerFromBinary% = iResult
End Function ' GetIntegerFromBinary%
' /////////////////////////////////////////////////////////////////////////////
' Receives a {sDelimeter} delimited list of numbers {MyString}
' and splits it up into an integer array arrInteger()
' beginning at index {iMinIndex}.
Sub GetIntegerArrayFromDelimList (MyString As String, sDelimiter As String, iMinIndex As Integer, arrInteger() As Integer)
ReDim arrString(-1) As String
Dim CleanString As String
Dim iLoop As Integer
Dim iCount As Integer: iCount = iMinIndex - 1
If Len(sDelimiter) > 0 Then
CleanString = MyString
If sDelimiter <> " " Then
CleanString = Replace$(CleanString, " ", "")
End If
split CleanString, sDelimiter, arrString()
iCount = iMinIndex - 1
For iLoop = LBound(arrString) To UBound(arrString)
If IsNum%(arrString(iLoop)) = TRUE Then
iCount = iCount + 1
ReDim _Preserve arrInteger(iMinIndex To iCount) As Integer
arrInteger(iCount) = Val(arrString(iLoop))
'DebugPrint "5633 arrInteger(" + cstr$(iCount) + ") = VAL(arrString(" + cstr$(iLoop) + ")) = " + cstr$(arrInteger(iCount))
End If
Next iLoop
Else
If IsNum%(MyString) = TRUE Then
ReDim _Preserve arrInteger(iMinIndex To iMinIndex) As Integer
arrInteger(iMinIndex) = Val(MyString)
End If
End If
'CleanString=""
'for iLoop=lbound(arrInteger) to ubound(arrInteger)
'CleanString = CleanString + iifstr$(iLoop=lbound(arrInteger), "", ",") + cstr$(arrInteger(iLoop))
'next iLoop
'DebugPrint "arrInteger=(" + CleanString + ")"
End Sub ' GetIntegerArrayFromDelimList
' /////////////////////////////////////////////////////////////////////////////
' IIF function for QB for integers
Function IIF (Condition, IfTrue, IfFalse)
If Condition Then IIF = IfTrue Else IIF = IfFalse
End Function
' /////////////////////////////////////////////////////////////////////////////
' IIF function for QB for strings
Function IIFSTR$ (Condition, IfTrue$, IfFalse$)
If Condition Then IIFSTR$ = IfTrue$ Else IIFSTR$ = IfFalse$
End Function
Function IntPadLeft$ (iValue As Integer, iWidth As Integer)
IntPadLeft$ = Right$(String$(iWidth, " ") + _Trim$(Str$(iValue)), iWidth)
End Function ' IntPadLeft$
Function IntPadRight$ (iValue As Integer, iWidth As Integer)
IntPadRight$ = Left$(_Trim$(Str$(iValue)) + String$(iWidth, " "), iWidth)
End Function ' IntPadRight$
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if number n is even
' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
Function IsEven% (n)
If n Mod 2 = 0 Then
IsEven% = TRUE
Else
IsEven% = FALSE
End If
End Function ' IsEven%
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if number n is odd
' 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%
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if value text$ is numeric.
Function IsNum% (text$)
IsNum% = IsNumber%(text$)
End Function ' IsNum%
'' NOTE: THIS FAILS FOR NUMBERS LIKE "002" AND "2.000":
'Function IsNum% (text$)
' Dim a$
' Dim b$
' a$ = _Trim$(text$)
' b$ = _Trim$(Str$(Val(text$)))
' If a$ = b$ Then
' IsNum% = TRUE
' Else
' IsNum% = FALSE
' End If
'End Function ' IsNum%
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if value OriginalString$ is numeric.
' Re: Does a Is Number function exist in QB64?
' https://www.qb64.org/forum/index.php?topic=896.15
' Version 2 by madscijr
' Returns TRUE (-1) if string is an integer, FALSE (0) if not
' Version 1 by MWheatley
' Reply #18 on: January 01, 2019, 11:24:30 AM
' returns 1 if string is an integer, 0 if not
Function IsNumber% (OriginalString$)
Dim bResult%: bResult% = FALSE
Dim iLoop%
Dim TestString$
'Dim bNegative%
Dim iDecimalCount%
Dim sNextChar$
'THEY SHOULD TRIM OUTSIDE THE FUNCTION!
'TestString$ = _TRIM$(OriginalString$)
If Len(OriginalString$) > 0 Then
TestString$ = ""
If Left$(OriginalString$, 1) = "+" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
'bNegative% = FALSE
ElseIf Left$(OriginalString$, 1) = "-" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
'bNegative% = TRUE
Else
TestString$ = OriginalString$
'bNegative% = FALSE
End If
If Len(TestString$) > 0 Then
bResult% = TRUE
iDecimalCount% = 0
For iLoop% = 1 To Len(TestString$)
sNextChar$ = Mid$(TestString$, iLoop%, 1)
If sNextChar$ = "." Then
iDecimalCount% = iDecimalCount% + 1
If iDecimalCount% > 1 Then
' TOO MANY DECIMAL POINTS, INVALID!
bResult% = FALSE
Exit For
End If
ElseIf Asc(sNextChar$) < 48 Or Asc(sNextChar$) > 57 Then
' NOT A NUMERAL OR A DECIMAL, INVALID!
bResult% = FALSE
Exit For
End If
Next iLoop%
End If
End If
IsNumber% = bResult%
End Function ' IsNumber%
' /////////////////////////////////////////////////////////////////////////////
' 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&
' /////////////////////////////////////////////////////////////////////////////
' remove scientific Notation to String (~40 LOC)
' SMcNeill Jan 7, 2020
' https://www.qb64.org/forum/index.php?topic=1555.msg112989#msg112989
' Last Function in code marked Best Answer (removed debug comments and
' blank lines added these 2 lines.)
Function N2S$ (EXP$)
ReDim t$, sign$, l$, r$, r&&
ReDim dp As Long, dm As Long, ep As Long, em As Long, check1 As Long, l As Long, i As Long
t$ = LTrim$(RTrim$(EXP$))
If Left$(t$, 1) = "-" Or Left$(t$, 1) = "N" Then sign$ = "-": t$ = Mid$(t$, 2)
dp = InStr(t$, "D+"): dm = InStr(t$, "D-")
ep = InStr(t$, "E+"): em = InStr(t$, "E-")
check1 = Sgn(dp) + Sgn(dm) + Sgn(ep) + Sgn(em)
If check1 < 1 Or check1 > 1 Then N2S = _Trim$(EXP$): Exit Function ' If no scientic notation is found, or if we find more than 1 type, it's not SN!
Select Case l ' l now tells us where the SN starts at.
Case Is < dp: l = dp
Case Is < dm: l = dm
Case Is < ep: l = ep
Case Is < em: l = em
End Select
l$ = Left$(t$, l - 1) ' The left of the SN
r$ = Mid$(t$, l + 1): r&& = Val(r$) ' The right of the SN, turned into a workable long
If InStr(l$, ".") Then ' Location of the decimal, if any
If r&& > 0 Then
r&& = r&& - Len(l$) + 2
Else
r&& = r&& + 1
End If
l$ = Left$(l$, 1) + Mid$(l$, 3)
End If
Select Case r&&
Case 0 ' what the heck? We solved it already?
' l$ = l$
Case Is < 0
For i = 1 To -r&&
l$ = "0" + l$
Next
l$ = "." + l$
Case Else
For i = 1 To r&&
l$ = l$ + "0"
Next
l$ = l$
End Select
N2S$ = sign$ + l$
End Function ' N2S$
Sub PauseDecisecond (iDS As Integer)
Dim iCount As Integer
iCount = 0
Do
iCount = iCount + 1
_Limit 10 ' run 10x every second
Loop Until iCount = iDS
End Sub ' PauseDecisecond
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if point (x1%, y1%) is adjacent to point (x2%, y2%)
Function PointsAreAdjacent% (x1%, y1%, x2%, y2%)
Dim bResult%: bResult% = FALSE
' x or y can be the same, but not both
If (x1% <> x2%) Or (y1% <> y2%) Then
If (x1% = x2%) Or ((x1% = (x2% + 1)) Or (x2% = (x1% + 1))) Then
If (y1% = y2%) Or ((y1% = (y2% + 1)) Or (y2% = (y1% + 1))) Then
bResult% = TRUE
End If
End If
End If
PointsAreAdjacent% = bResult%
End Function ' PointsAreAdjacent%
' /////////////////////////////////////////////////////////////////////////////
' Writes sText to file sFileName.
' If bAppend=TRUE appends to file, else overwrites it.
' Returns blank if successful else returns error message.
Function PrintFile$ (sFileName As String, sText As String, bAppend As Integer)
Dim sError As String: sError = ""
If Len(sError) = 0 Then
If (bAppend = TRUE) Then
If _FileExists(sFileName) Then
Open sFileName For Append As #1 ' opens an existing file for appending
Else
sError = "Error in PrintFile$ : File not found. Cannot append."
End If
Else
Open sFileName For Output As #1 ' opens and clears an existing file or creates new empty file
End If
End If
If Len(sError) = 0 Then
' NOTE: WRITE places text in quotes in the file
'WRITE #1, x, y, z$
'WRITE #1, sText
' PRINT does not put text inside quotes
Print #1, sText
Close #1
End If
PrintFile$ = sError
End Function ' PrintFile$
' /////////////////////////////////////////////////////////////////////////////
' Does a _PrintString at the specified row+column.
' iRow and iCol are 0-based.
' See also: PrintString1
Sub PrintString (iRow As Integer, iCol As Integer, MyString As String)
Dim iX As Integer
Dim iY As Integer
iX = _FontWidth * iCol
iY = _FontHeight * iRow ' (iRow + 1)
_PrintString (iX, iY), MyString
End Sub ' PrintString
' /////////////////////////////////////////////////////////////////////////////
' Does a _PrintString at the specified row+column.
' iRow and iCol are 1-based.
' See also: PrintString
Sub PrintString1 (iRow As Integer, iCol As Integer, MyString As String)
Dim iX As Integer
Dim iY As Integer
iX = _FontWidth * (iCol - 1)
iY = _FontHeight * (iRow - 1)
_PrintString (iX, iY), MyString
End Sub ' PrintString1
' /////////////////////////////////////////////////////////////////////////////
' Prints text character char$ at positoin x%,y% in color myColor&.
Sub PutCharXY (x%, y%, char$, myColor&)
Color myColor&
Locate y%, x%
Print char$;
End Sub ' PutCharXY
' /////////////////////////////////////////////////////////////////////////////
' Generate random value between Min and Max inclusive.
Function RandomNumber% (Min%, Max%)
Dim NumSpread%
' SET RANDOM SEED
'Randomize ' Initialize random-number generator.
Randomize Timer
' GET RANDOM # Min%-Max%
'RandomNumber = Int((Max * Rnd) + Min) ' generate number
NumSpread% = (Max% - Min%) + 1
RandomNumber% = Int(Rnd * NumSpread%) + Min% ' GET RANDOM # BETWEEN Max% AND Min%
End Function ' RandomNumber%
'' /////////////////////////////////////////////////////////////////////////////
'
'Sub RandomNumberTest
' Dim iCols As Integer: iCols = 10
' Dim iRows As Integer: iRows = 20
' Dim iLoop As Integer
' Dim iX As Integer
' Dim iY As Integer
' Dim sError As String
' Dim sFileName As String
' Dim sText As String
' Dim bAppend As Integer
' Dim iMin As Integer
' Dim iMax As Integer
' Dim iNum As Integer
' Dim iErrorCount As Integer
' Dim sInput$
'
' sFileName = "c:\temp\maze_test_1.txt"
' sText = "Count" + Chr$(9) + "Min" + Chr$(9) + "Max" + Chr$(9) + "Random"
' bAppend = FALSE
' sError = PrintFile$(sFileName, sText, bAppend)
' If Len(sError) = 0 Then
' bAppend = TRUE
' iErrorCount = 0
'
' iMin = 0
' iMax = iCols - 1
' For iLoop = 1 To 100
' iNum = RandomNumber%(iMin, iMax)
' sText = Str$(iLoop) + Chr$(9) + Str$(iMin) + Chr$(9) + Str$(iMax) + Chr$(9) + Str$(iNum)
' sError = PrintFile$(sFileName, sText, bAppend)
' If Len(sError) > 0 Then
' iErrorCount = iErrorCount + 1
' Print Str$(iLoop) + ". ERROR"
' Print " " + "iMin=" + Str$(iMin)
' Print " " + "iMax=" + Str$(iMax)
' Print " " + "iNum=" + Str$(iNum)
' Print " " + "Could not write to file " + Chr$(34) + sFileName + Chr$(34) + "."
' Print " " + sError
' End If
' Next iLoop
'
' iMin = 0
' iMax = iRows - 1
' For iLoop = 1 To 100
' iNum = RandomNumber%(iMin, iMax)
' sText = Str$(iLoop) + Chr$(9) + Str$(iMin) + Chr$(9) + Str$(iMax) + Chr$(9) + Str$(iNum)
' sError = PrintFile$(sFileName, sText, bAppend)
' If Len(sError) > 0 Then
' iErrorCount = iErrorCount + 1
' Print Str$(iLoop) + ". ERROR"
' Print " " + "iMin=" + Str$(iMin)
' Print " " + "iMax=" + Str$(iMax)
' Print " " + "iNum=" + Str$(iNum)
' Print " " + "Could not write to file " + Chr$(34) + sFileName + Chr$(34) + "."
' Print " " + sError
' End If
' Next iLoop
'
' Print "Finished generating numbers. Errors: " + Str$(iErrorCount)
' Else
' Print "Error creating file " + Chr$(34) + sFileName + Chr$(34) + "."
' Print sError
' End If
'
' Input "Press <ENTER> to continue", sInput$
'End Sub ' RandomNumberTest
' /////////////////////////////////////////////////////////////////////////////
' FROM: String Manipulation
' found at abandoned, outdated and now likely malicious qb64 dot net website
' http://www.qb64.[net]/forum/index_topic_5964-0/
'
'SUMMARY:
' Purpose: A library of custom functions that transform strings.
' Author: Dustinian Camburides (dustinian@gmail.com)
' Platform: QB64 (www.qb64.org)
' Revision: 1.6
' Updated: 5/28/2012
'SUMMARY:
'[Replace$] replaces all instances of the [Find] sub-string with the [Add] sub-string within the [Text] string.
'INPUT:
'Text: The input string; the text that's being manipulated.
'Find: The specified sub-string; the string sought within the [Text] string.
'Add: The sub-string that's being added to the [Text] string.
Function Replace$ (Text1 As String, Find1 As String, Add1 As String)
' VARIABLES:
Dim Text2 As String
Dim Find2 As String
Dim Add2 As String
Dim lngLocation As Long ' The address of the [Find] substring within the [Text] string.
Dim strBefore As String ' The characters before the string to be replaced.
Dim strAfter As String ' The characters after the string to be replaced.
' INITIALIZE:
' MAKE COPIESSO THE ORIGINAL IS NOT MODIFIED (LIKE ByVal IN VBA)
Text2 = Text1
Find2 = Find1
Add2 = Add1
lngLocation = InStr(1, Text2, Find2)
' PROCESSING:
' While [Find2] appears in [Text2]...
While lngLocation
' Extract all Text2 before the [Find2] substring:
strBefore = Left$(Text2, lngLocation - 1)
' Extract all text after the [Find2] substring:
strAfter = Right$(Text2, ((Len(Text2) - (lngLocation + Len(Find2) - 1))))
' /////////////////////////////////////////////////////////////////////////////
' https://staging.qb64phoenix.com/showthread.php?tid=644
' From: bplus
' Date: 07-18-2022, 03:16 PM
' Here is a Round$ that acts the way you'd expect in under 100 LOC
' b = b + ...
Function Round$ (anyNumber, dp As Long)
' 5 and up at decimal place dp+1 > +1 at decimal place 4 and down > +0 at dp
' 2 1 0.-1 -2 -3 -4 ... pick dp like this for this Round$ Function
sn$ = N2S$(Str$(anyNumber + .5 * 10 ^ dp)) ' get rid of sci notation, steve trims it so next find dot
dot = InStr(sn$, ".")
If dot Then
predot = dot - 1
postdot = Len(sn$) - (dot + 1)
Else
predot = Len(sn$)
postdot = 0
End If
' xxx.yyyyyy dp = -2
' ^ dp
If dp >= 0 Then
Rtn$ = Mid$(sn$, 1, predot - dp) + String$(dp, "0")
Else
Rtn$ = Mid$(sn$, 1, predot) + "." + Mid$(sn$, dot + 1, -dp)
End If
If Rtn$ = "" Then
Round$ = "0"
Else
Round$ = Rtn$
End If
End Function ' Round$
' /////////////////////////////////////////////////////////////////////////////
' TODO: verify these work (function Round$ works)
' 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 RoundNatural## (num##, digits%)
RoundNatural## = 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%
' /////////////////////////////////////////////////////////////////////////////
' TODO: verify this works
' 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
' /////////////////////////////////////////////////////////////////////////////
' Converts a chr$(13) delimited string
' into a 2-dimensional array.
' Usage:
' Dim StringArray(1 To 48, 1 To 128) As String
' StringTo2dArray StringArray(), GetMap$
' Version 2 with indexed array(row, columm)
' Renamed StringToArray to StringTo2dArray.
' See also: Array2dToString$
Sub StringTo2dArray (MyArray() As String, MyString As String)
Dim sDelim As String
ReDim arrLines(0) As String
Dim iRow As Integer
Dim iCol As Integer
Dim sChar As String
Dim iDim1 As Integer
Dim iDim2 As Integer
Dim iIndex1 As Integer
Dim iIndex2 As Integer
iDim1 = LBound(MyArray, 1)
iDim2 = LBound(MyArray, 2)
sDelim = Chr$(13)
split MyString, sDelim, arrLines()
For iRow = LBound(arrLines) To UBound(arrLines)
If iRow <= UBound(MyArray, 1) Then
For iCol = 1 To Len(arrLines(iRow))
If iCol <= UBound(MyArray, 2) Then
sChar = Mid$(arrLines(iRow), iCol, 1)
If Len(sChar) > 1 Then
sChar = Left$(sChar, 1)
Else
If Len(sChar) = 0 Then
sChar = "."
End If
End If
iIndex1 = iRow + iDim1
iIndex2 = (iCol - 1) + iDim2
MyArray(iIndex1, iIndex2) = sChar
'DebugPrint "MyArray(" + cstr$(iIndex1) + ", " + cstr$(iIndex2) + " = " + chr$(34) + sChar + chr$(34)
Else
' Exit if out of bounds
Exit For
End If
Next iCol
Else
' Exit if out of bounds
Exit For
End If
Next iRow
End Sub ' StringTo2dArray
Function StrJustifyRight$ (sValue As String, iWidth As Integer)
StrJustifyRight$ = Right$(String$(iWidth, " ") + sValue, iWidth)
End Function ' StrJustifyRight$
Function StrJustifyLeft$ (sValue As String, iWidth As Integer)
StrJustifyLeft$ = Left$(sValue + String$(iWidth, " "), iWidth)
End Function ' StrJustifyLeft$
Function StrJustifyCenter$ (sValue As String, iWidth As Integer)
Dim iLen0 As Integer
Dim iLen1 As Integer
Dim iLen2 As Integer
Dim iExtra As Integer
iLen0 = Len(sValue)
If iWidth = iLen0 Then
' no extra space: return unchanged
StrJustifyCenter$ = sValue
ElseIf iWidth > iLen0 Then
If IsOdd%(iWidth) Then
iWidth = iWidth - 1
End If
' center
iExtra = iWidth - iLen0
iLen1 = iExtra \ 2
iLen2 = iLen1 + (iExtra Mod 2)
StrJustifyCenter$ = String$(iLen1, " ") + sValue + String$(iLen2, " ")
Else
' string is too long: truncate
StrJustifyCenter$ = Left$(sValue, iWidth)
End If
End Function ' StrJustifyCenter$
' /////////////////////////////////////////////////////////////////////////////
' Use to pretty print TRUE and FALSE values.
Function TrueFalse$ (myValue)
If myValue = TRUE Then
TrueFalse$ = "TRUE"
Else
TrueFalse$ = "FALSE"
End If
End Function ' TrueFalse$
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GENERAL PURPOSE ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN KEYBOARD CODE FUNCTIONS
' NOTE: ALL CODES ARE FOR _BUTTON, EXCEPT:
' cF10 (_KEYDOWN)
' cAltLeft (_KEYHIT)
' cAltRight (_KEYHIT)
' cPrintScreen (_KEYHIT) <- may slow down pc?
' cPauseBreak (_KEYHIT) <- may not work?
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Function KeyCode_Escape% ()
KeyCode_Escape% = 2
End Function
Function KeyCode_F1% ()
KeyCode_F1% = 60
End Function
Function KeyCode_F2% ()
KeyCode_F2% = 61
End Function
Function KeyCode_F3% ()
KeyCode_F3% = 62
End Function
Function KeyCode_F4% ()
KeyCode_F4% = 63
End Function
Function KeyCode_F5% ()
KeyCode_F5% = 64
End Function
Function KeyCode_F6% ()
KeyCode_F6% = 65
End Function
Function KeyCode_F7% ()
KeyCode_F7% = 66
End Function
Function KeyCode_F8% ()
KeyCode_F8% = 67
End Function
Function KeyCode_F9% ()
KeyCode_F9% = 68
End Function
'_KEYDOWN CODE, NOT _BUTTON CODE
Function KeyCode_F10% ()
KeyCode_F10% = 17408
End Function
Function KeyCode_F11% ()
KeyCode_F11% = 88
End Function
Function KeyCode_F12% ()
KeyCode_F12% = 89
End Function
'_KEYHIT CODE, NOT _BUTTON CODE
Function KeyCode_PrintScreen% ()
KeyCode_PrintScreen% = -44
End Function
Function KeyCode_ScrollLock% ()
KeyCode_ScrollLock% = 71
End Function
'_KEYHIT CODE, NOT _BUTTON CODE
Function KeyCode_PauseBreak% ()
KeyCode_PauseBreak% = 31053
End Function
Function KeyCode_Tilde% ()
KeyCode_Tilde% = 42
End Function
Function KeyCode_1% ()
KeyCode_1% = 3
End Function
Function KeyCode_2% ()
KeyCode_2% = 4
End Function
Function KeyCode_3% ()
KeyCode_3% = 5
End Function
Function KeyCode_4% ()
KeyCode_4% = 6
End Function
Function KeyCode_5% ()
KeyCode_5% = 7
End Function
Function KeyCode_6% ()
KeyCode_6% = 8
End Function
Function KeyCode_7% ()
KeyCode_7% = 9
End Function
Function KeyCode_8% ()
KeyCode_8% = 10
End Function
Function KeyCode_9% ()
KeyCode_9% = 11
End Function
Function KeyCode_0% ()
KeyCode_0% = 12
End Function
Function KeyCode_Minus% ()
KeyCode_Minus% = 13
End Function
Function KeyCode_Equal% ()
KeyCode_Equal% = 14
End Function
Function KeyCode_BkSp% ()
KeyCode_BkSp% = 15
End Function
Function KeyCode_Ins% ()
KeyCode_Ins% = 339
End Function
Function KeyCode_Home% ()
KeyCode_Home% = 328
End Function
Function KeyCode_PgUp% ()
KeyCode_PgUp% = 330
End Function
Function KeyCode_Del% ()
KeyCode_Del% = 340
End Function
Function KeyCode_End% ()
KeyCode_End% = 336
End Function
Function KeyCode_PgDn% ()
KeyCode_PgDn% = 338
End Function
Function KeyCode_NumLock% ()
KeyCode_NumLock% = 326
End Function
Function KeyCode_KeypadSlash% ()
KeyCode_KeypadSlash% = 310
End Function
Function KeyCode_KeypadMultiply% ()
KeyCode_KeypadMultiply% = 56
End Function
Function KeyCode_KeypadMinus% ()
KeyCode_KeypadMinus% = 75
End Function
Function KeyCode_Keypad7Home% ()
KeyCode_Keypad7Home% = 72
End Function
Function KeyCode_Keypad8Up% ()
KeyCode_Keypad8Up% = 73
End Function
Function KeyCode_Keypad9PgUp% ()
KeyCode_Keypad9PgUp% = 74
End Function
Function KeyCode_KeypadPlus% ()
KeyCode_KeypadPlus% = 79
End Function
Function KeyCode_Keypad4Left% ()
KeyCode_Keypad4Left% = 76
End Function
Function KeyCode_Keypad5% ()
KeyCode_Keypad5% = 77
End Function
Function KeyCode_Keypad6Right% ()
KeyCode_Keypad6Right% = 78
End Function
Function KeyCode_Keypad1End% ()
KeyCode_Keypad1End% = 80
End Function
Function KeyCode_Keypad2Down% ()
KeyCode_Keypad2Down% = 81
End Function
Function KeyCode_Keypad3PgDn% ()
KeyCode_Keypad3PgDn% = 82
End Function
Function KeyCode_KeypadEnter% ()
KeyCode_KeypadEnter% = 285
End Function
Function KeyCode_Keypad0Ins% ()
KeyCode_Keypad0Ins% = 83
End Function
Function KeyCode_KeypadPeriodDel% ()
KeyCode_KeypadPeriodDel% = 84
End Function
Function KeyCode_Tab% ()
KeyCode_Tab% = 16
End Function
Function KeyCode_Q% ()
KeyCode_Q% = 17
End Function
Function KeyCode_W% ()
KeyCode_W% = 18
End Function
Function KeyCode_E% ()
KeyCode_E% = 19
End Function
Function KeyCode_R% ()
KeyCode_R% = 20
End Function
Function KeyCode_T% ()
KeyCode_T% = 21
End Function
Function KeyCode_Y% ()
KeyCode_Y% = 22
End Function
Function KeyCode_U% ()
KeyCode_U% = 23
End Function
Function KeyCode_I% ()
KeyCode_I% = 24
End Function
Function KeyCode_O% ()
KeyCode_O% = 25
End Function
Function KeyCode_P% ()
KeyCode_P% = 26
End Function
Function KeyCode_BracketLeft% ()
KeyCode_BracketLeft% = 27
End Function
Function KeyCode_BracketRight% ()
KeyCode_BracketRight% = 28
End Function
Function KeyCode_Backslash% ()
KeyCode_Backslash% = 44
End Function
Function KeyCode_CapsLock% ()
KeyCode_CapsLock% = 59
End Function
Function KeyCode_A% ()
KeyCode_A% = 31
End Function
Function KeyCode_S% ()
KeyCode_S% = 32
End Function
Function KeyCode_D% ()
KeyCode_D% = 33
End Function
Function KeyCode_F% ()
KeyCode_F% = 34
End Function
Function KeyCode_G% ()
KeyCode_G% = 35
End Function
Function KeyCode_H% ()
KeyCode_H% = 36
End Function
Function KeyCode_J% ()
KeyCode_J% = 37
End Function
Function KeyCode_K% ()
KeyCode_K% = 38
End Function
Function KeyCode_L% ()
KeyCode_L% = 39
End Function
Function KeyCode_Semicolon% ()
KeyCode_Semicolon% = 40
End Function
Function KeyCode_Apostrophe% ()
KeyCode_Apostrophe% = 41
End Function
Function KeyCode_Enter% ()
KeyCode_Enter% = 29
End Function
Function KeyCode_ShiftLeft% ()
KeyCode_ShiftLeft% = 43
End Function
Function KeyCode_Z% ()
KeyCode_Z% = 45
End Function
Function KeyCode_X% ()
KeyCode_X% = 46
End Function
Function KeyCode_C% ()
KeyCode_C% = 47
End Function
Function KeyCode_V% ()
KeyCode_V% = 48
End Function
Function KeyCode_B% ()
KeyCode_B% = 49
End Function
Function KeyCode_N% ()
KeyCode_N% = 50
End Function
Function KeyCode_M% ()
KeyCode_M% = 51
End Function
Function KeyCode_Comma% ()
KeyCode_Comma% = 52
End Function
Function KeyCode_Period% ()
KeyCode_Period% = 53
End Function
Function KeyCode_Slash% ()
KeyCode_Slash% = 54
End Function
Function KeyCode_ShiftRight% ()
KeyCode_ShiftRight% = 55
End Function
Function KeyCode_Up% ()
KeyCode_Up% = 329
End Function
Function KeyCode_Left% ()
KeyCode_Left% = 332
End Function
Function KeyCode_Down% ()
KeyCode_Down% = 337
End Function
Function KeyCode_Right% ()
KeyCode_Right% = 334
End Function
Function KeyCode_CtrlLeft% ()
KeyCode_CtrlLeft% = 30
End Function
Function KeyCode_WinLeft% ()
KeyCode_WinLeft% = 348
End Function
' _KEYHIT CODE NOT _BUTTON CODE
Function KeyCode_AltLeft% ()
KeyCode_AltLeft% = -30764
End Function
Function KeyCode_Spacebar% ()
KeyCode_Spacebar% = 58
End Function
' _KEYHIT CODE NOT _BUTTON CODE
Function KeyCode_AltRight% ()
KeyCode_AltRight% = -30765
End Function
Function KeyCode_WinRight% ()
KeyCode_WinRight% = 349
End Function
Function KeyCode_Menu% ()
KeyCode_Menu% = 350
End Function
Function KeyCode_CtrlRight% ()
KeyCode_CtrlRight% = 286
End Function
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END KEYBOARD CODE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN COLOR FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' NOTE: these are mostly negative numbers
' and have to be forced to positive
' when stored in the dictionary
' (only cEmpty should be negative)
Function cRed~& ()
cRed = _RGB32(255, 0, 0)
End Function
Function cOrangeRed~& ()
cOrangeRed = _RGB32(255, 69, 0)
End Function ' cOrangeRed~&
Function cDarkOrange~& ()
cDarkOrange = _RGB32(255, 140, 0)
End Function ' cDarkOrange~&
Function cOrange~& ()
cOrange = _RGB32(255, 165, 0)
End Function ' cOrange~&
Function cGold~& ()
cGold = _RGB32(255, 215, 0)
End Function ' cGold~&
Function cYellow~& ()
cYellow = _RGB32(255, 255, 0)
End Function ' cYellow~&
' LONG-HAIRED FRIENDS OF JESUS OR NOT,
' THIS IS NOT YELLOW ENOUGH (TOO CLOSE TO LIME)
' TO USE FOR OUR COMPLEX RAINBOW SEQUENCE:
Function cChartreuse~& ()
cChartreuse = _RGB32(127, 255, 0)
End Function ' cChartreuse~&
' WE SUBSTITUTE THIS CSS3 COLOR FOR INBETWEEN LIME AND YELLOW:
Function cOliveDrab1~& ()
cOliveDrab1 = _RGB32(192, 255, 62)
End Function ' cOliveDrab1~&
Function cLime~& ()
cLime = _RGB32(0, 255, 0)
End Function ' cLime~&
Function cMediumSpringGreen~& ()
cMediumSpringGreen = _RGB32(0, 250, 154)
End Function ' cMediumSpringGreen~&
Function cCyan~& ()
cCyan = _RGB32(0, 255, 255)
End Function ' cCyan~&
Function cDeepSkyBlue~& ()
cDeepSkyBlue = _RGB32(0, 191, 255)
End Function ' cDeepSkyBlue~&
Function cDodgerBlue~& ()
cDodgerBlue = _RGB32(30, 144, 255)
End Function ' cDodgerBlue~&
Function cSeaBlue~& ()
cSeaBlue = _RGB32(0, 64, 255)
End Function ' cSeaBlue~&
Function cBlue~& ()
cBlue = _RGB32(0, 0, 255)
End Function ' cBlue~&
Function cBluePurple~& ()
cBluePurple = _RGB32(64, 0, 255)
End Function ' cBluePurple~&
Function cDeepPurple~& ()
cDeepPurple = _RGB32(96, 0, 255)
End Function ' cDeepPurple~&
Function cPurple~& ()
cPurple = _RGB32(128, 0, 255)
End Function ' cPurple~&
Function cPurpleRed~& ()
cPurpleRed = _RGB32(128, 0, 192)
End Function ' cPurpleRed~&
Function cDarkRed~& ()
cDarkRed = _RGB32(160, 0, 64)
End Function ' cDarkRed~&
Function cBrickRed~& ()
cBrickRed = _RGB32(192, 0, 32)
End Function ' cBrickRed~&
Function cDarkGreen~& ()
cDarkGreen = _RGB32(0, 100, 0)
End Function ' cDarkGreen~&
Function cGreen~& ()
cGreen = _RGB32(0, 128, 0)
End Function ' cGreen~&
Function cOliveDrab~& ()
cOliveDrab = _RGB32(107, 142, 35)
End Function ' cOliveDrab~&
Function cLightPink~& ()
cLightPink = _RGB32(255, 182, 193)
End Function ' cLightPink~&
Function cHotPink~& ()
cHotPink = _RGB32(255, 105, 180)
End Function ' cHotPink~&
Function cDeepPink~& ()
cDeepPink = _RGB32(255, 20, 147)
End Function ' cDeepPink~&
Function cMagenta~& ()
cMagenta = _RGB32(255, 0, 255)
End Function ' cMagenta~&
Function cBlack~& ()
cBlack = _RGB32(0, 0, 0)
End Function ' cBlack~&
Function cDimGray~& ()
cDimGray = _RGB32(105, 105, 105)
End Function ' cDimGray~&
Function cGray~& ()
cGray = _RGB32(128, 128, 128)
End Function ' cGray~&
Function cDarkGray~& ()
cDarkGray = _RGB32(169, 169, 169)
End Function ' cDarkGray~&
Function cSilver~& ()
cSilver = _RGB32(192, 192, 192)
End Function ' cSilver~&
Function cLightGray~& ()
cLightGray = _RGB32(211, 211, 211)
End Function ' cLightGray~&
Function cGainsboro~& ()
cGainsboro = _RGB32(220, 220, 220)
End Function ' cGainsboro~&
Function cWhiteSmoke~& ()
cWhiteSmoke = _RGB32(245, 245, 245)
End Function ' cWhiteSmoke~&
Function cWhite~& ()
cWhite = _RGB32(255, 255, 255)
'cWhite = _RGB32(254, 254, 254)
End Function ' cWhite~&
Function cDarkBrown~& ()
cDarkBrown = _RGB32(128, 64, 0)
End Function ' cDarkBrown~&
Function cLightBrown~& ()
cLightBrown = _RGB32(196, 96, 0)
End Function ' cLightBrown~&
Function cKhaki~& ()
cKhaki = _RGB32(240, 230, 140)
End Function ' cKhaki~&
Function cEmpty~& ()
'cEmpty~& = -1
cEmpty = _RGB32(0, 0, 0, 0)
End Function ' cEmpty~&
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END COLOR FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
I have always had an issue remembering what trig function does what. I'm doing a graphic visualization aid so I can finally get my gourd wrapped around it all. I find it easier to absorb this sort of thing if I have a visual aid. It has some math issues to be ironed out, some rather clumsy code and I have more things I'm thinking of adding, but generally is doing what I wanted. I zipped the whole thing since it's relying on a library, but here's the base code.
EDIT: 7-29-2022 Upload changes
8-13-2022 added bolt circle calculator feature
Code: (Select All)
'Unit Circle.bas
_TITLE "Unit Circle Visualizer"
'MAIN MODULE
'Type declarations
TYPE V2
x AS INTEGER
y AS INTEGER
END TYPE
TYPE U2
x AS SINGLE
y AS SINGLE
END TYPE
TYPE object
x AS INTEGER
y AS INTEGER
r AS DOUBLE
END TYPE
'Global variables
DIM SHARED baselayer AS LONG
DIM SHARED ang(24) AS object
'DATA SECTION
DATA 0,0,"pi/12"
DATA 0,0,"pi/6",0,0,"pi/4"
DATA 0,0,"pi/3",0,0,"5(pi)/12"
DATA -16,0,"pi/2",0,0,"7(pi)/12"
DATA 0,0,"2(pi)/3",0,0,"3(pi)/4"
DATA 0,0,"5(pi)/6",0,0,"11(pi)/12"
DATA 0,8,"(180) pi",0,0,"13(pi)/12"
DATA 0,0,"7(pi)/6",0,0,"5(pi)/4"
DATA 0,0,"4(pi)/3",0,0,"17(pi)/12"
DATA 24,0,"3(pi)/2",0,0,"19(pi)/12"
DATA 0,0,"5(pi)/3",0,0,"7(pi)/4"
DATA 0,0,"11(pi)/6",0,0,"23(pi)/12"
DATA 0,8,"2(pi) (0)"
'SUBROUTINE SECTION
'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
SUB Bolt_Circ
WINDOW
Dialog_Box "Bolt Circle", 512, 512, 0, &HFF00FF00, &HFFFFFFFF, "c"
_PRINTMODE _KEEPBACKGROUND
LOCATE 4, _SHR(_WIDTH(0), 4) - 6
INPUT "# of holes: ", h%
LOCATE 5, _SHR(_WIDTH(0), 4) - 6
INPUT "radius: ", r!
_PRINTSTRING (_SHR(_WIDTH(0), 1) - 112, 140), "Hole coordinates relative to..."
DIM lb$(6)
lb$(1) = "Center": lb$(2) = "Quad 1": lb$(3) = "Quad 2"
lb$(4) = "Quad 3": lb$(5) = "Quad 4": lb$(6) = "From 1"
ref% = Chs_Key_Button%("c1234f", "h", 160, 6, 70, 32, 10, _SHR(_WIDTH(0), 1), lb$())
WINDOW (-512, 256)-(512, -256)
Clear_MB 1
IF ref% = -1 THEN EXIT SUB
_PUTIMAGE , baselayer
LINE (295, 205)-(500, 168 - (h% * 16) - 48), &HFF7F7FFF, BF
COLOR &HFF010101
_PRINTSTRING (PMAP(300, 0), PMAP(200, 1)), "Bolt Circle Coordinates"
_PRINTSTRING (PMAP(300, 0), PMAP(184, 1)), " X Y"
DIM bolt(h% - 1) AS object
DIM drill(h% - 1) AS U2
maxx! = 0: maxy! = 0
FOR x% = 0 TO UBOUND(bolt)
angle! = ((TwoPI) / h%) * x%
bolt(x%).r = angle!
bolt(x%).x = COS(angle!) * 200
bolt(x%).y = SIN(angle!) * 200
drill(x%).x = CINT(COS(angle!) * (r! * 1000)) / 1000
drill(x%).y = CINT(SIN(angle!) * (r! * 1000)) / 1000
IF x% > 0 THEN
maxx! = maxx! + (-(ABS(drill(x%).x) - maxx!) * (ABS(drill(x%).x) > maxx!))
END IF
maxy! = maxy! + (-(ABS(drill(x%).y) - maxy!) * (ABS(drill(x%).y) > maxy!))
NEXT x%
'find limits for ref%, modify maxx! & maxy! for quad or hole #1
SELECT CASE ref%
CASE IS = 1: maxx! = 0: maxy! = 0 ' no change
CASE IS = 2: maxx! = drill(0).x ' quad 1
CASE IS = 3: maxx! = -maxx! ' quad 2
CASE IS = 4: maxx! = -maxx!: maxy! = -maxy! ' quad 3
CASE IS = 5: maxx! = drill(0).x: maxy! = -maxy! ' quad 4
CASE IS = 6: maxx! = drill(0).x: maxy! = drill(0).y ' subtract hole 1 position
END SELECT
'reference crosshairs
LINE (-512, maxy! / r! * 200)-(1023, maxy! / r! * 200), &HFFFF0000, , 15 'horizontal
LINE (maxx! / r! * 200, 256)-(maxx! / r! * 200, -255), &HFFFF0000, , 15 'vertical
'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
SUB Main_Loop
DO ' DISPLAY REFRESH LOOP
DO ' INPUT LOOP
DIM AS V2 m, inpnt
DIM inang AS object
CLS
_PUTIMAGE , baselayer
k$ = INKEY$ ' get keypresses- set in% when valid
IF k$ <> "" THEN
IF k$ = CHR$(27) THEN SYSTEM ' exit program
END IF
ms% = MBS ' get mouse clicks
m.x = PMAP(_MOUSEX, 2)
m.y = PMAP(_MOUSEY, 3)
Tracer m
IF ms% AND 1 THEN ' if left click
Clear_MB 1
_AUTODISPLAY
FOR g% = 1 TO 24
IF _HYPOT(ang(g%).x - m.x, ang(g%).y - m.y) < 5 THEN
m.x = ang(g%).x: m.y = ang(g%).y
_PUTIMAGE , baselayer
Tracer m
Details ang(g%), 0
END IF
NEXT g%
IF ABS(_MOUSEX - 50) < 50 THEN
IF ABS(_MOUSEY - 136) < 16 THEN ' Enter angle code
LOCATE 9, 15
INPUT ": ", a!
_PUTIMAGE , baselayer
inang.r = _D2R(a!)
inpnt.x = 200 * COS(inang.r)
inpnt.y = 200 * SIN(inang.r)
Tracer inpnt
Details inang, -1
END IF
IF ABS(_MOUSEY - 184) < 16 THEN ' Enter SIN code
LOCATE 12, 15
INPUT ": ", s!
c! = SQR(1 - s! ^ 2) ' get COS
_PUTIMAGE , baselayer
LOCATE 12, 15
PRINT s!
LOCATE 15, 15
PRINT c!
inpnt.x = 200 * c!
inpnt.y = 200 * s!
Tracer inpnt
LOCATE 9, 15
PRINT _R2D(_ATAN2(inpnt.y, inpnt.x))
Press_Click
END IF
IF ABS(_MOUSEY - 232) < 16 THEN ' Enter COS code
LOCATE 15, 15
INPUT ": ", c!
s! = SQR(1 - c! ^ 2) ' get SIN
_PUTIMAGE , baselayer
LOCATE 15, 15
PRINT c!
LOCATE 12, 15
PRINT s!
inpnt.x = 200 * c!
inpnt.y = 200 * s!
Tracer inpnt
LOCATE 9, 15
PRINT _R2D(_ATAN2(inpnt.y, inpnt.x))
Press_Click
END IF
ELSEIF ABS(_MOUSEX - 999) < 50 THEN ' right side buttons
IF ABS(_MOUSEY - 136) < 16 THEN
Bolt_Circ
END IF
END IF
in% = -1
END IF
'IF ms% AND 2 THEN ' if right click
' Clear_MB 2
' 'right click code here
' in% = -1
'END IF
_DISPLAY
_LIMIT 30
LOOP UNTIL in% ' END: INPUT LOOP
'refresh main program displays
_DISPLAY
LOOP ' END: DISPLAY REFRESH LOOP
END SUB 'Main_Loop
'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
SUB Tracer (p AS V2)
DIM AS V2 ci, tn
LINE (0, 0)-(p.x, p.y), &H7F7F7F7F ' mouse leader line
ci = p: Vec_Norm ci, 200 ' circle intersection point
LINE (ci.x, 0)-(ci.x, ci.y), &HFFFF0000 ' red sine? line
IF ABS(ci.x) > 15 AND ABS(ci.y) > 15 THEN ' if room draw ortho box
LINE (ci.x - 10 * SGN(ci.x), 0)-(ci.x - 10 * SGN(ci.x), 10 * SGN(ci.y)), &HFFFF0000
LINE (ci.x - 10 * SGN(ci.x), 10 * SGN(ci.y))-(ci.x, 10 * SGN(ci.y)), &HFFFF0000
END IF
LINE (0, ci.y)-(ci.x, ci.y), &HFF0000FF, , 63 ' blue cosine? line
tn = ci: Vec_Orth tn: Vec_Norm tn, 550 ' compute tangent line
LINE (ci.x + tn.x, ci.y + tn.y)-(ci.x - tn.x, ci.y - tn.y), &HFFFF00FF 'purple tangent line
LINE (0, 0)-(ci.x, ci.y), &HFF00FF00 ' green radius line
COLOR &HFFFF0000
_PRINTSTRING (0, 32), "SIN= " + Fix_Float$((ci.y / _HYPOT(ci.x, ci.y)), 6)
COLOR &HFF0000FF
_PRINTSTRING (0, 48), "COS= " + Fix_Float$((ci.x / _HYPOT(ci.x, ci.y)), 6)
COLOR &HFFFF00FF
IF ci.x = 0 THEN
_PRINTSTRING (0, 64), "TAN= undefined"
ELSE
_PRINTSTRING (0, 64), "TAN= " + Fix_Float((ci.y / ci.x), 6)
END IF
COLOR &HFFFFFFFF
IF ci.y < 0 THEN
rad = TwoPI - ABS(_ATAN2(ci.y, ci.x))
ELSE
rad = _ATAN2(ci.y, ci.x)
END IF
_PRINTSTRING (0, 80), "Radians= " + Fix_Float$(rad, 10)
_PRINTSTRING (0, 96), "Degrees= " + Fix_Float$(_R2D(rad), 10)
END SUB 'Tracer
'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
SUB Vec_Norm (var AS V2, scalar AS INTEGER) 'normalize and scale a 2D vector
mag! = _HYPOT(var.x, var.y)
IF mag! = 0 THEN
var.x = 0: var.y = 0
ELSE
var.x = (var.x / mag!) * scalar
var.y = (var.y / mag!) * scalar
END IF
END SUB 'Vec_Norm
'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
SUB Vec_Orth (var AS V2) 'return 2D vector (var) as an orthogonal vector
x% = var.x: y% = var.y
var.x = -y%
var.y = x%
END SUB 'Vec_Orth
'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
FUNCTION Fix_Float$ (x##, dec AS INTEGER)
'fix_float is appropriately named as it needs fixing...
bs$ = STR$(x##) ' string of input number x##
ex = INSTR(bs$, "D") + INSTR(bs$, "E")
IF ex <> 0 THEN ' an exponential has been thrown
pwr = VAL(MID$(bs$, ex + 3))
'use pwr to loop pwr-1 0's after a "." then use left$(bs,1)
n$ = " ."
FOR z% = 1 TO pwr - 1
n$ = n$ + "0"
NEXT z%
Fix_Float$ = n$ + LEFT$(_TRIM$(bs$), 1)
ELSE ' a decimal number has been thrown
pnt = INSTR(bs$, ".")
IF pnt = 0 THEN
Fix_Float$ = bs$
ELSE
Fix_Float$ = LEFT$(bs$, pnt + dec)
END IF
END IF
My middleschool-aged child is currently writing a desktop suite in Scratch. So far it's got a notepad program, a pong game, a bitmap icon maker as a paint program. He figured out how to be able to save larger files by having the app talk to another app which writes the actual files because Scratch seemingly only lets you save 10 variables in a browser cache otherwise as stored data. He is going to be adding an email or messenger applet to it as well and liked my suggestion of a calculator. He wrote his first computer game using gamemaker ( but using the GML scripting) when he was 6, I had to explain how variables worked in algebra and grid coordinates worked... once.
The kid actually surprised me by explaining his workaround so he could write multiple and larger data files with Scratch. I just have to get him started with basic and C/C++ so he can start writing programs for me.
My wife and I will catch him staying up late or awake early watching videos on science, coding, and math.
Other parents ask what he's into and I say computers and they think I mean "computer games", which he certainly enjoys but when I explain what he actually does they are surprised.
At the same age I had played with my cousin's altair briefly and had only used a computer at the museum otherwise. It really is amazing how much children have access to today compared to when I was kid.
His birthday is coming up and I'm just a proud papa sharing this stuff.
I'm interested in creating a simple MIDI sequencer
and/or a 2 (or 3 or 4) track digital audio recorder
that lets you record while listening to the other track(s) play back.
Has anyone made (or seen) any simple QB64 programs that do either of these things?
(Simple being the operative word, here! )
Much appreciated...
Until recently, when someone posted a piece of code in the Forum, with a "Select All" button to allow users to copy/paste to try it out, it worked perfectly. But for 2 days now I have not been able to select the code, except by swiping. Has the function been de-activated?
'BIGNUM.BAS v0.n
'Sep-Dec 1996 by Marc Kummel aka Treebeard.
'Contact mkummel@rain.org, http://www.rain.org/~mkummel/
'
' ** site no longer available, use the link below
' https://web.archive.org/web/20200220020034/http://www.rain.org/~mkummel/tbvault.html
' Conditions:
'-------------
'This program and source code are yours to use and modify as you will, but
'they are offered as freeware with no warranty whatsoever. Give me credit,
'but do not distribute any changes under my name, or attribute such changes
'to me in any way. You're on your own!
'useful shared stuff, initialize these in bInit()
Dim Shared errormsg$, abortmsg$, Error$, bmem$(maxmem), out$
Dim Shared zmem$(maxstack), cname$(maxconst)
Dim Shared bncpath$, prmcntfile$
Dim Shared digits%, zstack%
'Prime count table data
Dim maxprmcnt%
Dim prmcnt&
'======================================
Dim n As String
Dim m As String
Dim c As String
digits% = 35
bInit
n = "7." + String$(digits% - 1, "7")
m = "9." + String$(digits% - 1, "9")
c = ""
bAdd (n), (m), c
Print "n + m = "; c
bSub (n), (m), c
Print "n - m = "; c
bMul (n), (m), c
Print "n * m = "; c
bDiv (n), (m), c
Print "n / m = "; c
bSqr "2", c
Print "Sqr(2) = "; c
bLn "2", c
Print "Ln(2) = "; c
bLog "2", "10", c
Print "Log10(2) = "; c
bSin "1", c
Print "Sin(1) = "; c
bCos "1", c
Print "Cos(1) = "; c
bTan "1", c
Print "Tan(1) = "; c
'======================================
' BNCxx.BAS
' BNC math module
' 1997 by Marc Kummel aka Treebeard.
' Contact mkummel@rain.org, http://www.rain.org/~mkummel/
's = |s|
'
Sub bAbs (s$)
If Left$(s$, 1) = neg$ Then s$ = Mid$(s$, 2)
End Sub
'out = s1 + s2
'
Sub bAdd (s1$, s2$, out$)
Dim last1%, dp1%, sign1%, last2%, dp2%, sign2%
Dim last%, d1%, d2%, dpt%, carry%
Dim i%, n%
'treat different signs as subtraction and exit
If sign1% = negative And sign2% = positive Then
bSub s2$, s1$, out$
bNeg s1$
Exit Sub
ElseIf sign1% = positive And sign2% = negative Then
bSub s1$, s2$, out$
bNeg s2$
Exit Sub
End If
'do the addition right to left
For i% = last% To 1 Step -1
If i% <> dpt% Then
n% = carry%
If d1% > 0 Then n% = n% + Val(Mid$(s1$, d1%, 1))
If d2% > 0 Then n% = n% + Val(Mid$(s2$, d2%, 1))
carry% = n% \ 10
Mid$(out$, i%, 1) = Chr$(asc0 + (n% Mod 10))
Else
Mid$(out$, i%, 1) = dp$
End If
d1% = d1% - 1
d2% = d2% - 1
Next i%
If carry% Then out$ = one$ + out$
'clean up
If sign1% = negative Then s1$ = neg$ + s1$: s2$ = neg$ + s2$: out$ = neg$ + out$
bClean s1$
bClean s2$
bClean out$
End Sub
'out = arccos(s)
'
Sub bArcCos (s$, out$)
Dim t$, t2$
'out = arctanh(s)
'
Sub bArcTanh (s$, out$)
'atanh(x) = Log((1 + x) / (1 - x)) / 2
out$ = zero$
End Sub
'Convert s$ FROM base base1% TO base base2%, including decimals to digits% places.
's$ is modified in place. No errors for illegal digits, eg 161 base 2 is
'treated as (1*2^2)+(6*2^1)+(1*2^0) even though the "6" is wrong. Bases
'to 16 are formed with 1..F, but larger bases are formed with digit groups
'separated by commas, eg 6,6,@100=(6*100^1+6*100^0)=606. Bases ok to 32K!
'Appends "@n" to end of string if base2%<>10, which GetArg() will recognize.
'Slow because of divisions, but the decimals are fun.
'
Sub bBase (s$, base1%, base2%)
Dim b1$, b2$, whole$, dec$, n$, r$, t$, tn$, dig$, z$
Dim negflag%, digmask%, groupflag%, dpt%
Dim i%, j%, last%, nn%
If base1% < 2 Or base2% < 2 Then s$ = Error$: Exit Sub
If base1% = base2% Then Exit Sub
If Left$(s$, 1) = neg$ Then s$ = Mid$(s$, 2): negflag% = True
b1$ = LTrim$(Str$(base1%))
b2$ = LTrim$(Str$(base2%))
digmask% = Len(LTrim$(Str$(base2% - 1)))
'convert FROM base base1%
dpt% = InStr(s$, dp$)
If dpt% = 0 Then dpt% = Len(s$) + 1
'if base 10, then we're done
If base1% = 10 Then
whole$ = Left$(s$, dpt% - 1)
dec$ = Mid$(s$, dpt%)
'figure decimal part
n$ = Mid$(s$, dpt% + 1)
If Len(n$) Then
GoSub bbConvertString
bPowerInt b1$, LTrim$(Str$(last%)), t$
bDiv n$, t$, dec$
End If
End If
'convert TO base base2%
'if base 10, then we're done
If base2% = 10 Then
bAdd whole$, dec$, s$
Else
s$ = ""
'figure whole part
Do
z$ = whole$
bDivIntMod z$, b2$, whole$, n$
nn% = Val(n$)
GoSub bbGetDigit
s$ = dig$ + s$
Loop Until whole$ = zero$
'figure decimal part
If Len(dec$) Then
s$ = s$ + dp$
r$ = one$
Do
z$ = r$
bMul z$, b2$, r$
bMul dec$, r$, n$
bInt n$
nn% = Val(n$)
GoSub bbGetDigit
s$ = s$ + dig$
z$ = n$
bDiv z$, r$, n$
z$ = n$
bSub dec$, z$, n$
dec$ = n$
Loop Until dec$ = zero$ Or Len(s$) > digits%
End If
End If
If Len(s$) = 0 Then s$ = zero$
If s$ <> zero$ Then
If base2% <> 10 Then s$ = s$ + " " + basechr$ + b2$
If negflag% Then s$ = neg$ + s$
End If
Exit Sub
'receive whole number n$ in base base1% and return it in base 10
bbConvertString:
tn$ = zero$
last% = Len(n$)
groupflag% = (base1% > 16) Or (InStr(n$, basesep$) > 0)
i% = 1
Do
If i% > last% Then Exit Do
If groupflag% Then
'digits in groups, eg 6,6,b100 = 6*10^1 + 6*10^0
j% = InStr(i%, n$, basesep$)
If j% = 0 Then j% = last%
nn% = Val(Mid$(n$, i%, j%))
i% = j% + 1
Else
'digits 1 by 1, eg 123 or ABC
nn% = Asc(Mid$(n$, i%, 1))
i% = i% + 1
Select Case nn%
Case 48 To 57: nn% = nn% - 48
Case 65 To 90: nn% = nn% - 55
Case Else: nn% = 0
End Select
End If
'return base base2% digit or group for nn%
bbGetDigit:
If base2% > 16 Then
dig$ = LTrim$(Str$(nn%))
dig$ = String$(digmask% - Len(dig$), zero$) + dig$ + basesep$
ElseIf nn% < 10 Then
dig$ = Chr$(nn% + asc0)
Else
dig$ = Chr$(nn% + 55)
End If
Return
End Sub
'check if s$ is in some other number base and convert it to base 10.
'
Sub bBase10 (s$)
Dim numbase%
bBaseCheck s$, numbase%
If numbase% Then bBase s$, numbase%, 10
End Sub
'return number and base from a string, or 0 if no base (=base 10).
'eg 100b2 returns s$="100" and numbase%=2
'
Sub bBaseCheck (s$, numbase%)
Dim i%, n%
If bIsBase%(s$) Then
'deal with 6bb16 (=6B hex)
For i% = Len(s$) To 1 Step -1
If UCase$(Mid$(s$, i%, 1)) = basechr$ Then n% = i%: Exit For
Next i%
numbase% = Val(Mid$(s$, n% + 1))
s$ = Left$(s$, n% - 1)
Else
numbase% = False
End If
End Sub
'Strip a number to "standard form" with no leading or trailing 0s and no
'final "." All routines should return all arguments in this form.
'
Sub bClean (s$)
Dim sign%
If Left$(s$, 1) = neg$ Then s$ = Mid$(s$, 2): sign% = True
bStripZero s$
If InStr(s$, dp$) Then bStripTail s$
If sign% And s$ <> zero$ Then s$ = neg$ + s$
End Sub
'clean up a number for display so .6 -> 0.6
'
Sub bCleanShow (s$)
bClean s$
If Left$(s$, 2) = "-." Then
s$ = "-0." + Mid$(s$, 3)
ElseIf Left$(s$, 1) = dp$ Then
s$ = zero$ + s$
End If
End Sub
'Compare two numbers using fast string compares. This can screw up since it
'uses string length, eg it reports "8"<"8." so watch out. The practice in
'these routines is no leading or trailing 0s and no final "." See bClean().
'
'Return 1 if s1 > s2
' 0 if s1 = s2
' -1 if s1 < s2
'
Function bComp% (s1$, s2$)
Dim s1flag%, s2flag%, sign1%, sign2%
Dim dp1%, dp2%, arg%
'kludge to fix 0<.1
If Left$(s1$, 1) = dp$ Then s1$ = zero$ + s1$: s1flag% = True
If Left$(s2$, 1) = dp$ Then s2$ = zero$ + s2$: s2flag% = True
sign1% = (Left$(s1$, 1) = neg$)
sign2% = (Left$(s2$, 1) = neg$)
dp1% = InStr(s1$, dp$): If dp1% = 0 Then dp1% = Len(s1$) + 1
dp2% = InStr(s2$, dp$): If dp2% = 0 Then dp2% = Len(s2$) + 1
If sign1% <> sign2% Then
If sign1% Then arg% = -1 Else arg% = 1
ElseIf s1$ = s2$ Then
arg% = 0
ElseIf (dp1% < dp2%) Or ((dp1% = dp2%) And (s1$ < s2$)) Then
arg% = -1
Else
arg% = 1
End If
If sign1% And sign2% Then arg% = -arg%
If s1flag% Then s1$ = Mid$(s1$, 2)
If s2flag% Then s2$ = Mid$(s2$, 2)
bComp% = arg%
End Function
'out = cos(x)
'
Sub bCos (s$, out$)
Dim t$, tfac$, fac$, z$
Dim nfac&
Dim olddigits%, flag%
'do powers of 10 with shifts
ElseIf t$ = one$ Then
out$ = s1$
sign1% = bSign%(out$)
If sign1% = negative Then bAbs out$
bShift out$, -slog2%
If sign1% <> sign2% Then bNeg out$
'the hard way
Else
'strip all
s2$ = t$: t$ = ""
bLogGet s1$, slog1%, sign1%, True
'figure decimal point and sign of answer
outlog% = slog1% + bLogDp%(s2$, slog2%)
If sign1% <> sign2% Then outsign% = negative Else outsign% = positive
'bump digits past leading zeros and always show whole quotient
olddigits% = digits%
digits% = digits% + Len(s2$)
If digits% < outlog% + 1 Then digits% = outlog% + 1
'do it, ignore remainder
If Len(s2$) <= maxlongdig Then bDivLong s1$, s2$, out$, t$ Else bDivChar s1$, s2$, out$, t$
'clean up
bLogPut out$, outlog%, outsign%
bLogPut s1$, slog1%, sign1%
bLogPut s2$, slog2%, sign2%
digits% = olddigits%
End If
End Sub
'out = s1 / s2 using character algorithm, digit by digit, slow but honest.
's1$ and s2$ must be stripped first, no decimals.
'
Sub bDivChar (s1$, s2$, quotient$, remainder$)
Dim last1%, last2%, ldvd%, lrem%, dig%, borrow%
Dim i%, j%, n%
Dim dvd$
last1% = Len(s1$) 'length of the dividend
last2% = Len(s2$) 'length of the divisor
quotient$ = ""
remainder$ = ""
For i% = 1 To digits%
'get next digit of dividend or zero$ if past end
If i% <= last1% Then
dvd$ = remainder$ + Mid$(s1$, i%, 1)
Else
dvd$ = remainder$ + zero$
End If
'if dividend < divisor then digit%=0 else have to calculate it.
'do fast compare using string operations. see bComp%()
bStripZero dvd$
ldvd% = Len(dvd$)
If (ldvd% < last2%) Or ((ldvd% = last2%) And (dvd$ < s2$)) Then
'divisor is bigger, so digit is 0, easy!
dig% = 0
remainder$ = dvd$
Else
'dividend is bigger, but no more than 9 times bigger.
'subtract divisor until we get remainder less than divisor.
'time hog, average is 5 tries through j% loop. There's a better way.
For dig% = 1 To 9
remainder$ = ""
borrow% = 0
For j% = 0 To ldvd% - 1
n% = last2% - j%
If n% < 1 Then n% = 0 Else n% = Val(Mid$(s2$, n%, 1))
n% = Val(Mid$(dvd$, ldvd% - j%, 1)) - n% - borrow%
If n% >= 0 Then borrow% = 0 Else borrow% = 1: n% = n% + 10
remainder$ = Chr$(asc0 + n%) + remainder$
Next j%
'if remainder < divisor then exit
bStripZero remainder$
lrem% = Len(remainder$)
If (lrem% < last2%) Or ((lrem% = last2%) And (remainder$ < s2$)) Then Exit For
dvd$ = remainder$
ldvd% = Len(dvd$)
Next dig%
End If
quotient$ = quotient$ + Chr$(asc0 + dig%)
Next i%
End Sub
'out = integer part of s1 / s2
'
Sub bDivInt (s1$, s2$, out$)
Dim t$
bDivIntMod s1$, s2$, out$, t$
End Sub
's1 / s2 = integer and remainder (s1 = s2 * q + r)
'bDivInt() and bDivMod() call this.
'
Sub bDivIntMod (s1$, s2$, quotient$, remainder$)
Dim slog1%, sign1%, slog2%, sign2%
Dim olddigits%, outlog%, outsign%
olddigits% = digits%
'strip the numbers, set flag false to NOT trim zeros, slower but needed
bLogGet s2$, slog2%, sign2%, False
If s2$ = zero$ Then quotient$ = Error$: remainder$ = Error$: Exit Sub
bLogGet s1$, slog1%, sign1%, False
'figure decimal point and sign of answer
outlog% = slog1% + bLogDp%(s2$, slog2%)
If sign1% <> sign2% Then outsign% = negative Else outsign% = positive
'a trick: figure the decimal and only find that many digits
digits% = outlog% + 1
'send the work out
If Len(s2$) <= maxlongdig Then bDivLong s1$, s2$, quotient$, remainder$ Else bDivChar s1$, s2$, quotient$, remainder$
'clean up
bLogPut s1$, slog1%, sign1%
bLogPut s2$, slog2%, sign2%
bClean quotient$
bClean remainder$
If sign1% <> sign2% Then bNeg quotient$
digits% = olddigits%
End Sub
'out = s1 / s2 using fast long-integer algorithm. s2$ must be <= 8 digits.
's1$ and s2$ must be stripped first, no decimals.
'
Sub bDivLong (s1$, s2$, quotient$, remainder$)
Dim rmdr&, dividend&, divisor&
Dim dig%, i%
If Len(quotient$) = 0 Then quotient$ = zero$
remainder$ = LTrim$(Str$(rmdr&))
End Sub
'Return an ellipsis... repeat just the decimal or whole string if no decimal.
'Stop at digits% length. Handy for big test numbers.
'
Sub bDot (s$, out$)
Dim t$
Dim n%
n% = InStr(s$, dp$)
If n% Then t$ = Mid$(s$, n% + 1) Else t$ = s$
out$ = s$
Do
out$ = out$ + t$
Loop Until Len(out$) >= digits%
out$ = Left$(out$, digits%)
End Sub
'out = e^s
'
Sub bExp (s$, out$)
Dim t$, fac$, z$
Dim olddigits%, eflag%
olddigits% = digits%
'if e^1, see if we already have it.
If bIsEqual%(s$, one$) Then
bMemory t$, emem, memget
If digits% <= Len(t$) - 1 Then out$ = t$: bTrimDig out$: Exit Sub
eflag% = True
End If
digits% = digits% + 5
'e^x = 1 + x + x^2/2! + x^3/3! + ...
out$ = one$
t$ = one$
fac$ = one$
Do
z$ = t$
bMul z$, s$, t$
bTrimDig t$
z$ = t$
bDiv z$, fac$, t$
bTrimDig t$
If bIsZero%(t$) Then Exit Do
z$ = out$
bAdd z$, t$, out$
bInc fac$, 1
Loop
digits% = olddigits%
bTrimDig out$
If eflag% Then bMemory out$, emem, memput
End Sub
'out = s!
'
Sub bFactorial (s$, out$)
Dim t$, mul$, z$
Dim num&, product&
Dim last%, i%
bInt s$
bAbs s$
If bIsZero%(s$) Then out$ = one$: Exit Sub '0!=1 really!
If Len(s$) <= maxlongdig Then GoSub bfLong Else GoSub bfChar
Exit Sub
bfChar:
'start the easy way to 99999999! then finish. This could take weeks!
t$ = s$
s$ = String$(maxlongdig, "9")
GoSub bfLong
bSwapString s$, t$
If out$ = abortmsg$ Then Return
Do Until t$ = s$
bInc t$, 1
z$ = out$
bMul z$, t$, out$
Loop
Return
bfLong:
'this is the long-integer multiply slightly customized
out$ = one$
For num& = 2& To CLng(Val(s$))
mul$ = out$
last% = Len(mul$)
out$ = Space$(last%)
product& = 0
For i% = last% To 1 Step -1
product& = product& + Val(Mid$(mul$, i%, 1)) * num&
Mid$(out$, i%, 1) = Chr$(asc0 + CInt(product& Mod 10&))
product& = product& \ 10&
Next i%
If product& Then out$ = LTrim$(Str$(product&)) + out$
Next num&
Return
End Sub
'out = GCD(s1,s2)
'figure Greatest Common Divisor using Euclid's Algorithm
'Byte, Jan 86, p. 397
'
Sub bGCD (s1$, s2$, out$)
Dim div$, dvd$, t$
'work with copies
div$ = s1$
dvd$ = s2$
If bIsMore%(div$, dvd$) Then bSwapString div$, dvd$
Do Until bIsZero%(div$)
bMod dvd$, div$, t$
dvd$ = div$
div$ = t$
Loop
out$ = dvd$
End Sub
's += num%
'Fast increment s$ by num% for internal use, but not quite primetime.
's$ must be positive (but decimals are ok). It's ok to use negative num%
'for decrements but if result goes negative it returns "0" with no warning.
'num% must be an integer +-32k.
'
Sub bInc (s$, num%)
Dim dig%, n%, borrow%
If num% = 0 Then Exit Sub
dig% = InStr(s$, dp$)
If dig% Then dig% = dig% - 1 Else dig% = Len(s$)
n% = num%
If n% > 0 Then 'increment (n>0)
Do While n%
If dig% < 1 Then
s$ = LTrim$(Str$(n%)) + s$
n% = 0
Else
n% = n% + Val(Mid$(s$, dig%, 1))
Mid$(s$, dig%, 1) = Chr$(asc0 + (n% Mod 10))
n% = n% \ 10
dig% = dig% - 1
End If
Loop
Else 'decrement (n<0)
n% = -n%
Do While n%
If dig% < 1 Then s$ = zero$: Exit Do
borrow% = 0
n% = Val(Mid$(s$, dig%, 1)) - n%
Do While n% < 0
n% = n% + 10: borrow% = borrow% + 1
Loop
Mid$(s$, dig%, 1) = Chr$(asc0 + n%)
n% = borrow%
dig% = dig% - 1
Loop
End If
bStripZero s$
End Sub
'Initialize b_routines, set globals, etc
'
Sub bInit ()
Dim i%
'a few defaults
'digits% = defaultdigits
errormsg$ = "error"
abortmsg$ = "abort"
'clear memory
zstack% = 0
For i% = 0 To maxmem
bmem$(i%) = zero$
Next i%
For i% = 1 To maxstack
zmem$(i%) = zero$
Next i%
bncpath$ = "" 'path for files (or current dir if null)
prmcntfile$ = "BNPRMCNT.DAT" 'prime count table
' LoadPrimeTable
End Sub
's = int(s)
'truncate towards 0 like Basic FIX: bInt(-3.3) returns -3.
'
Sub bInt (s$)
Dim n%
n% = InStr(s$, dp$)
If n% Then
If n% = 1 Then s$ = zero$ Else s$ = Left$(s$, n% - 1)
If s$ = neg$ Or Left$(s$, 2) = "-." Then s$ = zero$
End If
End Sub
'return s1\s2 if s2 is divisor of s1, else return 0.
'
Sub bIntDiv (s1$, s2$, out$)
Dim t$
bDivIntMod s1$, s2$, out$, t$
If t$ <> zero$ Then out$ = zero$
End Sub
's = 1/s
'
Sub bInv (s$)
Dim z$
z$ = s$
bDiv one$, z$, s$
End Sub
'return false or the position of the "B" if s$ is in another number base,
'eg 123b5 and abcb16 return 4.
'
Function bIsBase% (s$)
bIsBase% = InStr(UCase$(s$), basechr$)
End Function
'return true if s1 divides s2
'
Function bIsDiv% (s1$, s2$)
Dim t$
bMod s2$, s1$, t$
bIsDiv% = (t$ = zero$)
End Function
'return true if s1 = s2
'
Function bIsEqual% (s1$, s2$)
bIsEqual% = (s1$ = s2$)
End Function
'return true if s$ is even, no decimals!
'
Function bIsEven% (s$)
bIsEven% = (Val(Right$(s$, 1)) Mod 2 = 0)
End Function
'return true if s in an integer (no decimal point).
'
Function bIsInteger% (s$)
bIsInteger% = (InStr(s$, dp$) = 0)
End Function
'return true if s1 < s2
'
Function bIsLess% (s1$, s2$)
bIsLess% = (bComp%(s1$, s2$) = -1)
End Function
'return true if s1 > s2
'
Function bIsMore% (s1$, s2$)
bIsMore% = (bComp%(s1$, s2$) = 1)
End Function
'return true if s is negative
'
Function bIsNeg% (s$)
bIsNeg% = (Left$(s$, 1) = neg$)
End Function
Function bIsNotZero% (s$)
Dim flag%, i%
flag% = False
For i% = 1 To Len(s$)
If InStr("0-. ", Mid$(s$, i%, 1)) = False Then flag% = True: Exit For
Next i%
bIsNotZero% = flag%
End Function
'return true if odd
'
Function bIsOdd% (s$)
bIsOdd% = (Val(Right$(s$, 1)) Mod 2 <> 0)
End Function
'return true if s is prime
'
Function bIsPrime% (s$)
bIsPrime% = (bPrmDiv$(s$, False) = s$)
End Function
's is pseudoprime to base b if (b,s)=1 and b^(s-1)=1 (mod s). Integers only!
'
Function bIsPseudoPrime% (s$, bas$)
Dim t$, smin$
Dim flag%
flag% = False
If bIsRelPrime%(s$, bas$) Then
smin$ = s$: bInc smin$, -1
bModPower bas$, smin$, s$, t$
flag% = (t$ = one$)
End If
bIsPseudoPrime% = flag%
End Function
'return true if s1 and s2 are relatively prime, ie share no factor
'
Function bIsRelPrime% (s1$, s2$)
Dim gcd$
bGCD s1$, s2$, gcd$
bIsRelPrime% = bIsEqual%(gcd$, one$)
End Function
'Return true if s$ is zero$ or null, s$ needn't be clean.
'
Function bIsZero% (s$)
Dim flag%, i%
flag% = True
For i% = 1 To Len(s$)
If InStr("0-. ", Mid$(s$, i%, 1)) = False Then flag% = False: Exit For
Next i%
bIsZero% = flag%
End Function
'out = LCM(s1,s2)
'figure Least Common Multiple using Euclid's Algorithm for GCD.
'LCM (a,b) = (a*b) / GCD(a,b)
'Byte, Jan 86, p. 397
'
Sub bLcm (s1$, s2$, out$)
Dim product$, gcd$
'out = ln(s), natural logarithm
'
Sub bLn (s$, out$)
Dim t$, d$, tfac$, fac$, z$, w$
Dim ln10flag%, ln2flag%, olddigits%, flag%
If Not bIsMore%(s$, zero$) Then out$ = Error$: Exit Sub
If bIsEqual%(s$, "10") Then
bMemory t$, ln10mem, memget
If digits% <= Len(t$) - 1 Then out$ = t$: bTrimDig out$: Exit Sub
ln10flag% = True
ElseIf bIsEqual%(s$, "2") Then
bMemory t$, ln2mem, memget
If digits% <= Len(t$) - 1 Then out$ = t$: bTrimDig out$: Exit Sub
ln2flag% = True
End If
olddigits% = digits%
digits% = digits% + 5
If bIsLess%(s$, "1.6") Then GoSub LnSeries2 Else GoSub LnSeries1
digits% = olddigits%
bTrimDig out$
If ln10flag% Then
bMemory out$, ln10mem, memput
ElseIf ln2flag% Then
bMemory out$, ln2mem, memput
End If
Exit Sub
Do
z$ = t$
bMul z$, tfac$, t$
bTrimDig t$
bDiv t$, fac$, d$
bTrimDig d$
If bIsZero%(d$) Then Exit Do
If flag% Then
z$ = out$
bAdd z$, d$, out$
Else
z$ = out$
bSub z$, d$, out$
End If
flag% = Not flag%
bInc fac$, 1
Loop
Return
End Sub
'out = log(s1) base s2, or ln(s1) if s2=0
'
Sub bLog (s1$, s2$, out$)
Dim t$, z$
'log(s) base(n) = ln(s) / ln(n)
If bIsEqual%(s2$, "-1") Then
bExp s1$, out$
ElseIf bIsNeg%(s2$) Then
out$ = Error$
Else
bLn s1$, out$
If Not bIsZero%(s2$) Then
bLn s2$, t$
z$ = out$
bDiv z$, t$, out$
End If
End If
End Sub
'Take whole number and log from bLogGet() and return number of decimal
'places in the expanded number; OR take string and number of decimal points
'desired and return the log. It works both ways.
'
Function bLogDp% (s$, logdp%)
bLogDp% = Len(s$) - 1 - logdp%
End Function
'Strip s$ to whole number and base 10 integer logarithm and sign. Decimal
'point is implied after the first digit, and slog% counts places left or
'right. bLogPut() reverses the process, and bLogDp() gives info on the
'decimals. Tricky, but it works and simplifies dividing and multipling.
'
Sub bLogGet (s$, slog%, sign%, zeroflag%)
Dim dpt%, n%
If Left$(s$, 1) = neg$ Then s$ = Mid$(s$, 2): sign% = negative Else sign% = positive
bStripZero s$
dpt% = InStr(s$, dp$)
Select Case dpt%
Case 0
slog% = Len(s$) - 1
Case 1
n% = dpt% + 1
Do While Mid$(s$, n%, 1) = zero$
n% = n% + 1
Loop
s$ = Mid$(s$, n%)
slog% = dpt% - n%
Case Else
s$ = Left$(s$, dpt% - 1) + Mid$(s$, dpt% + 1)
slog% = dpt% - 2
End Select
'remove trailing 0's if zeroflag%
If zeroflag% Then bStripTail s$
End Sub
'Restore a number from the integer and log figured in bLogGet(). s$ is taken
'as a number with the decimal after first digit, and decimal is moved slog%
'places left or right, adding 0s as required. Called by bDiv() and bMul().
'
Sub bLogPut (s$, slog%, sign%)
Dim last%
last% = Len(s$)
If Len(s$) = 0 Or s$ = zero$ Then
s$ = zero$
ElseIf slog% < 0 Then
s$ = dp$ + String$(-slog% - 1, zero$) + s$
ElseIf slog% > last% - 1 Then
s$ = s$ + String$(slog% - last% + 1, zero$) + dp$
Else
s$ = Left$(s$, slog% + 1) + dp$ + Mid$(s$, slog% + 2)
End If
bClean s$
If sign% = negative Then s$ = neg$ + s$
End Sub
'return the largest of two integers
'
Function bMaxInt% (n1%, n2%)
If n1% >= n2% Then bMaxInt% = n1% Else bMaxInt% = n2%
End Function
'Put or Get a number string in a cell. Only 64k in PDS, much less in QB,
'beep for overflow.
'
Sub bMemory (s$, memcell%, memop%)
Dim i%
'in range?
If memcell% < 0 Or memcell% > maxmem Then Exit Sub
Select Case memop%
Case memget: s$ = bmem$(memcell%)
Case memput
'check for enough memory?
bmem$(memcell%) = s$
Case memclr: For i% = 0 To 9: bmem$(i%) = "": Next i%
End Select
End Sub
'Perform Miller test for a number and base, return true if s may be prime.
' Schneier, Applied Cryptography, p.260
' Robbins, Beginning Number Theory, p.262
'
Function bMillerTest% (s$, bas$)
Dim t$, z$, rmd$, w$, y$
Dim j%, flag%
Static lasts$, smin$, m$, k%
If bIsEven%(s$) Then bMillerTest% = False: Exit Function
'figure {k,m} so s = 2^k * m + 1. Save results for next call.
If s$ <> lasts$ Then
smin$ = s$
bInc smin$, -1
m$ = smin$
k% = 0
Do
t$ = m$
bDivIntMod t$, two$, m$, rmd$
If rmd$ = zero$ Then k% = k% + 1 Else m$ = t$: Exit Do
Loop
End If
bModPower bas$, m$, s$, z$
If z$ = one$ Or z$ = smin$ Then
flag% = True
Else
flag% = False
For j% = 1 To k% - 1
w$ = z$
y$ = z$
bMul w$, y$, z$
w$ = z$
bMod w$, s$, z$
If z$ = smin$ Then flag% = True: Exit For
Next j%
End If
bMillerTest% = flag%
End Function
'out = s1 mod s2
'remainder after division, works for non-integers, but doesn't mean much.
'
Sub bMod (s1$, s2$, out$)
Dim t$
bDivIntMod s1$, s2$, t$, out$
End Sub
'out = s1^-1 (mod s2)
'Find inverse mod a number with Extended Euclid Algorithm.
'Given a and n, find x such that a*x = 1 (mod n).
'Answer exists only if a and n are relatively prime, else return 0.
'
Sub bModInv (s1$, s2$, out$)
Dim g0$, g1$, g2$, v0$, v1$, v2$, y$, t$, z$
If Not bIsRelPrime%(s1$, s2$) Then out$ = zero$: Exit Sub
out$ = v0$
If bIsNeg%(out$) Then
z$ = out$
bAdd z$, s2$, out$
End If
End Sub
'out = (s1 ^ s2) mod s3
'
Sub bModPower (s1$, s2$, s3$, out$)
'Use variation of "Russian Peasant Method" to figure m=(c^d) mod n.
'Byte, Jan 83, p.206.
'test value: (71611947 ^ 63196467) mod 94815109 = 776582
'm=1
'do
' if d is odd then m=(m*c) mod n
' c=(c*c) mod n
' d=int(d/2)
'loop while d>0
'm is the answer
Dim c$, d$, z$, w$
Static n$ 'remember modulus for next call
'positive numbers only, modulus must be >1! Find mod inverse if s2=-1.
out$ = errormsg$
If Len(s3$) Then n$ = s3$
If bIsNeg%(s1$) Or bIsNeg%(n$) Then Exit Sub
If bIsNeg%(s2$) Then
If bIsEqual%(s2$, "-1") Then bModInv s1$, n$, out$
Exit Sub
End If
c$ = s1$
d$ = s2$
out$ = one$
Do
If bIsOdd%(d$) Then
z$ = out$
bMul z$, c$, out$
z$ = out$
bMod z$, n$, out$
End If
z$ = c$
w$ = c$
bMul z$, w$, c$
z$ = c$
bMod z$, n$, c$
z$ = d$
bDivInt z$, two$, d$
Loop Until bIsZero%(d$)
End Sub
'out = s1 * s2
'
Sub bMul (s1$, s2$, out$)
Dim t$
Dim slog1%, sign1%, slog2%, sign2%, outdp%, outsign%, outlog%, swapflag%
'do powers of 10 with shifts
ElseIf t$ = one$ Then
out$ = s1$
sign1% = bSign%(out$)
If sign1% = negative Then bAbs out$
bShift out$, slog2%
If sign1% <> sign2% Then bNeg out$
'the hard way
Else
'strip all
s2$ = t$: t$ = ""
bLogGet s1$, slog1%, sign1%, True
'figure decimal point and sign of answer
outdp% = bLogDp%(s1$, slog1%) + bLogDp%(s2$, slog2%)
If sign1% <> sign2% Then outsign% = negative Else outsign% = positive
'always multiply by the shorter number
If Len(s2$) > Len(s1$) Then bSwapString s1$, s2$: swapflag% = True
'do it
If Len(s2$) <= maxlongdig Then bMulLong s1$, s2$, out$ Else bMulChar s1$, s2$, out$
'clean up
outlog% = bLogDp%(out$, outdp%)
bLogPut out$, outlog%, outsign%
If swapflag% Then bSwapString s1$, s2$
bLogPut s1$, slog1%, sign1%
bLogPut s2$, slog2%, sign2%
End If
End Sub
'out = s1 * s2 using character algorithm, slow but honest. Whole numbers
'only. Inner loop is optimized and hard to understand, but it works.
'
Sub bMulChar (s1$, s2$, out$)
Dim last1%, last2%, last%
Dim i%, j%, k%, sj%, ej%
Dim product&
last1% = Len(s1$)
last2% = Len(s2$)
last% = last1% + last2%
out$ = Space$(last%)
product& = 0
For i% = 0 To last% - 1
k% = last1% - i%
sj% = 1 - k%: If sj% < 0 Then sj% = 0
ej% = last1% - k%: If ej% > last2% - 1 Then ej% = last2% - 1
For j% = sj% To ej%
product& = product& + Val(Mid$(s1$, k% + j%, 1)) * Val(Mid$(s2$, last2% - j%, 1))
Next j%
Mid$(out$, last% - i%, 1) = Chr$(asc0 + CInt(product& Mod 10&))
product& = product& \ 10&
Next i%
If product& Then out$ = LTrim$(Str$(product&)) + out$
End Sub
'out = s1 * s2 using fast long-integer algorithm. s2$ must be <= 8 digits.
's1$ and s2$ must be stripped first, whole numbers only.
'
Sub bMulLong (s1$, s2$, out$)
Dim last1%, i%
Dim s2val&, product&
last1% = Len(s1$)
s2val& = Val(s2$)
out$ = Space$(last1%)
For i% = last1% To 1 Step -1
product& = product& + Val(Mid$(s1$, i%, 1)) * s2val&
Mid$(out$, i%, 1) = Chr$(asc0 + CInt(product& Mod 10&))
product& = product& \ 10&
Next i%
If product& Then out$ = LTrim$(Str$(product&)) + out$
End Sub
'out = nCr, s1 things taken s2 at a time, order doesn't matter
'
Sub bnCr (s1$, s2$, out$)
' n! nPr
'nCr = -------- = ---
' r!(n-r)! r!
'nCr = nCn-r, so pick the smaller
Dim r$, t$, z$
bSub s1$, s2$, r$
If bIsMore%(r$, s2$) Then r$ = s2$
bnPr s1$, r$, t$
If t$ = errormsg$ Then Exit Sub
z$ = r$
bFactorial z$, r$
bDivInt t$, r$, out$
End Sub
's = -s
'
Sub bNeg (s$)
If Left$(s$, 1) = neg$ Then s$ = Mid$(s$, 2) Else s$ = neg$ + s$
End Sub
'Normalize s1 to range of +-{s2}
'
Sub bNorm (s1$, s2$)
Dim t$
Dim dpt%
t$ = s1$
bAbs t$
If Not bIsLess%(t$, s2$) Then
bDiv s1$, s2$, t$
dpt% = InStr(t$, dp$)
If dpt% = 0 Then
s1$ = zero$
Else
bMul s2$, Mid$(t$, dpt%), s1$
bTrimDig s1$
If bIsNeg%(t$) Then bNeg s1$
End If
End If
End Sub
'Normalize an angle in radians to +-2pi
'
Sub bNormRad (s$)
Dim pi2$
bPi2 pi2$
bNorm s$, pi2$
End Sub
'out = nPr, s1 things taken s2 at a time, order matters
'
Sub bnPr (s1$, s2$, out$)
' n!
'nPr = ------ = (n)*(n-1)*...*(n-r+1)
' (n-r)!
Dim t$, z$
bAbs s1$
bAbs s2$
If bIsMore%(s2$, s1$) Then out$ = errormsg$: Exit Sub
If bIsZero%(s2$) Then out$ = one$: Exit Sub
bSub s1$, s2$, out$
bInc out$, 1
t$ = out$
Do Until t$ = s1$
bInc t$, 1
z$ = out$
bMul t$, z$, out$
Loop
End Sub
'out = phi (Golden Ratio)
'
Sub bPhi (out$)
Dim t$
Dim olddigits%
olddigits% = digits%
'see if it's already in memory
bMemory t$, phimem, memget
If digits% <= Len(t$) - 1 Then
out$ = t$
bTrimDig out$
Exit Sub
End If
'else calculate it. Need to write this.
out$ = t$
End Sub
'pi with Machin's formula: pi= 16 arctan(1/5) - 4 arctan(1/239)
'
Sub bPi (out$)
Dim d$, k$, t$, tfac$, atan$, atan5$, atan239$, z$
Dim olddigits%, flag%
olddigits% = digits%
'see if it's already in memory
bMemory t$, pimem, memget
If digits% <= Len(t$) - 1 Then out$ = t$: bTrimDig out$: Exit Sub
'figure a bit more and truncate to get last place right
digits% = digits% + 5
Do
z$ = t$
bDiv z$, tfac$, t$
bDiv t$, k$, d$
bTrimDig d$
If bIsZero%(d$) Then Exit Do
If flag% Then
z$ = atan$
bAdd z$, d$, atan$
Else
z$ = atan$
bSub z$, d$, atan$
End If
flag% = Not flag%
bInc k$, 2
Loop
Return
End Sub
'return s=2*pi, from memory if possible
'
Sub bPi2 (s$)
Dim z$
bMemory s$, pi2mem, memget
If digits% <= Len(s$) - 1 Then
bTrimDig s$
Else
bPi s$
z$ = s$
bMul z$, two$, s$
bMemory s$, pi2mem, memput
End If
End Sub
'out = s1 ^ s2, for real s2
'
Sub bPower (s1$, s2$, out$)
Dim z$
Dim invflag%
If bIsInteger%(s2$) Then
bPowerInt s1$, s2$, out$
Else
If bIsNeg%(s2$) Then bNeg s2$: invflag% = True
bLn s1$, out$
z$ = out$
bMul z$, s2$, out$
z$ = out$
bExp z$, out$
If invflag% Then bNeg s2$: bInv out$
End If
End Sub
'out = s1 ^ s2, for integer s2 only! (It truncates s2)
'Uses variation of "Russian Peasant Method".
'
Sub bPowerInt (s1$, s2$, out$)
Dim c$, d$, z$, w$
Dim invflag%
bInt s2$
If bIsZero%(s2$) Then out$ = one$: Exit Sub
If bIsNeg%(s2$) Then bNeg s2$: invflag% = True
c$ = s1$
d$ = s2$
out$ = one$
Do
If bIsOdd%(d$) Then
z$ = out$
bMul z$, c$, out$
End If
z$ = c$
w$ = c$
bMul z$, w$, c$
z$ = d$
bDivInt z$, two$, d$
Loop Until bIsZero%(d$)
If invflag% Then
bNeg s2$
z$ = out$
bDiv one$, z$, out$
End If
End Sub
'If pflag% then count primes to s and return count else return s_th prime.
'If dspcol% then show progress on current line starting with that column.
'Will go forever if pflag% and s not prime.
'
Function bPrmCount$ (s$, dspcol%, pflag%)
Dim cnt$, num$
Dim n&
Dim i%, dinc%
'deal with exceptions up front
Select Case s$
Case "0": cnt$ = zero$: num$ = zero$
Case "1": cnt$ = zero$: num$ = two$
Case "2": cnt$ = one$: num$ = three$
Case "3": cnt$ = two$: num$ = five$
Case Else
'if no prime table then start from scratch else cue into table
If maxprmcnt% = 0 Then
i% = 0
'pflag% true: s$ is prime, count to it and return count
ElseIf pflag% Then
If bIsMore%(s$, LTrim$(Str$(prmcnt&(maxprmcnt%)))) Then
i% = maxprmcnt%
Else
n& = Val(s$)
For i% = 1 To maxprmcnt%
If prmcnt&(i%) > n& Then Exit For
Next i%
i% = i% - 1
End If
'pflag% false: s$ is the count, return that prime
Else
If bIsMore%(s$, LTrim$(Str$(maxprmcnt% * 1000&))) Then
i% = maxprmcnt%
Else
i% = Val(s$) \ 1000
End If
End If
'get start values
If i% = 0 Then
num$ = five$: cnt$ = three$
Else
num$ = LTrim$(Str$(prmcnt&(i%)))
cnt$ = LTrim$(Str$(i% * 1000&))
End If
If Val(num$) Mod 6 = 1 Then dinc% = 4 Else dinc% = 2
'finally to work
Do
If bIsPrime%(num$) Then
'IF dspcol% AND (RIGHT$(cnt$, 2) = "00") THEN PRINT "."; : IF POS(0) = 75 THEN LOCATE , dspcol%: PRINT TAB(80); : LOCATE , dspcol%
If pflag% Then
If num$ = s$ Then Exit Do
Else
If cnt$ = s$ Then Exit Do
End If
bInc cnt$, 1
End If
bInc num$, dinc%
dinc% = 6 - dinc%
Loop
End Select
If pflag% Then bPrmCount$ = cnt$ Else bPrmCount$ = num$
End Function
'Return smallest prime divisor or s$ if prime, no size limit, but slows
'down when s$>8 digits. This is strictly brute force and slow. Press <esc>
'to abort and it returns 0. If dspflag% then print (most) factors in
'lblTryNum of Factor frame, an inelegant kludge used by Factor(). A speed
'hit, but fun to watch.
'
Function bPrmDiv$ (s$, dspflag%)
Dim num$, sfac$, maxfac$, t$
Dim lfac&, lnum&, lmaxfac&, ldfac&
Dim i%, cnt%, flag%, dfac%
num$ = s$
bInt num$
bAbs num$
If Len(num$) <= maxlongdig Then GoSub bpdLong Else GoSub bpdChar
Exit Function
bpdChar:
'try some classic divisibility tests for small factors.
'Cf Gardner, Unexpected Hanging, p.160.
'by 2?
' If dspflag% Then
' frmBncFactor.lblTryNum.Caption = two$
' frmBncFactor.lblTryNum.Refresh
'End If
If Val(Right$(num$, 1)) Mod 2 = 0 Then bPrmDiv$ = two$: Return
'by 3?
'IF dspflag% THEN LOCATE , dspflag%: PRINT three$;
' If dspflag% Then
' frmBncFactor.lblTryNum.Caption = three$
' frmBncFactor.lblTryNum.Refresh
'End If
lfac& = 0
For i% = 1 To Len(num$)
lfac& = lfac& + Asc(Mid$(num$, i%, 1)) - asc0
Next i%
If lfac& Mod 3 = 0 Then bPrmDiv$ = three$: Return
'by 5?
'IF dspcol% THEN LOCATE , dspcol%: PRINT five$;
' If dspflag% Then
' frmBncFactor.lblTryNum.Caption = five$
' frmBncFactor.lblTryNum.Refresh
'End If
If Val(Right$(num$, 1)) Mod 5 = 0 Then bPrmDiv$ = five$: Return
'by 7, 11, or 13?
'IF dspcol% THEN LOCATE , dspcol%: PRINT "7+";
' If dspflag% Then
' frmBncFactor.lblTryNum.Caption = "7+"
' frmBncFactor.lblTryNum.Refresh
'End If
lfac& = 0
i% = Len(num$) + 1
cnt% = 3
flag% = True
Do
i% = i% - 3: If i% < 1 Then cnt% = i% + 2: i% = 1
If flag% Then
lfac& = lfac& + Val(Mid$(num$, i%, cnt%))
Else
lfac& = lfac& - Val(Mid$(num$, i%, cnt%))
End If
flag% = Not flag%
Loop While i% > 1
If lfac& Mod 7 = 0 Then bPrmDiv$ = "7": Return
If lfac& Mod 11 = 0 Then bPrmDiv$ = "11": Return
If lfac& Mod 13 = 0 Then bPrmDiv$ = "13": Return
'main loop, increment factor by 2 or 4.
sfac$ = "17"
dfac% = 2
bSqrInt num$, maxfac$
Do
'IF dspcol% THEN LOCATE , dspcol%: PRINT sfac$;
' If dspflag% Then
' frmBncFactor.lblTryNum.Caption = sfac$
' frmBncFactor.lblTryNum.Refresh
'End If
bMod num$, sfac$, t$
If bIsZero%(t$) Then Exit Do
bInc sfac$, dfac%
dfac% = 6 - dfac%
If bIsMore%(sfac$, maxfac$) Then sfac$ = num$: Exit Do
'If INKEY$ = esc$ Then sfac$ = zero$: Exit Do
Loop
bPrmDiv$ = sfac$
Return
bpdLong:
lnum& = Val(num$)
If lnum& <= 1 Then
lfac& = 1&
ElseIf lnum& Mod 2& = 0& Then
lfac& = 2&
ElseIf lnum& Mod 3& = 0& Then
lfac& = 3&
Else
lmaxfac& = Int(Sqr(lnum&))
lfac& = 5&
ldfac& = 2&
Do
'IF dspcol% THEN LOCATE , dspcol%: PRINT lfac&;
' If dspflag% Then
' frmBncFactor.lblTryNum.Caption = LTrim$(Str$(lfac&))
' frmBncFactor.lblTryNum.Refresh
'End If
If lnum& Mod lfac& = 0& Then Exit Do
lfac& = lfac& + ldfac&
ldfac& = 6& - ldfac&
If lfac& > lmaxfac& Then lfac& = lnum&: Exit Do
Loop
End If
bPrmDiv$ = LTrim$(Str$(lfac&))
Return
End Function
'Do Rabin-Miller Prime test times% times. If true, then probability that
's is composite is < .25^times%. Of course s$ is an odd integer.
'If dspcol% then show progress on current line starting with that column.
'
Function bPrmTest% (s$, times%, dspflag%)
Dim n$
Dim i%, flag%
If bIsEven%(s$) Then bPrmTest% = False: Exit Function
flag% = True
For i% = 2 To times% + 1
'If dspflag% Then Print ".";
n$ = LTrim$(Str$(i%))
If bIsRelPrime%(s$, n$) Then
flag% = bMillerTest%(s$, n$)
Else
flag% = False
End If
If Not flag% Then Exit For
Next i%
bPrmTest% = flag%
End Function
'radians to degrees, deg=rad*180/pi
'
Sub bRadToDeg (s$)
Dim t$, z$
'Return a random number. Expects an argument of form m.n:
' m.n returns m digits+decimal+n digits
' m returns m digits
' m. m digits with random decimal point
'<null> use last mask
'
Sub bRand (s$, out$)
Static randmask$
Dim t$
Dim n%
t$ = s$
If Len(t$) = 0 Then
If Len(randmask$) = 0 Then randmask$ = "5"
t$ = randmask$
End If
randmask$ = t$
n% = InStr(t$, dp$)
If n% = 0 Then
'R3 -> abc
out$ = bRnd$(Val(t$))
ElseIf n% = 1 Then
'R.3 -> .abc
out$ = dp$ + bRnd$(Val(Mid$(t$, 2)))
ElseIf n% = Len(t$) Then
'R3. -> abc with random dp
out$ = bRnd$(Val(t$) + 1)
Mid$(out$, Int(1 + Rnd * Len(out$)), 1) = dp$
Else
'R3.2 -> abc.ef
out$ = bRnd$(Val(Mid$(t$, 1, n% - 1))) + dp$ + bRnd$(Val(Mid$(t$, n% + 1)))
End If
End Sub
'Return a random number string of places% digits.
'
Function bRnd$ (places%)
Dim t$
Dim i%
If places% = 0 Then
bRnd$ = zero$
Else
t$ = Space$(places%)
Mid$(t$, 1, 1) = Chr$(asc0 + Int(Rnd * 9) + 1)
For i% = 2 To places%
Mid$(t$, i%, 1) = Chr$(asc0 + Int(Rnd * 10))
Next i%
bRnd$ = t$
End If
End Function
'Return a random number < max$, to digits places.
'
Sub bRndNum (max$, out$)
bMul LTrim$(Str$(Rnd)), max$, out$
End Sub
'out = s2 root of s1, (or s1 ^ 1/s2)
'
Sub bRoot (s1$, s2$, out$)
Dim t$, x$, root$, mroot$, r$, newx$, z$
Dim negflag%, invflag%
'easy 0 values
If bIsZero%(s2$) Then out$ = one$: Exit Sub
If bIsZero%(s1$) Then out$ = zero$: Exit Sub
'use logs for non-integer roots
If Not bIsInteger%(s2$) Then
t$ = s2$: bInv t$
bPower s1$, t$, out$
Exit Sub
End If
x$ = s1$
root$ = s2$
If bIsNeg%(x$) Then If bIsEven%(root$) Then out$ = errormsg$: Exit Sub Else bNeg x$: negflag% = True
If bIsNeg%(root$) Then bNeg root$: invflag% = True
If root$ = two$ Then bSqr x$, out$ Else GoSub brRoot
If invflag% Then bInv out$
If negflag% Then bNeg out$
Exit Sub
'Newton-Raphson method for any integer root
brRoot:
mroot$ = root$
bInc mroot$, -1
'a bug, these are never equal
'bTrimDig x$
'bTrimDig newx$
'IF x$ = newx$ THEN EXIT DO
If Left$(x$, digits% - 1) = Left$(newx$, digits% - 1) Then Exit Do
x$ = newx$
bTrimDig x$
Loop
out$ = newx$
Return
End Sub
'Take a string in "scientific notation" and expand it.
'Recognize both 66.6e2 AND 66.6d2 as 6660 to accommadate QB.
' ^ ^
'
Sub bSci (s$)
Dim n%, xp%, sign%
s$ = UCase$(LTrim$(s$))
n% = InStr(s$, "E")
If n% = 0 Then n% = InStr(s$, "D") 'because double# use "D" not "E"
If n% Then
xp% = Val(Mid$(s$, n% + 1))
s$ = Left$(s$, n% - 1)
bLogGet s$, n%, sign%, True
bLogPut s$, n% + xp%, sign%
End If
End Sub
'out = sec(x)
'
Sub bSec (s$, out$)
'sec(x)=1/cos(x)
bCos s$, out$
If bIsZero%(out$) Then
out$ = Error$
Else
bInv out$
End If
End Sub
'out = sech(s)
'
Sub bSech (s$, out$)
'sech(x) = 2 / (Exp(x) + Exp(-x))
out$ = zero$
End Sub
'Set digits% to dig% (or return value if 0).
'
Sub bSetDigits (dig%)
If dig% = False Then dig% = digits% Else digits% = dig%
End Sub
'shift decimal n% digits (minus=left), i.e multiply/divide by 10.
'
Sub bShift (s$, n%)
Dim slog%, sign%
bLogGet s$, slog%, sign%, False
bLogPut s$, slog% + n%, sign%
End Sub
'return sign of number (-1 or +1)
'
Function bSign% (s$)
If bIsNeg%(s$) Then bSign% = negative Else bSign% = positive
End Function
'out = sin(x)
'
Sub bSin (s$, out$)
Dim t$, tfac$, fac$, z$
Dim nfac&
Dim olddigits%, flag%
Do
z$ = t$
bMul z$, tfac$, t$
bTrimDig t$
z$ = t$
bDiv z$, fac$, t$
bTrimDig t$
If bIsZero%(t$) Then Exit Do
If flag% Then
z$ = out$
bAdd z$, t$, out$
Else
z$ = out$
bSub z$, t$, out$
End If
flag% = Not flag%
fac$ = LTrim$(Str$((nfac& + 1&) * (nfac& + 2&)))
nfac& = nfac& + 2&
Loop
digits% = olddigits%
bTrimDig out$
End Sub
'out = sinh(x) hyperbolic sine
'
Sub bSinh (s$, out$)
'sinh(x) = (Exp(x) - Exp(-x)) / 2
out$ = zero$
End Sub
'out = SQR(s) using the old hand method
'I learned this in high school, but I still don't understand it. It's fast.
Sub bSqr (s$, out$)
Dim dvd$, div$, dig$, newdiv$, t$, z$
Dim slog%, ssign%, slen%, spt%, olddigits%, n%, m%
If bIsNeg%(s$) Then out$ = errormsg$: Exit Sub
'strip to whole number + group digits by 2 left or right of decimal
bLogGet s$, slog%, ssign%, True
slen% = Len(s$)
If slog% Mod 2 Then spt% = 2 Else spt% = 1
'Force at least enough digits to show integer of root
olddigits% = digits%
n% = 1 + slog% \ 2
If digits% < n% Then digits% = n%
'estimate divisor, and adjust if too big. Unit is next digit of root.
bDivInt dvd$, div$, dig$
Do
bAdd div$, dig$, newdiv$
bMul newdiv$, dig$, t$
If Not bIsMore%(t$, dvd$) Then Exit Do
bInc dig$, -1
Loop
out$ = out$ + dig$
'form new divisor
z$ = dvd$
bSub z$, t$, dvd$
Loop
'clean up
bLogPut s$, slog%, ssign%
If slog% < 0 Then slog% = slog% - 1
bLogPut out$, slog% \ 2, ssign%
digits% = olddigits%
End Sub
'out = INT(SQR(s)), largest integer n such that n^2 <= s
'
Sub bSqrInt (s$, out$)
Dim t$
Dim olddigits%
If bIsNeg%(s$) Then out$ = errormsg$: Exit Sub
t$ = s$
bInt t$
'a trick: let bSqr() figure the decimal and only find that many digits
olddigits% = digits%
digits% = 0
bSqr t$, out$
digits% = olddigits%
End Sub
'Return a number string. str(4.31) returns 4 "31"s, i.e. 31313131.
'Handy for big test numbers.
'
Sub bStr (s$, out$)
Dim t$
Dim n%, i%
n% = InStr(s$, ".")
If n% Then t$ = Mid$(s$, n% + 1) Else t$ = Right$(s$, 1)
out$ = ""
For i% = 1 To Val(s$)
out$ = t$ + out$
Next i%
If Len(out$) = 0 Then out$ = zero$
End Sub
'Trim leading spaces, add decimal points, eliminate signs.
'Returns last%=length of string, dpt%=decimal place, sign%=-1 or 1.
'Called only by bAdd() and bSub() which needs a final decimal point.
'
Sub bStripDp (s$, last%, dpt%, sign%)
If Left$(s$, 1) = neg$ Then s$ = Mid$(s$, 2): sign% = negative Else sign% = positive
bStripZero s$
If InStr(s$, dp$) = 0 Then s$ = s$ + dp$
If s$ = dp$ Then s$ = "0."
dpt% = InStr(s$, dp$)
last% = Len(s$)
End Sub
'Strip trailing 0s to "." (but leave something)
'
Sub bStripTail (s$)
Dim n%
n% = Len(s$)
Do While Mid$(s$, n%, 1) = zero$
n% = n% - 1
If n% <= 1 Then Exit Do
Loop
If n% Then If Mid$(s$, n%, 1) = dp$ Then n% = n% - 1
s$ = Left$(s$, n%)
If Len(s$) = 0 Then s$ = zero$
End Sub
'Strip leading 0s and final "." (but leave something)
'
Sub bStripZero (s$)
Dim n%
n% = 1
Do While Mid$(s$, n%, 1) = zero$
n% = n% + 1
Loop
If n% > 1 Then s$ = Mid$(s$, n%)
If Right$(s$, 1) = dp$ Then s$ = Left$(s$, Len(s$) - 1)
If Len(s$) = 0 Then s$ = zero$
End Sub
'out = s1 - s2
'
Sub bSub (s1$, s2$, out$)
Dim last1%, dp1%, sign1%
Dim last2%, dp2%, sign2%
Dim last%, d1%, d2%, dpt%, borrow%, swapflag%
Dim i%, n%
'treat different signs as addition
If sign1% = negative And sign2% = positive Then
bNeg s1$
bNeg s2$
bAdd s1$, s2$, out$
bNeg s2$
Exit Sub
ElseIf sign1% = positive And sign2% = negative Then
bAdd s1$, s2$, out$
bNeg s2$
Exit Sub
End If
'always subtract smaller from bigger to avoid complements
If bIsMore%(s2$, s1$) Then
bSwapString s1$, s2$
bSwapInt d2%, d1%
swapflag% = True
End If
'do the subtraction right to left
For i% = last% To 1 Step -1
If i% <> dpt% Then
If d1% > 0 Then n% = Val(Mid$(s1$, d1%, 1)) Else n% = 0
If d2% > 0 Then n% = n% - Val(Mid$(s2$, d2%, 1))
n% = n% - borrow%
If n% >= 0 Then borrow% = 0 Else borrow% = 1: n% = n% + 10
Mid$(out$, i%, 1) = Chr$(asc0 + n%)
Else
Mid$(out$, i%, 1) = dp$
End If
d1% = d1% - 1
d2% = d2% - 1
Next i%
'clean up
If sign1% = negative Then s1$ = neg$ + s1$: s2$ = neg$ + s2$
If swapflag% Then
bSwapString s1$, s2$
sign1% = -sign1%
End If
If sign1% = negative Then out$ = neg$ + out$
bClean s1$
bClean s2$
bClean out$
End Sub
Sub bSwapInt (s1%, s2%)
Dim t%
t% = s1%
s1% = s2%
s2% = t%
End Sub
Sub bSwapString (s1$, s2$)
Dim t$
t$ = s1$
s1$ = s2$
s2$ = t$
End Sub
'out = tan(s)
'
Sub bTan (s$, out$)
Dim t$, tc$, ts$
'tan=sin/cos
t$ = s$
bNormRad t$
bCos t$, tc$
If bIsZero%(tc$) Then
out$ = Error$
Else
bSin t$, ts$
bDiv ts$, tc$, out$
End If
End Sub
Sub bTanh (s$, out$)
'tanh(x) = (Exp(x) - Exp(-x)) / (Exp(x) + Exp(-x))
out$ = zero$
End Sub
'Truncate s$ to digits% places
'
Sub bTrimDig (s$)
s$ = Left$(s$, digits% + 1)
End Sub
'Try to load table of prime counts, 66th item is the 66000th prime.
'Should be in current dircetory, but check path if not.
'
'Sub LoadPrimeTable ()
' Dim file$, path$, in$
' Dim i%, n%, m%, flag%, filenum%
'' if table not in current dir, then check path
' If Len(Dir$(file$)) = 0 Then
' path$ = Environ$("PATH")
' flag% = True
' n% = 1
' Do While n% < Len(path$)
' m% = InStr(n%, path$, ";")
' If m% = 0 Then m% = Len(path$) + 1
' file$ = Mid$(path$, n%, m% - n%)
' If Right$(file$, 1) <> "\" Then file$ = file$ + "\"
' file$ = file$ + prmcntfile$
' If Len(Dir$(file$)) Then
' bncpath$ = Mid$(path$, n%, m% - n%) + "\"
' flag% = False
' Exit Do
' End If
' n% = m% + 1
' Loop
' If flag% Then Exit Sub
' End If
'' found it, check for signature and load data
' Open file$ For Input As #filenum%
' Line Input #filenum%, in$
' If UCase$(Left$(in$, 7)) = "'BIGNUM" Then
' Do
' Line Input #filenum%, in$
' Loop While Left$(in$, 1) = "'"
' maxprmcnt% = Val(in$)
' ReDim prmcnt&(1 To maxprmcnt%)
' For i% = 1 To maxprmcnt%
' Input #filenum%, prmcnt&(i%)
' Next i%
' End If
' Close #filenum%
'End Sub
'PUT or GET a number from the stack, or beep
'
Sub WorkStack (s$, memop%)
Dim i%
Select Case memop%
Case memget
If zstack% Then
s$ = zmem$(zstack%)
zstack% = zstack% - 1
Else
s$ = zero$ 'stack underflow
End If
Case memput
If (zstack% < maxstack) Then
zstack% = zstack% + 1
zmem$(zstack%) = s$
Else
'stack overflow
End If
Case memclr
zstack% = False
For i% = 1 To maxstack: zmem$(i%) = zero$: Next i%
End Select
End Sub
One thing QB64 and its ancestors lacks, that VB6 and VBA and pretty much all modern languages have, is a native date/time type and associated operations and formatting functions. There are already 16 or so numeric types, so how about one for date/time?
I started throwing together some basic date/time functions, maybe someone will find this useful.
I'm sure this code could be done more efficiently but it seems to be working OK. There are still some features missing (a standard format date function, epoch-to-string function, count quarter/month/weekday/week, etc.) so this is still a Work in Progress.
' 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)
' MAKE SCREEN BIG TO FIT A LOT OF TEXT: 1024x768=128cols,48rows and 1280x1024=160cols,64rows
Screen _NewImage(1280, 1024, 32): _ScreenMove 0, 0
' DEMONSTRATION OF DATE/TIME STUFF:
TimeStringToSecondsTest
GetElapsedTimeTest
DateDiffTest
' EXIT
Screen 0
System ' return control to the operating system
End
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN TIMESTAMP FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' QB64 equivalent of the Visual Basic / VBA DateDiff function.
' See:
' Microsoft > Office VBA Reference > DateDiff function
' https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/datediff-function
' Receives:
' interval$ = String expression that is the interval of time you use
' to calculate the difference between date1$ and date2$,
' and can be one of the following values:
' SETTING DESCRIPTION COMMENT
' ------- ----------- -------------------
' yyyy Year (NOT SUPPORTED YET)
' q Quarter (NOT SUPPORTED YET)
' m Month (NOT SUPPORTED YET)
' y Day of year (NOT SUPPORTED YET)
' d Day
' w Weekday (NOT SUPPORTED YET)
' ww Week (NOT SUPPORTED YET)
' h Hour
' n Minute
' s Second
'
' date1##, date2## = Two dates you want to use in the calculation,
' in UNIX time (# seconds elapsed since 1/1/1970 12:00:00 AM GMT),
' we assume the dates are timezone-corrected.
' Returns an _Float specifying the number of time intervals between
' two specified dates.
Function DateDiff## (interval$, fDate1##, fDate2##)
Dim fResult As _Float: fResult = 0
Dim fDiffSeconds As _Float
fDiffSeconds = fDate2## - fDate1##
Select Case interval$
Case "yyyy":
' Year = UNDER CONSTRUCTION
Case "q":
' Quarter = UNDER CONSTRUCTION
Case "m":
' Month = UNDER CONSTRUCTION
Case "y":
' Day of year = UNDER CONSTRUCTION
Case "d":
' Get # of days
fResult = (fDiffSeconds \ 86400)
Case "w":
' Weekday = UNDER CONSTRUCTION
Case "ww":
' Week = UNDER CONSTRUCTION
Case "h":
' Get # of hours
fResult = (fDiffSeconds \ 3600)
Case "n":
' get # of minutes
fResult = (fDiffSeconds \ 60)
Case "s":
' get # of seconds
fResult = fDiffSeconds
Case Else:
' Unknown
End Select
Sub DateDiffSanityTest1 (interval$, date1$, date2$)
Dim fDate1 As _Float
Dim fDate2 As _Float
fDate1 = GetUnixTime##(date1$)
fDate2 = GetUnixTime##(date2$)
Print StrPadRight$(date1$, 22) + " = " + StrPadRight$(_Trim$(Str$(fDate1)), 12) + " seconds"
Print StrPadRight$(date2$, 22) + " = " + StrPadRight$(_Trim$(Str$(fDate2)), 12) + " seconds"
Print StrPadRight$("", 22) + " " + StrPadRight$(_Trim$(Str$(fDate2 - fDate1)), 12) + " seconds difference"
Print
End Sub ' DateDiffSanityTest1
' /////////////////////////////////////////////////////////////////////////////
' Receives:
' fSeconds = time period in seconds
' Returns:
' The time period in the format "{days} days, {hours} hours, {minutes} minutes, {seconds} seconds"
' TODO:
' Add support for years, months, weeks
Function GetElapsedTime$ (fElapsedSeconds As _Float)
Dim sResult As String: sResult = ""
Dim fSeconds As _Float
Dim iDays As _Integer64
Dim iHours As Integer
Dim iMinutes As Integer
Dim iSeconds As Integer
Dim sSign As String
' Handle negative values
If Sgn(fElapsedSeconds) = -1 Then
fSeconds = 0 - fElapsedSeconds
sSign = "-"
Else
fSeconds = fElapsedSeconds
sSign = ""
End If
' Get # of days
iDays = fSeconds \ 86400
' Get # of hours
fSeconds = fSeconds - (iDays * 86400)
iHours = fSeconds \ 3600
' get # of minutes
fSeconds = fSeconds - (iHours * 3600)
iMinutes = fSeconds \ 60
' get # of seconds
fSeconds = fSeconds - (iMinutes * 60)
iSeconds = Int(fSeconds)
' Assemble output
If (iDays > 0) Then sResult = _Trim$(Str$(iDays)) + " days"
If (iHours > 0) Then sResult = AppendString$(sResult, _Trim$(Str$(iHours)) + " hours", ", ")
If (iMinutes > 0) Then sResult = AppendString$(sResult, _Trim$(Str$(iMinutes)) + " minutes", ", ")
If (iSeconds > 0) Then sResult = AppendString$(sResult, _Trim$(Str$(iSeconds)) + " seconds", ", ")
sResult = sSign + sResult
' Return result
GetElapsedTime$ = sResult
End Function ' GetElapsedTime$
' /////////////////////////////////////////////////////////////////////////////
' Based on "Test Steve timeStamp" by SMcNeill & bplus
' https://www.qb64.org/forum/index.php?topic=1638.30
' https://www.qb64.org/forum/index.php?topic=1638.msg108650#msg108650
Sub GetElapsedTimeTest
ReDim arrDateTime$(-1)
Dim iLoop1 As Integer
Dim iLoop2 As Integer
Dim MyDateTime1$
Dim MyDateTime2$
Dim iYear As Integer
Dim MyDate1$
Dim MyDate2$
Dim fSeconds1 As _Float
Dim fSeconds2 As _Float
Dim fDiffSeconds As _Float
Dim in$
Cls
Print "Demonstration of Function GetElapsedTime$ (fElapsedSeconds As _Float)"
Print "---------------------------------------------------------------------"
Function GetTimeIntervalName$ (interval$)
Dim sInterval As String
Select Case interval$
Case "yyyy":
sInterval = "years"
Case "q":
sInterval = "quarters"
Case "m":
sInterval = "months"
Case "y":
sInterval = "days of the year"
Case "d":
sInterval = "days"
Case "w":
sInterval = "weekdays"
Case "ww":
sInterval = "weeks"
Case "h":
sInterval = "hours"
Case "n":
sInterval = "minutes"
Case "s":
sInterval = "seconds"
Case Else:
sInterval = "unknown units"
End Select
GetTimeIntervalName$ = sInterval
End Function ' GetTimeIntervalName$
' /////////////////////////////////////////////////////////////////////////////
' Based on "Test Steve timeStamp" by SMcNeill & bplus
' https://www.qb64.org/forum/index.php?topic=1638.30
' https://www.qb64.org/forum/index.php?topic=1638.msg108650#msg108650
' Receives:
' MyDate$ can be date or date+time, in any of the following formats:
' 12-hour time:
' 01-01-2020 11:59:59 PM
' 01/01/2020 11:59:59 PM
' 24-hour time:
' 01-01-2020 23:59:59
' 01/01/2020 23:59:59
' TODO: create the inverse function, receives epoch and returns a formatted date string.
Function GetUnixTime## (sDate$)
Dim iPos1 As Integer
Dim iPos2 As Integer
Dim iMonth As Integer
Dim iDay As Integer
Dim iYear As Integer
Dim iLoop1 As Integer
Dim fDateSeconds As _Float
Dim MyDate$
Dim sTime$
Dim fTimeSeconds As _Float ' MyTime##
Dim fTotalSeconds As _Float: fTotalSeconds = 0
' Do we have date+time or just date?
' Look at sDate$:
' e.g. 01-01-2020 11:59:59 PM
' 1234567890123456789012
' 10987654321
If Len(sDate$) > 19 Then
' Date + time, 12-hour time
sTime$ = Right$(sDate$, Len(sDate$) - 11)
fTimeSeconds = TimeStringToSeconds##(sTime$)
MyDate$ = Left$(sDate$, 10)
ElseIf Len(sDate$) > 10 Then
' Date + time, 24-hour time
sTime$ = Right$(sDate$, Len(sDate$) - 11)
fTimeSeconds = TimeStringToSeconds##(sTime$)
MyDate$ = Left$(sDate$, 10)
Else
' Just a date, assume time=12:00:00 AM
fTimeSeconds = 0
MyDate$ = sDate$
End If
MyDate$ = Replace$(MyDate$, "/", "-")
If iYear < 1970 Then
' CALCULATE SHE-IT BACKWARDS
Select Case iMonth ' turn the day backwards for the month
Case 1, 3, 5, 7, 8, 10, 12: iDay = 31 - iDay ' 31 days
Case 2: iDay = 28 - iDay ' special 28 or 29.
Case 4, 6, 9, 11: iDay = 30 - iDay ' 30 days
End Select
If iYear Mod 4 = 0 And iMonth < 3 Then ' check for normal leap year, and we're before it...
iDay = iDay + 1 ' assume we had a leap year, subtract another day
If iYear Mod 100 = 0 And iYear Mod 400 <> 0 Then iDay = iDay - 1 ' not a leap year if year is divisible by 100 and not 400
End If
' then count the months that passed after the current month
For iLoop1 = iMonth + 1 To 12
Select Case iLoop1
Case 2: iDay = iDay + 28
Case 3, 5, 7, 8, 10, 12: iDay = iDay + 31
Case 4, 6, 9, 11: iDay = iDay + 30
End Select
Next iLoop1
' we should now have the entered year calculated. Now lets add in for each year from this point to 1970
iDay = iDay + 365 * (1969 - iYear) ' 365 days per each standard year
For iLoop1 = 1968 To iYear + 1 Step -4 ' from 1968 onwards,backwards, skipping the current year (which we handled previously in the FOR loop)
iDay = iDay + 1 ' subtract an extra day every leap year
If (iLoop1 Mod 100) = 0 And (iLoop1 Mod 400) <> 0 Then iDay = iDay - 1 ' but skipping every year divisible by 100, but not 400
Next iLoop1
fDateSeconds = iDay * 24 * 60 * 60 ' Seconds are days * 24 hours * 60 minutes * 60 seconds
fTotalSeconds = -(fDateSeconds + 24 * 60 * 60 - fTimeSeconds)
'fDateSeconds = -(fDateSeconds + 24 * 60 * 60)
'Exit Function
Else
' CALCULATE FORWARD
iYear = iYear - 1970
For iLoop1 = 1 To iMonth ' for this year,
Select Case iLoop1 ' Add the number of days for each previous month passed
Case 1: iDay = iDay ' January doestn't have any carry over days.
Case 2, 4, 6, 8, 9, 11: iDay = iDay + 31
Case 3 ' Feb might be a leap year
If (iYear Mod 4) = 2 Then ' if this year is divisible by 4 (starting in 1972)
iDay = iDay + 29 ' its a leap year
If (iYear Mod 100) = 30 And (iYear Mod 400) <> 30 Then ' unless..
iDay = iDay - 1 ' the year is divisible by 100, and not divisible by 400
End If
Else ' year not divisible by 4, no worries
iDay = iDay + 28
End If
Case 5, 7, 10, 12: iDay = iDay + 30
End Select
Next iLoop1
iDay = (iDay - 1) + 365 * iYear ' current month days passed + 365 days per each standard year
For iLoop1 = 2 To iYear - 1 Step 4 ' from 1972 onwards, skipping the current year (which we handled previously in the FOR loopp)
iDay = iDay + 1 ' add an extra day every leap year
If (iLoop1 Mod 100) = 30 And (iLoop1 Mod 400) <> 30 Then iDay = iDay - 1 ' but skiping every year divisible by 100, but not 400
Next iLoop1
fTotalSeconds = fDateSeconds + fTimeSeconds
End If
GetUnixTime## = fTotalSeconds
End Function ' GetUnixTime##
' /////////////////////////////////////////////////////////////////////////////
' mod from Pete's calendar this is a very clear calc
' From "Test Steve timeStamp" by SMcNeill & bplus
' https://www.qb64.org/forum/index.php?topic=1638.30
' https://www.qb64.org/forum/index.php?topic=1638.msg108650#msg108650
Function IsLeapYear% (yr)
Dim bResult%: bResult% = FALSE
If yr Mod 4 = 0 Then
If yr Mod 100 = 0 Then
If yr Mod 400 = 0 Then
bResult% = TRUE
End If
Else
bResult% = TRUE
End If
End If
IsLeapYear% = bResult%
End Function ' IsLeapYear%
' /////////////////////////////////////////////////////////////////////////////
' Convert time string to seconds.
' Receives a time string in the format:
' {hh}:[mm}:{ss} {AM/PM}
' If the string contains "AM" or "PM" then it is treated as 12-hour time,
' else it is treated as 24-hour (military) time.
' Counts up the number of seconds from midnight until that time,
' and returns it as type Float.
' TODO:
' * First remove all non-numeric characters, except AM or PM on the right,
' so that we can parse dates with other separators, like "12.25.2003".
' * Create the inverse function "SecondsToTimeString$".
' * Create a date/time type with all the standard Date operations.
Function TimeStringToSeconds## (sTime$)
Dim sHH$: sHH$ = Left$(sTime$, 2)
Dim sNN$: sNN$ = Mid$(sTime$, 4, 2)
Dim sSS$: sSS$ = Mid$(sTime$, 7, 2)
Dim fSeconds##: fSeconds## = 0
' MAKE SURE VALUES ARE NUMBERS
If (IsNum%(sHH$) = TRUE) And (IsNum%(sNN$) = TRUE) And (IsNum%(sSS$) = TRUE) Then
' IF TIME CONTAINS AM/PM, USE 12-HOUR TIME, ELSE 24-HOUR
If InStr(UCase$(sTime$), "AM") > 0 Then
' 12-HOUR TIME, A.M.
'Print "Ante-meridian!"
If Val(sHH$) = 12 Then
' Hour is zero for 12 A.M.
'Print "12 A.M., that's zero for hours"
fSeconds## = (Val(sNN$) * 60) + Val(sSS$)
Else
' Count hour normally
'Print "Between 1 A.M. and 11:59:59 A.M."
fSeconds## = (Val(sHH$) * 3600) + (Val(sNN$) * 60) + Val(sSS$)
End If
ElseIf InStr(UCase$(sTime$), "PM") > 0 Then
' 12-HOUR TIME, P.M.
' Unless it is noon, add 12 hours.
If Val(sHH$) = 12 Then
' Count hour normally
'Print "12 noon. Leave hours alone."
fSeconds## = (Val(sHH$) * 3600) + (Val(sNN$) * 60) + Val(sSS$)
Else
' Add 12 hours.
'Print "Post-meridian but not noon. Add 12 hours."
fSeconds## = ((Val(sHH$) + 12) * 3600) + (Val(sNN$) * 60) + Val(sSS$)
End If
Else
' 24-HOUR TIME
'Print "24 hours, boys!!"
fSeconds## = (Val(sHH$) * 3600) + (Val(sNN$) * 60) + Val(sSS$)
End If
'Else
' Print "Something's not right"
' Print "(IsNum%(sHH$) = " + _Trim$(Str$(IsNum%(sHH$))) + ", sHH$=" + chr$(34) + sHH$ + chr$(34)
' Print "(IsNum%(sNN$) = " + _Trim$(Str$(IsNum%(sNN$))) + ", sNN$=" + chr$(34) + sNN$ + chr$(34)
' Print "(IsNum%(sSS$) = " + _Trim$(Str$(IsNum%(sSS$))) + ", sSS$=" + chr$(34) + sSS$ + chr$(34)
End If
' RETURN RESULT
TimeStringToSeconds## = fSeconds##
Sub TimeStringToSecondsTest
ReDim arrTime$(0 To 17)
Dim iLoop%
Dim in$
arrTime$(0) = "00:00:00"
arrTime$(1) = "12:00:00 AM"
arrTime$(2) = "01:00:00"
arrTime$(3) = "01:00:00 AM"
arrTime$(4) = "01:02:00 AM"
arrTime$(5) = "01:02:34 AM"
arrTime$(6) = "02:00:00"
arrTime$(7) = "02:00:00 AM"
arrTime$(8) = "02:02:00 AM"
arrTime$(9) = "02:02:34 AM"
arrTime$(10) = "01:00:00 PM"
arrTime$(11) = "01:02:00 PM"
arrTime$(12) = "01:02:34 PM"
arrTime$(13) = "13:00:00"
arrTime$(14) = "13:01:00"
arrTime$(15) = "13:01:34"
arrTime$(16) = "23:59:59"
arrTime$(17) = "11:59:59 PM"
Cls
Print "Demonstration of Function TimeStringToSeconds## (sTime$)"
Print "--------------------------------------------------------"
For iLoop% = LBound(arrTime$) To UBound(arrTime$)
Print "Time " + Chr$(34) + arrTime$(iLoop%) + Chr$(34) + " = " + _Trim$(Str$(TimeStringToSeconds##(arrTime$(iLoop%)))) + " seconds."
Next iLoop%
Input "PRESS ENTER TO CONTINUE"; in$
End Sub ' TimeStringToSecondsTest
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END TIMESTAMP FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GENERAL PURPOSE ROUTINES #GEN
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Function AppendString$ (MyString As String, NewString As String, MyDelimiter As String)
Dim sResult As String: sResult = MyString
If Len(MyString) > 0 Then
sResult = sResult + MyDelimiter
End If
sResult = sResult + NewString
AppendString$ = sResult
End Function ' AppendString$
Sub AppendToStringArray (MyStringArray$(), MyString$)
ReDim _Preserve MyStringArray$(LBound(MyStringArray$) To UBound(MyStringArray$) + 1)
MyStringArray$(UBound(MyStringArray$)) = MyString$
End Sub ' AppendToStringArray
' /////////////////////////////////////////////////////////////////////////////
' See also StringTo2dArray
Function Array2dToString$ (MyArray() As String)
Dim MyString As String
Dim iY As Integer
Dim iX As Integer
Dim sLine As String
MyString = ""
For iY = LBound(MyArray, 1) To UBound(MyArray, 1)
sLine = ""
For iX = LBound(MyArray, 2) To UBound(MyArray, 2)
sLine = sLine + MyArray(iY, iX)
Next iX
MyString = MyString + sLine + Chr$(13)
Next iY
Array2dToString$ = MyString
End Function ' Array2dToString$
'Function Array2dToStringTest$ (MyArray() As String)
' Dim MyString As String
' Dim iY As Integer
' Dim iX As Integer
' Dim sLine As String
' MyString = ""
' MyString = MyString + " 11111111112222222222333" + Chr$(13)
' MyString = MyString + " 12345678901234567890123456789012" + Chr$(13)
' For iY = LBound(MyArray, 1) To UBound(MyArray, 1)
' sLine = ""
' sLine = sLine + Right$(" " + cstr$(iY), 2)
' For iX = LBound(MyArray, 2) To UBound(MyArray, 2)
' sLine = sLine + MyArray(iY, iX)
' Next iX
' sLine = sLine + Right$(" " + cstr$(iY), 2)
' MyString = MyString + sLine + Chr$(13)
' Next iY
' MyString = MyString + " 12345678901234567890123456789012" + Chr$(13)
' MyString = MyString + " 11111111112222222222333" + Chr$(13)
' Array2dToStringTest$ = MyString
'End Function ' Array2dToStringTest$
' /////////////////////////////////////////////////////////////////////////////
' 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$
' /////////////////////////////////////////////////////////////////////////////
' Simple timestamp function
Function CurrentDateTime$
CurrentDateTime$ = Mid$(Date$, 7, 4) + "-" + _
Mid$(Date$, 1, 5) + " " + _
Time$
End Function ' CurrentDateTime$
' /////////////////////////////////////////////////////////////////////////////
' TODO: verify this works
' 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$
' /////////////////////////////////////////////////////////////////////////////
' Receives an {sDelim} delimited list {sInput}
' returns the list with all duplicate entries removed.
Function DedupeDelimList$ (sInput As String, sDelim As String)
ReDim arrLines(-1) As String
Dim sOutput As String
Dim iLoop As Integer
split sInput, sDelim, arrLines()
sOutput = sDelim
For iLoop = LBound(arrLines) To UBound(arrLines)
If InStr(1, sOutput, sDelim + arrLines(iLoop) + sDelim) = 0 Then
sOutput = sOutput + arrLines(iLoop) + sDelim
End If
Next iLoop
DedupeDelimList$ = sOutput
End Function ' DedupeDelimList$
' /////////////////////////////////////////////////////////////////////////////
' SMcNeill
' More efficient version of ExtendedTimer.
' This stores our day values and only updates them when necessary.
' We really don't need to figure out how many seconds are in today over and over endlessly
' -- just count them once, and when the clock swaps back to 0:0:0, add 24*60*60 seconds to the count.
' Re: how to time something (ie do loop for n seconds)
' https://forum.qb64.org/index.php?topic=4682.0
Function ExtendedTimer##
'modified extendedtimer to store the old day's count, and not have to recalculate it every time the routine is called.
Static olds As _Float, old_day As _Float
Dim m As Integer, d As Integer, y As Integer
Dim s As _Float, day As String
If olds = 0 Then 'calculate the day the first time the extended timer runs
day = Date$
m = Val(Left$(day, 2))
d = Val(Mid$(day, 4, 2))
y = Val(Right$(day, 4)) - 1970
Select Case m 'Add the number of days for each previous month passed
Case 2: d = d + 31
Case 3: d = d + 59
Case 4: d = d + 90
Case 5: d = d + 120
Case 6: d = d + 151
Case 7: d = d + 181
Case 8: d = d + 212
Case 9: d = d + 243
Case 10: d = d + 273
Case 11: d = d + 304
Case 12: d = d + 334
End Select
If (y Mod 4) = 2 And m > 2 Then d = d + 1 'add a day if this is leap year and we're past february
d = (d - 1) + 365 * y 'current month days passed + 365 days per each standard year
d = d + (y + 2) \ 4 'add in days for leap years passed
s = d * 24 * 60 * 60 'Seconds are days * 24 hours * 60 minutes * 60 seconds
old_day = s
End If
If Timer < oldt Then 'we went from 23:59:59 (a second before midnight) to 0:0:0 (midnight)
old_day = s + 83400 'add another worth of seconds to our counter
End If
oldt = Timer
olds = old_day + oldt
ExtendedTimer## = olds
End Function ' ExtendedTimer##
' /////////////////////////////////////////////////////////////////////////////
' TODO: find the newer formatting function?
Function FormatNumber$ (myValue, iDigits As Integer)
Dim strValue As String
strValue = DblToStr$(myValue) + String$(iDigits, " ")
If myValue < 1 Then
If myValue < 0 Then
strValue = Replace$(strValue, "-.", "-0.")
ElseIf myValue > 0 Then
strValue = "0" + strValue
End If
End If
FormatNumber$ = Left$(strValue, iDigits)
End Function ' FormatNumber$
' /////////////////////////////////////////////////////////////////////////////
' From: Bitwise Manipulations By Steven Roman
' http://www.romanpress.com/Articles/Bitwise_R/Bitwise.htm
' Returns the 8-bit binary representation
' of an integer iInput where 0 <= iInput <= 255
Function GetBinary$ (iInput1 As Integer)
Dim sResult As String
Dim iLoop As Integer
Dim iInput As Integer: iInput = iInput1
sResult = ""
If iInput >= 0 And iInput <= 255 Then
For iLoop = 1 To 8
sResult = LTrim$(RTrim$(Str$(iInput Mod 2))) + sResult
iInput = iInput \ 2
'If iLoop = 4 Then sResult = " " + sResult
Next iLoop
End If
GetBinary$ = sResult
End Function ' GetBinary$
' /////////////////////////////////////////////////////////////////////////////
' wonderfully inefficient way to read if a bit is set
' ival = GetBit256%(int we are comparing, int containing the bits we want to read)
' See also: GetBit256%, SetBit256%
Function GetBit256% (iNum1 As Integer, iBit1 As Integer)
Dim iResult As Integer
Dim sNum As String
Dim sBit As String
Dim iLoop As Integer
Dim bContinue As Integer
'DIM iTemp AS INTEGER
Dim iNum As Integer: iNum = iNum1
Dim iBit As Integer: iBit = iBit1
iResult = FALSE
bContinue = TRUE
If iNum < 256 And iBit <= 128 Then
sNum = GetBinary$(iNum)
sBit = GetBinary$(iBit)
For iLoop = 1 To 8
If Mid$(sBit, iLoop, 1) = "1" Then
'if any of the bits in iBit are false, return false
If Mid$(sNum, iLoop, 1) = "0" Then
iResult = FALSE
bContinue = FALSE
Exit For
End If
End If
Next iLoop
If bContinue = TRUE Then
iResult = TRUE
End If
End If
GetBit256% = iResult
End Function ' GetBit256%
' /////////////////////////////////////////////////////////////////////////////
' Returns the text character at positon x%, y%
' Does the same as:
' Locate y%, x%
' GetCharXY% = Screen(CsrLin, Pos(0))
' See also: GetColorXY&
Function GetCharXY% (x%, y%)
GetCharXY% = Screen(y%, x%, 0) ' when 3rd parameter = 0 returns character code
End Function ' GetCharXY%
' /////////////////////////////////////////////////////////////////////////////
' Returns the text color at positon x%, y%
' See also: GetCharXY%
Function GetColorXY& (x%, y%)
GetColorXY& = Screen(y%, x%, 1) ' when 3rd parameter = 1 returns character color
End Function ' GetColorXY
' /////////////////////////////////////////////////////////////////////////////
' Simple timestamp function
' Format: {YYYY}-{MM}-{DD} {hh}:[mm}:{ss}
' Uses:
' TIME$
' The TIME$ Function returns a STRING representation
' of the current computer time in a 24 hour format.
' https://qb64phoenix.com/qb64wiki/index.php/TIME$
' DATE$
' The DATE$ function returns the current computer date
' as a string in the format "mm-dd-yyyy".
' https://qb64phoenix.com/qb64wiki/index.php/DATE$
'
' TODO: support template where
' {yyyy} = 4 digit year
' {mm} = 2 digit month
' {dd} = 2 digit day
' {hh} = 2 digit hour (12-hour)
' {rr} = 2 digit hour (24-hour)
' {nn} = 2 digit minute
' {ss} = 2 digit second
' {ampm} = AM/PM
' We got the nn for minute from Microsoft > Office VBA Reference > DateDiff function
' https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/datediff-function
Function GetCurrentDateTime$ (sTemplate$)
Dim sDate$: sDate$ = Date$
Dim sTime$: sTime$ = Time$
Dim sYYYY$: sYYYY$ = Mid$(sDate$, 7, 4)
Dim sMM$: sMM$ = Mid$(sDate$, 1, 2)
Dim sDD$: sDD$ = Mid$(sDate$, 4, 2)
Dim sHH24$: sHH24$ = Mid$(sTime$, 1, 2)
Dim sHH$: sHH$ = ""
Dim sMI$: sMI$ = Mid$(sTime$, 4, 2)
Dim sSS$: sSS$ = Mid$(sTime$, 7, 2)
Dim iHour%: iHour% = Val(sHH24$)
Dim sAMPM$: sAMPM$ = ""
Dim result$: result$ = ""
' FIGURE OUT AM/PM
If InStr(sTemplate$, "{ampm}") > 0 Then
If iHour% = 0 Then
sAMPM$ = "AM"
iHour% = 12
ElseIf iHour% > 0 And iHour% < 12 Then
sAMPM$ = "AM"
ElseIf iHour% = 12 Then
sAMPM$ = "PM"
Else
sAMPM$ = "PM"
iHour% = iHour% - 12
End If
sHH$ = Right$("00" + _Trim$(Str$(iHour%)), 2)
End If
' RETURN RESULT
GetCurrentDateTime$ = result$
End Function ' GetCurrentDateTime$
' /////////////////////////////////////////////////////////////////////////////
' From: Bitwise Manipulations By Steven Roman
' http://www.romanpress.com/Articles/Bitwise_R/Bitwise.htm
' Returns the integer that corresponds to a binary string of length 8
Function GetIntegerFromBinary% (sBinary1 As String)
Dim iResult As Integer
Dim iLoop As Integer
Dim strBinary As String
Dim sBinary As String: sBinary = sBinary1
iResult = 0
strBinary = Replace$(sBinary, " ", "") ' Remove any spaces
For iLoop = 0 To Len(strBinary) - 1
iResult = iResult + 2 ^ iLoop * Val(Mid$(strBinary, Len(strBinary) - iLoop, 1))
Next iLoop
GetIntegerFromBinary% = iResult
End Function ' GetIntegerFromBinary%
' /////////////////////////////////////////////////////////////////////////////
' Receives a {sDelimeter} delimited list of numbers {MyString}
' and splits it up into an integer array arrInteger()
' beginning at index {iMinIndex}.
Sub GetIntegerArrayFromDelimList (MyString As String, sDelimiter As String, iMinIndex As Integer, arrInteger() As Integer)
ReDim arrString(-1) As String
Dim CleanString As String
Dim iLoop As Integer
Dim iCount As Integer: iCount = iMinIndex - 1
If Len(sDelimiter) > 0 Then
CleanString = MyString
If sDelimiter <> " " Then
CleanString = Replace$(CleanString, " ", "")
End If
split CleanString, sDelimiter, arrString()
iCount = iMinIndex - 1
For iLoop = LBound(arrString) To UBound(arrString)
If IsNum%(arrString(iLoop)) = TRUE Then
iCount = iCount + 1
ReDim _Preserve arrInteger(iMinIndex To iCount) As Integer
arrInteger(iCount) = Val(arrString(iLoop))
'DebugPrint "5633 arrInteger(" + cstr$(iCount) + ") = VAL(arrString(" + cstr$(iLoop) + ")) = " + cstr$(arrInteger(iCount))
End If
Next iLoop
Else
If IsNum%(MyString) = TRUE Then
ReDim _Preserve arrInteger(iMinIndex To iMinIndex) As Integer
arrInteger(iMinIndex) = Val(MyString)
End If
End If
'CleanString=""
'for iLoop=lbound(arrInteger) to ubound(arrInteger)
'CleanString = CleanString + iifstr$(iLoop=lbound(arrInteger), "", ",") + cstr$(arrInteger(iLoop))
'next iLoop
'DebugPrint "arrInteger=(" + CleanString + ")"
End Sub ' GetIntegerArrayFromDelimList
' /////////////////////////////////////////////////////////////////////////////
' IIF function for QB for integers
Function IIF (Condition, IfTrue, IfFalse)
If Condition Then IIF = IfTrue Else IIF = IfFalse
End Function
' /////////////////////////////////////////////////////////////////////////////
' IIF function for QB for strings
Function IIFSTR$ (Condition, IfTrue$, IfFalse$)
If Condition Then IIFSTR$ = IfTrue$ Else IIFSTR$ = IfFalse$
End Function
Function IntPadLeft$ (iValue As Integer, iWidth As Integer)
IntPadLeft$ = Right$(String$(iWidth, " ") + _Trim$(Str$(iValue)), iWidth)
End Function ' IntPadLeft$
Function IntPadRight$ (iValue As Integer, iWidth As Integer)
IntPadRight$ = Left$(_Trim$(Str$(iValue)) + String$(iWidth, " "), iWidth)
End Function ' IntPadRight$
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if number n is even
' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
Function IsEven% (n)
If n Mod 2 = 0 Then
IsEven% = TRUE
Else
IsEven% = FALSE
End If
End Function ' IsEven%
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if number n is odd
' 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%
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if value text$ is numeric.
Function IsNum% (text$)
IsNum% = IsNumber%(text$)
End Function ' IsNum%
'' NOTE: THIS FAILS FOR NUMBERS LIKE "002" AND "2.000":
'Function IsNum% (text$)
' Dim a$
' Dim b$
' a$ = _Trim$(text$)
' b$ = _Trim$(Str$(Val(text$)))
' If a$ = b$ Then
' IsNum% = TRUE
' Else
' IsNum% = FALSE
' End If
'End Function ' IsNum%
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if value OriginalString$ is numeric.
' Re: Does a Is Number function exist in QB64?
' https://www.qb64.org/forum/index.php?topic=896.15
' Version 2 by madscijr
' Returns TRUE (-1) if string is an integer, FALSE (0) if not
' Version 1 by MWheatley
' Reply #18 on: January 01, 2019, 11:24:30 AM
' returns 1 if string is an integer, 0 if not
Function IsNumber% (OriginalString$)
Dim bResult%: bResult% = FALSE
Dim iLoop%
Dim TestString$
'Dim bNegative%
Dim iDecimalCount%
Dim sNextChar$
'THEY SHOULD TRIM OUTSIDE THE FUNCTION!
'TestString$ = _TRIM$(OriginalString$)
If Len(OriginalString$) > 0 Then
TestString$ = ""
If Left$(OriginalString$, 1) = "+" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
'bNegative% = FALSE
ElseIf Left$(OriginalString$, 1) = "-" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
'bNegative% = TRUE
Else
TestString$ = OriginalString$
'bNegative% = FALSE
End If
If Len(TestString$) > 0 Then
bResult% = TRUE
iDecimalCount% = 0
For iLoop% = 1 To Len(TestString$)
sNextChar$ = Mid$(TestString$, iLoop%, 1)
If sNextChar$ = "." Then
iDecimalCount% = iDecimalCount% + 1
If iDecimalCount% > 1 Then
' TOO MANY DECIMAL POINTS, INVALID!
bResult% = FALSE
Exit For
End If
ElseIf Asc(sNextChar$) < 48 Or Asc(sNextChar$) > 57 Then
' NOT A NUMERAL OR A DECIMAL, INVALID!
bResult% = FALSE
Exit For
End If
Next iLoop%
End If
End If
IsNumber% = bResult%
End Function ' IsNumber%
' /////////////////////////////////////////////////////////////////////////////
' 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&
' /////////////////////////////////////////////////////////////////////////////
' remove scientific Notation to String (~40 LOC)
' SMcNeill Jan 7, 2020
' https://www.qb64.org/forum/index.php?topic=1555.msg112989#msg112989
' Last Function in code marked Best Answer (removed debug comments and
' blank lines added these 2 lines.)
Function N2S$ (EXP$)
ReDim t$, sign$, l$, r$, r&&
ReDim dp As Long, dm As Long, ep As Long, em As Long, check1 As Long, l As Long, i As Long
t$ = LTrim$(RTrim$(EXP$))
If Left$(t$, 1) = "-" Or Left$(t$, 1) = "N" Then sign$ = "-": t$ = Mid$(t$, 2)
dp = InStr(t$, "D+"): dm = InStr(t$, "D-")
ep = InStr(t$, "E+"): em = InStr(t$, "E-")
check1 = Sgn(dp) + Sgn(dm) + Sgn(ep) + Sgn(em)
If check1 < 1 Or check1 > 1 Then N2S = _Trim$(EXP$): Exit Function ' If no scientic notation is found, or if we find more than 1 type, it's not SN!
Select Case l ' l now tells us where the SN starts at.
Case Is < dp: l = dp
Case Is < dm: l = dm
Case Is < ep: l = ep
Case Is < em: l = em
End Select
l$ = Left$(t$, l - 1) ' The left of the SN
r$ = Mid$(t$, l + 1): r&& = Val(r$) ' The right of the SN, turned into a workable long
If InStr(l$, ".") Then ' Location of the decimal, if any
If r&& > 0 Then
r&& = r&& - Len(l$) + 2
Else
r&& = r&& + 1
End If
l$ = Left$(l$, 1) + Mid$(l$, 3)
End If
Select Case r&&
Case 0 ' what the heck? We solved it already?
' l$ = l$
Case Is < 0
For i = 1 To -r&&
l$ = "0" + l$
Next
l$ = "." + l$
Case Else
For i = 1 To r&&
l$ = l$ + "0"
Next
l$ = l$
End Select
N2S$ = sign$ + l$
End Function ' N2S$
Sub PauseDecisecond (iDS As Integer)
Dim iCount As Integer
iCount = 0
Do
iCount = iCount + 1
_Limit 10 ' run 10x every second
Loop Until iCount = iDS
End Sub ' PauseDecisecond
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if point (x1%, y1%) is adjacent to point (x2%, y2%)
Function PointsAreAdjacent% (x1%, y1%, x2%, y2%)
Dim bResult%: bResult% = FALSE
' x or y can be the same, but not both
If (x1% <> x2%) Or (y1% <> y2%) Then
If (x1% = x2%) Or ((x1% = (x2% + 1)) Or (x2% = (x1% + 1))) Then
If (y1% = y2%) Or ((y1% = (y2% + 1)) Or (y2% = (y1% + 1))) Then
bResult% = TRUE
End If
End If
End If
PointsAreAdjacent% = bResult%
End Function ' PointsAreAdjacent%
' /////////////////////////////////////////////////////////////////////////////
' Writes sText to file sFileName.
' If bAppend=TRUE appends to file, else overwrites it.
' Returns blank if successful else returns error message.
Function PrintFile$ (sFileName As String, sText As String, bAppend As Integer)
Dim sError As String: sError = ""
If Len(sError) = 0 Then
If (bAppend = TRUE) Then
If _FileExists(sFileName) Then
Open sFileName For Append As #1 ' opens an existing file for appending
Else
sError = "Error in PrintFile$ : File not found. Cannot append."
End If
Else
Open sFileName For Output As #1 ' opens and clears an existing file or creates new empty file
End If
End If
If Len(sError) = 0 Then
' NOTE: WRITE places text in quotes in the file
'WRITE #1, x, y, z$
'WRITE #1, sText
' PRINT does not put text inside quotes
Print #1, sText
Close #1
End If
PrintFile$ = sError
End Function ' PrintFile$
' /////////////////////////////////////////////////////////////////////////////
' Does a _PrintString at the specified row+column.
' iRow and iCol are 0-based.
' See also: PrintString1
Sub PrintString (iRow As Integer, iCol As Integer, MyString As String)
Dim iX As Integer
Dim iY As Integer
iX = _FontWidth * iCol
iY = _FontHeight * iRow ' (iRow + 1)
_PrintString (iX, iY), MyString
End Sub ' PrintString
' /////////////////////////////////////////////////////////////////////////////
' Does a _PrintString at the specified row+column.
' iRow and iCol are 1-based.
' See also: PrintString
Sub PrintString1 (iRow As Integer, iCol As Integer, MyString As String)
Dim iX As Integer
Dim iY As Integer
iX = _FontWidth * (iCol - 1)
iY = _FontHeight * (iRow - 1)
_PrintString (iX, iY), MyString
End Sub ' PrintString1
' /////////////////////////////////////////////////////////////////////////////
' Prints text character char$ at positoin x%,y% in color myColor&.
Sub PutCharXY (x%, y%, char$, myColor&)
Color myColor&
Locate y%, x%
Print char$;
End Sub ' PutCharXY
' /////////////////////////////////////////////////////////////////////////////
' Generate random value between Min and Max inclusive.
Function RandomNumber% (Min%, Max%)
Dim NumSpread%
' SET RANDOM SEED
'Randomize ' Initialize random-number generator.
Randomize Timer
' GET RANDOM # Min%-Max%
'RandomNumber = Int((Max * Rnd) + Min) ' generate number
NumSpread% = (Max% - Min%) + 1
RandomNumber% = Int(Rnd * NumSpread%) + Min% ' GET RANDOM # BETWEEN Max% AND Min%
End Function ' RandomNumber%
'' /////////////////////////////////////////////////////////////////////////////
'
'Sub RandomNumberTest
' Dim iCols As Integer: iCols = 10
' Dim iRows As Integer: iRows = 20
' Dim iLoop As Integer
' Dim iX As Integer
' Dim iY As Integer
' Dim sError As String
' Dim sFileName As String
' Dim sText As String
' Dim bAppend As Integer
' Dim iMin As Integer
' Dim iMax As Integer
' Dim iNum As Integer
' Dim iErrorCount As Integer
' Dim sInput$
'
' sFileName = "c:\temp\maze_test_1.txt"
' sText = "Count" + Chr$(9) + "Min" + Chr$(9) + "Max" + Chr$(9) + "Random"
' bAppend = FALSE
' sError = PrintFile$(sFileName, sText, bAppend)
' If Len(sError) = 0 Then
' bAppend = TRUE
' iErrorCount = 0
'
' iMin = 0
' iMax = iCols - 1
' For iLoop = 1 To 100
' iNum = RandomNumber%(iMin, iMax)
' sText = Str$(iLoop) + Chr$(9) + Str$(iMin) + Chr$(9) + Str$(iMax) + Chr$(9) + Str$(iNum)
' sError = PrintFile$(sFileName, sText, bAppend)
' If Len(sError) > 0 Then
' iErrorCount = iErrorCount + 1
' Print Str$(iLoop) + ". ERROR"
' Print " " + "iMin=" + Str$(iMin)
' Print " " + "iMax=" + Str$(iMax)
' Print " " + "iNum=" + Str$(iNum)
' Print " " + "Could not write to file " + Chr$(34) + sFileName + Chr$(34) + "."
' Print " " + sError
' End If
' Next iLoop
'
' iMin = 0
' iMax = iRows - 1
' For iLoop = 1 To 100
' iNum = RandomNumber%(iMin, iMax)
' sText = Str$(iLoop) + Chr$(9) + Str$(iMin) + Chr$(9) + Str$(iMax) + Chr$(9) + Str$(iNum)
' sError = PrintFile$(sFileName, sText, bAppend)
' If Len(sError) > 0 Then
' iErrorCount = iErrorCount + 1
' Print Str$(iLoop) + ". ERROR"
' Print " " + "iMin=" + Str$(iMin)
' Print " " + "iMax=" + Str$(iMax)
' Print " " + "iNum=" + Str$(iNum)
' Print " " + "Could not write to file " + Chr$(34) + sFileName + Chr$(34) + "."
' Print " " + sError
' End If
' Next iLoop
'
' Print "Finished generating numbers. Errors: " + Str$(iErrorCount)
' Else
' Print "Error creating file " + Chr$(34) + sFileName + Chr$(34) + "."
' Print sError
' End If
'
' Input "Press <ENTER> to continue", sInput$
'End Sub ' RandomNumberTest
' /////////////////////////////////////////////////////////////////////////////
' FROM: String Manipulation
' found at abandoned, outdated and now likely malicious qb64 dot net website
' http://www.qb64.[net]/forum/index_topic_5964-0/
'
'SUMMARY:
' Purpose: A library of custom functions that transform strings.
' Author: Dustinian Camburides (dustinian@gmail.com)
' Platform: QB64 (www.qb64.org)
' Revision: 1.6
' Updated: 5/28/2012
'SUMMARY:
'[Replace$] replaces all instances of the [Find] sub-string with the [Add] sub-string within the [Text] string.
'INPUT:
'Text: The input string; the text that's being manipulated.
'Find: The specified sub-string; the string sought within the [Text] string.
'Add: The sub-string that's being added to the [Text] string.
Function Replace$ (Text1 As String, Find1 As String, Add1 As String)
' VARIABLES:
Dim Text2 As String
Dim Find2 As String
Dim Add2 As String
Dim lngLocation As Long ' The address of the [Find] substring within the [Text] string.
Dim strBefore As String ' The characters before the string to be replaced.
Dim strAfter As String ' The characters after the string to be replaced.
' INITIALIZE:
' MAKE COPIESSO THE ORIGINAL IS NOT MODIFIED (LIKE ByVal IN VBA)
Text2 = Text1
Find2 = Find1
Add2 = Add1
lngLocation = InStr(1, Text2, Find2)
' PROCESSING:
' While [Find2] appears in [Text2]...
While lngLocation
' Extract all Text2 before the [Find2] substring:
strBefore = Left$(Text2, lngLocation - 1)
' Extract all text after the [Find2] substring:
strAfter = Right$(Text2, ((Len(Text2) - (lngLocation + Len(Find2) - 1))))
' /////////////////////////////////////////////////////////////////////////////
' https://staging.qb64phoenix.com/showthread.php?tid=644
' From: bplus
' Date: 07-18-2022, 03:16 PM
' Here is a Round$ that acts the way you'd expect in under 100 LOC
' b = b + ...
Function Round$ (anyNumber, dp As Long)
' 5 and up at decimal place dp+1 > +1 at decimal place 4 and down > +0 at dp
' 2 1 0.-1 -2 -3 -4 ... pick dp like this for this Round$ Function
sn$ = N2S$(Str$(anyNumber + .5 * 10 ^ dp)) ' get rid of sci notation, steve trims it so next find dot
dot = InStr(sn$, ".")
If dot Then
predot = dot - 1
postdot = Len(sn$) - (dot + 1)
Else
predot = Len(sn$)
postdot = 0
End If
' xxx.yyyyyy dp = -2
' ^ dp
If dp >= 0 Then
Rtn$ = Mid$(sn$, 1, predot - dp) + String$(dp, "0")
Else
Rtn$ = Mid$(sn$, 1, predot) + "." + Mid$(sn$, dot + 1, -dp)
End If
If Rtn$ = "" Then
Round$ = "0"
Else
Round$ = Rtn$
End If
End Function ' Round$
' /////////////////////////////////////////////////////////////////////////////
' TODO: verify these work (function Round$ works)
' 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 RoundNatural## (num##, digits%)
RoundNatural## = 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%
' /////////////////////////////////////////////////////////////////////////////
' TODO: verify this works
' 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
' /////////////////////////////////////////////////////////////////////////////
' Converts a chr$(13) delimited string
' into a 2-dimensional array.
' Usage:
' Dim StringArray(1 To 48, 1 To 128) As String
' StringTo2dArray StringArray(), GetMap$
' Version 2 with indexed array(row, columm)
' Renamed StringToArray to StringTo2dArray.
' See also: Array2dToString$
Sub StringTo2dArray (MyArray() As String, MyString As String)
Dim sDelim As String
ReDim arrLines(0) As String
Dim iRow As Integer
Dim iCol As Integer
Dim sChar As String
Dim iDim1 As Integer
Dim iDim2 As Integer
Dim iIndex1 As Integer
Dim iIndex2 As Integer
iDim1 = LBound(MyArray, 1)
iDim2 = LBound(MyArray, 2)
sDelim = Chr$(13)
split MyString, sDelim, arrLines()
For iRow = LBound(arrLines) To UBound(arrLines)
If iRow <= UBound(MyArray, 1) Then
For iCol = 1 To Len(arrLines(iRow))
If iCol <= UBound(MyArray, 2) Then
sChar = Mid$(arrLines(iRow), iCol, 1)
If Len(sChar) > 1 Then
sChar = Left$(sChar, 1)
Else
If Len(sChar) = 0 Then
sChar = "."
End If
End If
iIndex1 = iRow + iDim1
iIndex2 = (iCol - 1) + iDim2
MyArray(iIndex1, iIndex2) = sChar
'DebugPrint "MyArray(" + cstr$(iIndex1) + ", " + cstr$(iIndex2) + " = " + chr$(34) + sChar + chr$(34)
Else
' Exit if out of bounds
Exit For
End If
Next iCol
Else
' Exit if out of bounds
Exit For
End If
Next iRow
End Sub ' StringTo2dArray
Function StrJustifyRight$ (sValue As String, iWidth As Integer)
StrJustifyRight$ = Right$(String$(iWidth, " ") + sValue, iWidth)
End Function ' StrJustifyRight$
Function StrJustifyLeft$ (sValue As String, iWidth As Integer)
StrJustifyLeft$ = Left$(sValue + String$(iWidth, " "), iWidth)
End Function ' StrJustifyLeft$
Function StrJustifyCenter$ (sValue As String, iWidth As Integer)
Dim iLen0 As Integer
Dim iLen1 As Integer
Dim iLen2 As Integer
Dim iExtra As Integer
iLen0 = Len(sValue)
If iWidth = iLen0 Then
' no extra space: return unchanged
StrJustifyCenter$ = sValue
ElseIf iWidth > iLen0 Then
If IsOdd%(iWidth) Then
iWidth = iWidth - 1
End If
' center
iExtra = iWidth - iLen0
iLen1 = iExtra \ 2
iLen2 = iLen1 + (iExtra Mod 2)
StrJustifyCenter$ = String$(iLen1, " ") + sValue + String$(iLen2, " ")
Else
' string is too long: truncate
StrJustifyCenter$ = Left$(sValue, iWidth)
End If
End Function ' StrJustifyCenter$
' /////////////////////////////////////////////////////////////////////////////
' Use to pretty print TRUE and FALSE values.
Function TrueFalse$ (myValue)
If myValue = TRUE Then
TrueFalse$ = "TRUE"
Else
TrueFalse$ = "FALSE"
End If
End Function ' TrueFalse$
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GENERAL PURPOSE ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
I have made a number of refinements to vs GUI, reviewed in the docs file. About the only app not changed was the TTT with AI Game but included in zip, so the first vs GUI Thread may be abandoned and this one can replace it.
Here is the contents of the zip containing all updated apps:
First 5 files are 3 ttf Font Files I've tested code with, b+ Very Simple GUI.txt file or docs file that Introduces the vs GUI library and Controls System with Change plus Log of development, and direntry.h file that allows cross platform file and folders listings access.
Then 6 bas source files for apps:
#1 GUI Controls Editor.bas - helps get the Controls setup for a vs GUI app. Along with editing the Properties you can test the layout.
#5 GUI Practice Load.bas - is a file to practice with the Controls Editor.
#2 GUI Makeover Get Filename #4 is a handy file for Running, Killing, or Clipboard listing fully pathed Filenames.
#3 GUI makeover 3 Digit Color Color Picker.bas - is 3 digit system used to name colors for controls, the 3 digits are converted to RGB, making it simple to say and transfer color values. 1000 different shades can be designated with 3 digits.
#4 GUI TTT with AI.bas is just the unbeatable Tic Tac Toe game using GUI. You can compare to Fellippe's Inform version.
#6 Makeover #2 Kens Artillary B+ mod.bas is improved not only with larger text in GUI but also I got the AI working again and the computer will be a much tougher opponent!
Finally the last 2 files are the vs GUI.BI and .BM library code.
![[Image: 1screen.jpg]](https://i.ibb.co/yN3Nqh9/1screen.jpg)
)
