PureBasic Forums - English

Posted: **Mon Dec 24, 2007 6:41 am**

Hi there,

This is an associative array-includefile for procedural programming.
Have fun with it.

Best regards

Wolf

PS: Desctriptions are available in the code.

Code: Select all

; *************************************************************************************
; *  ASA
; *  Associative String-Array
; *  2007 By Hroudtwolf and Hellhound66
; *  PureBasic-Lounge.de
; *************************************************************************************


; *************************************************************************************
; *  Types
; *************************************************************************************

Global sASA_RETURNDUMMY.s ; For using in DLLs

#flSORTED      = 1

Structure tASAHEADER
    lCountOfItems.l
    sDefaultValue.s
    lReadPointer .l
    flags        .l
    LastRead     .l
    *ASADATA     .tASAITEM
EndStructure

Structure tASAITEM
    lHashID.l
    Sid   .s
    sValue .s
EndStructure

Prototype pASA_EnumCallback (*ASAObj , Sid.s , sValue.s , lParam.l)

; *************************************************************************************
; *  Function:       _Hash (sString.s)
; *************************************************************************************
; *  Description:   For internal use
; *************************************************************************************
; *  Parameters:      
; *
; *************************************************************************************
; *  Rückgabe:      
; *
; *************************************************************************************
Procedure.l _Hash (sString.s)
    Protected *Source    .CHARACTER = @sString
    Protected lHash      .l         = 5381
    ;ProcedureReturn 10
    While *Source\c
        lHash = ((lHash << 5) + lHash) + *Source\c
        *Source + SizeOf (CHARACTER)
    Wend
   
    ProcedureReturn lHash&$0FFFFFFF
EndProcedure


; *************************************************************************************
; *  Function:       PSwap(*Item1,*Item2)
; *************************************************************************************
; *  Description:   For internal use
; *************************************************************************************
; *  Parameters:    
; *************************************************************************************
; *  Rückgabe:       null
; *
; *************************************************************************************
Procedure PSwap(*Item1.tASAITEM,*Item2.tASAITEM)
    dummy.tASAITEM
    ; Debug "Swapping "+Str(*Item1\lHashID)+" with "+Str(*Item2\lHashID)

    dummy\lHashID = *Item1\lHashID
    dummy\Sid    = *Item1\Sid
    dummy\sValue  = *Item1\sValue
   
    *Item1\lHashID  = *Item2\lHashID
    *Item1\Sid     = *Item2\Sid
    *Item1\sValue   = *Item2\sValue
   
    *Item2\lHashID  = dummy\lHashID
    *Item2\Sid     = dummy\Sid
    *Item2\sValue   = dummy\sValue
   
    ;Debug "Swapped : "+Str(*Item1\lHashID)+" and "+Str(*Item2\lHashID)
EndProcedure

; *************************************************************************************
; *  Function:       GetNextHash(*ASAObj.tASAHEADER)
; *************************************************************************************
; *  Description:  For internal use
; *************************************************************************************
; *  Parameters:    
; *************************************************************************************
; *  Rückgabe:      
; *************************************************************************************
Procedure.s ASA_GetNextHash(*ASAObj.tASAHEADER)
    Protected lHash.l
   
    If Not *ASAObj Or Not *ASAObj\ASADATA
        ProcedureReturn sASA_RETURNDUMMY
    EndIf   
    *Ptr.tASAITEM = *ASAObj\ASADATA + *ASAObj\LastRead*SizeOf(tASAITEM)
    lHash = *Ptr\lHashID
    *Ptr.tASAITEM = *ASAObj\ASADATA + (1+*ASAObj\LastRead)*SizeOf(tASAITEM)
    If (lHash = *Ptr\lHashID)
        *ASAObj\LastRead+1
        ProcedureReturn *Ptr\sValue
    EndIf
    ProcedureReturn sASA_RETURNDUMMY
EndProcedure


; *************************************************************************************
; *  Function:       GetNextHashIdentifier(*ASAObj.tASAHEADER)
; *************************************************************************************
; *  Description:   For internal use
; *************************************************************************************
; *  Parameters:    
; *
; *************************************************************************************
; *  Rückgabe:     
; *************************************************************************************
Procedure.s ASA_GetNextHashIdentifier(*ASAObj.tASAHEADER)
    Protected lHash.l
    If Not *ASAObj Or Not *ASAObj\ASADATA
        ProcedureReturn sASA_RETURNDUMMY
    EndIf   
    *Ptr.tASAITEM = *ASAObj\ASADATA + *ASAObj\LastRead*SizeOf(tASAITEM)
    lHash = *Ptr\lHashID
    *Ptr.tASAITEM = *ASAObj\ASADATA + (1+*ASAObj\LastRead)*SizeOf(tASAITEM)
    If(lHash = *Ptr\lHashID)
        *ASAObj\LastRead+1
        ProcedureReturn *Ptr\Sid
    EndIf
    ProcedureReturn sASA_RETURNDUMMY
EndProcedure

; *************************************************************************************
; *  Function:       IsNextHash(*ASAObj.tASAHEADER)
; *************************************************************************************
; *  Description:  For internal use
; *************************************************************************************
; *  Parameters:   
; *
; *************************************************************************************
; *  Rückgabe:  
; *
; *************************************************************************************
Procedure.l ASA_IsNextHash(*ASAObj.tASAHEADER)
    Protected lHash.l
    If Not *ASAObj Or Not *ASAObj\ASADATA
        ProcedureReturn #False
    EndIf   
    *Ptr.tASAITEM = *ASAObj\ASADATA + *ASAObj\LastRead*SizeOf(tASAITEM)
    lHash = *Ptr\lHashID
    *Ptr.tASAITEM = *ASAObj\ASADATA + (1+*ASAObj\LastRead)*SizeOf(tASAITEM)
    If (lHash=*Ptr\lHashID)
        ProcedureReturn #True
    EndIf
    ProcedureReturn #False
EndProcedure
 


; *************************************************************************************
; *  Function:       ASA_Create (sDefaultValue.s)
; *************************************************************************************
; *  Description:   Creates an ASA-Array
; *************************************************************************************
; *  Parameters:   
; *               sDefaultValue.s      -     Standard value for association
; *************************************************************************************
; *  Rückgabe:    Handle to the ASA-Object
; *
; *************************************************************************************
Procedure ASA_Create (sDefaultValue.s)
    Protected *ASAObj.tASAHEADER
    *ASAObj = AllocateMemory (SizeOf (tASAHEADER))
    If Not *ASAObj
        ProcedureReturn #Null
    EndIf
   
    *ASAObj\lCountOfItems = 0
    *ASAObj\sDefaultValue = sDefaultValue
    *ASAObj\flags         = #flSORTED
    *ASAObj\ASADATA       = #Null
   
    ProcedureReturn *ASAObj
EndProcedure

; *************************************************************************************
; *  Function:       ASA_Set (*AsaObj.tASAHEADER , sIDentifier.s , sValue.s)
; *************************************************************************************
; *  Description:   Sets a value to an association in an array.
; *************************************************************************************
; *  Parameters:   
; *               *AsaObj      -     ASA-Object
; *               sIDentifier  -     Name of the Assoziation
; *               sValue       -     Value of the Assoziation
; *************************************************************************************
; *  Rückgabe:    True/False
; *
; *************************************************************************************
Procedure ASA_Set (*ASAObj.tASAHEADER , sIDentifier.s , sValue.s)
    Protected lHashID .l
    Protected *List   .tASAITEM   = *ASAObj\ASADATA
    Protected *Temp   .tASAHEADER
    Protected *EOA                = *ASAObj\ASADATA + (*ASAObj\lCountOfItems * SizeOf (tASAITEM))
   
    If Not *ASAObj Or Not sIDentifier
        ProcedureReturn #False
    EndIf
   
    lHashID = _Hash (sIDentifier)   
   
    If *ASAObj\ASADATA
        While *EOA > *List
            If *List\lHashID = lHashID
                If *List\Sid = sIDentifier
                    *List\sValue  = sValue
                    ProcedureReturn #True
                EndIf
            EndIf
            *List + SizeOf (tASAITEM)
        Wend
    EndIf
    *Temp = ReAllocateMemory (*ASAObj\ASADATA , (*ASAObj\lCountOfItems * SizeOf (tASAITEM)) + SizeOf (tASAITEM))
    If Not *Temp
        ProcedureReturn #False
    EndIf
   
    *ASAObj\flags   &(~#flSORTED) 
   
    *ASAObj\ASADATA = *Temp   
    *List           = *ASAObj\ASADATA +  (*ASAObj\lCountOfItems * SizeOf (tASAITEM))
    *List\lHashID   = lHashID
    *List\Sid      = sIDentifier
    *List\sValue    = sValue
    *ASAObj\lCountOfItems + 1
    ProcedureReturn #True
EndProcedure


; *************************************************************************************
; *  Function:       ASA_QSort(*List,min,max)
; *************************************************************************************
; *  Description:   For internal use
; *************************************************************************************
; *  Parameters:   
; *
; *************************************************************************************
; *  Rückgabe:      null
; *
; *************************************************************************************
Procedure ASA_QSort(*List.tASAHEADER,min.l,Max.l)
    low.l = min
    high.l = Max
    Ref.l = (min+Max)/2
    While(low<=high)
        *Ptr.tASAITEM = *List\ASADATA + Ref*SizeOf(tASAITEM)
        RefHash.l = *Ptr\lHashID

        *Ptr.tASAITEM = *List\ASADATA + low*SizeOf(tASAITEM)
        lHash.l = *Ptr\lHashID
        While((lHash<RefHash)And(low<Max))
            low+1
            *Ptr.tASAITEM = *List\ASADATA + low*SizeOf(tASAITEM)
            lHash = *Ptr\lHashID
        Wend
       
        *Ptr.tASAITEM = *List\ASADATA + high*SizeOf(tASAITEM)
        rHash.l = *Ptr\lHashID
        While((rHash>RefHash)And(high>min))
            high-1
            *Ptr.tASAITEM = *List\ASADATA + high*SizeOf(tASAITEM)
            rHash = *Ptr\lHashID
        Wend
       
        If(low<=high)
            PSwap(*List\ASADATA + low*SizeOf(tASAITEM),*List\ASADATA + high*SizeOf(tASAITEM))
            low+1
            high-1
        EndIf
       
    Wend
   
    If(min<high)
        ASA_QSort(*List,min,high)
    EndIf
    If(low<Max)
        ASA_QSort(*List,low,Max)
    EndIf
EndProcedure       
 
 
; *************************************************************************************
; *  Function:       ASA_Get (*AsaObj.tASAHEADER , sIDentifier.s)
; *************************************************************************************
; *  Description:   Retrieves a value from association in an array
; *************************************************************************************
; *  Parameters:   
; *               *AsaObj      -     ASA-Object
; *               sIdentifier  -     Name of the association
; *************************************************************************************
; *  Rückgabe:    String::Value of the assoziation
; *
; *************************************************************************************
Procedure.s ASA_Get (*ASAObj.tASAHEADER , sIDentifier.s)
    Protected lHashID .l
    Protected *List   .tASAITEM   = *ASAObj\ASADATA
    Protected *EOA                = *ASAObj\ASADATA + (*ASAObj\lCountOfItems * SizeOf (tASAITEM))
   
    If Not *ASAObj Or Not sIDentifier Or Not *ASAObj\ASADATA
        sASA_RETURNDUMMY = *ASAObj\sDefaultValue
        ProcedureReturn sASA_RETURNDUMMY
    EndIf
    If(*ASAObj\lCountOfItems=0)
        ProcedureReturn sASA_RETURNDUMMY
    EndIf
   
    lHash = _Hash (sIDentifier)
   

   
    *ASAObj\LastRead = 0

   
    If((*ASAObj\flags&#flSORTED)=0)

       
        If(*ASAObj\lCountOfItems<>1)

           
            ASA_QSort(*ASAObj,0,*ASAObj\lCountOfItems-1)

           
        EndIf
        *ASAObj\flags |#flSORTED

    EndIf
   

   
    min.l = 0
    Max.l = *ASAObj\lCountOfItems-1

    While(min<=Max)

        Ref = (min+Max)/2

        *Ptr.tASAITEM = *List + Ref*SizeOf(tASAITEM)

        If(*Ptr\lHashID=lHash)

            *Prev.tASAITEM = *Ptr-SizeOf(tASAITEM)
           
            While((Ref>0)And(*Prev\lHashID=lHash))
  
                Ref-1

                *Prev - SizeOf(tASAITEM)

               
            Wend
           
            *ASAObj\LastRead = Ref
           
            While(ASA_IsNextHash(*ASAObj))

               
                IDValue.s = ASA_GetNextHashIdentifier(*ASAObj)
                
                If(IDValue=sIDentifier)
                   
                    *Ptr = *List + *ASAObj\LastRead*SizeOf(tASAITEM)

                   sASA_RETURNDUMMY = *Ptr\sValue
                    ProcedureReturn sASA_RETURNDUMMY
                EndIf
               
            Wend
           
            ProcedureReturn *Ptr\sValue

           
        EndIf
       
        If(*Ptr\lHashID<lHash)

           
            min=Ref+1

           
        Else

           
            Max=Ref-1

           
        EndIf
    Wend
    ; Suche war erfolglos.
    sASA_RETURNDUMMY = *ASAObj\sDefaultValue
    ProcedureReturn sASA_RETURNDUMMY
EndProcedure

; *************************************************************************************
; *  Function:       ASA_Count (*AsaObj.tASAHEADER)
; *************************************************************************************
; *  Description:   Retrieves the number of entries in an array
; *************************************************************************************
; *  Parameters:   
; *               *AsaObj      -     ASA-Object
; *************************************************************************************
; *  Rückgabe:    LONG::Count of associations
; *
; *************************************************************************************
Procedure.l ASA_Count (*ASAObj.tASAHEADER)
    If Not *ASAObj
        ProcedureReturn #Null
    EndIf   
    ProcedureReturn *ASAObj\lCountOfItems
EndProcedure

; *************************************************************************************
; *  Function:       ASA_Save (*AsaObj.tASAHEADER , sFilename.s)
; *************************************************************************************
; *  Description:   Saves an ASA-Object to disc
; *************************************************************************************
; *  Parameters:   
; *               *AsaObj      -     ASA-Object
; *               sFilename    -     Name of the new file
; *************************************************************************************
; *  Rückgabe:    True/False
; *
; *************************************************************************************
Procedure.l ASA_Save (*ASAObj.tASAHEADER , sFilename.s)
    Protected lFileID.l
    Protected *List   .tASAITEM   = *ASAObj\ASADATA
    Protected *EOA                = *ASAObj\ASADATA + (*ASAObj\lCountOfItems * SizeOf (tASAITEM))
   
    If Not *ASAObj Or Not sFilename Or Not *ASAObj\ASADATA
        ProcedureReturn #False
    EndIf
   
   
    lFileID = CreateFile (#PB_Any , sFilename)
    If Not lFileID
        ProcedureReturn #False
    EndIf   
   
    WriteLong (lFileID , 'ASA')
    WriteLong (lFileID , Len (*ASAObj\sDefaultValue) * SizeOf (CHARACTER))
    WriteData (lFileID ,  @*ASAObj\sDefaultValue , Len (*ASAObj\sDefaultValue) * SizeOf (CHARACTER))
   
    While *EOA > *List
        WriteLong (lFileID , *List\lHashID)
        WriteLong (lFileID , Len (*List\Sid) * SizeOf (CHARACTER))
        WriteData (lFileID , @*List\Sid , Len (*List\Sid) * SizeOf (CHARACTER))
        WriteLong (lFileID , Len (*List\sValue) * SizeOf (CHARACTER))
        WriteData (lFileID , @*List\sValue , Len (*List\sValue) * SizeOf (CHARACTER))
        *List + SizeOf (tASAITEM)
    Wend   
   
    CloseFile (lFileID)
    ProcedureReturn #True
EndProcedure

; *************************************************************************************
; *  Function:       ASA_Load (sFilename.s)
; *************************************************************************************
; *  Description:   Loads an ASA-Array from disc
; *************************************************************************************
; *  Parameters:   
; *               sFilename    -     Name of the file
; *************************************************************************************
; *  Rückgabe:    Handle to an ASA-Object
; *
; *************************************************************************************
Procedure.l ASA_Load (sFilename.s)
    Protected lFileID .l
    Protected lStrSize.l
    Protected sTemp   .s
    Protected *ASAObj  .tASAHEADER
    Protected *List    .tASAITEM
    Protected *Temp
   
    If Not sFilename
        ProcedureReturn #False
    EndIf
   
   
    lFileID = ReadFile (#PB_Any , sFilename)
    If Not lFileID
        ProcedureReturn #False
    EndIf   
   
    If ReadLong (lFileID) <> 'ASA'
        ProcedureReturn #False
    EndIf
    lStrSize = ReadLong (lFileID)
    sTemp    = Space (lStrSize / SizeOf (CHARACTER))
    ReadData (lFileID ,  @sTemp , lStrSize)
   
    *ASAObj = ASA_Create (sTemp)
   
    While Not Eof (lFileID)
        *Temp = ReAllocateMemory (*ASAObj\ASADATA , (*ASAObj\lCountOfItems * SizeOf (tASAITEM)) + SizeOf (tASAITEM))
        If Not *Temp
            ProcedureReturn #False
        EndIf
        *ASAObj\ASADATA = *Temp   
        *List           = *ASAObj\ASADATA +  (*ASAObj\lCountOfItems * SizeOf (tASAITEM))
        *List\lHashID   = ReadLong (lFileID)
        lStrSize        = ReadLong (lFileID)
        *List\Sid      = Space (lStrSize / SizeOf (CHARACTER))
        ReadData (lFileID ,  @*List\Sid , lStrSize)
        lStrSize        = ReadLong (lFileID)
        *List\sValue    = Space (lStrSize / SizeOf (CHARACTER))
        ReadData (lFileID ,  @*List\sValue , lStrSize)
        *ASAObj\lCountOfItems + 1
    Wend
   
    CloseFile (lFileID)
    ProcedureReturn *ASAObj
EndProcedure

; *************************************************************************************
; *  Function:       ASA_Free (*AsaObj.tASAHEADER)
; *************************************************************************************
; *  Description:   Releases the whole array
; *************************************************************************************
; *  Parameters:   
; *               *AsaObj      -     ASA-Object
; *************************************************************************************
; *  Rückgabe:    null
; *
; *************************************************************************************
Procedure.l ASA_Free (*ASAObj.tASAHEADER)
    If Not *ASAObj
        ProcedureReturn #Null
    EndIf   
    If *ASAObj\ASADATA
        FreeMemory (*ASAObj\ASADATA)
    EndIf
    FreeMemory (*ASAObj)
    ProcedureReturn #Null
EndProcedure

; *************************************************************************************
; *  Function:       ASA_Flush (*AsaObj.tASAHEADER)
; *************************************************************************************
; *  Description:   Deletes all entries in the array
; *************************************************************************************
; *  Parameters:   
; *               *AsaObj      -     ASA-Object
; *************************************************************************************
; *  Rückgabe:    null
; *
; *************************************************************************************
Procedure.l ASA_Flush (*ASAObj.tASAHEADER)
    If Not *ASAObj
        ProcedureReturn #Null
    EndIf   
    If *ASAObj\ASADATA
        FreeMemory (*ASAObj\ASADATA)
    EndIf
    *ASAObj\ASADATA = #Null
    ProcedureReturn #Null
EndProcedure

; *************************************************************************************
; *  Function:       ASA_Enum (*AsaObj.tASAHEADER , *Callback , lUserParam.l)
; *************************************************************************************
; *  Description:   Reads an array and sends its data to a callback function.
; *************************************************************************************
; *  Parameters:   
; *               *AsaObj      -     ASA-Object
; *               *Callback    -     Callback that is retrieving datas.
; *               lUserParam   -     User defined long value.
; *               Examble-Callback:
; *               
; *               Procedure EnumCallback (*ASAObj , sID.s , sValue.s , lParam.l)
; *               EndProcedure
; *           
; *               If the returns false, the enumeration will be breaked.
; *************************************************************************************
; *  Rückgabe:    True/False
; *
; *************************************************************************************
Procedure.l ASA_Enum (*ASAObj.tASAHEADER , *Callback.pASA_EnumCallback , lUserParam.l)
    Protected *List   .tASAITEM   = *ASAObj\ASADATA
    Protected *EOA                = *ASAObj\ASADATA + (*ASAObj\lCountOfItems * SizeOf (tASAITEM))
   
    If Not *ASAObj Or Not *Callback Or Not *ASAObj\ASADATA
        ProcedureReturn #False
    EndIf   
   
    While *EOA > *List
        If Not *Callback (*ASAObj , *List\Sid , *List\sValue , lUserParam)
            ProcedureReturn #False
        EndIf
        *List + SizeOf (tASAITEM)
    Wend     
   
    ProcedureReturn #True
EndProcedure

; *************************************************************************************
; *  Function:       ASA_GetIDByIndex (*AsaObj.tASAHEADER , lIndex.l)
; *************************************************************************************
; *  Description:   Detects the identifier on the given index
; *************************************************************************************
; *  Parameters:   
; *               *AsaObj      -     ASA-Object
; *               lIndex       -     Index of the elements (starts with 0)
; *************************************************************************************
; *  Return:    String::Identifier
; *
; *************************************************************************************
Procedure.s ASA_GetIDByIndex (*ASAObj.tASAHEADER , lindex.l)
    Protected *List   .tASAITEM
    sASA_RETURNDUMMY = ""
   
    If Not *ASAObj Or Not *ASAObj\ASADATA
        ProcedureReturn sASA_RETURNDUMMY
    EndIf   
   
    If lindex > (*ASAObj\lCountOfItems - 1)
        ProcedureReturn sASA_RETURNDUMMY
    EndIf
   
    ; By Hell added:
   
    *ASAObj\LastRead = lindex

   
    If((*ASAObj\flags&#flSORTED)=0)
        ; Die Liste ist unsortiert.
       
        If(*ASAObj\lCountOfItems<>1)
           
            ASA_QSort(*ASAObj,0,*ASAObj\lCountOfItems-1)

        EndIf
        *ASAObj\flags |#flSORTED

    EndIf
   
    *List = *ASAObj\ASADATA + (lindex * SizeOf (tASAITEM))
    sASA_RETURNDUMMY = *List\Sid
    ProcedureReturn sASA_RETURNDUMMY
EndProcedure

Posted: **Mon Dec 24, 2007 11:54 am**

Very handy!! Thankyou! =)

Gonna play bit with it

Thalius

Posted: **Mon Dec 24, 2007 3:25 pm**

Will check this out (after the holiday season!)

Thanks. Have a great new year.

Posted: **Sun Aug 17, 2008 10:48 am**

Hroudtwolf wrote:Hi there,

This is an associative array-includefile for procedural programming.
Have fun with it.

Best regards

Wolf

PS: Desctriptions are available in the code.

Hello.
Could you give an example how do we use this code?
Regards.

Thanos

Posted: **Sun Aug 17, 2008 2:23 pm**

Hi,

Code: Select all

*AsaObject = ASA_Create ( "FreeBasic is not the same like PureBasic" )

ASA_Set ( *AsaObject , "PureBasic" , "Feel the pure power." )
ASA_Set ( *AsaObject , "BlitzBasic" , "Feel a little bit power." )


Debug ASA_Get ( *AsaObject , "PureBasic" )
Debug ASA_Get ( *AsaObject , "FreeBasic" )
Debug ASA_Get ( *AsaObject , "BlitzBasic" )

ASA is a fast associative array include.
You can use it for many things like dynamic language support,
a little database, holding and reading settings and a lot of more.

Regards

Wolf

Posted: **Sun Aug 17, 2008 5:00 pm**

Hroudtwolf wrote:Hi,
ASA is a fast associative array include.
You can use it for many things like dynamic language support,
a little database, holding and reading settings and a lot of more.

Regards

Wolf

Excellent code!
Thank you very much for your reply.
Regards.

Thanos

PureBasic Forums - English

ASA. Associative array.

ASA. Associative array.

Re: ASA. Associative array.