' #Filename "test_HashFunctions2.tBasic"
#MINVERSION 1.9.16.17
Uses "console"
' every bucket in the database can hold
' - any type of variable - except strings
' - a list (dynamic Array) of fixed size variables or just single elements
' very simple: in front of data is a Dword
' similar to BString/ dynamic string "StrPtrLen(StrPtr( ))"
' but this Dword is a pointer to some Heap-Memory where
' the type-name can be read out using Heap_Get()
' ----------------------------------------------------------------------
Function TBMain()
' ----------------------------------------------------------------------
' create a database:
Local db As tDatabase
' little helpers:
Local i As Long
Local sKeys() As String
' this makes an array of 3 doubles, named "myDoubleArray", 1:
db.Store "Double", "myDoubleArray", 1, MKD$(1.1, 2.2, 3.3)
' some information about current data:
PrintL db.DataKey In 15
PrintL " Type " & db.DataType
PrintL " CountOf " & db.DataCountOf
PrintL " SizeOf " & db.DataSizeOf
PrintL " Len " & db.DataLen
' place a virtual layover onto the data:
Local data1(db.DataCountOf) Like db.DataType At db.DataPtr
PrintL
' now show data itself:
For i = 1 To db.DataCountOf
PrintL i, data1(i)
Next
PrintL
PrintL $CRLF & Repeat$(30, "-") & " key to continue" In 28
WaitKey
PrintL
Print "now create an array of type "
' this makes space for a list of longs - or at least 1 long:
PrintL db.Store("Long", "myLongList") In 15
Print "it's key is "
PrintL db.DataKey In 15
PrintL
PrintL "setting data: 5, 4, 3, 2, 1"
db.DataSet(MKL$(5, 4, 3, 2, 1))
PrintL
PrintL "just for fun append some more data: 0, -1, -2"
db.DataSet db.DataGet & MKL$(0, -1, -2)
PrintL
Print "now create an array of type "
' this makes another array of 4 doubles, named "myDoubleArray", 255
PrintL db.Store("Double", "myDoubleArray", 255, 4) In 15
' place the layover onto the data-space:
ReDim data1(db.DataCountOf) At db.DataPtr
PrintL "fill via layover with"
For i = 1 To db.DataCountOf
data1(i) = 1.23 * i
PrintL i, data1(i)
Next
PrintL $CRLF & Repeat$(30, "-") & " key to continue" In 28
WaitKey
PrintL
PrintL "access something that is stored as " & $DQ & "myLong" & $DQ
db.Access("myLong")
PrintL db.DataKey In 15
PrintL " Type " & db.DataType
PrintL " CountOf " & db.DataCountOf
PrintL " SizeOf " & db.DataSizeOf
PrintL " Len " & db.DataLen
Local data2(db.DataCountOf) Like db.DataType At db.DataPtr
For i = 1 To db.DataCountOf
PrintL i, data2(i)
Next
PrintL $CRLF & Repeat$(30, "-") & " key to continue" In 28
WaitKey
PrintL
PrintL "access something that is stored as " & $DQ & "myDoubleArray" & $DQ & ", 255"
db.access("myDoubleArray", 255)
PrintL db.DataKey In 15
PrintL " Type " & db.DataType
PrintL " CountOf " & db.DataCountOf
PrintL " SizeOf " & db.DataSizeOf
PrintL " Len " & db.DataLen
Local data3(db.DataCountOf) Like db.DataType At db.DataPtr
For i = 1 To db.DataCountOf
PrintL i, data3(i)
Next
PrintL $CRLF & Repeat$(30, "-") & " key to continue" In 28
WaitKey
PrintL
PrintL "list all keys that start with " & $DQ & "my" & $DQ
i = db.ListOf "my", sKeys
While i
PrintL sKeys(i)
i -= 1
Wend
PrintL
PrintL "now free all data that is named as " & $DQ & "myDouble" & $DQ
db.DataFree("myDouble")
PrintL "and list all keys that start with " & $DQ & "my" & $DQ & " again"
i = db.ListOf "my", sKeys
While i
PrintL sKeys(i)
i -= 1
Wend
PrintL
PrintL $CRLF & Repeat$(30, "-") & " key to end" In 28
WaitKey
End Function
'---------------------------------------------------------------------------------
Function Type_Enumerate(ByVal sType As String, _
Optional ByVal TestExist As Boolean _
) As DWord
'---------------------------------------------------------------------------------
' to create a global uniform Type-name-enumeration
' every type gets stored only once
' the "enumerated" number can be used to compare types.
' every "enumerated" number is unique since it's a memory-pointer
' which is valid until the script ends
' all type-names get stored in UCase and can be read out at this
' pointer using Heap_Get()
Static hAllTypes As DWord
' this points a heap with a list of pointers to all enumerated type-names
Local Index As Long ' will hold the index of requested pointer
If Not Type_Exists(sType) Then
MsgBox 0, "invalid type-name passed: " & $DQ & sType & $DQ, _
%MB_OK Or %MB_ICONERROR, "Type_Enumerate: Error"
Stop
EndIf
sType = Ucase$(sType) ' from here all type-names work in UCASE
If HEAP_Size(hAllTypes) Then ' are there any pointers already?
' place virtual Dword-array upon the pointer-list:
Local vPtr(HEAP_Size(hAllTypes)/4) As DWord At hAllTypes
' and scan if any of the list points the requested type-name
Index = Array Scan vPtr Ptr, = sType
If Index Then
Return vPtr(Index)
EndIf
EndIf
' does not exist yet:
If TestExist Then Return 0
' store sType and append its Pointer to function-static hAllTypes
HEAP_Set(hAllTypes, HEAP_Get(hAllTypes) & MKDWD$(HEAP_AllocByStr(sType)) )
' return last appended pointer
Function = Peek(DWord, HEAP_End(hAllTypes) - 3 )
' use Heap_Get() on the result to read type-name
End Function
' #######################################################################
Type tDatabase
' #######################################################################
Private
pHash As DWord
Public
' these hold values of the last accessed bucket:
DataKey As String
DataPtr As DWord
DataType As String
DataCountOf As Long
DataSizeOf As Long
DataLen As Long
' ----------------------------------------------------------------------
Function _Create(Optional ByVal capacity As Long = 384)
' ----------------------------------------------------------------------
' create some space:
If Me.pHash = 0 Then
capacity = MinMax(capacity, 50, &H3FFFFFFF)
Me.pHash = Hash_New(capacity)
EndIf
End Function
' ----------------------------------------------------------------------
Function Store( ByVal sType As String, _
ByVal sName As String, _
Optional ByVal Index As Long, _
ByVal sData As String _
) As String
' ----------------------------------------------------------------------
' creates a new entry to the database
' make sure this tDatabase is valid:
If Not Hash_Validate(Me.pHash) Then
MsgBox 0, "pointer of hash-table invalid:" & Str$(Me.pHash), _
%MB_OK Or %MB_ICONERROR, "tDatabase.Store: Error"
Stop
EndIf
' if we exceed the capacity enlarge the database:
If Hash_Count(Me.pHash) + 3 >= Hash_CapGet(Me.pHash) Then
Hash_CapSet(Me.pHash, Hash_CapGet(Me.pHash) * 1.5)
EndIf
' store type & get a pointer where to read it:
Local pType As DWord = Type_Enumerate(sType)
Me.DataType = sType
' create key from name & Index:
Me.DataKey = sName & Hex$(Index, 8)
' make sure the key is unique:
While Hash_Exists(Me.pHash, Me.DataKey)
Index += 1
Me.DataKey = sName & Hex$(Index, 8)
Wend
Local data Like sType At 0
Me.DataSizeOf = SizeOf(data)
If StrPtrLen(StrPtr(sData)) = 0 Then
' if no data passed create 1 element filled with 0
sData = Repeat$(Me.DataSizeOf, MKBYT$(0))
Me.DataCountOf = 1
Else
If All( StrPtrLen(StrPtr(sData)) < SizeOf(data), _
Val(sData) > 0 _
) Then
Me.DataCountOf = Val(sData)
sData = Repeat$(Me.DataSizeOf * Me.DataCountOf, MKBYT$(0))
Else
Me.DataCountOf = StrPtrLen(StrPtr(sData))/Me.DataSizeOf
EndIf
EndIf
Me.DataLen = StrPtrLen(StrPtr(sData))
' store type & data:
Hash_Set(Me.pHash, Me.DataKey, MKDWD$(pType) & sData)
' get the pointer where data starts:
Me.DataPtr = Hash_GetPtr(Me.pHash, Me.DataKey) + 4
Function = Me.DataType
End Function
' ----------------------------------------------------------------------
Function Access(ByVal sKey As String, _
Optional ByVal Index As Long _
) As String
' ----------------------------------------------------------------------
' this will fill udt-elements of the database
' if no index passed it will use any bucket thats
' key starts with sKey
' make sure this tDatabase is valid:
If Not Hash_Validate(Me.pHash) Then
MsgBox 0, "pointer of hash-table invalid:" & Str$(Me.pHash), _
%MB_OK Or %MB_ICONERROR, "tDatabase.Access: Error"
Stop
EndIf
If Function_CParams = 2 Then
sKey = sKey & Hex$(Index, 8)
EndIf
If Not Hash_Exists(Me.pHash, sKey) Then
' if the key does not exist then check for any
' key that starts with the passed sKey:
Local sList() As String
If Me.ListOf(sKey, sList) > 0 Then
sKey = sList(1)
Else
MsgBox 0, "invalid key " & $DQ & sKey & $DQ & " passed", _
%MB_OK Or %MB_ICONERROR, "tDatabase.Access: Error"
Stop
EndIf
EndIf
Local sData As String = Hash_Get(Me.pHash, sKey)
sData = Memory_Get(StrPtr(sData) + 4, StrPtrLen(StrPtr(sData)) - 4)
Me.DataKey = sKey
Me.DataPtr = Hash_GetPtr(Me.pHash, sKey) + 4
Me.DataType = HEAP_Get(Peek(DWord, Me.DataPtr - 4))
Local data Like Me.DataType At Me.DataPtr
Me.DataSizeOf = SizeOf(data)
Me.DataLen = StrPtrLen(StrPtr(sData))
Me.DataCountOf = Me.DataLen / Me.DataSizeOf
Function = sData
End Function
' ----------------------------------------------------------------------
Function ListOf(ByVal sKeypart As String, _
ByRef sFound() As String _
) As Long
' ----------------------------------------------------------------------
' get a list of all keys that start with sKeypart
' into byref passed sFound()
' returns count of matches
Local sKeys, sList() As String
Local nKeys As Long
sKeys = Hash_GetKeys(Me.pHash, $CRLF)
nKeys = Parse sKeys, sList, $CRLF
Function = Array Extract sList, Collate Ucase, StartsWith sKeypart InTo sFound
End Function
' ----------------------------------------------------------------------
Function DataSet( ByVal sData As String ) As DWord
' ----------------------------------------------------------------------
' this will set new data to last accessed bucket
' returns pointer where data was stored
If Not Hash_Exists(Me.pHash, Me.DataKey) Then Return 0
Local pType As DWord = Peek(DWord, Me.DataPtr - 4)
If StrPtrLen(StrPtr(sData)) < Me.DataSizeOf Then
sData = Repeat$(Me.DataSizeOf, MKBYT$(0))
EndIf
Me.DataLen = StrPtrLen(StrPtr(sData))
Me.DataCountOf = Me.DataLen / Me.DataSizeOf
Hash_Set(Me.pHash, Me.DataKey, MKDWD$(pType) & sData)
Me.DataPtr = Hash_GetPtr(Me.pHash, Me.DataKey) + 4
Function = Me.DataPtr
End Function
' ----------------------------------------------------------------------
Function DataGet() As String
' ----------------------------------------------------------------------
' this will get data of last accessed bucket
If Not Hash_Exists(Me.pHash, Me.DataKey) Then Return ""
Function = Memory_Get(Me.DataPtr, Me.DataLen)
End Function
' ----------------------------------------------------------------------
Function DataFree(Optional ByVal sKey As String, _
ByVal Index As Long )
' ----------------------------------------------------------------------
' this will free data
Local sList() As String
Local lCount As Long
If Function_CParams = 0 Then
ReDim sList(1)
sList(1) = Me.DataKey
lCount = 1
ElseIf Function_CParams = 2 Then
ReDim sList(1)
sList(1) = sKey & Hex$(Index, 8)
lCount = 1
Else
lCount = Me.ListOf(sKey, sList)
EndIf
While lCount
If Hash_Exists(Me.pHash, sList(lCount)) Then
Hash_Del(Me.pHash, sList(lCount))
lCount -= 1
EndIf
Wend
Me.DataKey = ""
Me.DataPtr = 0
Me.DataType = ""
Me.DataCountOf = 1
Me.DataSizeOf = 0
Me.DataLen = 0
End Function
' .......................................................................
End Type
' .......................................................................
Bookmarks