Results 1 to 3 of 3

Thread: data-structures and more

  1. #1
    thinBasic MVPs
    Join Date
    Oct 2012
    Location
    Germany
    Age
    54
    Posts
    1,529
    Rep Power
    170

    data-structures and more

    since tB 1.9.16.x introduced data-structures as Hash & AVL-tree we have great opportunities to store our data and very fast access to it.

    But for some cases as named and indexed objects, that need to be stored & accessed not by just one key and to have information about type of data it would be great to have some kind of database that allows to access stored objects by their name [& index] as common [array-] variables and be able to tell theirs Typename.

    Stored objects might be controls for some GUI-project, entities or shapes to draw & render and lots more.

    I currently use heap-memory and do all the management with a couple of comparison- & scan-methods
    but i think this can be improved in execution-speed if we had something as this built-in.

    Attached some example database-type which can store any data that mandatory Extends the same Dataheader,
    all stored information will have 3 properties telling type, name and index.

    Instead of controls, entities or shapes the example-script uses some "food"-type,
    split into different subtypes as "meat" and "fruits" which have different properties.

    I hope something as this could become a module or part of core-engine.

    ' #Filename "test_tDatabase.tbasic"
    Uses "console"
    
    #INCLUDE Once "tDatabase.tBasicU" 
    
    %brightYellow = %CONSOLE_FOREGROUND_GREEN | %CONSOLE_FOREGROUND_RED | %CONSOLE_FOREGROUND_INTENSITY
    %brightPurple = %CONSOLE_FOREGROUND_BLUE  | %CONSOLE_FOREGROUND_RED | %CONSOLE_FOREGROUND_INTENSITY
    
    
    ' we create a database for some food: 
    
    
    ' #####################################################################
    Type tFood                        Extends tDataheader
    ' #####################################################################
      
      ' each item will know it's type
      ' each item will have a name & index 
      
      pTaste As DWord
      Weight As Double
      
    ' ---------------------------------------------------------------------
      Function SetTaste(ByVal sTaste As String)
        Me.pTaste = HEAP_ReAllocByStr(Me.pTaste, sTaste)
      End Function   
      
    ' ---------------------------------------------------------------------
      Function Info() 
        ' every extension of tFood MUST HAVE Info() or 
        ' has to extend some extension of tFood that has Info()
        
        PrintL Me.Type$(), Me.Name$, Me.Index In %brightYellow
        
        ' create layover of the real type at Me:
        Local realMe Like Me.Type$() At VarPtr(Me)
        
        ' call Info() on the real type:
        If realMe.Info() Then Nop
       
        ' use "If <...> Then Nop" to request a result even if none needed
        ' since it's dimensioned dynamic, using keyword "Like"
        
      End Function
    ' ---------------------------------------------------------------------
      Function Free() As DWord
        ' use a Free()-function on any data stored with tDatabase
        
        ' to free allocated resources that are noded to Me
         
        PrintL Function_Name & ": " & Me.Name$, Me.Index In %brightYellow
        
        ' kill all information
        Me.pType = 0
        Me.pName = 0
        Me.Index = 0
        
        HEAP_Free(Me.pTaste)
        Me.pTaste = 0  
        Me.Weight = 0
      
      End Function  
        
    End Type
    
    ' #####################################################################
    Type tFruit                       Extends tFood
    ' #####################################################################
      Stones As Long  
    ' ---------------------------------------------------------------------
      Function Info()
        PrintL "  Taste  " & HEAP_Get(Me.pTaste)
        PrintL "  Weight " & Me.Weight
        PrintL "  Stones " & Me.Stones
      End Function
    End Type
    
    ' #####################################################################
    Type tMeat                        Extends tFood
    ' #####################################################################
      Bones As Byte
    ' ---------------------------------------------------------------------
      Function Info()
        PrintL "  Taste  " & HEAP_Get(Me.pTaste)
        PrintL "  Weight " & Me.Weight
        PrintL "  Bones  " & Me.Bones
      End Function
    End Type
    
    
    ' ---------------------------------------------------------------------
    
    '[!] create Global Database:
    Global Database As tDatabase
    
    
    ' ---------------------------------------------------------------------
    Function TBMain()
    ' ---------------------------------------------------------------------
      Local pAll()   As DWord
      Local i        As Long
      
      ' .....................................................................
      PrintL "adding some data to database: " In %brightYellow
      PrintL
      
      ' dim meat as tMeat, named Porkchop at allocated memory
      Local meat Like Database.Alloc("tMeat", "Porkchop") At Database.DataPtr
        meat.Weight = 0.5
        meat.SetTaste("yummy")
        meat.Bones = 1
      
      ' allocate another tMeat, named Roulade 
      Database.Alloc("tMeat", "Roulade")           
      ' place virtual meat upon last by Database used DataPtr   
        SetAt(meat, Database.DataPtr)
        meat.Weight = 0.7
        meat.SetTaste("sappy")
      
      ' dim fruit as tFruit, named Banana at allocated memory
      Local fruit Like Database.Alloc("tFruit", "Banana") At Database.DataPtr
        fruit.Weight = 0.2
        fruit.setTaste("sweet")
      
      ' allocate another tFruit, named Apple
      Database.Alloc("tFruit", "Apple")
        SetAt(fruit, Database.DataPtr)
        fruit.Weight = 0.3
        fruit.SetTaste("bittersweet")
        fruit.Stones = 14
        
      ' get a list of all data-ptrs:  
      Database.ListAll(pAll)
      
      ' prepare tFood -layover
      Local item As tFood At 0  
      
      ' let all items give information:
      
      For i = 1 To CountOf(pAll)
        SetAt( item, pAll(i) )
        If item.Info() Then Nop
      Next
      PrintL
      PrintL Repeat$(30, "-") & " key to continue" In %brightPurple
      WaitKey 
      PrintL   
      ' .....................................................................
      
      PrintL "now free some data passing its name:"  
      PrintL
        
      Database.Free("Roulade")
      Database.Free("Banana")
      PrintL
     
      PrintL "now we have " & Str$(Database.ListAll(pAll)) & " items stored in database"
      
      
      PrintL
      PrintL Repeat$(30, "-") & " key to continue" In %brightPurple
      WaitKey
      PrintL  
      ' .....................................................................
      
      PrintL "adding 3 more items of food:"  In %brightYellow
      
      Database.Alloc("tMeat", "Liver")
      SetAt(meat, Database.DataPtr)
        meat.Weight = 1.5
        meat.SetTaste("disgusting")
        
      Database.Alloc("tFruit", "Peach")
      SetAt(fruit, Database.DataPtr)
        fruit.Weight   = 0.35
        fruit.SetTaste("very good")
        fruit.Stones   = 1
      
      Database.Alloc("tFruit", "Apple")
        SetAt(fruit, Database.DataPtr)
        fruit.Weight = 0.4
        fruit.SetTaste("sour")
        fruit.Stones = 19
     
      Database.ListAll(pAll)
      PrintL "Now we have altogether:"
      
      For i = 1 To CountOf(pAll)
        SetAt( item, pAll(i) )
        If item.Info() Then Nop
      Next
      
      PrintL
      PrintL Repeat$(30, "-") & " key to continue" In %brightPurple
      WaitKey 
      PrintL 
      
      ' .....................................................................
      
      Print "does Apple 2 exist?               "
      PrintL IIf$(Database.GetPtr("Apple", 2), "Yes", "No" ) In %brightYellow
      
      Print "does Apple 3 exist?               "
      PrintL IIf$(Database.GetPtr("Apple", 3), "Yes", "No" ) In %brightYellow
      
      Print "does a dataptr 123 exist in Database? "
      PrintL IIf$(Database.IsPtr(123), "Yes", "No" )         In %brightYellow
      
      Print "is current item valid for Database?   "
      PrintL IIf$(Database.IsPtr(GetAt(item)), "Yes", "No" ) In %brightYellow
      
      Print  "item is: " & Database.Name$(GetAt(item)) 
      Print  " "         & Database.Index(GetAt(item))
      PrintL " of type " & Database.TypeAt(GetAt(item)) 
      PrintL 
      
      PrintL "porkchop is of type " & DataBase.Type$("porkchop")
      
      
      PrintL
      PrintL Repeat$(30, "-") & " key to continue" In %brightPurple
      WaitKey 
      PrintL 
      ' .....................................................................
      
      If DataBase.ListName(pAll, "Apple") Then
        PrintL "we have" & Str$(CountOf(pAll)) & " items named APPLE:" 
        PrintL
        
        For i = 1 To CountOf(pAll)
          SetAt( item, pAll(i) )
          If item.Info() Then Nop
        Next
      EndIf 
     
      PrintL
      PrintL Repeat$(30, "-") & " key to continue" In %brightPurple
      WaitKey 
      ' .....................................................................
      PrintL 
      
      If DataBase.ListType(pAll, "tFruit") Then
        PrintL "we have" & Str$(CountOf(pAll)) & " items of type tFruit:" 
        PrintL
        For i = 1 To CountOf(pAll)
          SetAt( item, pAll(i) )
          If item.Info() Then Nop
        Next
      EndIf 
      
      PrintL
      PrintL Repeat$(30, "-") & " key to continue" In %brightPurple
      WaitKey 
      PrintL 
      
      ' .....................................................................
      
      PrintL "now free all data named Apple:" In %brightYellow
      Database.Free("Apple")      
      PrintL
      PrintL "then we have:"
      If Database.ListAll(pAll) Then
        For i = 1 To CountOf(pAll)
          SetAt( item, pAll(i) )
          If item.Info() Then Nop
        Next
      EndIf
    
      PrintL
      PrintL Repeat$(30, "-") & " key to continue" In %brightPurple
      WaitKey 
      PrintL 
      
      ' .....................................................................
      
      PrintL "now free all passing a pointer" & $CRLF 
      
      For i = 1 To CountOf(pAll)
        Database.FreeAt(pAll(i))
      Next  
      PrintL
      PrintL "we have " & Str$(Database.ListAll(pAll)) & " items stored in database"
      PrintL
      PrintL Repeat$(30, "-") & " key to end"  In %brightPurple
      WaitKey
      
    End Function
    
    Be assured- as soon as Hash-table has the ability to list all keys- i will come up with some better & faster methods to do the above
    Attached Images Attached Images
    Attached Files Attached Files
    Last edited by ReneMiner; 20-02-2016 at 18:52.
    I think there are missing some Forum-sections as beta-testing and support

  2. #2
    thinBasic MVPs
    Join Date
    Oct 2012
    Location
    Germany
    Age
    54
    Posts
    1,529
    Rep Power
    170

    Lightbulb fits the topic...

    It's just a raw sketch how we can use hash-tables to store similar objects of completely different types.

    You could replace the udts tTest1 & tTest2 with

    buttons, textboxes, treeviews etc. ("myButton" 1, "myButton" 2, "txtPassword" 1, "txtPassword" 2, ... )
    or even with spaceships of klingons, borg, ferenghi, humans...

    whatever different stuff you want to group that has something in common, a name (perhaps also an Index), same named methods that do something totally different depending on its type...

    Not much to keep it understandeable.

    ' #Filename "test_Hashstuff.tBasic"
    #MINVERSION 1.9.16.17
    
    Uses "console"
    
    ' ----------------------------------------------------------------------
    Function TBMain()                                                       
    ' ----------------------------------------------------------------------
      
      Local myObjects     As tHash
      Local sKey, sKeys() As String
      Local nKeys         As Long
      
      
      For nKeys = 1 To 3
        sKey = myObjects.Make("tTest1", "someDoubles")
        PrintL "Key " & nKeys & " is " & sKey  In 14
        PrintL " DataSize " & myObjects.DataSize(sKey)
        PrintL " DataType " & myObjects.Type$(sKey)
        PrintL " DataPtr  " & myObjects.DataPtr
        PrintL
      Next
      
      sKey = myObjects.Make("tTest2", "someLongs")
      PrintL "Key 4 is " & sKey In 14
      PrintL " DataSize " & myObjects.DataSize(sKey)
      PrintL " DataType " & myObjects.Type$("SomeL") ' will this work?
      PrintL " DataPtr  " & myObjects.DataPtr
      PrintL
      
      PrintL $CRLF & Repeat$(30, "-") & " key to continue" In 28              
      WaitKey 
      PrintL
      
      Print "Keys that start with " 
      PrintL "someDoubles" In 12
      
      nKeys = myObjects.listOf("SomeDoubles", sKeys)
      While nKeys 
        ' ( just go backward here to avoid more variables )
        PrintL sKeys(nKeys)
        nKeys -= 1
      Wend
       
      PrintL $CRLF & Repeat$(30, "-") & " key to end" In 28              
      WaitKey 
      
    End Function 
    
    ' this be 2 totally different udts that we store to a hash-table: 
    
    ' #######################################################################
    Type tTest1
    ' #######################################################################
      d1 As Double
      d2 As Double
      d3 As Double
    ' .......................................................................
    End Type
    ' .......................................................................
    
    ' #######################################################################
    Type tTest2 
    ' #######################################################################
      l1 As Long
      l2 As Long    
    ' .......................................................................
    End Type   
    ' .......................................................................
    
    
    
    ' this the hash-table that allows to name and index data of different type
    ' it also "knows" the size & type of stored data  
    ' #######################################################################
    Type tHash
    ' #######################################################################
      Private 
      pHash As DWord
      
      Public 
      DataPtr  As DWord     ' holds the last affected ptr
      DataType As String    ' holds last keys type
      
    ' ----------------------------------------------------------------------
      Function _Create(Optional ByVal capacity As Long = 200)
    ' ----------------------------------------------------------------------
        
        ' setup some space:
        If Me.pHash = 0 Then
          capacity = MinMax(capacity, 50, &H3FFFFFFF)
          Me.pHash = Hash_New(capacity)
          
        EndIf
          
        
      End Function
                 
    ' ----------------------------------------------------------------------
      Function Make(ByVal sType As String,  _
                    ByVal sName As String,  _
           Optional ByVal Index As Long = 1 _
                    ) As String
    ' ----------------------------------------------------------------------
        ' create space for a variable of sType with the passed name and index
        
        Static pAllTypes As DWord
        
        If Not Hash_Validate(Me.pHash) Then Return ""
        
        Local  i         As Long   
        Local  pType     As DWord
        Local  sKey      As String = sName & Hex$(Index, 8)
        
        Local data       Like sType At 0
        
        
        
        While Hash_Exists(Me.pHash, sKey)
          ' make sure the key is unique: 
          Index += 1
          sKey = sName & Hex$(Index, 8)
        Wend
        
        If Hash_Count(Me.pHash) + 2 >= Hash_CapGet(Me.pHash) Then
          ' if we exceed the capacity simply double it:
          Hash_CapSet(Me.pHash, Hash_CapGet(Me.pHash) * 2)
          
        EndIf
        
        
        sType = Ucase$(sType) ' from here all type-names work in UCASE
        
        If HEAP_Size(pAllTypes) Then    ' are there any pointers already?     
          ' place virtual Dword-array upon the pointer-list:
          Local vPtr(HEAP_Size(pAllTypes)/4) As DWord At pAllTypes
          ' and scan if any of the list points the requested type-name
          i = Array Scan vPtr Ptr, = sType
        EndIf
        
        If i Then 
          pType = vPtr(i)
        Else
          ' create a new Heap that stores the type:
          HEAP_Set pType, sType
          ' append the new pointer to the list
          HEAP_Set( pAllTypes, HEAP_Get(pAllTypes) & MKDWD$(pType) )
        EndIf
        
        ' create a slot for the data and poke its type in front                
        Hash_Set(Me.pHash, sKey, MKDWD$(pType) & Repeat$(SizeOf(data), MKBYT$(0)))
        
        ' set dataPtr to hold position where the data starts:
        Me.DataPtr  = Hash_GetPtr(Me.pHash, sKey) + 4
        
        ' datatype be current type of data
        Me.DataType = sType
        
       
        ' return the key for the data:
        Function = sKey
        
      End Function
    
    ' ----------------------------------------------------------------------
      Function Type$(ByVal sKey As String) As String
    ' ----------------------------------------------------------------------
        ' find out the type of data which we have a key for:
        
        If Hash_Exists(Me.pHash, sKey) Then 
          Me.DataPtr  = Hash_GetPtr(Me.pHash, sKey) + 4
          Me.DataType = HEAP_Get(Peek(DWord, Hash_GetPtr(Me.pHash, sKey)))
        Else
        ' if the key does not exist we check for any 
        ' key that starts with the passed sKey:
          Local sList() As String
          If Me.ListOf(sKey, sList) > 0 Then
            Me.DataPtr  = Hash_GetPtr(Me.pHash, sList(1)) + 4
            Me.DataType = HEAP_Get(Peek(DWord, Hash_GetPtr(Me.pHash, sList(1))))
          Else
            Me.DataPtr = 0
            Me.Dataype = "Variant"
          EndIf 
        EndIf
          
        Function = Me.DataType
        
        
      End Function
    
    ' ----------------------------------------------------------------------
      Function DataSize(ByVal sKey As String) As Long
    ' ----------------------------------------------------------------------
        
        Local data Like Me.Type$(sKey) At 0
        Function = SizeOf(data)
        
      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
        
      
    ' .......................................................................
    End Type 
    ' .......................................................................
    
    Global myHash As tHash(500)
    
    To use data contained in a "hash-slot" for the layover-stuff its necessary to dimension tHash global as shown at the end of the script.

    Then you can think of
    ' create key for a requested object as:
    Local Index As Long = 123
    Local sKey As String = "Klingon" & Hex$(Index, 8) 
    
    ' layover to object-data 
    Local Ship1 Like myHash.Type$(sKey) At myHash.DataPtr
    
    
    Index = Ship1.GetClosestShipIndex("Human")
    ' build the needed key:
    sKey = "Human" & Hex$(Index, 8)
    
    Local Ship2 Like myHash.Type$(sKey) At myHash.DataPtr
    ' humans may have different brands of ships...
    
    If Ship1.GunsLoaded Then
      Ship1.SetTarget( Ship2.Position )
      Ship1.Fire
      Ship2.Shields -=Ship1.Firepower
      If Ship2.Shields <= 0 Then
        Ship2.Explode
      '...
    
    Last edited by ReneMiner; 27-08-2016 at 10:03.
    I think there are missing some Forum-sections as beta-testing and support

  3. #3
    thinBasic MVPs
    Join Date
    Oct 2012
    Location
    Germany
    Age
    54
    Posts
    1,529
    Rep Power
    170

    hash-table-experimenting

    ' #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
    ' .......................................................................
    
    Last edited by ReneMiner; 28-08-2016 at 11:38.
    I think there are missing some Forum-sections as beta-testing and support

Similar Threads

  1. Using Dictionary to store data structures
    By ErosOlmi in forum Dictionary module
    Replies: 4
    Last Post: 13-07-2014, 08:46
  2. UK data
    By ErosOlmi in forum General
    Replies: 0
    Last Post: 05-02-2010, 23:37
  3. Nested UDT structures passed as param to API function
    By ErosOlmi in forum Preview testing
    Replies: 1
    Last Post: 31-10-2008, 09:24
  4. Data trigger and data events
    By ErosOlmi in forum TBEM module - thinBasic Event Manager module
    Replies: 9
    Last Post: 10-10-2008, 22:54

Members who have read this thread: 0

There are no members to list at the moment.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •