Posts: 343
Threads: 24
Joined: Jul 2022
Reputation:
20
Step1 Presentation of project
Just to keep in theme of the dictionary structure data made by array in QB64, here we attempt to build a dictionary with hash index.
We start from here
Code: (Select All) 'Assosziatives Array: https://jeff.win/qbhash/
'28. Feb. 2023
Type element
tag As String * 10
value As String * 10
End Type
Dim Shared aa(10) As element
Dim Shared aalast ' Last occupied AA() element
setvalue "foo", "bar"
setvalue "foo", "coffee"
Print getvalue$("foo") ' prints bar also after adding coffee
End
Function getvalue$ (tag As String)
tag = LTrim$(RTrim$(tag))
tag = tag + String$(10 - Len(tag), " ")
For i = 0 To aalast
If (tag = aa(i).tag) Then
getvalue$ = aa(i).value
Exit Function
End If
Next
End Function
Sub setvalue (tag As String, value As String)
aa(aalast).tag = tag
aa(aalast).value = value
aalast = aalast + 1
End Sub
this code has been taken from this article on this webpage QBHash
this demo is very simple and with many limitations that cannot let us think about it like a real dictonary data structure.
What is the data structure coded has these features: you can store more than one value linked to the tag value; moreover these collisions (new values linked to the tag) are stored into different cells of the array. The author to get this result used an external index/counter (AALAST). In the while the GetValue SUB is broken because it returns only the first value linked to the string index.
However here more information.
Issues:
1 the value stored can fit only 10 characters (ASCII values)
Code: (Select All) Type element
tag As String * 10 ' <----- hash value stored as a string of 10 characters that is searched sequentially
value As String * 10 '<----- max 10 character for value
End Type
2 the hash index is not direct but searched rowly from the start to the end of arrayList
Code: (Select All) Function getvalue$ (tag As String)
tag = LTrim$(RTrim$(tag))
tag = tag + String$(10 - Len(tag), " ")
For i = 0 To aalast
If (tag = aa(i).tag) Then
getvalue$ = aa(i).value
Exit Function
End If
Next
End Function
3 the store value routine does not avoid that the hashindex value has no duplicates.
Code: (Select All) Sub setvalue (tag As String, value As String)
aa(aalast).tag = tag
aa(aalast).value = value
aalast = aalast + 1
End Sub
4 the search value routine get the first cell of the array that has the hashvalue searched
Code: (Select All) If (tag = aa(i).tag) Then
getvalue$ = aa(i).value
Exit Function
End If
Now we try to work to solve these issues.
Posts: 343
Threads: 24
Joined: Jul 2022
Reputation:
20
Step 2 transformation of the Hash Table
in the first post we have a Hash Table that uses an UDT to store key and value, the access to the value is performed with a sequential search until we find the wanted key and so we can get the value related. This hash table managed the collision shifting the next value associated for the same key to the next available cell empty . When we search for a key we get the first value that has been stored in the table at the lower/higher position depending from the order of reading of the table ascending/descending.
In this second post we transform the original Hash Table making variable the lenght of the index and the lenght of value stored. Moreover after populating the hash table with a FOR loop, the Hash table has a direct access to the value using the index without any FOR/DO/WHILE sequential search . For now the collision activates an overwriting of the previous value. But this is one of the 3 available solutions (:overwrite, shifting and listing) for this kind of datatype
IMHO code has enough comments to be almost clear:
Code: (Select All) '----------model of hash table with string index------------
Type HashTable
index As String '<---variable lenght of string index
value As String '<--- variable lenght of value stored
End Type
'-----------------------------------------------------------
Dim HashString(0 To 10) As HashTable '<--- instance of hashtable
' ------------ INITIALIZATION made using a single character ------
For c = 64 To 74 Step 1
Call StoreValue(Chr$(c), String$(Int(c / 10), (c + 1)), HashString())
Next
'-----------------------------------------------------------------
'----------------SHOWING hashtable filled---------------
For c = 0 To 10
Print c, HashString(c).index, HashString(c).value
Next c
'-------------------------------------------------------
'extracting some value directly from table without FOR loop and comparison
Print GetValue$("A", HashString())
Print GetValue$("E", HashString())
Print GetValue$("H", HashString())
End
'-------------- subroutines/ Functions' area --------------------
' this function returns the value linked in the table H
' to the index IND
Function GetValue$ (ind As String, H() As HashTable)
GetValue$ = H(GetIndex(ind)).value
End Function
'this subroutine stores a value VALU linked to the index IND
' in the hashtable HASH
' In this implementation the SUB overwrites thre previouse value
' stored into the hashtable if it happens a collision
' but this behaviour can be easily changed for storing the new value
' or in OPEN (searching the next cell with no value into it)
' or in list adding the value to the string already staying in hashtable
Sub StoreValue (ind As String, valu As String, Hash() As HashTable)
Hash(GetIndex(ind)).index = ind
Hash(GetIndex(ind)).value = valu
End Sub
' this function calculates the Hash value for storing in the hashtable
' the linked value
Function GetIndex% (i As String)
Dim a As Integer, k As _Integer64, hash As _Integer64
k = 1
For a = 1 To Len(i)
hash = hash + ((Asc(i, a)) * k)
k = k * 10
Next a
GetIndex% = hash Mod 10
End Function
Welcome ideas, constructive criticisms, other code demonstrations and all you, kind people of QB64, want to share about these arguments.
Posts: 714
Threads: 102
Joined: Apr 2022
Reputation:
14
Great post Tempodi.
Here is an implementation by luke on the old qb64.org site, which I added a menu and test harness to.
I finally got arround to adding a logical delete operation.
I'll have to compare code to see if & how the general method used differs from your examples,
and maybe do a speed test to see if there is any difference.
Code: (Select All) Dim Shared m_sTitle As String: m_sTitle = "dictionary-test"
_Title m_sTitle ' display in the Window's title bar
' QB64 implementation of a dictionary / associative array,
' based on an algorithm by luke at qb64.org.
Option _Explicit
Const FALSE = 0
Const TRUE = Not FALSE
Const cIntDictSize = 1000
Const cIntLookupSize = 32767
' Object to store in the symbol table
Type DictionaryType
key As String
intValue As Integer
lngValue As Long
strValue As String
IsDeleted As Integer
End Type ' DictionaryType
Dim Shared ProgramPath$: ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared ProgramName$: ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' Actual stored obejcts
Dim Shared m_arrDict(cIntDictSize) As DictionaryType
' Mapping between hash and index
Dim Shared m_arrLookup(cIntLookupSize) As Long
Dim Shared m_iLastIndex As Long
Dim in$
DictionaryTest1
Print ProgramName$ + " finished."
Input "PRESS <ENTER> TO EXIT", in$
System ' return control to the operating system
End
' /////////////////////////////////////////////////////////////////////////////
Sub DictionaryTest1
Dim entry As DictionaryType
Dim lngID As Long
Dim bResult As Integer
Dim bFinished As Integer
Dim key$
Dim iLoop As Long
Dim in$
Dim in2$
Dim sValue$
Dim strValue$
Dim intValue%
Dim lngValue&
Screen _NewImage(800, 600, 32): _ScreenMove 0, 0
Cls
entry.key = "c"
entry.lngValue = 333
entry.strValue = "c1"
entry.intValue = 3
entry.IsDeleted = FALSE
WriteDictionary entry
entry.key = "a"
entry.lngValue = 111
entry.strValue = "a2"
entry.intValue = 1
entry.IsDeleted = FALSE
WriteDictionary entry
entry.key = "b"
entry.lngValue = 222
entry.strValue = "b3"
entry.intValue = 2
entry.IsDeleted = FALSE
WriteDictionary entry
Print "Table has " + _Trim$(Str$(m_iLastIndex)) + " entries:"
For iLoop = 1 To m_iLastIndex
Print " " + m_arrDict(iLoop).key
Next iLoop
Do
Print
Print "1. Show all values"
Print "2. Read value"
Print "3. Write value"
Print "4. Delete value"
Input "Action? (blank to exit) ", in2$: in$ = Left$(in2$, 1)
If in$ = "1" Then
' SHOW ALL VALUES
Print "Table has " + _Trim$(Str$(m_iLastIndex)) + " entries:"
' SHOWS PHYSICAL CONTENTS BUT MISSES LOGICAL DELETION
For iLoop = 1 To m_iLastIndex
If GetID&(m_arrDict(iLoop).key) > 0 Then
If m_arrDict(iLoop).IsDeleted = FALSE Then
Print "Item #" + _Trim$(Str$(iLoop))
Else
Print "*DELETED* Item #" + _Trim$(Str$(iLoop))
End If
Print " .key = " + Chr$(34) + m_arrDict(iLoop).key + Chr$(34)
Print " .lngValue = " + _Trim$(Str$(m_arrDict(iLoop).lngValue))
Print " .strValue = " + Chr$(34) + m_arrDict(iLoop).strValue + Chr$(34)
Print " .intValue = " + _Trim$(Str$(m_arrDict(iLoop).intValue))
End If
Next iLoop
ElseIf in$ = "2" Then
' FIND + DISPLAY ONE VALUE
Input "Item to find? ", key$
If Len(key$) > 0 Then
lngID = GetID&(key$)
If lngID > 0 Then
If m_arrDict(iLoop).IsDeleted = FALSE Then
Print "Item " + Chr$(34) + key$ + Chr$(34) + " values:"
Else
Print "*DELETED* Item " + Chr$(34) + key$ + Chr$(34) + " values:"
End If
Print " .lngValue = " + _Trim$(Str$(m_arrDict(lngID).lngValue))
Print " .strValue = " + Chr$(34) + m_arrDict(lngID).strValue + Chr$(34)
Print " .intValue = " + _Trim$(Str$(m_arrDict(lngID).intValue))
Else
Print "Item " + Chr$(34) + key$ + Chr$(34) + " not found in dictionary."
End If
End If
ElseIf in$ = "3" Then
' WRITE VALUE (OVERWRITE IF EXISTING, ELSE INSERT)
Input "Key? ", key$
If Len(key$) > 0 Then
bFinished = FALSE
' Prompt for a Long Integer
If TRUE = TRUE Then
Do
Input "lngValue? (blank to cancel) ", sValue$
If Len(sValue$) > 0 Then
If IsNum%(sValue$) = TRUE Then
lngValue& = Val(sValue$)
bFinished = TRUE
Else
Print Chr$(34) + in2$ + Chr$(34) + " is not a valid number."
End If
Else
Exit Do
End If
Loop Until bFinished = TRUE
End If
' Prompt for a String
If bFinished = TRUE Then
Do
Input "strValue? (blank to cancel) ", strValue$
If Len(strValue$) > 0 Then
bFinished = TRUE
Else
Exit Do
End If
Loop Until bFinished = TRUE
End If
' Prompt for an Integer
If bFinished = TRUE Then
Do
Input "intValue? (blank to cancel) ", sValue$
If Len(sValue$) > 0 Then
If IsNum%(sValue$) = TRUE Then
intValue% = Val(sValue$)
bFinished = TRUE
Else
Print Chr$(34) + in2$ + Chr$(34) + " is not a valid number."
End If
Else
Exit Do
End If
Loop Until bFinished = TRUE
End If
' Write the values
If bFinished = TRUE Then
lngID = GetID&(key$)
If lngID > 0 Then
If m_arrDict(lngID).IsDeleted = FALSE Then
Print "Item " + Chr$(34) + key$ + Chr$(34) + " found in dictionary. Updating."
Else
Print "*DELETED* Item " + Chr$(34) + key$ + Chr$(34) + " found in dictionary. Updating."
End If
m_arrDict(lngID).lngValue = lngValue&
m_arrDict(lngID).strValue = strValue$
m_arrDict(lngID).intValue = intValue%
m_arrDict(lngID).IsDeleted = FALSE
Else
Print "Item " + Chr$(34) + key$ + Chr$(34) + " not found in dictionary. Inserting."
entry.key = key$
entry.lngValue = lngValue&
entry.strValue = strValue$
entry.intValue = intValue%
entry.IsDeleted = FALSE
WriteDictionary entry
End If
' Read back the values
Print "READING BACK VALUES:"
lngID = GetID&(key$)
If lngID > 0 Then
If m_arrDict(lngID).IsDeleted = FALSE Then
Print "Item " + Chr$(34) + key$ + Chr$(34) + " values:"
Else
Print "*DELETED* Item " + Chr$(34) + key$ + Chr$(34) + " values:"
End If
Print " .lngValue =" + _Trim$(Str$(m_arrDict(lngID).lngValue))
Print " .strValue =" + Chr$(34) + m_arrDict(lngID).strValue + Chr$(34)
Print " .intValue =" + _Trim$(Str$(m_arrDict(lngID).intValue))
Else
Print "Item " + Chr$(34) + key$ + Chr$(34) + " not found in dictionary."
End If
End If
End If
ElseIf in$ = "4" Then
' LOGICAL DELETE
Input "Item to delete? ", key$
If Len(key$) > 0 Then
lngID = GetID&(key$)
If lngID > 0 Then
Print "Logically deleting item " + Chr$(34) + key$ + Chr$(34) + "."
bResult = DeleteID(key$)
If bResult = TRUE Then
Print "Verifying deletion."
lngID = GetID&(key$)
Print "lngID=" + _Trim$(Str$(lngID))
Else
Print "Error: key " + Chr$(34) + key$ + Chr$(34) + " found by GetID& but not found by DeleteID."
End If
Else
Print "Key " + Chr$(34) + key$ + Chr$(34) + " not found in dictionary."
End If
End If
ElseIf Len(in$) = 0 Then
Exit Do
Else
Print Chr$(34) + in2$ + Chr$(34) + " is not a valid choice."
End If
Loop
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
Screen 0
End Sub ' DictionaryTest1
' ****************************************************************************************************************************************************************
' BEGIN ASSOCIATIVE ARRAY FUNCTIONS
' ****************************************************************************************************************************************************************
' /////////////////////////////////////////////////////////////////////////////
' Re: associative arrays / dictionaries in QB64?
' https://www.qb64.org/forum/index.php?topic=3387.15
' From: luke
' Date: « Reply #17 on: December 20, 2020, 08:12:31 PM »
'
' My interpreter uses a hash table for storing program symbols.
' I've pulled it out and added a small demo program.
'
' It does a proper hashing of the contents and can support any
' kind of data for the "value" half because it works with a UDT,
' but it does require two SHARED arrays and a SHARED variable.
' I suppose if you really wanted to you could convert it to a
' _MEM based thing with keep it all as local variables,
' but I only needed one instance of the table in my case.
'
' Copyright 2020 Luke Ceddia
' SPDX-License-id: Apache-2.0
' arrDict.bm - Symbol Table
' /////////////////////////////////////////////////////////////////////////////
' Logically deletes item with key key$ from dictionary,
' returns TRUE if item was found and deleted.
' If not found or delete failed, returns FALSE.
Function DeleteID% (key$)
Dim bResult%
Dim hIndex~&
Dim lngIndex As Long
Dim iLower
Dim iUpper
' INITIALIZE
bResult% = FALSE
' LOOK IN FIRST POSITION FOR KEY
hIndex~& = GetHash~&(key$, UBound(m_arrLookup))
' IS KEY FOUND (KEEP LOOKING UNTIL FOUND)
Do
' IS POSITION VALID?
If (hIndex~& >= LBound(m_arrLookup)) And (hIndex~& <= UBound(m_arrLookup)) Then
' MAKE SURE KEY IS FOUND
' IF NOT FOUND, NO NEED TO DELETE, EXIT AND RETURN FALSE
lngIndex = m_arrLookup(hIndex~&)
If lngIndex > 0 Then
' FOUND KEY, LOGICALLY DELETE FROM INDEX
If m_arrDict(lngIndex).key = key$ Then
' FLAG AS LOGICALLY DELETED
m_arrDict(lngIndex).IsDeleted = TRUE
' RETURN TRUE = FOUND AND DELETED
DeleteID% = TRUE
Exit Function
End If
Else
DeleteID% = FALSE
Exit Function
End If
Else
' POSITION NOT VALID
iLower = LBound(m_arrLookup)
iUpper = UBound(m_arrLookup)
print "Hash of key$ " + chr$(34) + key$ + chr$(34) + " = " + _
_Trim$(Str$(hIndex~&)) + " outside bounds of m_arrLookup " + _
"(" + _
_Trim$(Str$(iLower)) + _
"-" + _
_Trim$(Str$(iUpper)) + _
")"
DeleteID% = FALSE
Exit Do
End If
' LOOK IN NEXT POSITION FOR KEY
hIndex~& = (hIndex~& + 1) Mod (UBound(m_arrLookup) + 1)
Loop
' RETURN RESULT
DeleteID% = bResult%
End Function ' DeleteID%
' /////////////////////////////////////////////////////////////////////////////
' Returns index for key key$ in associative array m_arrDict
' or 0 if not found.
Function GetID& (key$)
Dim lngResult As Long
Dim hIndex~&
Dim lngIndex As Long
lngResult = 0
' GET THE FIRST HASH POSITION
hIndex~& = GetHash~&(key$, UBound(m_arrLookup))
' LOOK FOR THE KEY
Do
' CHECK THE NEXT HASH POSITION'S INDEX
lngIndex = m_arrLookup(hIndex~&)
' POSITIVE MEANS FOUND
If lngIndex > 0 Then
' MAY HAVE FOUND IT, DOES THE KEY MATCH?
If m_arrDict(lngIndex).key = key$ Then
' RETURN THE POSITION
lngResult = lngIndex
Exit Do
End If
Else
' NONE, EXIT
Exit Do
End If
' LOOK AT THE NEXT HASH POSITION
hIndex~& = (hIndex~& + 1) Mod (UBound(m_arrLookup) + 1)
Loop
' RETURN RESULT
GetID& = lngResult
End Function ' GetID&
' /////////////////////////////////////////////////////////////////////////////
' Adds values in entry to associative array m_arrDict
' under key entry.key.
Sub WriteDictionary (entry As DictionaryType)
ExpandArrayIfNeeded
m_iLastIndex = m_iLastIndex + 1
m_arrDict(m_iLastIndex) = entry
InsertLookup entry.key, m_iLastIndex
End Sub ' WriteDictionary
' ****************************************************************************************************************************************************************
' END ASSOCIATIVE ARRAY FUNCTIONS
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' BEGIN ASSOCIATIVE ARRAY Strictly internal functions
' ****************************************************************************************************************************************************************
' /////////////////////////////////////////////////////////////////////////////
' Automatically expands the dictionary arrays m_arrDict & m_arrLookup
' if space is low.
Sub ExpandArrayIfNeeded
Const SYMTAB_MAX_LOADING = 0.75
Const SYMTAB_GROWTH_FACTOR = 2
Dim iLoop As Long
If m_iLastIndex = UBound(m_arrDict) Then
ReDim _Preserve m_arrDict(UBound(m_arrDict) * SYMTAB_GROWTH_FACTOR) As DictionaryType
End If
If m_iLastIndex / UBound(m_arrLookup) <= SYMTAB_MAX_LOADING Then
Exit Sub
End If
ReDim m_arrLookup(UBound(m_arrLookup) * SYMTAB_GROWTH_FACTOR)
For iLoop = 1 To m_iLastIndex
InsertLookup m_arrDict(iLoop).key, iLoop
Next iLoop
End Sub ' ExpandArrayIfNeeded
' /////////////////////////////////////////////////////////////////////////////
' Returns a hash key for key value key$, upto max value lngMax&.
' (I'm not quite sure where the 5381 and 33 come from but it works.)
' Attributed to D. J. Bernstein
' http://www.cse.yorku.ca/~oz/hash.html
Function GetHash~& (key$, lngMax&)
Dim hash~&
Dim iLoop As Long
hash~& = 5381 ' <- not sure where this # comes from?
For iLoop = 1 To Len(key$)
hash~& = ((hash~& * 33) Xor Asc(key$, iLoop)) Mod lngMax&
Next iLoop
'0<=hash<=max-1, so 1<=hash+1<=max
GetHash~& = hash~& + 1
End Function ' GetHash~&
' /////////////////////////////////////////////////////////////////////////////
' Inserts array index pointing to item with key key$
' in dictionary array m_arrDict at position lngIndex&.
Sub InsertLookup (key$, lngIndex&)
Dim hIndex~&
hIndex~& = GetHash~&(key$, UBound(m_arrLookup))
Do
If m_arrLookup(hIndex~&) = 0 Then Exit Do
hIndex~& = (hIndex~& + 1) Mod (UBound(m_arrLookup) + 1)
Loop
m_arrLookup(hIndex~&) = lngIndex&
End Sub ' InsertLookup
' ****************************************************************************************************************************************************************
' END ASSOCIATIVE ARRAY Strictly internal functions
' ****************************************************************************************************************************************************************
' ################################################################################################################################################################
' BEGIN GENERAL PURPOSE ROUTINES #GEN
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' Hack function, to be replaced with something better
Function DblToInt% (dblOld As Double)
Dim dblNew As Double
Dim sValue As String
Dim iPos As Integer
dblNew = RoundDouble#(dblOld, 0)
sValue = DblToStr$(dblNew)
DblToInt% = Val(sValue)
End Function ' DblToInt%
' /////////////////////////////////////////////////////////////////////////////
' 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#)
Dim result$: result$ = ""
Dim value$
Dim Xpos%
Dim expo%
Dim sign$
Dim valu$
Dim dot%
Dim L%
Dim add$
Dim min$
Dim DP$
Dim n%
Dim num$
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")
End If
If expo% < 0 Then
min$ = String$(Abs(expo%) - (dot% - 1), "0")
DP$ = "."
End If
num$ = ""
For n% = 1 To L%
If Mid$(valu$, n%, 1) <> "." Then
num$ = num$ + Mid$(valu$, n%, 1)
End If
Next n%
result$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
Else
result$ = value$
End If
DblToStr$ = result$
End Function ' DblToStr$
' /////////////////////////////////////////////////////////////////////////////
Function DblRoundedToStr$ (dblValue As Double, intNumPlaces As Integer)
Dim dblNew As Double
dblNew = RoundDouble#(dblValue, intNumPlaces)
DblRoundedToStr$ = DblToStr$(dblNew)
End Function ' DblRoundedToStr$
' /////////////////////////////////////////////////////////////////////////////
Function DoubleABS# (dblValue As Double)
If Sgn(dblValue) = -1 Then
DoubleABS# = 0 - dblValue
Else
DoubleABS# = dblValue
End If
End Function ' DoubleABS#
' /////////////////////////////////////////////////////////////////////////////
' Gets the # of seconds so far today
Function GetTimeSeconds& ()
Dim result&: result& = 0
Dim sTime$: sTime$ = Time$
Dim sHH24$: sHH24$ = Mid$(sTime$, 1, 2)
Dim sMI$: sMI$ = Mid$(sTime$, 4, 2)
Dim sSS$: sSS$ = Mid$(sTime$, 7, 2)
result& = result& + Val(sSS$)
result& = result& + (Val(sMI$) * 60)
result& = result& + ((Val(sHH24$) * 60) * 60)
' RETURN RESULT
GetTimeSeconds& = result&
End Function ' GetTimeSeconds&
' /////////////////////////////////////////////////////////////////////////////
' 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
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if value text$ is numeric.
Function IsNum% (text$)
IsNum% = IsNumber%(text$)
End Function ' IsNum%
'' OLD IsNum% CHECK FAILS FOR NUMBERS LIKE "002" AND "2.000":
'' from https://www.qb64.org/forum/index.php?topic=896.0
'Function IsNum% (text$)
' Dim a$
' Dim b$
' a$ = _Trim$(text$)
' b$ = _Trim$(Str$(Val(text$)))
' If a$ = b$ Then
' IsNum% = TRUE
' Else
' IsNum% = FALSE
' End If
'End Function ' IsNum%
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if value OriginalString$ is numeric else returns FALSE.
' 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 iDecimalCount%
Dim sNextChar$
If Len(OriginalString$) > 0 Then
TestString$ = ""
If Left$(OriginalString$, 1) = "+" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
ElseIf Left$(OriginalString$, 1) = "-" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
Else
TestString$ = OriginalString$
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
' /////////////////////////////////////////////////////////////////////////////
' Combines all elements of in$() into a single string
' with delimiter$ separating the elements.
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
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$
' /////////////////////////////////////////////////////////////////////////////
' Prints MyString$, iLinesPerPage% lines at a time,
' then waits for user to press a key to continue,
' before printing the next iLinesPerPage% lines.
Sub PrintPaged (MyString$, iLinesPerPage%)
Dim delim$
ReDim arrTest$(0)
Dim iLoop%
Dim iCount%
Dim in$
delim$ = Chr$(13)
split MyString$, delim$, arrTest$()
iCount% = 0
For iLoop% = LBound(arrTest$) To UBound(arrTest$)
iCount% = iCount% + 1
If iCount% > iLinesPerPage% Then
Sleep
iCount% = 0
End If
Print arrTest$(iLoop%)
Next iLoop%
End Sub ' PrintPaged
' /////////////////////////////////////////////////////////////////////////////
' 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$
' /////////////////////////////////////////////////////////////////////////////
' 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$
' /////////////////////////////////////////////////////////////////////////////
' Initializes random number generator seed.
' NOTE:
' using # of seconds so far in the day
' may be slightly more random than Randomize Timer
' unless user runs program at exact same time every day
Sub InitializeRandom
Dim t9#
t9# = (Timer * 1000000) Mod 32767
Randomize t9#
End Sub ' InitializeRandom
' /////////////////////////////////////////////////////////////////////////////
' Initializes random number generator seed.
' *** NOT SURE IF THIS ONE WORKS ***
Sub InitializeRandom1
Dim iSeed As Integer
iSeed = GetTimeSeconds& Mod 32767
Randomize iSeed
End Sub ' InitializeRandom1
' /////////////////////////////////////////////////////////////////////////////
' Generate random value between Min and Max inclusive.
' Note: random-number generator should be initialized with
' InitializeRandom or Randomize Timer
Function RandomNumber% (Min%, Max%)
Dim NumSpread%
NumSpread% = (Max% - Min%) + 1
RandomNumber% = Int(Rnd * NumSpread%) + Min% ' GET RANDOM # BETWEEN Max% AND Min%
End Function ' RandomNumber%
' /////////////////////////////////////////////////////////////////////////////
$If Then
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
$End If
' /////////////////////////////////////////////////////////////////////////////
' [Replace$] replaces all instances of the [Find] sub-string
' with the [Add] sub-string within the [Text] string.
' 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
' 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.
' FROM: String Manipulation
' found at abandoned, outdated and now likely malicious qb64 dot net website
' http://www.qb64.[net]/forum/index_topic_5964-0/
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 COPIES SO 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$
' /////////////////////////////////////////////////////////////////////////////
$If Then
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
$End If
' /////////////////////////////////////////////////////////////////////////////
' Rounding functions.
' FROM:
' 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.
' =============================================================================
' ROUNDING FUNCTIONS FOR TYPE _FLOAT
' Receives + returns _FLOAT myVar## (-1.18E-4932 to +1.18E+4932)
' old name: RoundNatural##
Function Round## (num##, digits%)
Round## = Int(num## * 10 ^ digits% + .5) / 10 ^ digits%
End Function
Function RoundUp## (num##, digits%)
RoundUp## = _Ceil(num## * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundDown## (num##, digits%)
RoundDown## = Int(num## * 10 ^ digits%) / 10 ^ digits%
End Function
' old name: Round_Scientific##
Function RoundScientific## (num##, digits%)
RoundScientific## = _Round(num## * 10 ^ digits%) / 10 ^ digits%
End Function
' =============================================================================
' ROUNDING FUNCTIONS FOR TYPE DOUBLE
Function RoundDouble# (num#, digits%)
RoundDouble# = Int(num# * 10 ^ digits% + .5) / 10 ^ digits%
End Function
Function RoundUpDouble# (num#, digits%)
RoundUpDouble# = _Ceil(num# * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundDownDouble# (num#, digits%)
RoundDownDouble# = Int(num# * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundScientificDouble# (num#, digits%)
RoundScientificDouble# = _Round(num# * 10 ^ digits%) / 10 ^ digits%
End Function
' =============================================================================
' ROUNDING FUNCTIONS FOR TYPE SINGLE
Function RoundSingle! (num!, digits%)
RoundSingle! = Int(num! * 10 ^ digits% + .5) / 10 ^ digits%
End Function
' NOTE: not sure this one works: when digits%=3, it rounds .31 to .32
Function RoundUpSingle! (num!, digits%)
RoundUpSingle! = _Ceil(num! * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundDownSingle! (num!, digits%)
RoundDownSingle! = Int(num! * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundScientificSingle! (num!, digits%)
RoundScientificSingle! = _Round(num! * 10 ^ digits%) / 10 ^ digits%
End Function
' /////////////////////////////////////////////////////////////////////////////
' Receives a Single, rounds it to intNumPlaces places,
' and returns the result as a string.
Function SngRoundedToStr$ (sngValue As Single, intNumPlaces As Integer)
Dim sngNew As Single
sngNew = RoundSingle!(sngValue, intNumPlaces)
SngRoundedToStr$ = SngToStr$(sngNew)
End Function ' SngRoundedToStr$
' /////////////////////////////////////////////////////////////////////////////
' Receives a Single, rounds it to 0 places,
' and returns the result as an Integer.
' NOTE: Hack function, to be replaced with something better?
Function SngToInt% (sngOld As Single)
Dim sngNew As Single
Dim sValue As String
Dim iPos As Integer
sngNew = RoundSingle!(sngOld, 0)
sValue = SngToStr$(sngNew)
SngToInt% = Val(sValue)
End Function ' SngToInt%
' /////////////////////////////////////////////////////////////////////////////
' Converts a Single to a string, formatted without scientific notation.
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example usage:
' A string function that displays extremely small or large exponential
' decimal values.
Function SngToStr$ (n!)
Dim result$: result$ = ""
Dim value$
Dim Xpos%
Dim expo%
Dim sign$
Dim valu$
Dim dot%
Dim L%
Dim add$
Dim min$
Dim DP$
Dim n%
Dim num$
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")
End If
If expo% < 0 Then
min$ = String$(Abs(expo%) - (dot% - 1), "0")
DP$ = "."
End If
num$ = ""
For n% = 1 To L%
If Mid$(valu$, n%, 1) <> "." Then
num$ = num$ + Mid$(valu$, n%, 1)
End If
Next n%
result$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
Else
result$ = value$
End If
SngToStr$ = result$
End Function ' SngToStr$
' /////////////////////////////////////////////////////////////////////////////
' Splits a string in$ by delimeter delimiter$
' into an array result$().
' 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, iDelimLen) = delimiter$
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
' /////////////////////////////////////////////////////////////////////////////
$If Then
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
$End If
' /////////////////////////////////////////////////////////////////////////////
$If Then
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$(" + _Trim$(Str$(iLoop%)) + ") = " + Chr$(34) + out$ + Chr$(34)
Next iLoop%
Print
Print "SplitAndReplaceTest finished."
End Sub ' SplitAndReplaceTest
$End If
' /////////////////////////////////////////////////////////////////////////////
' 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 @GEN
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN REFERENCE #REF
' ################################################################################################################################################################
' =============================================================================
' 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%
' Screen _NewImage(1024, 768, 32): _ScreenMove 0, 0
' iCols = _Width(0) \ _FontWidth
' iRows = _Height(0) \ _FontHeight
' Print "_Width(0) =" + _Trim$(Str$(_Width(0)))
' Print "_Height(0) =" + _Trim$(Str$(_Height(0)))
' Print "_FontWidth =" + _Trim$(Str$(_FontWidth))
' Print "_FontHeight=" + _Trim$(Str$(_FontHeight))
' Print "iCols = _Width(0) \ _FontWidth = " + _Trim$(Str$(iCols))
' Print "iRows = _Height(0) \ _FontHeight = " + _Trim$(Str$(iRows))
$If Then
'Pete:
'Oh, does anyone else like how using $IF/THEN works as a block REM statement?
'I mean I'd rather we had a QB64 block remark statement like the one used for JavaScript, but thi hack will do.
$End If
' ################################################################################################################################################################
' END REFERENCE @REF
' ################################################################################################################################################################
'#END
Posts: 714
Threads: 102
Joined: Apr 2022
Reputation:
14
(03-14-2023, 03:04 PM)TempodiBasic Wrote: Step 2 transformation of the Hash Table
...
Welcome ideas, constructive criticisms, other code demonstrations and all you, kind people of QB64, want to share about these arguments.
I finally got around to putting your hash array dictionary and the one I built (based on Luke Ceddia's code) into a program with a little speed test, and yours is much faster!
(Code is below.)
The Luke version has some extra code to check for duplicates and whatnot, so that could be causing it to be slower.
Any ideas what the main bottleneck is?
What would be nice would be to take the best of both, to get some extra features and the speed...
Code: (Select All) ' This tests and compares 2 different implementations
' of dictionary/associative array :
' Re: associative arrays / dictionaries in QB64?
' by Luke Ceddia, December 20, 2020, 08:12:31 PM
' https://www.qb64.org/forum/index.php?topic=3387.15
' An hash array dictonary step by step
' by TempodiBasic, 3/14/2023, 11:04 AM
' https://qb64phoenix.com/forum/showthread.php?tid=1547
Dim Shared m_sTitle As String: m_sTitle = "dictionary-test"
_Title m_sTitle ' display in the Window's title bar
Option _Explicit
Const FALSE = 0
Const TRUE = Not FALSE
Const cIntDictSize = 1000
Const cIntLookupSize = 32767
' For dictionary by Luke
' Object to store in the symbol table
Type DictionaryType
key As String
intValue As Integer
lngValue As Long
strValue As String
IsDeleted As Integer
End Type ' DictionaryType
' For dictionary by TempodiBasic
' https://qb64phoenix.com/forum/showthread.php?tid=1547
' renamed HashTable to TempodiData
Type TempodiData
index As String '<---variable lenght of string index
value As String '<--- variable lenght of value stored
End Type
Dim Shared ProgramPath$: ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared ProgramName$: ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' For dictionary by Luke
ReDim Shared m_arrDict(cIntDictSize) As DictionaryType ' Actual stored obejcts
Dim Shared m_arrLookup(cIntLookupSize) As Long ' Mapping between hash and index
Dim Shared m_iLastIndex As Long
' For dictionary by TempodiBasic
' https://qb64phoenix.com/forum/showthread.php?tid=1547
' renamed HashString to TempodiIndex
Dim Shared TempodiIndex(0 To 1000) As TempodiData '<--- instance of hashtable
' Local vars
Dim in$
' Run the tests
DictionaryTest2
' Done
Print ProgramName$ + " finished."
Input "PRESS <ENTER> TO EXIT", in$
System ' return control to the operating system
End
' /////////////////////////////////////////////////////////////////////////////
Sub DictionaryTest2
Dim RoutineName As String: RoutineName = "DictionaryTest2"
Dim entry As DictionaryType
Dim lngID As Long
Dim intID As Integer
Dim bResult As Integer
Dim bFinished As Integer
Dim key$
Dim iLoop As Long
Dim in$
Dim in2$
Dim sValue$
Dim strValue$
Dim intValue%
Dim lngValue&
Dim t#
Dim iCount1 As _Integer64
Dim iCount2 As _Integer64
Dim iCount3 As _Integer64
ReDim arrData(-1) As DictionaryType
' =============================================================================
' GENERATE TEST DATA
For iLoop = 48 To 57 ' 0-9
ReDim _Preserve arrData(UBound(arrData) + 1) As DictionaryType
entry.key = Chr$(iLoop)
entry.intValue = iLoop
entry.lngValue = iLoop * 1000
entry.strValue = Chr$(iLoop) + Chr$(iLoop) + _Trim$(Str$(iLoop))
entry.IsDeleted = FALSE
arrData(UBound(arrData)) = entry
Next iLoop
For iLoop = 65 To 90 ' A-Z
ReDim _Preserve arrData(UBound(arrData) + 1) As DictionaryType
entry.key = Chr$(iLoop)
entry.intValue = iLoop
entry.lngValue = iLoop * 1000
entry.strValue = Chr$(iLoop) + Chr$(iLoop) + _Trim$(Str$(iLoop))
entry.IsDeleted = FALSE
arrData(UBound(arrData)) = entry
Next iLoop
For iLoop = 97 To 122 ' a-z
ReDim _Preserve arrData(UBound(arrData) + 1) As DictionaryType
entry.key = Chr$(iLoop)
entry.intValue = iLoop
entry.lngValue = iLoop * 1000
entry.strValue = Chr$(iLoop) + Chr$(iLoop) + _Trim$(Str$(iLoop))
entry.IsDeleted = FALSE
arrData(UBound(arrData)) = entry
Next iLoop
' =============================================================================
' TEST "Luke" DICTIONARY - RUN FOR 3 SECONDS
Print "Testing " + Chr$(34) + "Luke" + Chr$(34) + " dictionary for 3 seconds..."
iCount1 = 0
't# = Timer + 3
t# = ExtendedTimer + 3
Do
' WRITE VALUES
For iLoop = LBound(arrData) To UBound(arrData)
WriteStringToDictionary arrData(iLoop).key, arrData(iLoop).strValue
iCount1 = iCount1 + 1
Next iLoop
' FIND VALUES
For iLoop = LBound(arrData) To UBound(arrData)
lngID = GetID&(arrData(iLoop).key)
If lngID > 0 Then
strValue$ = m_arrDict(lngID).strValue
End If
iCount1 = iCount1 + 1
Next iLoop
Loop Until ExtendedTimer > t#
'Loop Until Timer > t#
' =============================================================================
' TEST "TempodiBasic" DICTIONARY WITH ID CHECK - RUN FOR 3 SECONDS
Print "Testing " + Chr$(34) + "TempodiBasic" + Chr$(34) + " dictionary for 3 seconds..."
iCount2 = 0
't# = Timer + 3
t# = ExtendedTimer + 3
Do
' WRITE VALUES
For iLoop = LBound(arrData) To UBound(arrData)
StoreValue arrData(iLoop).key, arrData(iLoop).strValue
iCount2 = iCount2 + 1
Next iLoop
' FIND VALUES
For iLoop = LBound(arrData) To UBound(arrData)
intID = GetIndex%(arrData(iLoop).key)
If intID > -1 Then
strValue$ = GetValue$(arrData(iLoop).key)
End If
iCount2 = iCount2 + 1
Next iLoop
Loop Until ExtendedTimer > t#
'Loop Until Timer > t#
' =============================================================================
' TEST "TempodiBasic" DICTIONARY WITHOUT ID CHECK - RUN FOR 3 SECONDS
Print "Testing " + Chr$(34) + "TempodiBasic" + Chr$(34) + " dictionary (no ID check) for 3 seconds..."
iCount3 = 0
't# = Timer + 3
t# = ExtendedTimer + 3
Do
' WRITE VALUES
For iLoop = LBound(arrData) To UBound(arrData)
StoreValue arrData(iLoop).key, arrData(iLoop).strValue
iCount3 = iCount3 + 1
Next iLoop
' FIND VALUES
For iLoop = LBound(arrData) To UBound(arrData)
'intID = GetIndex%(arrData(iLoop).key)
'if intID > -1 then
strValue$ = GetValue$(arrData(iLoop).key)
'end if
iCount3 = iCount3 + 1
Next iLoop
Loop Until ExtendedTimer > t#
'Loop Until Timer > t#
' =============================================================================
' SHOW RESULTS
Print "In 3 seconds:"
Print "Luke algorithm counted to " + _Trim$(Str$(iCount1))
Print "Tempodi algorithm counted to " + _Trim$(Str$(iCount2))
Print "Tempodi algorithm (without ID check) counted to " + _Trim$(Str$(iCount3))
Print
Print "PRESS ANY KEY TO CONTINUE"
Sleep
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
Screen 0
End Sub ' DictionaryTest2
' ****************************************************************************************************************************************************************
' BEGIN ASSOCIATIVE ARRAY FUNCTIONS (Luke)
' ****************************************************************************************************************************************************************
' /////////////////////////////////////////////////////////////////////////////
' Re: associative arrays / dictionaries in QB64?
' https://www.qb64.org/forum/index.php?topic=3387.15
' From: luke
' Date: « Reply #17 on: December 20, 2020, 08:12:31 PM »
'
' My interpreter uses a hash table for storing program symbols.
' I've pulled it out and added a small demo program.
'
' It does a proper hashing of the contents and can support any
' kind of data for the "value" half because it works with a UDT,
' but it does require two SHARED arrays and a SHARED variable.
' I suppose if you really wanted to you could convert it to a
' _MEM based thing with keep it all as local variables,
' but I only needed one instance of the table in my case.
'
' Copyright 2020 Luke Ceddia
' SPDX-License-id: Apache-2.0
' arrDict.bm - Symbol Table
' /////////////////////////////////////////////////////////////////////////////
' Logically deletes item with key key$ from dictionary,
' returns TRUE if item was found and deleted.
' If not found or delete failed, returns FALSE.
Function DeleteID% (key$)
Dim bResult%
Dim hIndex~&
Dim lngIndex As Long
Dim iLower
Dim iUpper
' INITIALIZE
bResult% = FALSE
' LOOK IN FIRST POSITION FOR KEY
hIndex~& = GetHash~&(key$, UBound(m_arrLookup))
' IS KEY FOUND (KEEP LOOKING UNTIL FOUND)
Do
' IS POSITION VALID?
If (hIndex~& >= LBound(m_arrLookup)) And (hIndex~& <= UBound(m_arrLookup)) Then
' MAKE SURE KEY IS FOUND
' IF NOT FOUND, NO NEED TO DELETE, EXIT AND RETURN FALSE
lngIndex = m_arrLookup(hIndex~&)
If lngIndex > 0 Then
' FOUND KEY, LOGICALLY DELETE FROM INDEX
If m_arrDict(lngIndex).key = key$ Then
' FLAG AS LOGICALLY DELETED
m_arrDict(lngIndex).IsDeleted = TRUE
' RETURN TRUE = FOUND AND DELETED
DeleteID% = TRUE
Exit Function
End If
Else
DeleteID% = FALSE
Exit Function
End If
Else
' POSITION NOT VALID
iLower = LBound(m_arrLookup)
iUpper = UBound(m_arrLookup)
print "Hash of key$ " + chr$(34) + key$ + chr$(34) + " = " + _
_Trim$(Str$(hIndex~&)) + " outside bounds of m_arrLookup " + _
"(" + _
_Trim$(Str$(iLower)) + _
"-" + _
_Trim$(Str$(iUpper)) + _
")"
DeleteID% = FALSE
Exit Do
End If
' LOOK IN NEXT POSITION FOR KEY
hIndex~& = (hIndex~& + 1) Mod (UBound(m_arrLookup) + 1)
Loop
' RETURN RESULT
DeleteID% = bResult%
End Function ' DeleteID%
' /////////////////////////////////////////////////////////////////////////////
' Returns index for key key$ in associative array m_arrDict
' or 0 if not found.
Function GetID& (key$)
Dim lngResult As Long
Dim hIndex~&
Dim lngIndex As Long
lngResult = 0
' GET THE FIRST HASH POSITION
hIndex~& = GetHash~&(key$, UBound(m_arrLookup))
' LOOK FOR THE KEY
Do
' CHECK THE NEXT HASH POSITION'S INDEX
lngIndex = m_arrLookup(hIndex~&)
' POSITIVE MEANS FOUND
If lngIndex > 0 Then
' MAY HAVE FOUND IT, DOES THE KEY MATCH?
If m_arrDict(lngIndex).key = key$ Then
' RETURN THE POSITION
lngResult = lngIndex
Exit Do
End If
Else
' NONE, EXIT
Exit Do
End If
' LOOK AT THE NEXT HASH POSITION
hIndex~& = (hIndex~& + 1) Mod (UBound(m_arrLookup) + 1)
Loop
' RETURN RESULT
GetID& = lngResult
End Function ' GetID&
' /////////////////////////////////////////////////////////////////////////////
' Adds values in entry to associative array m_arrDict
' under key entry.key.
Sub WriteDictionary (entry As DictionaryType)
ExpandArrayIfNeeded
m_iLastIndex = m_iLastIndex + 1
m_arrDict(m_iLastIndex) = entry
InsertLookup entry.key, m_iLastIndex
End Sub ' WriteDictionary
' /////////////////////////////////////////////////////////////////////////////
' Writes just a string value StringValue$
' to associative array m_arrDict under key key$.
Sub WriteStringToDictionary (key$, StringValue$)
ExpandArrayIfNeeded
m_iLastIndex = m_iLastIndex + 1
m_arrDict(m_iLastIndex).key = key$
m_arrDict(m_iLastIndex).strValue = StringValue$
m_arrDict(m_iLastIndex).IsDeleted = FALSE
InsertLookup key$, m_iLastIndex
End Sub ' WriteStringToDictionary
' ****************************************************************************************************************************************************************
' END ASSOCIATIVE ARRAY FUNCTIONS (Luke)
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' BEGIN ASSOCIATIVE ARRAY Strictly internal functions (Luke)
' ****************************************************************************************************************************************************************
' /////////////////////////////////////////////////////////////////////////////
' Automatically expands the dictionary arrays m_arrDict & m_arrLookup
' if space is low.
Sub ExpandArrayIfNeeded
Const SYMTAB_MAX_LOADING = 0.75
Const SYMTAB_GROWTH_FACTOR = 2
Dim iLoop As Long
If m_iLastIndex = UBound(m_arrDict) Then
ReDim _Preserve m_arrDict(UBound(m_arrDict) * SYMTAB_GROWTH_FACTOR) As DictionaryType
End If
If m_iLastIndex / UBound(m_arrLookup) <= SYMTAB_MAX_LOADING Then
Exit Sub
End If
ReDim m_arrLookup(UBound(m_arrLookup) * SYMTAB_GROWTH_FACTOR)
For iLoop = 1 To m_iLastIndex
InsertLookup m_arrDict(iLoop).key, iLoop
Next iLoop
End Sub ' ExpandArrayIfNeeded
' /////////////////////////////////////////////////////////////////////////////
' Returns a hash key for key value key$, upto max value lngMax&.
' (I'm not quite sure where the 5381 and 33 come from but it works.)
' Attributed to D. J. Bernstein
' http://www.cse.yorku.ca/~oz/hash.html
Function GetHash~& (key$, lngMax&)
Dim hash~&
Dim iLoop As Long
hash~& = 5381 ' <- not sure where this # comes from?
For iLoop = 1 To Len(key$)
hash~& = ((hash~& * 33) Xor Asc(key$, iLoop)) Mod lngMax&
Next iLoop
'0<=hash<=max-1, so 1<=hash+1<=max
GetHash~& = hash~& + 1
End Function ' GetHash~&
' /////////////////////////////////////////////////////////////////////////////
' Inserts array index pointing to item with key key$
' in dictionary array m_arrDict at position lngIndex&.
Sub InsertLookup (key$, lngIndex&)
Dim hIndex~&
hIndex~& = GetHash~&(key$, UBound(m_arrLookup))
Do
If m_arrLookup(hIndex~&) = 0 Then Exit Do
hIndex~& = (hIndex~& + 1) Mod (UBound(m_arrLookup) + 1)
Loop
m_arrLookup(hIndex~&) = lngIndex&
End Sub ' InsertLookup
' ****************************************************************************************************************************************************************
' END ASSOCIATIVE ARRAY Strictly internal functions (Luke)
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' BEGIN ASSOCIATIVE ARRAY FUNCTIONS For dictionary by TempodiBasic
' https://qb64phoenix.com/forum/showthread.php?tid=1547
' ****************************************************************************************************************************************************************
' this function returns the value linked to the index IND
' in the table TempodiIndex
Function GetValue$ (ind As String)
GetValue$ = TempodiIndex(GetIndex(ind)).value
End Function ' GetValue$
' this subroutine stores a value VALU linked to the index IND
' in the hashtable HASH
' In this implementation the SUB overwrites thre previouse value
' stored into the hashtable if it happens a collision
' but this behaviour can be easily changed for storing the new value
' or in OPEN (searching the next cell with no value into it)
' or in list adding the value to the string already staying in hashtable
Sub StoreValue (ind As String, valu As String)
TempodiIndex(GetIndex(ind)).value = valu
End Sub ' StoreValue
' this function calculates the Hash value for storing
' the linked value in the hashtable
Function GetIndex% (ind As String)
Dim a As Integer
Dim k As _Integer64
Dim hash As _Integer64
k = 1
For a = 1 To Len(ind)
hash = hash + ((Asc(ind, a)) * k)
'k = k * 10
k = k * 1000
Next a
'GetIndex% = hash Mod 10
GetIndex% = hash Mod 1000
End Function ' GetIndex%
' ****************************************************************************************************************************************************************
' END ASSOCIATIVE ARRAY FUNCTIONS For dictionary by TempodiBasic
' ****************************************************************************************************************************************************************
' ################################################################################################################################################################
' BEGIN GENERAL PURPOSE ROUTINES #GEN
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' Integer to string
Function cstr$ (myValue)
'cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
cstr$ = _Trim$(Str$(myValue))
End Function ' cstr$
' /////////////////////////////////////////////////////////////////////////////
' Hack function, to be replaced with something better
Function DblToInt% (dblOld As Double)
Dim dblNew As Double
Dim sValue As String
Dim iPos As Integer
dblNew = RoundDouble#(dblOld, 0)
sValue = DblToStr$(dblNew)
DblToInt% = Val(sValue)
End Function ' DblToInt%
' /////////////////////////////////////////////////////////////////////////////
' 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#)
Dim result$: result$ = ""
Dim value$
Dim Xpos%
Dim expo%
Dim sign$
Dim valu$
Dim dot%
Dim L%
Dim add$
Dim min$
Dim DP$
Dim n%
Dim num$
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")
End If
If expo% < 0 Then
min$ = String$(Abs(expo%) - (dot% - 1), "0")
DP$ = "."
End If
num$ = ""
For n% = 1 To L%
If Mid$(valu$, n%, 1) <> "." Then
num$ = num$ + Mid$(valu$, n%, 1)
End If
Next n%
result$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
Else
result$ = value$
End If
DblToStr$ = result$
End Function ' DblToStr$
' /////////////////////////////////////////////////////////////////////////////
Function DblRoundedToStr$ (dblValue As Double, intNumPlaces As Integer)
Dim dblNew As Double
dblNew = RoundDouble#(dblValue, intNumPlaces)
DblRoundedToStr$ = DblToStr$(dblNew)
End Function ' DblRoundedToStr$
' /////////////////////////////////////////////////////////////////////////////
Function DoubleABS# (dblValue As Double)
If Sgn(dblValue) = -1 Then
DoubleABS# = 0 - dblValue
Else
DoubleABS# = dblValue
End If
End Function ' DoubleABS#
' /////////////////////////////////////////////////////////////////////////////
' Use with timer functions to avoid "after midnight" bug.
' 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
' SMcNeill, QB64 Developer
' Reply #1 on: Today at 11:26:52 am
'
' One caveat here: You *can* experience bugs with this after midnight.
'
' Program starts at 23:59:59.
' Add three seconds -- 24:00:02... (In seconds, and not hours and minutes like this, though hours and minutes are easier to visualize.)
' Clock hits midnight: 0:00:00
'
' At no point will you ever have TIMER become greater than t#.
'
' If you're going to have a program which might run into this issue,
' I'd suggest just plugging in my ExtendedTimer and use it instead:
'
' Most of us write time code to test little snippets for which method might
' be faster for us while we're coding. The clock resetting on us isn't
' normally such a big deal. When it is, however, all you have to do is
' swap to the ExtendedTimer function [below]
'
' Returns a value for you based off DAY + TIME, rather than just time alone!
' No midnight clock issues with something like that in our programs. ;)
' Example using regular Timer:
' t# = Timer + 3
' Do
' '(SOMETHING)
' Loop Until Timer > t#
' Usage:
' ' DO SOMETHING FOR 3 SECONDS
' t# = ExtendedTimer1 + 3
' Do
' '(SOMETHING)
' Loop Until Timer > t#
$If EXTENDEDTIMER = UNDEFINED Then
$Let EXTENDEDTIMER = TRUE
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, oldt 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##
$End If
' /////////////////////////////////////////////////////////////////////////////
' Gets the # of seconds so far today
Function GetTimeSeconds& ()
Dim result&: result& = 0
Dim sTime$: sTime$ = Time$
Dim sHH24$: sHH24$ = Mid$(sTime$, 1, 2)
Dim sMI$: sMI$ = Mid$(sTime$, 4, 2)
Dim sSS$: sSS$ = Mid$(sTime$, 7, 2)
result& = result& + Val(sSS$)
result& = result& + (Val(sMI$) * 60)
result& = result& + ((Val(sHH24$) * 60) * 60)
' RETURN RESULT
GetTimeSeconds& = result&
End Function ' GetTimeSeconds&
' /////////////////////////////////////////////////////////////////////////////
' 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
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if value text$ is numeric.
Function IsNum% (text$)
IsNum% = IsNumber%(text$)
End Function ' IsNum%
'' OLD IsNum% CHECK FAILS FOR NUMBERS LIKE "002" AND "2.000":
'' from https://www.qb64.org/forum/index.php?topic=896.0
'Function IsNum% (text$)
' Dim a$
' Dim b$
' a$ = _Trim$(text$)
' b$ = _Trim$(Str$(Val(text$)))
' If a$ = b$ Then
' IsNum% = TRUE
' Else
' IsNum% = FALSE
' End If
'End Function ' IsNum%
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if value OriginalString$ is numeric else returns FALSE.
' 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 iDecimalCount%
Dim sNextChar$
If Len(OriginalString$) > 0 Then
TestString$ = ""
If Left$(OriginalString$, 1) = "+" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
ElseIf Left$(OriginalString$, 1) = "-" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
Else
TestString$ = OriginalString$
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
' /////////////////////////////////////////////////////////////////////////////
' Combines all elements of in$() into a single string
' with delimiter$ separating the elements.
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
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$
' /////////////////////////////////////////////////////////////////////////////
' Prints MyString$, iLinesPerPage% lines at a time,
' then waits for user to press a key to continue,
' before printing the next iLinesPerPage% lines.
Sub PrintPaged (MyString$, iLinesPerPage%)
Dim delim$
ReDim arrTest$(0)
Dim iLoop%
Dim iCount%
Dim in$
delim$ = Chr$(13)
split MyString$, delim$, arrTest$()
iCount% = 0
For iLoop% = LBound(arrTest$) To UBound(arrTest$)
iCount% = iCount% + 1
If iCount% > iLinesPerPage% Then
Sleep
iCount% = 0
End If
Print arrTest$(iLoop%)
Next iLoop%
End Sub ' PrintPaged
' /////////////////////////////////////////////////////////////////////////////
' 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$
' /////////////////////////////////////////////////////////////////////////////
' 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$
' /////////////////////////////////////////////////////////////////////////////
' Initializes random number generator seed.
' NOTE:
' using # of seconds so far in the day
' may be slightly more random than Randomize Timer
' unless user runs program at exact same time every day
Sub InitializeRandom
Dim t9#
t9# = (Timer * 1000000) Mod 32767
Randomize t9#
End Sub ' InitializeRandom
' /////////////////////////////////////////////////////////////////////////////
' Initializes random number generator seed.
' *** NOT SURE IF THIS ONE WORKS ***
Sub InitializeRandom1
Dim iSeed As Integer
iSeed = GetTimeSeconds& Mod 32767
Randomize iSeed
End Sub ' InitializeRandom1
' /////////////////////////////////////////////////////////////////////////////
' Generate random value between Min and Max inclusive.
' Note: random-number generator should be initialized with
' InitializeRandom or Randomize Timer
Function RandomNumber% (Min%, Max%)
Dim NumSpread%
NumSpread% = (Max% - Min%) + 1
RandomNumber% = Int(Rnd * NumSpread%) + Min% ' GET RANDOM # BETWEEN Max% AND Min%
End Function ' RandomNumber%
' /////////////////////////////////////////////////////////////////////////////
$If Then
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
$End If
' /////////////////////////////////////////////////////////////////////////////
' [Replace$] replaces all instances of the [Find] sub-string
' with the [Add] sub-string within the [Text] string.
' 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
' 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.
' FROM: String Manipulation
' found at abandoned, outdated and now likely malicious qb64 dot net website
' http://www.qb64.[net]/forum/index_topic_5964-0/
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 COPIES SO 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$
' /////////////////////////////////////////////////////////////////////////////
$If Then
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
$End If
' /////////////////////////////////////////////////////////////////////////////
' Rounding functions.
' FROM:
' 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.
' =============================================================================
' ROUNDING FUNCTIONS FOR TYPE _FLOAT
' Receives + returns _FLOAT myVar## (-1.18E-4932 to +1.18E+4932)
' old name: RoundNatural##
Function Round## (num##, digits%)
Round## = Int(num## * 10 ^ digits% + .5) / 10 ^ digits%
End Function
Function RoundUp## (num##, digits%)
RoundUp## = _Ceil(num## * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundDown## (num##, digits%)
RoundDown## = Int(num## * 10 ^ digits%) / 10 ^ digits%
End Function
' old name: Round_Scientific##
Function RoundScientific## (num##, digits%)
RoundScientific## = _Round(num## * 10 ^ digits%) / 10 ^ digits%
End Function
' =============================================================================
' ROUNDING FUNCTIONS FOR TYPE DOUBLE
Function RoundDouble# (num#, digits%)
RoundDouble# = Int(num# * 10 ^ digits% + .5) / 10 ^ digits%
End Function
Function RoundUpDouble# (num#, digits%)
RoundUpDouble# = _Ceil(num# * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundDownDouble# (num#, digits%)
RoundDownDouble# = Int(num# * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundScientificDouble# (num#, digits%)
RoundScientificDouble# = _Round(num# * 10 ^ digits%) / 10 ^ digits%
End Function
' =============================================================================
' ROUNDING FUNCTIONS FOR TYPE SINGLE
Function RoundSingle! (num!, digits%)
RoundSingle! = Int(num! * 10 ^ digits% + .5) / 10 ^ digits%
End Function
' NOTE: not sure this one works: when digits%=3, it rounds .31 to .32
Function RoundUpSingle! (num!, digits%)
RoundUpSingle! = _Ceil(num! * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundDownSingle! (num!, digits%)
RoundDownSingle! = Int(num! * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundScientificSingle! (num!, digits%)
RoundScientificSingle! = _Round(num! * 10 ^ digits%) / 10 ^ digits%
End Function
' /////////////////////////////////////////////////////////////////////////////
' Receives a Single, rounds it to intNumPlaces places,
' and returns the result as a string.
Function SngRoundedToStr$ (sngValue As Single, intNumPlaces As Integer)
Dim sngNew As Single
sngNew = RoundSingle!(sngValue, intNumPlaces)
SngRoundedToStr$ = SngToStr$(sngNew)
End Function ' SngRoundedToStr$
' /////////////////////////////////////////////////////////////////////////////
' Receives a Single, rounds it to 0 places,
' and returns the result as an Integer.
' NOTE: Hack function, to be replaced with something better?
Function SngToInt% (sngOld As Single)
Dim sngNew As Single
Dim sValue As String
Dim iPos As Integer
sngNew = RoundSingle!(sngOld, 0)
sValue = SngToStr$(sngNew)
SngToInt% = Val(sValue)
End Function ' SngToInt%
' /////////////////////////////////////////////////////////////////////////////
' Converts a Single to a string, formatted without scientific notation.
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example usage:
' A string function that displays extremely small or large exponential
' decimal values.
Function SngToStr$ (n!)
Dim result$: result$ = ""
Dim value$
Dim Xpos%
Dim expo%
Dim sign$
Dim valu$
Dim dot%
Dim L%
Dim add$
Dim min$
Dim DP$
Dim n%
Dim num$
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")
End If
If expo% < 0 Then
min$ = String$(Abs(expo%) - (dot% - 1), "0")
DP$ = "."
End If
num$ = ""
For n% = 1 To L%
If Mid$(valu$, n%, 1) <> "." Then
num$ = num$ + Mid$(valu$, n%, 1)
End If
Next n%
result$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
Else
result$ = value$
End If
SngToStr$ = result$
End Function ' SngToStr$
' /////////////////////////////////////////////////////////////////////////////
' Splits a string in$ by delimeter delimiter$
' into an array result$().
' 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, iDelimLen) = delimiter$
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
' /////////////////////////////////////////////////////////////////////////////
$If Then
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
$End If
' /////////////////////////////////////////////////////////////////////////////
$If Then
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$(" + _Trim$(Str$(iLoop%)) + ") = " + Chr$(34) + out$ + Chr$(34)
Next iLoop%
Print
Print "SplitAndReplaceTest finished."
End Sub ' SplitAndReplaceTest
$End If
' /////////////////////////////////////////////////////////////////////////////
' 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 @GEN
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN REFERENCE #REF
' ################################################################################################################################################################
' =============================================================================
' 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%
' Screen _NewImage(1024, 768, 32): _ScreenMove 0, 0
' iCols = _Width(0) \ _FontWidth
' iRows = _Height(0) \ _FontHeight
' Print "_Width(0) =" + _Trim$(Str$(_Width(0)))
' Print "_Height(0) =" + _Trim$(Str$(_Height(0)))
' Print "_FontWidth =" + _Trim$(Str$(_FontWidth))
' Print "_FontHeight=" + _Trim$(Str$(_FontHeight))
' Print "iCols = _Width(0) \ _FontWidth = " + _Trim$(Str$(iCols))
' Print "iRows = _Height(0) \ _FontHeight = " + _Trim$(Str$(iRows))
$If Then
'Pete:
'Oh, does anyone else like how using $IF/THEN works as a block REM statement?
'I mean I'd rather we had a QB64 block remark statement like the one used for JavaScript, but thi hack will do.
$End If
' ################################################################################################################################################################
' END REFERENCE @REF
' ################################################################################################################################################################
'#END
Posts: 343
Threads: 24
Joined: Jul 2022
Reputation:
20
Hi Madscijr
thanks for running demo posted here above.
The hash dictionary made by Luke is very professional with a structured code in library to add in tail to the main program or to use as .BI e .BM files!
Luke has left reference to all the webpages used as original ideas ipmomrte into his work or inspirations for his code.
this webpage is still active but it does not give so many information about hashes algorithms, only few informations good for who has alreay a good knowledge of hash methods.
your demo made with that library runs good.
Now I'll try the comparing methods demonstration.
See later!
Posts: 343
Threads: 24
Joined: Jul 2022
Reputation:
20
@Madscijr
after copying, pasting and running your last code, I got this error
![[Image: image.png]](https://i.ibb.co/mRHZ9Qy/image.png)
in which on running the line 380 gives a duplicate name error.
Looking at code in the line 380 of code of the library of Luke simply I see that it has been expanded the SHARED array m_arrLookUp...
This array has been declared at line 45 as SHARED.
This is a strange result, because running your demo the SUB ExpandArrayIfNeed has been called when I have put as input the choice 3. Write with no runtime error.
Using QB64pe v. 3.4.1 on Windows 11
Posts: 714
Threads: 102
Joined: Apr 2022
Reputation:
14
(03-19-2023, 09:16 PM)TempodiBasic Wrote: @Madscijr
after copying, pasting and running your last code, I got this error
in which on running the line 380 gives a duplicate name error.
Looking at code in the line 380 of code of the library of Luke simply I see that it has been expanded the SHARED array m_arrLookUp...
This array has been declared at line 45 as SHARED.
This is a strange result, because running your demo the SUB ExpandArrayIfNeed has been called when I have put as input the choice 3. Write with no runtime error.
Using QB64pe v. 3.4.1 on Windows 11
Hmm. I was using QB64 2.0.2 for this, maybe there is an incompatibility?
I went to try with QB64PE 3.6.0 and am getting compilation errors on a simple test program
Code: (Select All) Cls
Print "hello world"
Sleep
so I will need to fix that, before I can recreate your issue.
(I just posted a plea for help in the "help me" section...)
Stay tuned!
Posts: 1,588
Threads: 59
Joined: Jul 2022
Reputation:
52
03-21-2023, 01:56 AM
(This post was last modified: 03-21-2023, 01:57 AM by mnrvovrfc.)
madscijr
It doesn't matter which version of QB64 or PE for this code, but it has to be fixed. I haven't run the program listed here with the fix I'm proposing below. The array with the error was originally initialized "As Long", but that was forgotten in the error line. (Otherwise it's trying to redefine "As Single", because there's no _DEFINE statement or alike which changes the "default" type, which is not allowed.) So if you can try this code again with the version of QB64 that is working for you.
Code: (Select All) ReDim m_arrLookup(ubm_arrLookup * SYMTAB_GROWTH_FACTOR) As Long
Line #45 might have to be changed to "ReDim" instead of "Dim" also.
Then carry on soldier. 
EDIT: I have to read more carefully the earlier posts in a topic! But whoever got the error needs to fix it like I proposed.
Posts: 343
Threads: 24
Joined: Jul 2022
Reputation:
20
(03-21-2023, 01:56 AM)mnrvovrfc Wrote: madscijr
It doesn't matter which version of QB64 or PE for this code, but it has to be fixed. I haven't run the program listed here with the fix I'm proposing below. The array with the error was originally initialized "As Long", but that was forgotten in the error line. (Otherwise it's trying to redefine "As Single", because there's no _DEFINE statement or alike which changes the "default" type, which is not allowed.) So if you can try this code again with the version of QB64 that is working for you.
Code: (Select All) ReDim m_arrLookup(ubm_arrLookup * SYMTAB_GROWTH_FACTOR) As Long
Line #45 might have to be changed to "ReDim" instead of "Dim" also.
Then carry on soldier.
EDIT: I have to read more carefully the earlier posts in a topic! But whoever got the error needs to fix it like I proposed.
Hi mnrvovfrc
thanks for the idea!
I have lost that in the sub the ReDim lacks of typer definition!
But I have tried adding AS LONG to the REDIM in the sub and the runtime error is still there.
Gosh!
Now I have just tried to substituite DIM SHARED with REDIM SHARED at line 45 and lasting the type definition of data at 380 and now it runs good!
Thanks again. Here the results:
Posts: 714
Threads: 102
Joined: Apr 2022
Reputation:
14
03-23-2023, 04:46 AM
(This post was last modified: 03-23-2023, 04:48 AM by madscijr.)
(03-21-2023, 10:31 AM)TempodiBasic Wrote: (03-21-2023, 01:56 AM)mnrvovrfc Wrote: It doesn't matter which version of QB64 or PE for this code, but it has to be fixed.
The array with the error was originally initialized "As Long", but that was forgotten in the error line.
...
Line #45 might have to be changed to "ReDim" instead of "Dim" also.
...
Then carry on soldier.
EDIT: I have to read more carefully the earlier posts in a topic! But whoever got the error needs to fix it like I proposed. I have lost that in the sub the ReDim lacks of typer definition!
But I have tried adding AS LONG to the REDIM in the sub and the runtime error is still there.
Now I have just tried to substituite DIM SHARED with REDIM SHARED at line 45 and lasting the type definition of data at 380 and now it runs good!
...
Here the results:
I was a little distracted with that QB64PE issue, but now that it works, back to this.
Thank you both, below is the fixed code.
(03-19-2023, 08:07 PM)TempodiBasic Wrote: The hash dictionary made by Luke is very professional with a structured code in library to add in tail to the main program or to use as .BI e .BM files!
Luke has left reference to all the webpages used as original ideas ipmomrte into his work or inspirations for his code.
this webpage is still active but it does not give so many information about hashes algorithms, only few informations good for who has alreay a good knowledge of hash methods.
your demo made with that library runs good.
Now I'll try the comparing methods demonstration.
See later!
Now that the code is working, back to the test results:
![[Image: tempodi-speed.png]](https://i.ibb.co/60VrFPt/tempodi-speed.png)
Even with the extra ID check, your dictionary is 398 times faster! And 524x faster without!
So, I am wondering what specifically is the bottleneck in the "Luke" version?
(Poor Luke, his code is probably fine, I probably messed it up somewhere to slow it down.)
Do you think that the "Luke" version can be improved to get the speed AND the features?
Code: (Select All) ' This tests and compares 2 different implementations
' of dictionary/associative array :
' Re: associative arrays / dictionaries in QB64?
' by Luke Ceddia, December 20, 2020, 08:12:31 PM
' https://www.qb64.org/forum/index.php?topic=3387.15
' An hash array dictonary step by step
' by TempodiBasic, 3/14/2023, 11:04 AM
' https://qb64phoenix.com/forum/showthread.php?tid=1547
Dim Shared m_sTitle As String: m_sTitle = "dictionary-test"
_Title m_sTitle ' display in the Window's title bar
Option _Explicit
Const FALSE = 0
Const TRUE = Not FALSE
Const cIntDictSize = 1000
Const cIntLookupSize = 32767
' For dictionary by Luke
' Object to store in the symbol table
Type DictionaryType
key As String
intValue As Integer
lngValue As Long
strValue As String
IsDeleted As Integer
End Type ' DictionaryType
' For dictionary by TempodiBasic
' https://qb64phoenix.com/forum/showthread.php?tid=1547
' renamed HashTable to TempodiData
Type TempodiData
index As String '<---variable lenght of string index
value As String '<--- variable lenght of value stored
End Type
Dim Shared ProgramPath$: ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared ProgramName$: ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' For dictionary by Luke
ReDim Shared m_arrDict(cIntDictSize) As DictionaryType ' Actual stored obejcts
ReDim Shared m_arrLookup(cIntLookupSize) As Long ' Mapping between hash and index
Dim Shared m_iLastIndex As Long
' For dictionary by TempodiBasic
' https://qb64phoenix.com/forum/showthread.php?tid=1547
' renamed HashString to TempodiIndex
ReDim Shared TempodiIndex(0 To 1000) As TempodiData '<--- instance of hashtable
' Local vars
Dim in$
' Run the tests
DictionaryTest2
' Done
Print ProgramName$ + " finished."
Input "PRESS <ENTER> TO EXIT", in$
System ' return control to the operating system
End
' /////////////////////////////////////////////////////////////////////////////
Sub DictionaryTest2
Dim RoutineName As String: RoutineName = "DictionaryTest2"
Dim entry As DictionaryType
Dim lngID As Long
Dim intID As Integer
Dim bResult As Integer
Dim bFinished As Integer
Dim key$
Dim iLoop As Long
Dim in$
Dim in2$
Dim sValue$
Dim strValue$
Dim intValue%
Dim lngValue&
Dim t#
Dim iCount1 As _Integer64
Dim iCount2 As _Integer64
Dim iCount3 As _Integer64
ReDim arrData(-1) As DictionaryType
' =============================================================================
' GENERATE TEST DATA
For iLoop = 48 To 57 ' 0-9
ReDim _Preserve arrData(UBound(arrData) + 1) As DictionaryType
entry.key = Chr$(iLoop)
entry.intValue = iLoop
entry.lngValue = iLoop * 1000
entry.strValue = Chr$(iLoop) + Chr$(iLoop) + _Trim$(Str$(iLoop))
entry.IsDeleted = FALSE
arrData(UBound(arrData)) = entry
Next iLoop
For iLoop = 65 To 90 ' A-Z
ReDim _Preserve arrData(UBound(arrData) + 1) As DictionaryType
entry.key = Chr$(iLoop)
entry.intValue = iLoop
entry.lngValue = iLoop * 1000
entry.strValue = Chr$(iLoop) + Chr$(iLoop) + _Trim$(Str$(iLoop))
entry.IsDeleted = FALSE
arrData(UBound(arrData)) = entry
Next iLoop
For iLoop = 97 To 122 ' a-z
ReDim _Preserve arrData(UBound(arrData) + 1) As DictionaryType
entry.key = Chr$(iLoop)
entry.intValue = iLoop
entry.lngValue = iLoop * 1000
entry.strValue = Chr$(iLoop) + Chr$(iLoop) + _Trim$(Str$(iLoop))
entry.IsDeleted = FALSE
arrData(UBound(arrData)) = entry
Next iLoop
' =============================================================================
' TEST "Luke" DICTIONARY - RUN FOR 3 SECONDS
Print "Testing " + Chr$(34) + "Luke" + Chr$(34) + " dictionary for 3 seconds..."
iCount1 = 0
't# = Timer + 3
t# = ExtendedTimer + 3
Do
' WRITE VALUES
For iLoop = LBound(arrData) To UBound(arrData)
WriteStringToDictionary arrData(iLoop).key, arrData(iLoop).strValue
iCount1 = iCount1 + 1
Next iLoop
' FIND VALUES
For iLoop = LBound(arrData) To UBound(arrData)
lngID = GetID&(arrData(iLoop).key)
If lngID > 0 Then
strValue$ = m_arrDict(lngID).strValue
End If
iCount1 = iCount1 + 1
Next iLoop
Loop Until ExtendedTimer > t#
'Loop Until Timer > t#
' =============================================================================
' TEST "TempodiBasic" DICTIONARY WITH ID CHECK - RUN FOR 3 SECONDS
Print "Testing " + Chr$(34) + "TempodiBasic" + Chr$(34) + " dictionary for 3 seconds..."
iCount2 = 0
't# = Timer + 3
t# = ExtendedTimer + 3
Do
' WRITE VALUES
For iLoop = LBound(arrData) To UBound(arrData)
StoreValue arrData(iLoop).key, arrData(iLoop).strValue
iCount2 = iCount2 + 1
Next iLoop
' FIND VALUES
For iLoop = LBound(arrData) To UBound(arrData)
intID = GetIndex%(arrData(iLoop).key)
If intID > -1 Then
strValue$ = GetValue$(arrData(iLoop).key)
End If
iCount2 = iCount2 + 1
Next iLoop
Loop Until ExtendedTimer > t#
'Loop Until Timer > t#
' =============================================================================
' TEST "TempodiBasic" DICTIONARY WITHOUT ID CHECK - RUN FOR 3 SECONDS
Print "Testing " + Chr$(34) + "TempodiBasic" + Chr$(34) + " dictionary (no ID check) for 3 seconds..."
iCount3 = 0
't# = Timer + 3
t# = ExtendedTimer + 3
Do
' WRITE VALUES
For iLoop = LBound(arrData) To UBound(arrData)
StoreValue arrData(iLoop).key, arrData(iLoop).strValue
iCount3 = iCount3 + 1
Next iLoop
' FIND VALUES
For iLoop = LBound(arrData) To UBound(arrData)
'intID = GetIndex%(arrData(iLoop).key)
'if intID > -1 then
strValue$ = GetValue$(arrData(iLoop).key)
'end if
iCount3 = iCount3 + 1
Next iLoop
Loop Until ExtendedTimer > t#
'Loop Until Timer > t#
' =============================================================================
' SHOW RESULTS
Print "In 3 seconds:"
Print "Luke algorithm counted to " + _Trim$(Str$(iCount1))
Print "Tempodi algorithm counted to " + _Trim$(Str$(iCount2))
Print "Tempodi algorithm (without ID check) counted to " + _Trim$(Str$(iCount3))
Print
Print "PRESS ANY KEY TO CONTINUE"
Sleep
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
Screen 0
End Sub ' DictionaryTest2
' ****************************************************************************************************************************************************************
' BEGIN ASSOCIATIVE ARRAY FUNCTIONS (Luke)
' ****************************************************************************************************************************************************************
' /////////////////////////////////////////////////////////////////////////////
' Re: associative arrays / dictionaries in QB64?
' https://www.qb64.org/forum/index.php?topic=3387.15
' From: luke
' Date: « Reply #17 on: December 20, 2020, 08:12:31 PM »
'
' My interpreter uses a hash table for storing program symbols.
' I've pulled it out and added a small demo program.
'
' It does a proper hashing of the contents and can support any
' kind of data for the "value" half because it works with a UDT,
' but it does require two SHARED arrays and a SHARED variable.
' I suppose if you really wanted to you could convert it to a
' _MEM based thing with keep it all as local variables,
' but I only needed one instance of the table in my case.
'
' Copyright 2020 Luke Ceddia
' SPDX-License-id: Apache-2.0
' arrDict.bm - Symbol Table
' /////////////////////////////////////////////////////////////////////////////
' Logically deletes item with key key$ from dictionary,
' returns TRUE if item was found and deleted.
' If not found or delete failed, returns FALSE.
Function DeleteID% (key$)
Dim bResult%
Dim hIndex~&
Dim lngIndex As Long
Dim iLower
Dim iUpper
' INITIALIZE
bResult% = FALSE
' LOOK IN FIRST POSITION FOR KEY
hIndex~& = GetHash~&(key$, UBound(m_arrLookup))
' IS KEY FOUND (KEEP LOOKING UNTIL FOUND)
Do
' IS POSITION VALID?
If (hIndex~& >= LBound(m_arrLookup)) And (hIndex~& <= UBound(m_arrLookup)) Then
' MAKE SURE KEY IS FOUND
' IF NOT FOUND, NO NEED TO DELETE, EXIT AND RETURN FALSE
lngIndex = m_arrLookup(hIndex~&)
If lngIndex > 0 Then
' FOUND KEY, LOGICALLY DELETE FROM INDEX
If m_arrDict(lngIndex).key = key$ Then
' FLAG AS LOGICALLY DELETED
m_arrDict(lngIndex).IsDeleted = TRUE
' RETURN TRUE = FOUND AND DELETED
DeleteID% = TRUE
Exit Function
End If
Else
DeleteID% = FALSE
Exit Function
End If
Else
' POSITION NOT VALID
iLower = LBound(m_arrLookup)
iUpper = UBound(m_arrLookup)
print "Hash of key$ " + chr$(34) + key$ + chr$(34) + " = " + _
_Trim$(Str$(hIndex~&)) + " outside bounds of m_arrLookup " + _
"(" + _
_Trim$(Str$(iLower)) + _
"-" + _
_Trim$(Str$(iUpper)) + _
")"
DeleteID% = FALSE
Exit Do
End If
' LOOK IN NEXT POSITION FOR KEY
hIndex~& = (hIndex~& + 1) Mod (UBound(m_arrLookup) + 1)
Loop
' RETURN RESULT
DeleteID% = bResult%
End Function ' DeleteID%
' /////////////////////////////////////////////////////////////////////////////
' Returns index for key key$ in associative array m_arrDict
' or 0 if not found.
Function GetID& (key$)
Dim lngResult As Long
Dim hIndex~&
Dim lngIndex As Long
lngResult = 0
' GET THE FIRST HASH POSITION
hIndex~& = GetHash~&(key$, UBound(m_arrLookup))
' LOOK FOR THE KEY
Do
' CHECK THE NEXT HASH POSITION'S INDEX
lngIndex = m_arrLookup(hIndex~&)
' POSITIVE MEANS FOUND
If lngIndex > 0 Then
' MAY HAVE FOUND IT, DOES THE KEY MATCH?
If m_arrDict(lngIndex).key = key$ Then
' RETURN THE POSITION
lngResult = lngIndex
Exit Do
End If
Else
' NONE, EXIT
Exit Do
End If
' LOOK AT THE NEXT HASH POSITION
hIndex~& = (hIndex~& + 1) Mod (UBound(m_arrLookup) + 1)
Loop
' RETURN RESULT
GetID& = lngResult
End Function ' GetID&
' /////////////////////////////////////////////////////////////////////////////
' Adds values in entry to associative array m_arrDict
' under key entry.key.
Sub WriteDictionary (entry As DictionaryType)
ExpandArrayIfNeeded
m_iLastIndex = m_iLastIndex + 1
m_arrDict(m_iLastIndex) = entry
InsertLookup entry.key, m_iLastIndex
End Sub ' WriteDictionary
' /////////////////////////////////////////////////////////////////////////////
' Writes just a string value StringValue$
' to associative array m_arrDict under key key$.
Sub WriteStringToDictionary (key$, StringValue$)
ExpandArrayIfNeeded
m_iLastIndex = m_iLastIndex + 1
m_arrDict(m_iLastIndex).key = key$
m_arrDict(m_iLastIndex).strValue = StringValue$
m_arrDict(m_iLastIndex).IsDeleted = FALSE
InsertLookup key$, m_iLastIndex
End Sub ' WriteStringToDictionary
' ****************************************************************************************************************************************************************
' END ASSOCIATIVE ARRAY FUNCTIONS (Luke)
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' BEGIN ASSOCIATIVE ARRAY Strictly internal functions (Luke)
' ****************************************************************************************************************************************************************
' /////////////////////////////////////////////////////////////////////////////
' Automatically expands the dictionary arrays m_arrDict & m_arrLookup
' if space is low.
Sub ExpandArrayIfNeeded
Const SYMTAB_MAX_LOADING = 0.75
Const SYMTAB_GROWTH_FACTOR = 2
Dim iLoop As Long
If m_iLastIndex = UBound(m_arrDict) Then
ReDim _Preserve m_arrDict(UBound(m_arrDict) * SYMTAB_GROWTH_FACTOR) As DictionaryType
End If
If m_iLastIndex / UBound(m_arrLookup) <= SYMTAB_MAX_LOADING Then
Exit Sub
End If
ReDim m_arrLookup(UBound(m_arrLookup) * SYMTAB_GROWTH_FACTOR) As Long
For iLoop = 1 To m_iLastIndex
InsertLookup m_arrDict(iLoop).key, iLoop
Next iLoop
End Sub ' ExpandArrayIfNeeded
' /////////////////////////////////////////////////////////////////////////////
' Returns a hash key for key value key$, upto max value lngMax&.
' (I'm not quite sure where the 5381 and 33 come from but it works.)
' Attributed to D. J. Bernstein
' http://www.cse.yorku.ca/~oz/hash.html
Function GetHash~& (key$, lngMax&)
Dim hash~&
Dim iLoop As Long
hash~& = 5381 ' <- not sure where this # comes from?
For iLoop = 1 To Len(key$)
hash~& = ((hash~& * 33) Xor Asc(key$, iLoop)) Mod lngMax&
Next iLoop
'0<=hash<=max-1, so 1<=hash+1<=max
GetHash~& = hash~& + 1
End Function ' GetHash~&
' /////////////////////////////////////////////////////////////////////////////
' Inserts array index pointing to item with key key$
' in dictionary array m_arrDict at position lngIndex&.
Sub InsertLookup (key$, lngIndex&)
Dim hIndex~&
hIndex~& = GetHash~&(key$, UBound(m_arrLookup))
Do
If m_arrLookup(hIndex~&) = 0 Then Exit Do
hIndex~& = (hIndex~& + 1) Mod (UBound(m_arrLookup) + 1)
Loop
m_arrLookup(hIndex~&) = lngIndex&
End Sub ' InsertLookup
' ****************************************************************************************************************************************************************
' END ASSOCIATIVE ARRAY Strictly internal functions (Luke)
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' BEGIN ASSOCIATIVE ARRAY FUNCTIONS For dictionary by TempodiBasic
' https://qb64phoenix.com/forum/showthread.php?tid=1547
' ****************************************************************************************************************************************************************
' this function returns the value linked to the index IND
' in the table TempodiIndex
Function GetValue$ (ind As String)
GetValue$ = TempodiIndex(GetIndex(ind)).value
End Function ' GetValue$
' this subroutine stores a value VALU linked to the index IND
' in the hashtable HASH
' In this implementation the SUB overwrites thre previouse value
' stored into the hashtable if it happens a collision
' but this behaviour can be easily changed for storing the new value
' or in OPEN (searching the next cell with no value into it)
' or in list adding the value to the string already staying in hashtable
Sub StoreValue (ind As String, valu As String)
TempodiIndex(GetIndex(ind)).value = valu
End Sub ' StoreValue
' this function calculates the Hash value for storing
' the linked value in the hashtable
Function GetIndex% (ind As String)
Dim a As Integer
Dim k As _Integer64
Dim hash As _Integer64
k = 1
For a = 1 To Len(ind)
hash = hash + ((Asc(ind, a)) * k)
'k = k * 10
k = k * 1000
Next a
'GetIndex% = hash Mod 10
GetIndex% = hash Mod 1000
End Function ' GetIndex%
' ****************************************************************************************************************************************************************
' END ASSOCIATIVE ARRAY FUNCTIONS For dictionary by TempodiBasic
' ****************************************************************************************************************************************************************
' ################################################################################################################################################################
' BEGIN GENERAL PURPOSE ROUTINES #GEN
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' Integer to string
Function cstr$ (myValue)
'cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
cstr$ = _Trim$(Str$(myValue))
End Function ' cstr$
' /////////////////////////////////////////////////////////////////////////////
' Hack function, to be replaced with something better
Function DblToInt% (dblOld As Double)
Dim dblNew As Double
Dim sValue As String
Dim iPos As Integer
dblNew = RoundDouble#(dblOld, 0)
sValue = DblToStr$(dblNew)
DblToInt% = Val(sValue)
End Function ' DblToInt%
' /////////////////////////////////////////////////////////////////////////////
' 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#)
Dim result$: result$ = ""
Dim value$
Dim Xpos%
Dim expo%
Dim sign$
Dim valu$
Dim dot%
Dim L%
Dim add$
Dim min$
Dim DP$
Dim n%
Dim num$
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")
End If
If expo% < 0 Then
min$ = String$(Abs(expo%) - (dot% - 1), "0")
DP$ = "."
End If
num$ = ""
For n% = 1 To L%
If Mid$(valu$, n%, 1) <> "." Then
num$ = num$ + Mid$(valu$, n%, 1)
End If
Next n%
result$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
Else
result$ = value$
End If
DblToStr$ = result$
End Function ' DblToStr$
' /////////////////////////////////////////////////////////////////////////////
Function DblRoundedToStr$ (dblValue As Double, intNumPlaces As Integer)
Dim dblNew As Double
dblNew = RoundDouble#(dblValue, intNumPlaces)
DblRoundedToStr$ = DblToStr$(dblNew)
End Function ' DblRoundedToStr$
' /////////////////////////////////////////////////////////////////////////////
Function DoubleABS# (dblValue As Double)
If Sgn(dblValue) = -1 Then
DoubleABS# = 0 - dblValue
Else
DoubleABS# = dblValue
End If
End Function ' DoubleABS#
' /////////////////////////////////////////////////////////////////////////////
' Use with timer functions to avoid "after midnight" bug.
' 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
' SMcNeill, QB64 Developer
' Reply #1 on: Today at 11:26:52 am
'
' One caveat here: You *can* experience bugs with this after midnight.
'
' Program starts at 23:59:59.
' Add three seconds -- 24:00:02... (In seconds, and not hours and minutes like this, though hours and minutes are easier to visualize.)
' Clock hits midnight: 0:00:00
'
' At no point will you ever have TIMER become greater than t#.
'
' If you're going to have a program which might run into this issue,
' I'd suggest just plugging in my ExtendedTimer and use it instead:
'
' Most of us write time code to test little snippets for which method might
' be faster for us while we're coding. The clock resetting on us isn't
' normally such a big deal. When it is, however, all you have to do is
' swap to the ExtendedTimer function [below]
'
' Returns a value for you based off DAY + TIME, rather than just time alone!
' No midnight clock issues with something like that in our programs. ;)
' Example using regular Timer:
' t# = Timer + 3
' Do
' '(SOMETHING)
' Loop Until Timer > t#
' Usage:
' ' DO SOMETHING FOR 3 SECONDS
' t# = ExtendedTimer1 + 3
' Do
' '(SOMETHING)
' Loop Until Timer > t#
$If EXTENDEDTIMER = UNDEFINED Then
$Let EXTENDEDTIMER = TRUE
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, oldt 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##
$End If
' /////////////////////////////////////////////////////////////////////////////
' Gets the # of seconds so far today
Function GetTimeSeconds& ()
Dim result&: result& = 0
Dim sTime$: sTime$ = Time$
Dim sHH24$: sHH24$ = Mid$(sTime$, 1, 2)
Dim sMI$: sMI$ = Mid$(sTime$, 4, 2)
Dim sSS$: sSS$ = Mid$(sTime$, 7, 2)
result& = result& + Val(sSS$)
result& = result& + (Val(sMI$) * 60)
result& = result& + ((Val(sHH24$) * 60) * 60)
' RETURN RESULT
GetTimeSeconds& = result&
End Function ' GetTimeSeconds&
' /////////////////////////////////////////////////////////////////////////////
' 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
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if value text$ is numeric.
Function IsNum% (text$)
IsNum% = IsNumber%(text$)
End Function ' IsNum%
'' OLD IsNum% CHECK FAILS FOR NUMBERS LIKE "002" AND "2.000":
'' from https://www.qb64.org/forum/index.php?topic=896.0
'Function IsNum% (text$)
' Dim a$
' Dim b$
' a$ = _Trim$(text$)
' b$ = _Trim$(Str$(Val(text$)))
' If a$ = b$ Then
' IsNum% = TRUE
' Else
' IsNum% = FALSE
' End If
'End Function ' IsNum%
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if value OriginalString$ is numeric else returns FALSE.
' 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 iDecimalCount%
Dim sNextChar$
If Len(OriginalString$) > 0 Then
TestString$ = ""
If Left$(OriginalString$, 1) = "+" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
ElseIf Left$(OriginalString$, 1) = "-" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
Else
TestString$ = OriginalString$
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
' /////////////////////////////////////////////////////////////////////////////
' Combines all elements of in$() into a single string
' with delimiter$ separating the elements.
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
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$
' /////////////////////////////////////////////////////////////////////////////
' Prints MyString$, iLinesPerPage% lines at a time,
' then waits for user to press a key to continue,
' before printing the next iLinesPerPage% lines.
Sub PrintPaged (MyString$, iLinesPerPage%)
Dim delim$
ReDim arrTest$(0)
Dim iLoop%
Dim iCount%
Dim in$
delim$ = Chr$(13)
split MyString$, delim$, arrTest$()
iCount% = 0
For iLoop% = LBound(arrTest$) To UBound(arrTest$)
iCount% = iCount% + 1
If iCount% > iLinesPerPage% Then
Sleep
iCount% = 0
End If
Print arrTest$(iLoop%)
Next iLoop%
End Sub ' PrintPaged
' /////////////////////////////////////////////////////////////////////////////
' 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$
' /////////////////////////////////////////////////////////////////////////////
' 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$
' /////////////////////////////////////////////////////////////////////////////
' Initializes random number generator seed.
' NOTE:
' using # of seconds so far in the day
' may be slightly more random than Randomize Timer
' unless user runs program at exact same time every day
Sub InitializeRandom
Dim t9#
t9# = (Timer * 1000000) Mod 32767
Randomize t9#
End Sub ' InitializeRandom
' /////////////////////////////////////////////////////////////////////////////
' Initializes random number generator seed.
' *** NOT SURE IF THIS ONE WORKS ***
Sub InitializeRandom1
Dim iSeed As Integer
iSeed = GetTimeSeconds& Mod 32767
Randomize iSeed
End Sub ' InitializeRandom1
' /////////////////////////////////////////////////////////////////////////////
' Generate random value between Min and Max inclusive.
' Note: random-number generator should be initialized with
' InitializeRandom or Randomize Timer
Function RandomNumber% (Min%, Max%)
Dim NumSpread%
NumSpread% = (Max% - Min%) + 1
RandomNumber% = Int(Rnd * NumSpread%) + Min% ' GET RANDOM # BETWEEN Max% AND Min%
End Function ' RandomNumber%
' /////////////////////////////////////////////////////////////////////////////
$If Then
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
$End If
' /////////////////////////////////////////////////////////////////////////////
' [Replace$] replaces all instances of the [Find] sub-string
' with the [Add] sub-string within the [Text] string.
' 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
' 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.
' FROM: String Manipulation
' found at abandoned, outdated and now likely malicious qb64 dot net website
' http://www.qb64.[net]/forum/index_topic_5964-0/
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 COPIES SO 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$
' /////////////////////////////////////////////////////////////////////////////
$If Then
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
$End If
' /////////////////////////////////////////////////////////////////////////////
' Rounding functions.
' FROM:
' 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.
' =============================================================================
' ROUNDING FUNCTIONS FOR TYPE _FLOAT
' Receives + returns _FLOAT myVar## (-1.18E-4932 to +1.18E+4932)
' old name: RoundNatural##
Function Round## (num##, digits%)
Round## = Int(num## * 10 ^ digits% + .5) / 10 ^ digits%
End Function
Function RoundUp## (num##, digits%)
RoundUp## = _Ceil(num## * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundDown## (num##, digits%)
RoundDown## = Int(num## * 10 ^ digits%) / 10 ^ digits%
End Function
' old name: Round_Scientific##
Function RoundScientific## (num##, digits%)
RoundScientific## = _Round(num## * 10 ^ digits%) / 10 ^ digits%
End Function
' =============================================================================
' ROUNDING FUNCTIONS FOR TYPE DOUBLE
Function RoundDouble# (num#, digits%)
RoundDouble# = Int(num# * 10 ^ digits% + .5) / 10 ^ digits%
End Function
Function RoundUpDouble# (num#, digits%)
RoundUpDouble# = _Ceil(num# * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundDownDouble# (num#, digits%)
RoundDownDouble# = Int(num# * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundScientificDouble# (num#, digits%)
RoundScientificDouble# = _Round(num# * 10 ^ digits%) / 10 ^ digits%
End Function
' =============================================================================
' ROUNDING FUNCTIONS FOR TYPE SINGLE
Function RoundSingle! (num!, digits%)
RoundSingle! = Int(num! * 10 ^ digits% + .5) / 10 ^ digits%
End Function
' NOTE: not sure this one works: when digits%=3, it rounds .31 to .32
Function RoundUpSingle! (num!, digits%)
RoundUpSingle! = _Ceil(num! * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundDownSingle! (num!, digits%)
RoundDownSingle! = Int(num! * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundScientificSingle! (num!, digits%)
RoundScientificSingle! = _Round(num! * 10 ^ digits%) / 10 ^ digits%
End Function
' /////////////////////////////////////////////////////////////////////////////
' Receives a Single, rounds it to intNumPlaces places,
' and returns the result as a string.
Function SngRoundedToStr$ (sngValue As Single, intNumPlaces As Integer)
Dim sngNew As Single
sngNew = RoundSingle!(sngValue, intNumPlaces)
SngRoundedToStr$ = SngToStr$(sngNew)
End Function ' SngRoundedToStr$
' /////////////////////////////////////////////////////////////////////////////
' Receives a Single, rounds it to 0 places,
' and returns the result as an Integer.
' NOTE: Hack function, to be replaced with something better?
Function SngToInt% (sngOld As Single)
Dim sngNew As Single
Dim sValue As String
Dim iPos As Integer
sngNew = RoundSingle!(sngOld, 0)
sValue = SngToStr$(sngNew)
SngToInt% = Val(sValue)
End Function ' SngToInt%
' /////////////////////////////////////////////////////////////////////////////
' Converts a Single to a string, formatted without scientific notation.
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example usage:
' A string function that displays extremely small or large exponential
' decimal values.
Function SngToStr$ (n!)
Dim result$: result$ = ""
Dim value$
Dim Xpos%
Dim expo%
Dim sign$
Dim valu$
Dim dot%
Dim L%
Dim add$
Dim min$
Dim DP$
Dim n%
Dim num$
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")
End If
If expo% < 0 Then
min$ = String$(Abs(expo%) - (dot% - 1), "0")
DP$ = "."
End If
num$ = ""
For n% = 1 To L%
If Mid$(valu$, n%, 1) <> "." Then
num$ = num$ + Mid$(valu$, n%, 1)
End If
Next n%
result$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
Else
result$ = value$
End If
SngToStr$ = result$
End Function ' SngToStr$
' /////////////////////////////////////////////////////////////////////////////
' Splits a string in$ by delimeter delimiter$
' into an array result$().
' 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, iDelimLen) = delimiter$
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
' /////////////////////////////////////////////////////////////////////////////
$If Then
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
$End If
' /////////////////////////////////////////////////////////////////////////////
$If Then
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$(" + _Trim$(Str$(iLoop%)) + ") = " + Chr$(34) + out$ + Chr$(34)
Next iLoop%
Print
Print "SplitAndReplaceTest finished."
End Sub ' SplitAndReplaceTest
$End If
' /////////////////////////////////////////////////////////////////////////////
' 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 @GEN
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN REFERENCE #REF
' ################################################################################################################################################################
' =============================================================================
' 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%
' Screen _NewImage(1024, 768, 32): _ScreenMove 0, 0
' iCols = _Width(0) \ _FontWidth
' iRows = _Height(0) \ _FontHeight
' Print "_Width(0) =" + _Trim$(Str$(_Width(0)))
' Print "_Height(0) =" + _Trim$(Str$(_Height(0)))
' Print "_FontWidth =" + _Trim$(Str$(_FontWidth))
' Print "_FontHeight=" + _Trim$(Str$(_FontHeight))
' Print "iCols = _Width(0) \ _FontWidth = " + _Trim$(Str$(iCols))
' Print "iRows = _Height(0) \ _FontHeight = " + _Trim$(Str$(iRows))
$If Then
'Pete:
'Oh, does anyone else like how using $IF/THEN works as a block REM statement?
'I mean I'd rather we had a QB64 block remark statement like the one used for JavaScript, but thi hack will do.
$End If
' ################################################################################################################################################################
' END REFERENCE @REF
' ################################################################################################################################################################
'#END
|
