| Welcome, Guest |
You have to register before you can post on our site.
|
| Forum Statistics |
» Members: 499
» Latest member: Blayk
» Forum threads: 2,852
» Forum posts: 26,721
Full Statistics
|
| Latest Threads |
Glow Bug
Forum: Programs
Last Post: SierraKen
14 minutes ago
» Replies: 5
» Views: 46
|
Who wants to PLAY?
Forum: QBJS, BAM, and Other BASICs
Last Post: dbox
1 hour ago
» Replies: 13
» Views: 182
|
BAM Sample Programs
Forum: QBJS, BAM, and Other BASICs
Last Post: CharlieJV
3 hours ago
» Replies: 36
» Views: 1,966
|
Audio storage, stereo swi...
Forum: Programs
Last Post: Petr
9 hours ago
» Replies: 8
» Views: 349
|
_CONSOLEINPUT is blocking
Forum: General Discussion
Last Post: mdijkens
Yesterday, 12:24 PM
» Replies: 7
» Views: 125
|
Most efficient way to bui...
Forum: General Discussion
Last Post: ahenry3068
01-17-2025, 11:36 PM
» Replies: 9
» Views: 136
|
QBJS - ANSI Draw
Forum: QBJS, BAM, and Other BASICs
Last Post: madscijr
01-17-2025, 11:24 PM
» Replies: 4
» Views: 132
|
Fun with Ray Casting
Forum: a740g
Last Post: a740g
01-17-2025, 05:50 AM
» Replies: 10
» Views: 248
|
Very basic key mapping de...
Forum: SMcNeill
Last Post: a740g
01-17-2025, 02:33 AM
» Replies: 1
» Views: 54
|
Methods in types
Forum: General Discussion
Last Post: bobalooie
01-17-2025, 01:02 AM
» Replies: 0
» Views: 64
|
|
|
| some date/time/timestamp functions revisited |
|
Posted by: madscijr - 07-27-2022, 10:05 PM - Forum: Works in Progress
- Replies (7)
|
 |
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.
Code: (Select All) _TITLE "TimeStampFunctions"
' BOOLEAN VALUES
Const FALSE = 0
Const TRUE = Not FALSE
' 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
DateDiff## = fResult
End Function ' DateDiff##
' /////////////////////////////////////////////////////////////////////////////
Sub DateDiffTest
Dim in$
Cls
Print "Demonstration of Function DateDiff## (interval$, fDate1##, fDate2##)"
Print "--------------------------------------------------------------------"
DateDiffTest1 "s", "07-04-2022 12:00:00 PM", "07-04-2022 12:00:45 PM" ' 45s
DateDiffTest1 "s", "07/04/2022 12:00:00 PM", "07/04/2022 12:00:45 PM" ' 45s
DateDiffTest1 "s", "07-04-2022 12:00:00", "07-04-2022 12:00:45" ' 45s
DateDiffTest1 "s", "07/04/2022 12:00:00", "07/04/2022 12:00:45" ' 45s
Print
DateDiffTest1 "n", "07-04-2022 12:00:00 PM", "07-04-2022 12:12:34 PM" ' 754s
DateDiffTest1 "n", "07/04/2022 12:00:00 PM", "07/04/2022 12:12:34 PM" ' 754s
DateDiffTest1 "n", "07-04-2022 12:00:00", "07-04-2022 12:12:34" ' 754s
DateDiffTest1 "n", "07/04/2022 12:00:00", "07/04/2022 12:12:34" ' 754s
Print
DateDiffTest1 "h", "07-04-2022 12:00:00 PM", "07-04-2022 01:15:43 PM" ' 47743s
DateDiffTest1 "h", "07/04/2022 12:00:00 PM", "07/04/2022 01:15:43 PM" ' 47743s 1:15:43
DateDiffTest1 "h", "07-04-2022 12:00:00", "07-04-2022 13:15:43" ' 4543s 1:15:43
DateDiffTest1 "h", "07/04/2022 12:00:00", "07/04/2022 13:15:43" ' 4543s 1:15:43
Print
DateDiffTest1 "d", "07-04-2022 12:00:00 PM", "07-05-2022 01:15:43 PM" ' 134143s
DateDiffTest1 "d", "07/04/2022 12:00:00 PM", "07/05/2022 01:15:43 PM" ' 134143s 1:15:43
DateDiffTest1 "d", "07-04-2022 12:00:00", "07-05-2022 13:15:43" ' 94543s 26:15:43
DateDiffTest1 "d", "07/04/2022 12:00:00", "07/05/2022 13:15:43" ' 94543s 26:15:43
Input "PRESS ENTER TO CONTINUE"; in$
End Sub ' DateDiffTest
' /////////////////////////////////////////////////////////////////////////////
Sub DateDiffTest1 (interval$, date1$, date2$)
Dim fDiff As _Float
Dim sInterval As String
sInterval = GetTimeIntervalName$(interval$)
fDiff = DateDiff##(interval$, GetUnixTime##(date1$), GetUnixTime##(date2$))
Print _
StrPadLeft$(_Trim$(Str$(fDiff)), 8) + " " + _
StrPadRight$(sInterval, 7) + " " + _
"elapsed between " + _
StrPadRight$(date1$, 22) + " and " + _
StrPadRight$(date2$, 22)
End Sub ' DateDiffTest1
' /////////////////////////////////////////////////////////////////////////////
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 "---------------------------------------------------------------------"
' TEST DATES
AppendToStringArray arrDateTime$(), "01-01-0966 00:00:00"
AppendToStringArray arrDateTime$(), "01-01-1815 00:00:00"
AppendToStringArray arrDateTime$(), "01-01-1970 00:00:00"
AppendToStringArray arrDateTime$(), "01-01-2020 00:00:00"
AppendToStringArray arrDateTime$(), "01-01-2020 12:00:00 AM"
AppendToStringArray arrDateTime$(), "01-01-2020 12:00:00 PM"
AppendToStringArray arrDateTime$(), "01-01-2020 01:00:00 PM"
AppendToStringArray arrDateTime$(), "01-01-2020 11:59:59 PM"
AppendToStringArray arrDateTime$(), "01-02-2020 12:00:00 AM"
AppendToStringArray arrDateTime$(), "07-27-2022 12:00:00 PM"
AppendToStringArray arrDateTime$(), "07-27-2022 06:00:00 PM"
AppendToStringArray arrDateTime$(), "07-28-2022 00:00:00"
AppendToStringArray arrDateTime$(), "01-01-2023 00:00:00"
AppendToStringArray arrDateTime$(), "01-01-2525 00:00:00"
' GET CURRENT DATE/TIME
MyDateTime1$ = GetCurrentDateTime$("{mm}/{dd}/{yyyy} {hh}:{nn}:{ss} {ampm}")
fSeconds1 = GetUnixTime##(MyDateTime1$)
Print "Current date/time is " + MyDateTime1$ + " = " + _Trim$(Str$(fSeconds1)) + " seconds"
Print
' COMPARE TEST DATES
For iLoop1 = LBound(arrDateTime$) To UBound(arrDateTime$)
MyDateTime2$ = arrDateTime$(iLoop1)
fSeconds2 = GetUnixTime##(MyDateTime2$)
fDiffSeconds = fSeconds1 - fSeconds2
Print _
StrPadRight$(MyDateTime1$, 22) + _
" - " + _
StrPadRight$(MyDateTime2$, 22) + _
" = " + _
StrPadRight$(_Trim$(Str$(fSeconds1)), 12) + "s" + _
" - " + _
StrPadRight$(_Trim$(Str$(fSeconds2)), 12) + "s" + _
" = " + _
StrPadRight$(_Trim$(Str$(fDiffSeconds)), 12) + "s" + _
" = " + _
GetElapsedTime$(fDiffSeconds)
Next iLoop1
Input "PRESS ENTER TO CONTINUE"; in$
End Sub ' GetElapsedTimeTest
' /////////////////////////////////////////////////////////////////////////////
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$, "/", "-")
' Get seconds for date
iPos1 = InStr(MyDate$, "-")
iPos2 = InStr(iPos1 + 1, MyDate$, "-")
iMonth = Val(Left$(MyDate$, iPos1))
iDay = Val(Mid$(MyDate$, iPos1 + 1))
iYear = Val(Mid$(MyDate$, iPos2 + 1))
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
fDateSeconds = iDay * 24 * 60 * 60 ' Seconds are days * 24 hours * 60 minutes * 60 seconds
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##
End Function ' TimeStringToSeconds##
' /////////////////////////////////////////////////////////////////////////////
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
' PRINT "Current date time (simple format) = " + Chr$(34) + GetCurrentDateTime$("{yyyy}-{mm}-{dd} {rr}:{nn}:{ss}") + Chr$(34)
' PRINT "Current date time (US format) = " + Chr$(34) + GetCurrentDateTime$("{mm}/{dd}/{yyyy} {hh}:{nn}:{ss} {ampm}") + Chr$(34)
' PRINT "Filename timestamp = " + Chr$(34) + GetCurrentDateTime$("{yyyy}{mm}{dd}_{rr}{nn}{ss}") + Chr$(34)
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
' POPULATE TEMPLATE
result$ = sTemplate$
result$ = Replace$(result$, "{yyyy}", sYYYY$)
result$ = Replace$(result$, "{mm}", sMM$)
result$ = Replace$(result$, "{dd}", sDD$)
result$ = Replace$(result$, "{hh}", sHH$)
result$ = Replace$(result$, "{rr}", sHH24$)
result$ = Replace$(result$, "{nn}", sMI$)
result$ = Replace$(result$, "{ss}", sSS$)
result$ = Replace$(result$, "{ampm}", sAMPM$)
' 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
ReDim arrInteger(-1) As Integer
'DebugPrint "GetIntegerArrayFromDelimList " + _
' "MyString=" + chr$(34) + MyString + chr$(34) + ", " + _
' "sDelimiter=" + chr$(34) + sDelimiter + chr$(34) + ", " + _
' "iMinIndex=" + cstr$(iMinIndex) + ", " + _
' "arrInteger()"
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%
' /////////////////////////////////////////////////////////////////////////////
'Sub IsNumberTest
' Dim in$
' Cls
' IsNumberTest1 "1"
' IsNumberTest1 "01"
' IsNumberTest1 "001"
' IsNumberTest1 "-1"
' IsNumberTest1 "-01"
' IsNumberTest1 "-001"
' IsNumberTest1 "+1"
' IsNumberTest1 "+01"
' IsNumberTest1 "+001"
' IsNumberTest1 ".1"
' IsNumberTest1 ".01"
' IsNumberTest1 ".001"
' IsNumberTest1 ".10"
' IsNumberTest1 ".100"
' IsNumberTest1 "..100"
' IsNumberTest1 "100."
' Input "PRESS ENTER TO CONTINUE TEST";in$
' Cls
' IsNumberTest1 "0.10"
' IsNumberTest1 "00.100"
' IsNumberTest1 "000.1000"
' IsNumberTest1 "000..1000"
' IsNumberTest1 "000.1000.00"
' IsNumberTest1 "+1.00"
' IsNumberTest1 "++1.00"
' IsNumberTest1 "+-1.00"
' IsNumberTest1 "-1.00"
' IsNumberTest1 "-+1.00"
' IsNumberTest1 " 1"
' IsNumberTest1 "1 "
' IsNumberTest1 "1. 01"
' IsNumberTest1 "+1 "
'End Sub ' IsNumberTest
'Sub IsNumberTest1(MyString As String)
' Const cWidth = 16
' Dim sInput As String : sInput = left$(Chr$(34) + MyString + Chr$(34) + String$(cWidth, " "), cWidth)
' Dim sResult As String : sResult = right$(String$(2, " ") + _Trim$(Str$(IsNumber%(MyString))), 2)
' Print "IsNumber%(" + sInput + ") returns " + sResult
'End Sub ' IsNumberTest1
' /////////////////////////////////////////////////////////////////////////////
' 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$
' /////////////////////////////////////////////////////////////////////////////
' Pauses for iDS deciseconds (iDS * 100 ms)
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.
' Example:
' ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
' ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' sFileName = ProgramPath$ + ProgramName$ + ".OUT.txt"
' sText = "This is a test." + chr$(13) + "Here is line 2." + chr$(13) + "End."
' sError = PrintFile$(sFileName, sText, FALSE)
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))))
' Return the substring:
Text2 = strBefore + Add2 + strAfter
' Locate the next instance of [Find2]:
lngLocation = InStr(1, Text2, Find2)
' Next instance of [Find2]...
Wend
' OUTPUT:
Replace$ = Text2
End Function ' Replace$
'' /////////////////////////////////////////////////////////////////////////////
'
'Sub ReplaceTest
' Dim in$
'
' Print "-------------------------------------------------------------------------------"
' Print "ReplaceTest"
' Print
'
' Print "Original value"
' in$ = "Thiz iz a teZt."
' Print "in$ = " + Chr$(34) + in$ + Chr$(34)
' Print
'
' Print "Replacing lowercase " + Chr$(34) + "z" + Chr$(34) + " with " + Chr$(34) + "s" + Chr$(34) + "..."
' in$ = Replace$(in$, "z", "s")
' Print "in$ = " + Chr$(34) + in$ + Chr$(34)
' Print
'
' Print "Replacing uppercase " + Chr$(34) + "Z" + Chr$(34) + " with " + Chr$(34) + "s" + Chr$(34) + "..."
' in$ = Replace$(in$, "Z", "s")
' Print "in$ = " + Chr$(34) + in$ + Chr$(34)
' Print
'
' Print "ReplaceTest finished."
'End Sub ' ReplaceTest
' /////////////////////////////////////////////////////////////////////////////
' https://qb64phoenix.com/forum/showthread.php?tid=644
' From: bplus
' Date: 07-18-2022, 03:16 PM
' Here is a Round$ that acts the way you'd expect in under 100 LOC
' b = b + ...
Function Round$ (anyNumber, dp As Long)
' 5 and up at decimal place dp+1 > +1 at decimal place 4 and down > +0 at dp
' 2 1 0.-1 -2 -3 -4 ... pick dp like this for this Round$ Function
sn$ = N2S$(Str$(anyNumber + .5 * 10 ^ dp)) ' get rid of sci notation, steve trims it so next find dot
dot = InStr(sn$, ".")
If dot Then
predot = dot - 1
postdot = Len(sn$) - (dot + 1)
Else
predot = Len(sn$)
postdot = 0
End If
' xxx.yyyyyy dp = -2
' ^ dp
If dp >= 0 Then
Rtn$ = Mid$(sn$, 1, predot - dp) + String$(dp, "0")
Else
Rtn$ = Mid$(sn$, 1, predot) + "." + Mid$(sn$, dot + 1, -dp)
End If
If Rtn$ = "" Then
Round$ = "0"
Else
Round$ = Rtn$
End If
End Function ' Round$
'' /////////////////////////////////////////////////////////////////////////////
'
'Sub RoundTest
' Print Round$(.15, 0) ' 0
' Print Round$(.15, -1) ' .2
' Print Round$(.15, -2) ' .15
' Print Round$(.15, -3) ' .150
' Print
' Print Round$(3555, 0) ' 3555
' Print Round$(3555, 1) ' 3560
' Print Round$(3555, 2) ' 3600 'good
' Print Round$(3555, 3) ' 4000
' Print
' Print Round$(23.149999, -1) ' 23.1
' Print Round$(23.149999, -2) ' 23.15
' Print Round$(23.149999, -3) ' 23.150
' Print Round$(23.149999, -4) ' 23.1500
' Print
' Print Round$(23.143335, -1) ' 23.1 OK?
' Print Round$(23.143335, -2) ' 23.14
' Print Round$(23.143335, -3) ' 23.143
' Print Round$(23.143335, -4) ' 23.1433
' Print Round$(23.143335, -5) ' 23.14334
' Print
' Dim float31 As _Float
' float31 = .310000000000009
' Print Round$(.31, -2) ' .31
' Print Round$(.31##, -2)
' Print Round$(float31, -2)
'End Sub ' RoundTest
' /////////////////////////////////////////////////////////////////////////////
' 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
'' /////////////////////////////////////////////////////////////////////////////
'
'Sub SplitTest
' Dim in$
' Dim delim$
' ReDim arrTest$(0)
' Dim iLoop%
'
' delim$ = Chr$(10)
' in$ = "this" + delim$ + "is" + delim$ + "a" + delim$ + "test"
' Print "in$ = " + Chr$(34) + in$ + Chr$(34)
' Print "delim$ = " + Chr$(34) + delim$ + Chr$(34)
' split in$, delim$, arrTest$()
'
' For iLoop% = LBound(arrTest$) To UBound(arrTest$)
' Print "arrTest$(" + LTrim$(RTrim$(Str$(iLoop%))) + ") = " + Chr$(34) + arrTest$(iLoop%) + Chr$(34)
' Next iLoop%
' Print
' Print "Split test finished."
'End Sub ' SplitTest
'' /////////////////////////////////////////////////////////////////////////////
'
'Sub SplitAndReplaceTest
' Dim in$
' Dim out$
' Dim iLoop%
' ReDim arrTest$(0)
'
' Print "-------------------------------------------------------------------------------"
' Print "SplitAndReplaceTest"
' Print
'
' Print "Original value"
' in$ = "This line 1 " + Chr$(13) + Chr$(10) + "and line 2" + Chr$(10) + "and line 3 " + Chr$(13) + "finally THE END."
' out$ = in$
' out$ = Replace$(out$, Chr$(13), "\r")
' out$ = Replace$(out$, Chr$(10), "\n")
' out$ = Replace$(out$, Chr$(9), "\t")
' Print "in$ = " + Chr$(34) + out$ + Chr$(34)
' Print
'
' Print "Fixing linebreaks..."
' in$ = Replace$(in$, Chr$(13) + Chr$(10), Chr$(13))
' in$ = Replace$(in$, Chr$(10), Chr$(13))
' out$ = in$
' out$ = Replace$(out$, Chr$(13), "\r")
' out$ = Replace$(out$, Chr$(10), "\n")
' out$ = Replace$(out$, Chr$(9), "\t")
' Print "in$ = " + Chr$(34) + out$ + Chr$(34)
' Print
'
' Print "Splitting up..."
' split in$, Chr$(13), arrTest$()
'
' For iLoop% = LBound(arrTest$) To UBound(arrTest$)
' out$ = arrTest$(iLoop%)
' out$ = Replace$(out$, Chr$(13), "\r")
' out$ = Replace$(out$, Chr$(10), "\n")
' out$ = Replace$(out$, Chr$(9), "\t")
' Print "arrTest$(" + cstr$(iLoop%) + ") = " + Chr$(34) + out$ + Chr$(34)
' Next iLoop%
' Print
'
' Print "SplitAndReplaceTest finished."
'End Sub ' SplitAndReplaceTest
' /////////////////////////////////////////////////////////////////////////////
' 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 StrPadLeft$ (sValue As String, iWidth As Integer)
StrPadLeft$ = Right$(String$(iWidth, " ") + sValue, iWidth)
End Function ' StrPadLeft$
' /////////////////////////////////////////////////////////////////////////////
Function StrJustifyRight$ (sValue As String, iWidth As Integer)
StrJustifyRight$ = Right$(String$(iWidth, " ") + sValue, iWidth)
End Function ' StrJustifyRight$
' /////////////////////////////////////////////////////////////////////////////
Function StrPadRight$ (sValue As String, iWidth As Integer)
StrPadRight$ = Left$(sValue + String$(iWidth, " "), iWidth)
End Function ' StrPadRight$
' /////////////////////////////////////////////////////////////////////////////
Function StrJustifyLeft$ (sValue As String, iWidth As Integer)
StrJustifyLeft$ = Left$(sValue + String$(iWidth, " "), iWidth)
End Function ' StrJustifyLeft$
' /////////////////////////////////////////////////////////////////////////////
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%
Function StrJustifyCenter$ (sValue As String, iWidth As Integer)
Dim iLen0 As Integer
Dim iLen1 As Integer
Dim iLen2 As Integer
Dim iExtra As Integer
iLen0 = Len(sValue)
If iWidth = iLen0 Then
' no extra space: return unchanged
StrJustifyCenter$ = sValue
ElseIf iWidth > iLen0 Then
If IsOdd%(iWidth) Then
iWidth = iWidth - 1
End If
' center
iExtra = iWidth - iLen0
iLen1 = iExtra \ 2
iLen2 = iLen1 + (iExtra Mod 2)
StrJustifyCenter$ = String$(iLen1, " ") + sValue + String$(iLen2, " ")
Else
' string is too long: truncate
StrJustifyCenter$ = Left$(sValue, iWidth)
End If
End Function ' StrJustifyCenter$
' /////////////////////////////////////////////////////////////////////////////
' 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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' #REFERENCE
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' SOME USEFUL STUFF FOR REFERENCE:
' Type Name Type suffix symbol Minimum value Maximum value Size in Bytes
' --------------------- ------------------ ---------------------------- -------------------------- -------------
' _BIT ` -1 0 1/8
' _BIT * n `n -128 127 n/8
' _UNSIGNED _BIT ~` 0 1 1/8
' _BYTE %% -128 127 1
' _UNSIGNED _BYTE ~%% 0 255 1
' INTEGER % -32,768 32,767 2
' _UNSIGNED INTEGER ~% 0 65,535 2
' LONG & -2,147,483,648 2,147,483,647 4
' _UNSIGNED LONG ~& 0 4,294,967,295 4
' _INTEGER64 && -9,223,372,036,854,775,808 9,223,372,036,854,775,807 8
' _UNSIGNED _INTEGER64 ~&& 0 18,446,744,073,709,551,615 8
' SINGLE ! or none -2.802597E-45 +3.402823E+38 4
' DOUBLE # -4.490656458412465E-324 +1.797693134862310E+308 8
' _FLOAT ## -1.18E-4932 +1.18E+4932 32(10 used)
' _OFFSET %& -9,223,372,036,854,775,808 9,223,372,036,854,775,807 Use LEN
' _UNSIGNED _OFFSET ~%& 0 18,446,744,073,709,551,615 Use LEN
' _MEM none combined memory variable type N/A Use LEN
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' @REFERENCE
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
|
|
| Andross from Star Fox |
|
Posted by: SierraKen - 07-26-2022, 05:59 PM - Forum: Programs
- Replies (1)
|
 |
Someone named Joshua Dickerson figured this out back in the 90's and posted it online, I'm guessing the newsgroup comp.lang.basic.misc where I used to hang out.
He made one of the faces and later on I added some more to the screen. They rotate. I don't know anything about how he made this but it's pretty cool so I thought I would share it.
Andross is the bad guy from the Super Nintendo game Star Fox.
Code: (Select All) 'By Joshua Dickerson
'
DECLARE SUB InitProgram ()
DECLARE SUB MainLoop ()
DECLARE SUB Calc3D ()
DECLARE SUB Rotation ()
DECLARE SUB DrawObject ()
'
Dim Shared Lines, World(500, 3)
Dim Shared X, Y, Z, sX, sY, Xa, Ya, Za, sXs, sYs, D
Dim Shared R1, R2, R3, Sr1, Sr2, Sr3, Cr1, Cr2, Cr3, mX, mY, mZ, Eye
'
Read Lines
For I = 1 To Lines
For J = 1 To 3
Read World(I, J)
Next
Next
'
InitProgram
MainLoop
Screen 0
End
'
'CUBE LOOKING THINGY
'
'EMPEROR ANDROSS (STAR FOX)
Data 142
'
'ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄNOSEÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
Data 5,-4,10,-5,-4,10,-5,-4,10,-5,-25,10
Data -5,-25,10,0,-52,0,0,-52,0,5,-25,10
Data 5,-25,10,5,-4,10,5,-25,10,10,-18,2
Data 10,-18,2,10,2,2,10,2,2,5,-4,10
Data 10,2,2,-10,2,2,-10,2,2,-5,-4,10
Data -10,2,2,-10,-18,2,-10,-18,2,-5,-25,10
'
'ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄMOUTHÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
Data -10,2,2,-28,26,0,-10,2,2,0,14,5
Data 0,14,5,10,2,2,28,26,0,10,2,2
Data -28,26,0,0,14,5,0,14,5,28,26,0
Data -28,26,0,0,18,6,0,18,6,28,26,0
Data -28,26,0,0,31,6,0,31,6,28,26,0
Data 0,14,5,0,18,6,-28,26,0,0,36,5
Data 0,36,5,28,26,0,0,31,6,0,36,5
Data -8,47,0,0,36,5,0,36,5,8,47,0
'
'ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄOUTLINE OF FACEÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
Data 0,-52,0,-26,-47,0,-26,-47,0,-37,-32,0
Data -37,-32,0,-37,-6,0,-37,-6,0,-28,26,0
Data -28,26,0,-8,47,0,-8,47,0,8,47,0
Data 8,47,0,28,26,0,28,26,0,37,-6,0
Data 37,-6,0,37,-32,0,37,-32,0,26,-47,0
Data 26,-47,0,0,-52,0
'
'ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄFOREHEADÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
Data 0,-52,0,-23,-33,10,-23,-33,10,-5,-25,10
Data -26,-47,0,-23,-33,10,-37,-32,0,-23,-33,10
Data -37,-18,0,-23,-33,10,-10,-18,2,-23,-33,10
Data 0,-52,0,23,-33,10,23,-33,10,5,-25,10
Data 26,-47,0,23,-33,10,37,-32,0,23,-33,10
Data 37,-18,0,23,-33,10,23,-33,10,10,-18,2
'
'ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄEYES + CHEEKSÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
Data -37,-18,0,-23,-26,12,-23,-26,12,-10,-18,2
Data -37,-18,0,-23,-13,10,-23,-13,10,-10,-18,2
Data -37,-18,0,-23,-17,12,-23,-17,12,-10,-18,2
Data -23,-33,10,-23,-26,12,-23,-17,12,-23,-13,10
Data -10,2,2,-23,-13,10,-23,-13,10,-37,-6,0
Data 37,-18,0,23,-26,12,23,-26,12,10,-18,2
Data 37,-18,0,23,-13,10,23,-13,10,10,-18,2
Data 37,-18,0,23,-17,12,23,-17,12,10,-18,2
Data 23,-33,10,23,-26,12,23,-17,12,23,-13,10
Data 10,2,2,23,-13,10,23,-13,10,37,-6,0
'
Sub Calc3D
'
X = -1 * X: Xa = Cr1 * X - Sr1 * Z: Za = Sr1 * X + Cr1 * Z
X = Cr2 * Xa + Sr2 * Y: Ya = Cr2 * Y - Sr2 * Xa: Z = Cr3 * Za - Sr3 * Ya
Y = Sr3 * Za + Cr3 * Ya: X = X + mX: Y = Y + mY: Z = Z + mZ: sX = D * X / Z
sY = D * Y / Z
'
End Sub
'
Sub DrawObject
'
Rotation
For I = 1 To Lines Step 2
X = World(I, 1)
Y = World(I, 2)
Z = World(I, 3)
Calc3D
sXs = sX: sYs = sY
'
X = World(I + 1, 1)
Y = World(I + 1, 2)
Z = World(I + 1, 3)
Calc3D
For ty = 1 To 100 Step 80
For tt = -100 To 150 Step 60
Rem LINE (sXs, sYs)-(sX, sY), Eye
Line (sXs + tt, sYs + ty)-(sX + tt, sY + ty), Eye
Next tt
Next ty
Next
'
End Sub
'
Sub InitProgram
'
Screen 9, 1, 0, 1
Window (-200, -150)-(200, 150)
View (8, 9)-(632, 341), 0, 15
Cls 'PAGE 0
'
Screen 9, 1, 1, 0
Window (-200, -150)-(200, 150)
View (8, 9)-(632, 341), 0, 15
Cls 'PAGE 1
'
D = 1200 'View point and rotation values
mZ = -1500
mX = -5
R1 = 0
R2 = 0
R3 = .3
'
End Sub
'
Sub MainLoop
'
While InKey$ = ""
_Limit 10
'R1 = R1 + RND(1) * .05: IF R1 > 6.28 THEN R1 = 0
'R2 = R2 + RND(1) * .05: IF R2 > 6.28 THEN R2 = 0
'R3 = R3 + RND(1) * .05: IF R3 > 6.28 THEN R3 = 0
R1 = R1 + .1: If R1 > 6.28 Then R1 = 0
'
Cls: Eye = 7: DrawObject
Page = Abs(Page = 0) 'Page switching is used to hide the drawing
Screen 9, 1, 1 - Page, Page 'process so the image looks smooth.
Wend
'
End Sub
'
Sub Rotation
'
Sr1 = Sin(R1): Sr2 = Sin(R2): Sr3 = Sin(R3)
Cr1 = Cos(R1): Cr2 = Cos(R2): Cr3 = Cos(R3)
'
End Sub
|
|
|
|
| _INTEGER64 calculation |
|
Posted by: vinceg2022 - 07-25-2022, 09:12 PM - Forum: Learning Resources and Archives
- Replies (8)
|
 |
Hi all
Just a quick query.
Why does this code produce these results
billion&& = 10000000000
PRINT billion&&
billionCalc&& = 100000 * 100000
PRINT billionCalc&&
10000000000
1410065408
Is it something to do with the type that would be used for the 2 x 100000 values are not _INTEGER64, so it miscalculates them, or am I just not getting it.
|
|
|
|
| Welcome Everyone ! |
|
Posted by: MasterGy - 07-25-2022, 03:16 PM - Forum: MasterGy
- Replies (4)
|
|
Hello !
Thanks to SMcNEIL for creating a separate folder for me !
Unfortunately, I lost a lot of the smaller code, but the bigger works are all there.
I'm short on time right now and I've been patching old programs. You already know almost all of them, but the latest versions will always appear here. The packages also contain the source codes. It also contains an exe that I generated under Win7, with QB64 1.2.
If you have a different operating system, you can create an EXE from the source code.
Have fun !
|
|
|
|
| Manually resizing with $RESIZE:ON |
|
Posted by: SMcNeill - 07-24-2022, 08:28 PM - Forum: Learning Resources and Archives
- Replies (7)
|
 |
As I posted in a different thread in the Help area, I thought I'd go ahead and share these two demos here to help preserve them for the future.
Demo 1 here is an example of how to use $RESIZE:ON to adjust your program's width and height, without adjusting the fontsize or scale. This works basically like the IDE does, and resizes the number of rows and columns which you have available for use with the program:
Code: (Select All) $Resize:On
activeScreen = _NewImage(80, 25, 0) 'standard screen 0
Screen activeScreen
DrawBorder
_Delay .25
clearInitialResize = _Resize 'clear thr size change from where QB64 first starts up
Do
If _Resize Then
tempScreen = _NewImage(_ResizeWidth \ _FontWidth, _ResizeHeight \ _FontHeight, 0)
Screen tempScreen
_FreeImage activeScreen
activeScreen = tempScreen
DrawBorder
End If
Loop Until _KeyHit
System
Sub DrawBorder
Color 4
For x = 1 To _Width
Locate 1, x: Print Chr$(219);
Locate _Height, x: Print Chr$(219);
Next
For y = 1 To _Height
Locate y, 1: Print Chr$(219);
Locate y, _Width: Print Chr$(219);
Next
Color 15
Locate _Height \ 2, _Width \ 2 - 12: Print "Resize On, Non-Scale Demo"
Locate _Height \ 2 + 2, 3: Print "Width:"; _Width
Locate _Height \ 2 + 3, 3: Print "Height:"; _Height
End Sub
Demo 2 here works in a very similar manner, except it uses two screens. The activeScreen always remains the same size -- 640 x 400 pixels, in this case, and the viewScreen changes size and scales the image on the screen to suit whatever size we expand it to:
Code: (Select All) $Resize:On
activeScreen = _NewImage(640, 400, 256) '256 color screen so we can use _PUTIMAGE for scaling
viewScreen = _NewImage(640, 400, 256) 'a second screen to scale to
Screen viewScreen
_Dest activeScreen: _Source activeScreen
DrawBorder
_Delay .25
clearInitialResize = _Resize 'clear thr size change from where QB64 first starts up
Do
If _Resize Then
tempScreen = _NewImage(_ResizeWidth, _ResizeHeight, 256)
Screen tempScreen
_FreeImage viewScreen
viewScreen = tempScreen
End If
_PutImage , activeScreen, viewScreen
_Limit 30
Loop Until _KeyHit
System
Sub DrawBorder
Color 4
For x = 1 To _Width \ _FontWidth
Locate 1, x: Print Chr$(219);
Locate _Height \ _FontHeight, x: Print Chr$(219);
Next
For y = 1 To _Height \ _FontHeight
Locate y, 1: Print Chr$(219);
Locate y, _Width \ _FontWidth: Print Chr$(219);
Next
Color 15
Locate 3, 3: Print "Resize On, Scale-Size Demo"
Locate 5, 3: Print "Width:"; _Width
Locate 6, 3: Print "Height:"; _Height
End Sub
Note that neither of these demos maintain aspect ratio, so images may stretch or skew depending on how you resize them. If this isn't your desired effect, then you'd have to adjust for that inside the program with a few IF statements manually. 
|
|
|
|
Making QB64 work on Linux |
|
Posted by: mnrvovrfc - 07-22-2022, 11:50 PM - Forum: General Discussion
- Replies (18)
|
 |
Hello. Used QB64 since v0.86 approximately, was on the oldest of the forums for a while and contributed a few programs. Used v0.98 a lot but turned off by its bugginess and the inability to play ancient tracker modules. I created a few multimedia apps but not patient enough to do games which is what I want to do the most. I like creating and listening to electronic music on my computer.
TL;DR
While I have an Internet connection for a short time, after a pause of eight years, decided to test "Phoenix Edition" on various Linux distros. Tried so far with Fedora (v35 GNOME and v36 MATE and XFCE), Solus (MATE) and Void ("glibc" XFCE). One will need to do a bit of investigating so it works properly on Solus. Do not pick "musl" branch for Void because it will not work; it's 64-bit only and might be counterproductive to use a programming system like this. AV Linux is installed on another external disk but might not last long because I cannot use the touchpad, cannot change a lot of things because I purposely run it live with persistence. Tried many other distros like Bunsen Labs Lithium, Linux Mint, Mageia, OpenSUSE "Tumbleweed", Salix, usually failed because they insisted being installed only to an internal hard drive. Also had Ubuntu Studio v22.04 but my computer isn't powerful enough for it. I have Manjaro installed on hard disk and probably QB64 works there too (and for Arch) but I picked a package for some other BASIC. That one might be temporary, though, I don't like the desktop environment I chose for it (same as for Ubuntu Studio).
DISCLAIMER: I don't do "VirtualBox" or alike, it doesn't work on my computer. It might affect what could be done with QB64.
This programming system works without problems on Porteus, at least on my side. It only requires the download of "05-devel.xzm".
Info about Porteus GNU/Linux here:
https://distrowatch.com/table.php?distribution=porteus
(linked that page because the "standard" site is not "https" and some people are touchy about that)
Note this will not work on Slackware or whatever else is based on it! Do not try it!!! I am able to list precisely the shared libraries required for "qb64" and any ELF executable created with this programming system. Used "readelf" program.
Code: (Select All) libGL.so.1
libGLU.so.1
libX11.so.6
libc.so.6
libgcc_s.so.1
libm.so.6
libstdc++.so.6
However on eg. Slackware you will also need the header files, at least those that correspond to "Freeglut", "libX11" and the font-handling libraries. I'm sorry, I don't have any information about that. I only wanted to report a successful use of QB64 on a distro less known than Fedora, the 'untus and others.
BTW note to the developers. This is to cause a QB64-created program to be able to report runtime errors. You should consider changing the "MessageBox" code so on Linux, it searches for "xmessage" and if it doesn't find it, use "zenity" instead. Some distros don't come with "xmessage" and no easy way to acquire it, Solus is one of them. On Fedora the "xmessage" dialog might look strange and after that, it complains on terminal about a font missing "charsets". I made the change to "libqb.cpp" but I'm not going to post the portion with changes unless I'm asked for it.
One more thing, sorry if I keep writing. A BMP file could be loaded successfully but each time, it errors on the terminal about 16-bit files not supported. "_DEFLATE" and "_INFLATE" do not work, but "zlib" library seems to exist. Thank you for implementing "SHELL", this is very helpful and before that I had to write my own routine which was clunky.
|
|
|
|
| A neat little MS-DOS emulator |
|
Posted by: JRace - 07-22-2022, 06:27 PM - Forum: General Discussion
- Replies (8)
|
 |
Don't know if anyone other than myself is interested, but TAKEDA, toshiya has a site full of computer emulators, including a really cool, *small* MS-DOS emulator.
It is a single-file emulator which runs DOS EXEs directly, with no need for any subdirectories or configurations.
The download ZIP actually contains many builds, each emulating a different CPU. 32-bit and 64-bit versions are included for each emulator.
It is for Windows only (runs fine on Windows 7 Pro), and runs text-mode DOS programs with no graphics or sound.
It's a command-line program, but you can drag-and-drop an EXE file onto it to run.
I use it to make various DOS compilers and interpreters run under Win. It even works with SOME multi-file compiler suites, such as Quick C and Small C. It can be much more handy than firing up DOSBox just to quickly check something in QB or GWB.
It has a command-line switch which allows you to make a single-file Windows executable of your DOS program.
(One problem, though: Some DOS programs (e.g.QBasic) can have trouble finding a file you want to open (even though the file open dialog shows it!), so you must "take the long way" to it by navigating to the directory which holds the file.
http://takeda-toshiya.my.coocan.jp/
(The site is in Japanese with a little English, but it's easy to find one's way around.)
![[Image: 2022-07-22-130953.png]](https://i.ibb.co/8jPQM19/2022-07-22-130953.png)
free ssl image hosting
|
|
|
|
|
![[Image: Calculator-by-Sierra-Ken.jpg]](https://i.ibb.co/37H2kzT/Calculator-by-Sierra-Ken.jpg)
You can copy from any program and paste it to the calculator, or copy from the calculator and paste it to itself. Tell me what you think, thanks.