Array in a String

[Theo Gottwald]

If nothing else, this might be interesting. The array exists entirely inside a host string. May be stored and passed as a string. Array remains intact for life of host string. Doesn't need to be freed, just a string. Must be passed ByRef to stay current. Elements in array may be other hosted in-string arrays. This has limitation due to string overhead, but fast for light use. Public domain, use at own risk. SDurham

Source: Powerbasic-Forum

Code Select Expand

' In-String String & WString Array
    ' CSV on steroids.
    ' Not for heavy use.

    ' ((( The array exist entirely inside host string. )))
    ' May be passed or stored anywhere, remains intact for life of host string.
    ' store in file, database, another string container, ...

    ' No ReDim(), just set, get, add, insert and delete.
    ' To reset or erase array, container$ = "".

    ' Doesn't need to be freed, it's just a string.

    ' Needs to be passed ByRef to stay current.
    ' A copy of the host string is a new instance.
    ' The original can be updated from a copy, original = copy.
    ' Host string protected with hash tag.

    ' Should be limited to a few thousand strings.

    ' add 1,000 random strings to empty arra = 0.000 seconds
    ' set 1,000 values =  0.000 seconds
    ' get 1,000 from array of 1,000 value = 0.014 seconds

    ' add 2,000 random strings to empty array = 0.000 seconds
    ' set 2,000 values = 0.023 seconds
    ' get 2,000 from array of 2,000 values = 0.055 seconds

    ' add 5,000 random strings to empty array = 0.028 seconds
    ' set 5,000 values = 0.297 seconds
    ' get 5,000 from array of 5,000 values = 0.453 seconds

    ' add 10,000 random strings to empty array = 0.054 seconds
    ' set 10,000 values = 0.846 seconds
    ' get 10,000 from array of 10,000 values = 1.447 seconds

    ' add 20,000 random strings to empty array = 0.158 seconds
    ' set 20,000 values = 3.431 seconds
    ' get 20,000 from array of 20,000 values = 5.842 seconds

    ' add 30,000 random strings to empty array = 0.270 seconds
    ' set 30,000 values = 7.165 seconds
    ' get 30,000 from array of 30,000 values = 12.556 seconds

    ' about 5,000 to 10,000 limit for small strings
    ' less for large strings

#If Not %Def(%HostedStringArray230304)
    %HostedStringArray230304 = 1
    %HostedStringArrayTag = -1622479746
    ' String Array Stored in String
    ' Memory allocation is just a string.
    ' public domain, use at own risk
    ' SDurham
    Function SarrCount(container$) ThreadSafe As Long
        ' get item count
        If Len(container$) And Peek(Long, StrPtr(container$)) = %HostedStringArrayTag Then Function = Peek(Long, StrPtr(container$) + 4)
    End Function
    Sub SarrAdd(container$, ByVal value As String) ThreadSafe
        ' append value to end of array
        Local itemCount&
        itemCount& = SarrCount(container$)
        If itemCount& = 0 Then
            container$ = Mkl$(%HostedStringArrayTag) + Mkl$(1) + Mkl$(Len(value)) + value
        Else
            container$ += Mkl$(Len(value)) + value
            Poke Long, StrPtr(container$) + 4, itemCount& + 1
        End If
    End Sub
    Function SarrGet(container$, ByVal index As Long) ThreadSafe As String
        ' get value at one-based index
        Local itemCount&, itemCounter&
        Local p As Long Ptr
        itemCount& = SarrCount(container$)
        If index > 0 And index <= itemCount& Then
            itemCounter& = 0
            p = StrPtr(container$) + 8
            While itemCounter& < index - 1
                Incr itemCounter&
                p += 4 + @p
            Wend
            Function = Peek$(p + 4, @p)
        End If
    End Function
    Sub SarrSet(container$, ByVal index As Long, ByVal value As String) ThreadSafe
        ' set value at one-based index
        Local itemCount&, bytes&, itemCounter&
        Local p As Long Ptr
        itemCount& = SarrCount(container$)
        If index > 0 And index <= itemCount& Then
            itemCounter& = 0
            bytes& = 8
            p = StrPtr(container$) + 8
            While itemCounter& < index - 1
                Incr itemCounter&
                bytes& += 4 + @p
                p += 4 + @p
            Wend
            container$ = Left$(container$, bytes&) + Mkl$(Len(value)) + value + Mid$(container$, bytes& + 1 + 4 + @p)
        End If
    End Sub
    Sub SarrInsert(container$, ByVal index As Long, ByVal value As String) ThreadSafe
        ' insert value at one-based index
        Local itemCount&, bytes&, itemCounter&
        Local p As Long Ptr
        itemCount& = SarrCount(container$)
        If index > 0 And index <= itemCount& Then
            itemCounter& = 0
            bytes& = 8
            p = StrPtr(container$) + 8
            While itemCounter& < index - 1
                Incr itemCounter&
                bytes& += 4 + @p
                p += 4 + @p
            Wend
            container$ = Left$(container$, bytes&) + Mkl$(Len(value)) + value + Mid$(container$, bytes& + 1)
            Poke Long, StrPtr(container$) + 4, itemCount& + 1
        End If
    End Sub
    Sub SarrDelete(container$, ByVal index As Long) ThreadSafe
        ' delete value at one-based index
        Local itemCount&, bytes&, itemCounter&
        Local p As Long Ptr
        itemCount& = SarrCount(container$)
        If Len(container$) And index > 0 And index <= itemCount& Then
            itemCounter& = 0
            bytes& = 8
            p = StrPtr(container$) + 8
            While itemCounter& < index - 1
                Incr itemCounter&
                bytes& += 4 + @p
                p += 4 + @p
            Wend
            container$ = Left$(container$, bytes&) + Mid$(container$, bytes& + 1 + 4 + @p)
            Poke Long, StrPtr(container$) + 4, itemCount& - 1
        End If
    End Sub
#EndIf '%HostedStringArray230304

#If Not %Def(%HostedWStringArray230304)
    %HostedWStringArray230304 = 1
    ' String Array Stored in String
    ' Memory allocation is just a string.
    ' public domain, use at own risk
    ' SDurham
    Function WarrCount(container$) ThreadSafe As Long
        ' get item count
        Function = SarrCount(container$)
    End Function
    Sub WarrAdd(container$, ByVal value As WString) ThreadSafe
        ' append value to end of array
        SarrAdd container$, ChrToUtf8$(value)
    End Sub
    Function WarrGet(container$, ByVal index As Long) ThreadSafe As WString
        ' get value at one-based index
        Function = Utf8ToChr$(SarrGet(container$, index))
    End Function
    Sub WarrSet(container$, ByVal index As Long, ByVal value As WString) ThreadSafe
        ' set value at one-based index
        SarrSet container$, index, ChrToUtf8$(value)
    End Sub
    Sub WarrInsert(container$, ByVal index As Long, ByVal value As WString) ThreadSafe
        ' insert value at one-based index
        SarrInsert container$, index, ChrToUtf8$(value)
    End Sub
    Sub WarrDelete(container$, ByVal index As Long) ThreadSafe
        ' delete value at one-based index
        SarrDelete container$, index
    End Sub
#EndIf '%HostedWStringArray230304
�

[size=4]Test-Code:[/size]

[code]
#Option LargeMem32
#Compile Exe
#Dim All

#Include Once "..\Hosted String Array.inc"

%TestCount = 1000

Function PBMain() As Long
    Register i As Long
    Local h&, outFile$, hprocess&
    h& = FreeFile
    outFile$ = Exe.Path$ + Exe.Name$ + ".txt"
    Kill outFile$
    Open outFile$ For Append As h&

    Local arr$
    Local a() As String
    Local d As Double

    Randomize
    ReDim a(1 To %TestCount)
    For i = 1 To %TestCount
        a(i) = Format$(Rnd(1, 99999999))
    Next i

    Print# h&, ""
    Print# h&, "Sub SarrAdd(container$, ByVal value As String) ThreadSafe"
    Print# h&, "    append value to end of array"
    Print# h&, "        add 5 values "
    SarrAdd arr$, "AA"
    SarrAdd arr$, "BB"
    SarrAdd arr$, "CC"
    SarrAdd arr$, "DD"
    SarrAdd arr$, "EE"
    SarrAdd arr$, "FF"
    Print# h&, "--- Display Array ---"
    For i = 1 To SarrCount(arr$)
        Print# h&, "index "+Format$(i)+" = " + $Dq + SarrGet(arr$, i) + $Dq
    Next i

    Print# h&, ""
    Print# h&, "Function SarrGet(container$, ByVal index As Long) ThreadSafe As String"
    Print# h&, "    get value at one-based index"
    Print# h&, "Sub SarrSet(container$, ByVal index As Long, ByVal value As String) ThreadSafe"
    Print# h&, "    set value at one-based index"
    Print# h&, "        Get/Set values"
    For i = 1 To SarrCount(arr$)
        SarrSet arr$, i, Left$(SarrGet(arr$, i), 1)
    Next i
    Print# h&, "--- Display Array ---"
    For i = 1 To SarrCount(arr$)
        Print# h&, "index "+Format$(i)+" = " + $Dq + SarrGet(arr$, i) + $Dq
    Next i

    Print# h&, ""
    Print# h&, "Sub SarrInsert(container$, ByVal index As Long, ByVal value As String) ThreadSafe"
    Print# h&, "    insert value at one-based index"
    Print# h&, "        insert value at index 1"
    SarrInsert arr$, 2, "String inserted at index 2"
    Print# h&, "--- Display Array ---"
    For i = 1 To SarrCount(arr$)
        Print# h&, "index "+Format$(i)+" = " + $Dq + SarrGet(arr$, i) + $Dq
    Next i

    Print# h&, ""
    Print# h&, "Sub SarrDelete(container$, ByVal index As Long) ThreadSafe"
    Print# h&, "    delete value at one-based index"
    Print# h&, "        delete value at index 2"
    SarrDelete arr$, 2
    Print# h&, "--- Display Array ---"
    For i = 1 To SarrCount(arr$)
        Print# h&, "index "+Format$(i)+" = " + $Dq + SarrGet(arr$, i) + $Dq
    Next i

    Print# h&, ""
    Print# h&, ""
    Print# h&, ""
    Print# h&, "clear array"
    arr$ = ""
    Print# h&, "add "+Format$(%TestCount, "#,")+" random strings to empty array"
    d = Timer
    For i = 1 To %TestCount
        SarrAdd arr$, a(i)
    Next i
    Print# h&, "Time = " + Format$(Timer - d, "000.000")

    Print# h&, ""
    Print# h&, "set "+Format$(%TestCount, "#,")+" values"
    For i = 1 To %TestCount
        SarrSet arr$, i, a(i)
    Next i
    Print# h&, "Time = " + Format$(Timer - d, "000.000")

    Print# h&, ""
    Print# h&, "get "+Format$(%TestCount, "#,")+" from array of "+Format$(%TestCount, "#,")+" values"
    For i = 1 To %TestCount
        If SarrGet(arr$, i) <> a(i) Then
            ? "SarrGet() fail" : Exit For
        End If
    Next i
    Print# h&, "Time = " + Format$(Timer - d, "000.000")

    Print# h&, ""
    Print# h&, ""

    Close h&
    Sleep 1
    hprocess& = Shell("notepad.exe " + outFile$, 1)
End Function�

[/code]