PHP-like associative arrays

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
Makoto WATANABE
Posts: 196
Joined: Apr 10, 2010 11:41
Location: Japan
Contact:

Re: PHP-like associative arrays

Postby Makoto WATANABE » Jun 20, 2020 1:44

Dear All !

Thank you for your continuas support.

In srvaldez's Zamaster's "Ultimate FB HashMap" sample program, I was able to confirm that the index of 676 strings was set up flawlessly.

Thank you so much!
Zamaster
Posts: 1025
Joined: Jun 20, 2005 21:40
Contact:

Re: PHP-like associative arrays

Postby Zamaster » Jun 20, 2020 6:08

Sir Valdez (srvaldez)! Some code for you: https://github.com/DotStarMoney/13C/blo ... hashmap.bi

Turning back the clock to 2016 and I remember the 64 bit implementation was borked: for the FBGD competition I used it and I *seem* to remember fixing the 64bit hash code. Give the code at the link a swiz?

...always enjoy a reason to come back here! Bye everyone for another number of years probably ❤
Makoto WATANABE
Posts: 196
Joined: Apr 10, 2010 11:41
Location: Japan
Contact:

Re: PHP-like associative arrays

Postby Makoto WATANABE » Jun 20, 2020 11:35

Dear Zamaster;

I am grateful to have received a direct reply from Zamaster san, whose name I know in the "Community Code Library".

On my site ,I would like to introduce "The Ultimate FB HashMap" with Japanese comments to Japanese people.
I would appreciate your approval.
ShawnLG
Posts: 137
Joined: Dec 25, 2008 20:21

Re: PHP-like associative arrays

Postby ShawnLG » Jun 20, 2020 16:27

I have added collision currection to the hash mapping. The hash function would be useless without it. I was unable to test it because I do not know of any collision conditions.

Why is the hash table defined in two dimentions?

assocarray.bi

Code: Select all

' collision divergent by ShawnLG

#Define ASSOC_ARRAY_LOG_COLLISIONS
   
'
'  Paul Hsieh's SuperFastHash
'  http://www.azillionmonkeys.com/qed/hash.html
'   
Function SuperFastHash(Key As Const String) As UInteger

    #Define get16bits(d) ((Cast(UInteger, Cast(UByte Ptr, d)[1]) Shl 8) + Cast(UInteger, Cast(UByte Ptr, d)[0]))
   
    Dim As UInteger length = Len(Key), hash = length, tmp
    Dim As Integer r
    Dim As ZString Ptr chars = cast(ZString ptr,StrPtr(Key))
   
    If length = 0 Then Return 0
   
    r = length And 3
    length Shr= 2
   
    Do While length > 0
       
        hash  += get16bits(chars)
        tmp    = (get16bits(chars + 2) Shl 11) Xor hash
        hash   = (hash Shl 16) Xor tmp
        chars += 2 * SizeOf(UShort)
        hash  += hash Shr 11
       
        length -= 1
    Loop
   
    Select Case r
       
        Case 3
            hash += get16bits(chars)
            hash Xor= hash Shr 16
            hash Xor= chars[SizeOf(UShort)] Shl 18
            hash += hash Shr 11
           
        Case 2
            hash += get16bits(chars)
            hash Xor= hash Shl 11
            hash += hash Shr 17
           
        Case 1
            hash += *Cast(UByte Ptr, chars)
            hash Xor= hash Shl 10
            hash += hash Shr 1
           
    End Select
   
    hash Xor= hash Shl 3
     hash +=   hash Shr 5
     hash Xor= hash Shl 4
     hash +=   hash Shr 17
     hash Xor= hash Shl 25
     hash +=   hash Shr 6
   
    Return hash
   
    #Undef get16bits
       
End Function

Type HashFunc As Function(Key As Const String) As UInteger

Enum KeyType
    Undefined
    IntegerKey
    StringKey
End Enum

#Macro DefineAssocArrayType(_TYPE_)
   
    #Ifndef __ASSOC_ARRAY_TYPE_##_TYPE_
    #Define __ASSOC_ARRAY_TYPE_##_TYPE_
   
    Type _TYPE_##ArrayItem
        Value        As _TYPE_
        Key         As KeyType
        Union
            iKey    As Integer Ptr
            sKey    As String Ptr
        End Union
        HashIndex   As UInteger
        Declare Sub Clear
        Declare Destructor
    End Type
   
    Sub _TYPE_##ArrayItem.Clear
        Select Case Key
            Case IntegerKey:     DeAllocate iKey
            Case StringKey:     DeAllocate sKey
        End Select
    End Sub
   
    Destructor _TYPE_##ArrayItem
        This.Clear
    End Destructor

    Type _TYPE_##Array
       
        Public:
       
            Declare Property Item(ByVal Key As Integer) As _TYPE_
            Declare Property Item(ByVal Key As Integer, Value As _TYPE_)
           
            Declare Property Item(ByVal Key As String) As _TYPE_
            Declare Property Item(ByVal Key As String, Value As _TYPE_)
           
            Declare Constructor(numBuckets As Integer = 10007, numItems As Integer = 31, hashfunc As HashFunc = ProcPtr(SuperFastHash))
            Declare Destructor
       
        Private:
           
            hash                As HashFunc
            table                As _TYPE_##ArrayItem Pointer Pointer
            numBuckets        As Integer
            itemsPerBucket    As Integer
       
    End Type

    Constructor _TYPE_##Array(numBuckets As Integer = 10007, numItems As Integer = 31, hashfunc As HashFunc = ProcPtr(SuperFastHash))
       
        This.numBuckets = numBuckets
        itemsPerBucket = numItems
        hash = hashfunc
       
        table = New _TYPE_##ArrayItem Pointer[numBuckets]
       
        For i As Integer = 0 To numBuckets - 1
            table[i] = New _TYPE_##ArrayItem[itemsPerBucket]
        Next
       
    End Constructor

    Destructor _TYPE_##Array
        For i As Integer = 0 To numBuckets - 1
            Delete[] table[i]
        Next
        Delete[] table
    End Destructor

    Property _TYPE_##Array.Item(ByVal Key As Integer) As _TYPE_
        Dim As UInteger keyHash = hash(Chr(1) + Str(Key))
        Do ' Find our value if it was indexed in a collision.
              If table[keyHash Mod numBuckets][keyHash Mod itemsPerBucket].HashIndex <> KeyHash Then
                 keyHash = (keyHash + 1) Mod numBuckets
              End If
        Loop Until table[keyHash Mod numBuckets][keyHash Mod itemsPerBucket].HashIndex = KeyHash
        Return table[keyHash Mod numBuckets][keyHash Mod itemsPerBucket].Value
    End Property
   
    Property _TYPE_##Array.Item(ByVal Key As Integer, Value As _TYPE_)
        Dim As UInteger keyHash = hash(Chr(1) + Str(Key))
        Do ' Collision divergent.
              If table[keyHash Mod numBuckets][keyHash Mod itemsPerBucket].Key <> Undefined Then
                 KeyHash = (KeyHash + 1) Mod numBuckets
              End If
        Loop Until table[keyHash Mod numBuckets][keyHash Mod itemsPerBucket].Key = Undefined Or table[keyHash Mod numBuckets][keyHash Mod itemsPerBucket].HashIndex = KeyHash
        With table[keyHash Mod numBuckets][keyHash Mod itemsPerBucket]
            'If .Key <> Undefined Then ' collision - DAMMIT!
            '    If Not (.Key = IntegerKey And *.iKey = Key) Then
            '        .Clear
            '        #Ifdef ASSOC_ARRAY_LOG_COLLISIONS
            '            Print "collision: (integer)"; Key; " with ";
            '            Select Case .Key
            '                Case IntegerKey:     Print " (integer) "; .iKey
            '                Case StringKey:     Print " (string) ";     .sKey
            '            End Select
            '        #EndIf
            '    EndIf
            'EndIf
            .Value = Value
            .Key = IntegerKey
            .iKey = Allocate(SizeOf(Integer))
            *.iKey = Key
            .HashIndex = keyHash
        End With
    End Property
   
    Property _TYPE_##Array.Item(ByVal Key As String) As _TYPE_
        Dim As UInteger keyHash = hash(Key)
        Do ' Find our value if it was indexed in a collision.
              If table[keyHash Mod numBuckets][keyHash Mod itemsPerBucket].HashIndex <> KeyHash Then
                 keyHash = (keyHash + 1) Mod numBuckets
              End If
        Loop Until table[keyHash Mod numBuckets][keyHash Mod itemsPerBucket].HashIndex = KeyHash
        Return table[keyHash Mod numBuckets][keyHash Mod itemsPerBucket].Value
    End Property
   
    Property _TYPE_##Array.Item(ByVal Key As String, Value As _TYPE_)
        Dim As UInteger keyHash = hash(Key)
        Do ' Collision divergent.
             If table[keyHash Mod numBuckets][keyHash Mod itemsPerBucket].Key <> Undefined Then
                KeyHash = (KeyHash + 1) Mod numBuckets
             End If
        Loop Until table[keyHash Mod numBuckets][keyHash Mod itemsPerBucket].Key = Undefined Or table[keyHash Mod numBuckets][keyHash Mod itemsPerBucket].HashIndex = KeyHash
        With table[keyHash Mod numBuckets][keyHash Mod itemsPerBucket]
            'If .Key <> Undefined Then ' collision - DAMMIT!
            '    If Not (.Key = StringKey And *.sKey = Key) Then
            '        .Clear
            '        #Ifdef ASSOC_ARRAY_LOG_COLLISIONS
            '            Print "collision: (string)"; Key; " with ";
            '            Select Case .Key
            '                Case IntegerKey:     Print " (integer) "; .iKey
            '                Case StringKey:     Print " (string) ";     .sKey
            '            End Select
            '        #EndIf
            '    EndIf
            'EndIf
            .Value = Value
            .Key = StringKey
            .sKey = Callocate(SizeOf(String))
            *.sKey = Key
            .HashIndex = keyHash
        End With
    End Property

    #EndIf
#EndMacro
srvaldez
Posts: 2538
Joined: Sep 25, 2005 21:54

Re: PHP-like associative arrays

Postby srvaldez » Jun 20, 2020 16:55

@ShawnLG
your corrected assocarray.bi works without a flaw, thanks a million :-)

@Zamaster
thank you for visiting and thanks for the link, will try your code a bit later :-)
Makoto WATANABE
Posts: 196
Joined: Apr 10, 2010 11:41
Location: Japan
Contact:

Re: PHP-like associative arrays

Postby Makoto WATANABE » Jun 21, 2020 9:33

Dear ShawnLG;

Thanks for your correction.

I checked with the following program.
There still seems to be collisions.

Code: Select all

#Include "assocarray.bi"

DefineAssocArrayType( Integer )

Dim Shared As IntegerArray ArrayItemID
Dim Shared ItemID As String     
Dim Shared Counter As Integer
Dim Shared CounterRead As Integer
Dim Shared CounterCollision As Integer
Dim Shared As Integer i, j
   
Counter = 0
CounterRead = 0
CounterCollision = 0

For i = Asc("A") To Asc("Z")
   For j = Asc("A") To Asc("Z")
      ItemID = "A" + Chr(i) + Chr(j)
      CounterRead = CounterRead + 1
     
      If ArrayItemID.Item(ItemID) = 0 Then
         Counter = Counter + 1
         ArrayItemID.Item(ItemID) = Counter
      Else
         CounterCollision = CounterCollision + 1
         Print Counter,ItemID,ArrayItemID.Item(ItemID)
      End If
   Next j
Next i
   
Print

Print ItemID
Print
Print "CounterRead = ";CounterRead,"Counter = ";Counter,"CounterCollision = ";CounterCollision

Sleep
srvaldez
Posts: 2538
Joined: Sep 25, 2005 21:54

Re: PHP-like associative arrays

Postby srvaldez » Jun 21, 2020 10:29

hello Makoto WATANABE
I don't follow your logic, but in the following test there are 16 collisions

Code: Select all

#Include "assocarray.bi"

DefineAssocArrayType( Integer )

Dim Shared As IntegerArray ArrayItemID
Dim Shared ItemID As String     
Dim Shared As Integer Collisions=0, Counter, i, j, k

Counter = 0
For i = Asc("A") To Asc("Z")
   For j = Asc("A") To Asc("Z")
      For k = Asc("A") To Asc("Z")
         ItemID = Chr(i) + Chr(j) + Chr(k)
         Counter += 1
         ArrayItemID.Item(ItemID) = Counter
      next
   Next
Next

Counter = 0
For i = Asc("A") To Asc("Z")
   For j = Asc("A") To Asc("Z")
      For k = Asc("A") To Asc("Z")
         ItemID = Chr(i) + Chr(j) + Chr(k)
         Counter += 1
         If (ArrayItemID.Item(ItemID) - Counter) <> 0 Then
            Print "ItemID = ";ItemID, "Counter = ";Counter, "ArrayItemID.Item(";ItemID;") = ";ArrayItemID.Item(ItemID);" should be ";counter
            Collisions+=1
         End If
      next
   Next
Next
if Collisions>0 then
   Print Collisions;" Collisions encountered"
else
   Print "no Collisions encountered"
end if


Code: Select all

ItemID = FCI  Counter =  3441             ArrayItemID.Item(FCI) =  14285 should be  3441
ItemID = GBV  Counter =  4104             ArrayItemID.Item(GBV) =  10023 should be  4104
ItemID = IBK  Counter =  5445             ArrayItemID.Item(IBK) =  5485 should be  5445
ItemID = IJO  Counter =  5657             ArrayItemID.Item(IJO) =  7126 should be  5657
ItemID = IMO  Counter =  5735             ArrayItemID.Item(IMO) =  13692 should be  5735
ItemID = IYU  Counter =  6053             ArrayItemID.Item(IYU) =  9020 should be  6053
ItemID = KLG  Counter =  7053             ArrayItemID.Item(KLG) =  10269 should be  7053
ItemID = LWX  Counter =  8032             ArrayItemID.Item(LWX) =  13408 should be  8032
ItemID = MMG  Counter =  8431             ArrayItemID.Item(MMG) =  11172 should be  8431
ItemID = MNE  Counter =  8455             ArrayItemID.Item(MNE) =  17108 should be  8455
ItemID = MXJ  Counter =  8720             ArrayItemID.Item(MXJ) =  10713 should be  8720
ItemID = OZN  Counter =  10128            ArrayItemID.Item(OZN) =  14932 should be  10128
ItemID = SQQ  Counter =  12601            ArrayItemID.Item(SQQ) =  13903 should be  12601
ItemID = VWP  Counter =  14784            ArrayItemID.Item(VWP) =  17373 should be  14784
ItemID = WPQ  Counter =  15279            ArrayItemID.Item(WPQ) =  17150 should be  15279
ItemID = WQU  Counter =  15309            ArrayItemID.Item(WQU) =  16749 should be  15309
 16 Collisions encountered
srvaldez
Posts: 2538
Joined: Sep 25, 2005 21:54

Re: PHP-like associative arrays

Postby srvaldez » Jun 21, 2020 11:15

however Zamaster's hashmap encountered no collisions in this test
it generates 456976 items, so it takes a while

Code: Select all

#include "hashmap.bi"

dsm_HashMap_define(zstring, integer)

using dsm

dim as HashMap(zstring, integer) ArrayItemID
Dim Shared ItemID As String     
Dim Shared As Integer Collisions=0, Counter, i, j, k, l

Counter = 0
For i = Asc("A") To Asc("Z")
   For j = Asc("A") To Asc("Z")
      For k = Asc("A") To Asc("Z")
         For l = Asc("A") To Asc("Z")
            ItemID = Chr(i) + Chr(j) + Chr(k) + Chr(l)
            Counter += 1
            ArrayItemID.insert( ItemID, Counter )
         next
      next
   Next
Next

Counter = 0
For i = Asc("A") To Asc("Z")
   For j = Asc("A") To Asc("Z")
      For k = Asc("A") To Asc("Z")
         For l = Asc("A") To Asc("Z")
            ItemID = Chr(i) + Chr(j) + Chr(k) + Chr(l)
            Counter += 1
            If (ArrayItemID.retrieve(ItemID) - Counter) <> 0 Then
               Print "ItemID = ";ItemID, "Counter = ";Counter, "ArrayItemID.retrieve(";ItemID;") = ";ArrayItemID.retrieve(ItemID)
               Collisions+=1
            End If
         next
      next
   Next
Next
if Collisions>0 then
   Print Collisions;" Collisions encountered"
else
   Print "no Collisions encountered"
end if
ShawnLG
Posts: 137
Joined: Dec 25, 2008 20:21

Re: PHP-like associative arrays

Postby ShawnLG » Jun 22, 2020 17:18

Makoto WATANABE wrote:Dear ShawnLG;

Thanks for your correction.

I checked with the following program.
There still seems to be collisions.


You are right. There is still a problem with collisions. i had a feeling something was quite not right. Thanks for testing it. I was reliying on the hash key for reference for collision avoidance, but this is not reliable because more than one entry can share the same key. I would need to save the original index entry in the hash table for reference on finding the correct hash entry. This would use more memory but all the entries are dynamically allocated anyway. I will fix it when I have some free time.
paul doe
Posts: 1315
Joined: Jul 25, 2017 17:22
Location: Argentina

Re: PHP-like associative arrays

Postby paul doe » Jun 22, 2020 20:09

ShawnLG wrote:...
You are right. There is still a problem with collisions. i had a feeling something was quite not right.
...

It seems to me that what you want is a Perfect Hashing Function. If your set of keys is limited and known in advance, this can be a great solution. However:
ShawnLG wrote:...
I was reliying on the hash key for reference for collision avoidance, but this is not reliable because more than one entry can share the same key.
...

As long as you're using a common hash scheme, collisions are unavoidable (since you're basically cramming many items into a limited space), so you need to resolve them in some way. Hashing is not meant to avoid searching altogether, but to greatly reduce the search space. I'd say that a hash function that shows up to 8 collisions under an optimal load of the hash table (around half of it) is pretty good, especially if it's fast to compute.
dodicat
Posts: 6723
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: PHP-like associative arrays

Postby dodicat » Jun 23, 2020 16:00

I cannot get zamasters .bi file to work (testing svraldez's code)
I get "null.bi" not found, not surprised, I haven't got it.
Where can I get a complete assocarray.bi and hashmap.bi?

I made up a little thingy myself.

Code: Select all

 

#define pushtop(a) ubound(a)+1
#define poptop(a) ubound(a)
#define bottom(a) lbound(a)
#define map(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))\((b)-(a))+(c)

#macro push(a,index,insert)
If (index)>=Lbound(a) And (index)<=Ubound(a)+1 Then
    Var index2=(index)-Lbound(a)
    Redim Preserve a(Lbound(a) To  Ubound(a)+1)
    For x As Long= Ubound(a) To Lbound(a)+index2+1 Step -1
        Swap a(x),a(x-1)
    Next x
    a(Lbound(a)+index2)=(insert)
End If
#endmacro

#macro pop(a,index)
If index>=Lbound(a) And (index)<=Ubound(a) Then
    For x As Long=(index) To Ubound(a)-1
        a(x)=a(x+1)
    Next x
    Redim Preserve a(Lbound(a) To Ubound(a)-1)
End If
#endmacro

#macro printout(t,range)
    for n as long=range
        print t(n).idx,t(n).fi,t(n).fs
    next
#endmacro

dim shared as string _s1_,_s2_
#macro setstrings(t)
_s1_="":_s2_=""
for n as long=lbound(t) to ubound(t)
    _s1_+=str(t(n).fi)+chr(0)
    _s2_+=str(t(n).fs)+chr(0)
    next
#endmacro


#macro setup(k,dtype1,dtype2)
Type udt##k
    Dim As Long idx
    as dtype1 fi
    Dim As dtype2   fs
    declare function find overload(as dtype2) as long
    declare function find overload(as dtype1) as long
    declare sub add(() as udt##k, as long,as dtype1,as dtype2)
    declare Sub revamp(() as udt##k)
    declare sub remove(() as udt##k,i as long)
End Type

Sub udt##k.revamp(t() as udt##k)
    redim preserve t(1 to ubound(t)+1)
    For n As Long=Lbound(t) To Ubound(t)
        t(n).idx=n
    Next n
    setstrings(t)
End Sub

sub udt##k.add(t() as udt##k,n as long,num as dtype1,g as dtype2)
     dim as udt##k tmp
    tmp.fi=num
    tmp.fs=g
   push(t,n,tmp)
end sub

sub udt##k.remove(t() as udt##k,i as long)
    pop(t,i)
end sub

function udt##k.find(g as dtype2) as long
    var i =instr(_s2_,str(g)),count=0
       if i then
        for z as long=0 to i
            if _s2_[z]=0 then count+=1
        next z
        return count+1
    end if
   
end function

function udt##k.find(g as dtype1) as long
     var i =instr(_s1_,str(g)),count=0
       if i then
        for z as long=0 to i
            if _s1_[z]=0 then count+=1
        next z
        return count+1
        end if
end function

#endmacro

dim as double tot=timer
setup(1,long,string)

redim as udt1 t()


dim as long Counter = 0
dim as string itemid
dim as long i,j,k
For i = Asc("A") To Asc("Z")
   For j = Asc("A") To Asc("Z")
      For k = Asc("A") To Asc("Z")
            ItemID = Chr(i) + Chr(j) + Chr(k)
            Counter += 1
           type<udt1>. Add(t(),pushtop(t), counter,ItemID )
      next
   Next
Next

type<udt1>.revamp(t()) 'must do


print "The last few"
print "id","field1","field2"
printout(t,ubound(t)-20 to ubound(t))
dim as double tt

tt=timer


dim as long collisions
Counter = 0
For i = Asc("A") To Asc("Z")
   For j = Asc("A") To Asc("Z")
      For k = Asc("A") To Asc("Z")
            ItemID = Chr(i) + Chr(j) + Chr(k)
            Counter += 1
            var i=type<udt1>.find(ItemID)
            if t(i).fi-counter<>0 then
               Print "ItemID = ";ItemID, "Counter = ";Counter', "ArrayItemID.retrieve(";ItemID;") = ";ArrayItemID.retrieve(ItemID)
               Collisions+=1
            End If
      next
   Next
Next
if Collisions>0 then
   Print Collisions;" Collisions encountered"
else
   Print "no Collisions encountered"
end if
print timer-tot;"  total time"
sleep

 
srvaldez
Posts: 2538
Joined: Sep 25, 2005 21:54

Re: PHP-like associative arrays

Postby srvaldez » Jun 23, 2020 16:33

dodicat wrote:Where can I get a complete assocarray.bi and hashmap.bi?

you can get all the files in the folder CoTGH at https://github.com/DotStarMoney/13C
however, null.bi just defines null if it's not defined

Code: Select all

#Ifndef NULL
#Define NULL 0
#EndIf

BTW dodicat, clever macros :-)
dodicat
Posts: 6723
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: PHP-like associative arrays

Postby dodicat » Jun 23, 2020 17:16

Thanks srvaldez.
28 megabytes and complicated copyright (not that I bother about that), puts me off a bit.
I'll sift through it later. I assume that it is pretty fast for your example, but as you say, some repeats.
srvaldez
Posts: 2538
Joined: Sep 25, 2005 21:54

Re: PHP-like associative arrays

Postby srvaldez » Jun 24, 2020 15:15

@dodicat
would you explain why this is necessary?
type<udt1>.revamp(t()) 'must do
fxm
Posts: 9987
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: PHP-like associative arrays

Postby fxm » Jun 24, 2020 16:00

@dodicat
Around that:
There is no reason to declare the member procedures 'find', 'add', 'revamp' and 'remove' as non static procedures, because every time it forces to call them on a temporary instance like 'type<udt1>()' which is useless at the end (and therefore created for nothing).
It is better in my opinion to call them statically like this:

Code: Select all

#define pushtop(a) ubound(a)+1
#define poptop(a) ubound(a)
#define bottom(a) lbound(a)
#define map(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))\((b)-(a))+(c)

#macro push(a,index,insert)
If (index)>=Lbound(a) And (index)<=Ubound(a)+1 Then
    Var index2=(index)-Lbound(a)
    Redim Preserve a(Lbound(a) To  Ubound(a)+1)
    For x As Long= Ubound(a) To Lbound(a)+index2+1 Step -1
        Swap a(x),a(x-1)
    Next x
    a(Lbound(a)+index2)=(insert)
End If
#endmacro

#macro pop(a,index)
If index>=Lbound(a) And (index)<=Ubound(a) Then
    For x As Long=(index) To Ubound(a)-1
        a(x)=a(x+1)
    Next x
    Redim Preserve a(Lbound(a) To Ubound(a)-1)
End If
#endmacro

#macro printout(t,range)
    for n as long=range
        print t(n).idx,t(n).fi,t(n).fs
    next
#endmacro

dim shared as string _s1_,_s2_
#macro setstrings(t)
_s1_="":_s2_=""
for n as long=lbound(t) to ubound(t)
    _s1_+=str(t(n).fi)+chr(0)
    _s2_+=str(t(n).fs)+chr(0)
    next
#endmacro


#macro setup(k,dtype1,dtype2)
Type udt##k
    Dim As Long idx
    as dtype1 fi
    Dim As dtype2   fs
    declare static function find overload(as dtype2) as long
    declare static function find overload(as dtype1) as long
    declare static sub add(() as udt##k, as long,as dtype1,as dtype2)
    declare static Sub revamp(() as udt##k)
    declare static sub remove(() as udt##k,i as long)
End Type

Sub udt##k.revamp(t() as udt##k)
    redim preserve t(1 to ubound(t)+1)
    For n As Long=Lbound(t) To Ubound(t)
        t(n).idx=n
    Next n
    setstrings(t)
End Sub

sub udt##k.add(t() as udt##k,n as long,num as dtype1,g as dtype2)
     dim as udt##k tmp
    tmp.fi=num
    tmp.fs=g
   push(t,n,tmp)
end sub

sub udt##k.remove(t() as udt##k,i as long)
    pop(t,i)
end sub

function udt##k.find(g as dtype2) as long
    var i =instr(_s2_,str(g)),count=0
       if i then
        for z as long=0 to i
            if _s2_[z]=0 then count+=1
        next z
        return count+1
    end if
   
end function

function udt##k.find(g as dtype1) as long
     var i =instr(_s1_,str(g)),count=0
       if i then
        for z as long=0 to i
            if _s1_[z]=0 then count+=1
        next z
        return count+1
        end if
end function

#endmacro

dim as double tot=timer
setup(1,long,string)

redim as udt1 t()


dim as long Counter = 0
dim as string itemid
dim as long i,j,k
For i = Asc("A") To Asc("Z")
   For j = Asc("A") To Asc("Z")
      For k = Asc("A") To Asc("Z")
            ItemID = Chr(i) + Chr(j) + Chr(k)
            Counter += 1
            udt1.Add(t(),pushtop(t), counter,ItemID )
      next
   Next
Next

udt1.revamp(t()) 'must do


print "The last few"
print "id","field1","field2"
printout(t,ubound(t)-20 to ubound(t))
dim as double tt

tt=timer


dim as long collisions
Counter = 0
For i = Asc("A") To Asc("Z")
   For j = Asc("A") To Asc("Z")
      For k = Asc("A") To Asc("Z")
            ItemID = Chr(i) + Chr(j) + Chr(k)
            Counter += 1
            var i=udt1.find(ItemID)
            if t(i).fi-counter<>0 then
               Print "ItemID = ";ItemID, "Counter = ";Counter', "ArrayItemID.retrieve(";ItemID;") = ";ArrayItemID.retrieve(ItemID)
               Collisions+=1
            End If
      next
   Next
Next
if Collisions>0 then
   Print Collisions;" Collisions encountered"
else
   Print "no Collisions encountered"
end if
print timer-tot;"  total time"
sleep

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 3 guests