Add 100,000 random values to empty array = 0.007 seconds
sort array of 100,000 random values = 0.016 seconds
binary search array of 100,000 values for all 100,000 values = 0.031 seconds
The number array exists entirely inside host string and remains intact for life of host. Stored or pass as a string. Doesn't need to be free, set null or let it go out of scope. Array is buffered, use a large buffer for a lot of items. No ReDim(), just add, insert and delete.
The example is a Quad array. May be any number type.
Example for Long array.
Global replace "Quad" with "Long"
Global replace "Qud" witn "Lng"
Replace %SQudArrItemSize = 8 with 4
Replace %SQudArrTag with another number. The tag protects the host string.
' In-String Quad Array
' ((( The array exist entirely inside host string. )))
'
' Array stays intact for life of host string, stored, passed, ...
' Doesn't need to be freed, just a string.
'
' Host string needs to be passed ByRef to stay current.
' A different host string, or copy, is a different instance.
' To update original from copy, original = copy.
' Host string protected with hash tag to prevent invalid strings.
'
' Memory is buffered, no ReDim(); the memory is the string.
' Just add, insert and delete values.
' Array grows and shrinks as needed.
' Increase buffer size for really big arrays, about 1/10th expected items.
'
' add 100,000 random values to empty array = 0.007 seconds
' sort array of 100,000 random values = 0.016 seconds
' binary search array of 100,000 values for all 100,000 values = 0.031 seconds
'
' add 1,000,000 random values to empty array = 0.079 seconds
' sort array of 1,000,000 random values = 0.222 seconds
' binary search array of 1,000,000 values for all 1,000,000 values = 0.315 seconds
'
' add 10,000,000 random values to empty array = 0.967 seconds
' sort array of 10,000,000 random values = 2.43 seconds
' binary search array of 10,000,000 values for all 10,000,000 values = 6.550 seconds
'
' public domain, use at own risk
' SDurham
#If Not %Def(%HostedQuadArray230304)
%HostedQuadArray230304 = 1
' In-String Quad Array
%SQudArrTag = 1002691372
%SQudArrHeaderSize = 16
%SQudArrItemSize = 8
%SQudArrDefaultBuffer = 1
Type SQudArrT
tag As Long
count As Long
max As Long
buffer As Long
End Type
Sub SQudArrSetup(container$) ThreadSafe
' array setup : not necessary to call
Local t As SQudArrT
t.tag = %SQudArrTag
t.buffer = %SQudArrDefaultBuffer
container$ = t
End Sub
Sub SQudArrBuffer(container$, ByVal buffer As Long) ThreadSafe
' change buffer : about 1/10 expected items
' default buffer = %SQudArrDefaultBuffer for small arrays up to 10,000 items
Local p As SQudArrT Ptr
If Len(container$) = 0 Then SQudArrSetup(container$)
If Cvl(container$) = %SQudArrTag Then
p = StrPtr(container$)
If buffer > 0 Then @p.buffer = buffer Else @p.buffer = %SQudArrDefaultBuffer
End If
End Sub
Sub SQudArrGrow(container$, ByVal items As Long) ThreadSafe
' make room for items : not necessary to call, automatic
Local additionalItems As Long
Local p As SQudArrT Ptr
If Len(container$) = 0 Then SQudArrSetup(container$)
If Cvl(container$) = %SQudArrTag Then
p = StrPtr(container$)
If items > @p.max - @p.count Then
additionalItems = items + @p.buffer
@p.max += additionalItems
container$ += Nul$(additionalItems * %SQudArrItemSize)
End If
End If
End Sub
Sub SQudArrShrink(container$) ThreadSafe
' free excess memory
Local p As SQudArrT Ptr
If Cvl(container$) = %SQudArrTag Then
p = StrPtr(container$)
If @p.count = 0 Then
SQudArrClear(container$)
ElseIf @p.count <> @p.max Then
@p.max = @p.count
container$ = Left$(container$, %SQudArrHeaderSize + (@p.count * %SQudArrItemSize))
End If
End If
End Sub
Sub SQudArrClear(container$) ThreadSafe
' empty container
Local buffer As Long
Local p As SQudArrT Ptr
If Len(container$) = 0 Then SQudArrSetup(container$)
If Cvl(container$) = %SQudArrTag Then
p = StrPtr(container$)
buffer = @p.buffer
container$ = ""
SQudArrBuffer(container$, buffer)
End If
End Sub
Function SQudArrCount(container$) ThreadSafe As Long
' get item count
If Cvl(container$) = %SQudArrTag Then Function = Peek(Long, StrPtr(container$) + 4)
End Function
Function SQudArrGet(container$, ByVal index As Long) ThreadSafe As Quad
' get value at one-based index
Local arrCount As Long
Local arr As Quad Ptr
If Cvl(container$) = %SQudArrTag Then
arrCount = Peek(Long, StrPtr(container$) + 4)
If index > 0 And index <= arrCount Then
arr = StrPtr(container$) + %SQudArrHeaderSize - %SQudArrItemSize
Function = @arr[index]
End If
End If
End Function
Sub SQudArrSet(container$, ByVal index As Long, ByVal value As Quad) ThreadSafe
' set value at one-based index
Local arrCount As Long
Local arr As Quad Ptr
If Cvl(container$) = %SQudArrTag Then
arrCount = Peek(Long, StrPtr(container$) + 4)
If index > 0 And index <= arrCount Then
arr = StrPtr(container$) + %SQudArrHeaderSize - %SQudArrItemSize
@arr[index] = value
End If
End If
End Sub
Sub SQudArrAdd(container$, ByVal value As Quad) ThreadSafe
' append value to end of array : redimension automatic
Local p As SQudArrT Ptr
Local arr As Quad Ptr
If Len(container$) = 0 Then SQudArrSetup(container$)
If Cvl(container$) = %SQudArrTag Then
SQudArrGrow(container$, 1)
p = StrPtr(container$)
Incr @p.count
arr = StrPtr(container$) + %SQudArrHeaderSize - %SQudArrItemSize
@arr[@p.count] = value
End If
End Sub
Sub SQudArrInsert(container$, ByVal index As Long, ByVal value As Quad) ThreadSafe
' insert value at one-based index : redimension automatic
Local p As SQudArrT Ptr
Local arr As Quad Ptr
If Cvl(container$) = %SQudArrTag Then
p = StrPtr(container$)
If index > 0 And index <= @p.count Then
SQudArrGrow(container$, 1)
p = StrPtr(container$)
Incr @p.count
SQudArrMove(container$, index, index + 1, @p.count - index)
arr = StrPtr(container$) + %SQudArrHeaderSize - %SQudArrItemSize
@arr[index] = value
End If
End If
End Sub
Sub SQudArrDelete(container$, ByVal index As Long) ThreadSafe
' delete value at one-based index : redimension automatic
Local p As SQudArrT Ptr
If Cvl(container$) = %SQudArrTag Then
p = StrPtr(container$)
If index > 0 And index <= @p.count Then
If index < @p.count Then SQudArrMove(container$, index + 1, index, @p.count - index)
Decr @p.count
If @p.max > @p.count + (@p.buffer * 2) Then SQudArrShrink(container$)
End If
End If
End Sub
Sub SQudArrMove(container$, ByVal fromIndex As Long, ByVal toIndex As Long, ByVal items As Long) Private ThreadSafe
'PRIVATE: move memory block
Local arr As Quad Ptr
arr = StrPtr(container$) + %SQudArrHeaderSize - %SQudArrItemSize
Memory Copy arr + (fromIndex * %SQudArrItemSize), arr + (toIndex * %SQudArrItemSize), items * %SQudArrItemSize
End Sub
#EndIf '%HostedQuadArray230304
#If Not %Def(%HostedQuadArrayExtra230304)
%HostedQuadArrayExtra230304 = 1
Sub SQudArrFastDelete(container$, ByVal index As Long) ThreadSafe
' fast delete value at one-based index : redimension automatic
' fast on massive array but destroys array order
' traverse back to front to use fast delete
Local p As SQudArrT Ptr
Local arr As Quad Ptr
If Cvl(container$) = %SQudArrTag Then
p = StrPtr(container$)
If index > 0 And index <= @p.count Then
arr = StrPtr(container$) + %SQudArrHeaderSize - %SQudArrItemSize
If index < @p.count Then Swap @arr[index], @arr[@p.count]
Decr @p.count
If @p.max > @p.count + (@p.buffer * 2) Then SQudArrShrink(container$)
End If
End If
End Sub
Sub SQudArrSort(container$) ThreadSafe
' non-recursive quick sort
Register i As Long
Register j As Long
Local k, leftIndex, rightIndex, counter, arrCount As Long
Local value As Quad
Local arr As Quad Ptr
If Cvl(container$) = %SQudArrTag Then
arrCount = Peek(Long, StrPtr(container$) + 4)
If arrCount > 1 Then
arr = StrPtr(container$) + %SQudArrHeaderSize - %SQudArrItemSize
leftIndex = 1
rightIndex = arrCount
counter = 1
!PUSH leftIndex
!PUSH rightIndex
While counter
Decr counter
!POP rightIndex
!POP leftIndex
i = leftIndex
j = rightIndex
k = i + j
Shift Right k, 1
value = @arr[k]
While i <= j
While @arr[i] < value
Incr i
Wend
While @arr[j] > value
Decr j
Wend
If i <= j Then
Swap @arr[i], @arr[j] : Incr i : Decr j
End If
Wend
If leftIndex < j Then
!PUSH leftIndex
!PUSH j
Incr counter
End If
If i < rightIndex Then
!PUSH i
!PUSH rightIndex
Incr counter
End If
Wend
End If
End If
End Sub
Function SQudArrSortSearch(container$, ByVal value As Quad) ThreadSafe As Long
' binary search for value : return index : zero if not found : array must be sorted
Register i As Long
Local bot, top, arrCount As Long
Local arr As Quad Ptr
If Cvl(container$) = %SQudArrTag Then
arrCount = Peek(Long, StrPtr(container$) + 4)
If arrCount Then
arr = StrPtr(container$) + %SQudArrHeaderSize - %SQudArrItemSize
bot = 1
top = arrCount
While top >= bot
i = bot + top
Shift Right i, 1 'divide by 2
If value > @arr[i] Then
bot = i + 1
ElseIf value < @arr[i] Then
top = i - 1
Else
Function = i : Exit Function
End If
Wend
End If
End If
End Function
Sub SQudArrSortInsert(container$, ByVal value As Quad) ThreadSafe
' insert value at sort position : added if empty : array must be sorted or empty
Register i As Long
Local bot, top, compare, arrCount As Long
Local arr As Quad Ptr
If Cvl(container$) = %SQudArrTag Then
arrCount = Peek(Long, StrPtr(container$) + 4)
If arrCount Then
arr = StrPtr(container$) + %SQudArrHeaderSize - %SQudArrItemSize
bot = 1
top = arrCount
While top >= bot
i = bot + top
Shift Right i, 1 'divide by 2
compare = Switch&(value > @arr[i], 1, value < @arr[i], -1) 'else zero, match
If compare > 0 Then
bot = i + 1
ElseIf compare < 0 Then
top = i - 1
Else
SQudArrInsert(container$, i, value) : Exit Sub
End If
Wend
If compare < 0 Then
SQudArrInsert(container$, i, value)
ElseIf i < arrCount Then
SQudArrInsert(container$, i + 1, value)
Else
SQudArrAdd(container$, value)
End If
Else
SQudArrAdd(container$, value)
End If
End If
End Sub
Sub SQudArrSortDelete(container$, ByVal value As Quad) ThreadSafe
' binary search for value : delete one instance if found : array must be sorted
Local x As Long
x = SQudArrSortSearch(container$, value)
If x Then SQudArrDelete(container$, x)
End Sub
Sub SQudArrUnique(container$)
' delete all duplicates : not sorted when done
Register i As Long
Local arrCount As Long
Local arr As Quad Ptr
If Cvl(container$) = %SQudArrTag Then
arrCount = Peek(Long, StrPtr(container$) + 4)
If arrCount > 1 Then
arr = StrPtr(container$) + %SQudArrHeaderSize - %SQudArrItemSize
SQudArrSort(container$)
For i = arrCount - 1 To 1 Step -1
If @arr[i + 1] = @arr[i] Then SQudArrFastDelete(container$, i + 1)
Next i
End If
End If
End Sub
Sub SQudArrReverse(container$) ThreadSafe
' reverse array
Register i As Long
Register j As Long
Local arrCount As Long
Local arr As Quad Ptr
If Cvl(container$) = %SQudArrTag Then
arrCount = Peek(Long, StrPtr(container$) + 4)
If arrCount > 1 Then
arr = StrPtr(container$) + %SQudArrHeaderSize - %SQudArrItemSize
i = 1
j = arrCount
While i < j
Swap @arr[i], @arr[j]
Incr i
Decr j
Wend
End If
End If
End Sub
Sub SQudArrPushFirst(container$, ByVal value As Quad) ThreadSafe
' add value at front of array
If SQudArrCount(container$) Then SQudArrInsert(container$, 1, value) Else SQudArrAdd(container$, value)
End Sub
Sub SQudArrPushLast(container$, ByVal value As Quad) ThreadSafe
' append value to end of array
SQudArrAdd(container$, value)
End Sub
Function SQudArrPopFirst(container$) ThreadSafe As Quad
' get and delete first value in array
If SQudArrCount(container$) Then
Function = SQudArrGet(container$, 1)
SQudArrDelete(container$, 1)
End If
End Function
Function SQudArrPopLast(container$) ThreadSafe As Quad
' get and delete last value in array
Local arrCount As Long
arrCount = Peek(Long, StrPtr(container$) + 4)
If arrCount Then
Function = SQudArrGet(container$, arrCount)
SQudArrDelete(container$, arrCount)
End If
End Function
#EndIf '%HostedQuadArrayExtra230304�
Test-Code:
#Option LargeMem32
#Compile Exe
#Dim All
#Include Once "..\Hosted Quad Array.inc"
%TestCount = 100000
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 d As Double
Local a() As Quad
Randomize
ReDim a(1 To %TestCount)
For i = 1 To %TestCount
a(i) = Rnd(1, 255)
'a(i) = rnd(-7777777, 7777777)
Next i
Print# h&, "Sub SQudArrAdd(container$, ByVal value As Quad) ThreadSafe "
Print# h&, " append value to end of array : redimension automatic"
Print# h&, " add 5 values"
For i = 1 To 5
SQudArrAdd arr$, i * 10
Next i
Print# h&, "--- Display Array ---"
For i = 1 To SQudArrCount(arr$)
Print# h&, "index "+Format$(i)+" = " Format$(SQudArrGet(arr$, i))
Next i
Print# h&, ""
Print# h&, "Function SQudArrGet(container$, ByVal index As Long) ThreadSafe As Quad"
Print# h&, " get value at one-based index"
Print# h&, "Sub SQudArrSet(container$, ByVal index As Long, ByVal value As Quad) ThreadSafe"
Print# h&, " set value at one-based index"
Print# h&, " Get/Set values"
For i = 1 To SQudArrCount(arr$)
SQudArrSet arr$, i, SQudArrGet(arr$, i) / 10
Next i
SQudArrSet arr$, 5, 55
Print# h&, "--- Display Array ---"
For i = 1 To SQudArrCount(arr$)
Print# h&, "index "+Format$(i)+" = " Format$(SQudArrGet(arr$, i))
Next i
Print# h&, ""
Print# h&, "Sub SQudArrInsert(container$, ByVal index As Long, ByVal value As Quad) ThreadSafe"
Print# h&, " insert value at one-based index : redimension automatic"
Print# h&, " insert value at index 2"
SQudArrInsert arr$, 2, 22
Print# h&, "--- Display Array ---"
For i = 1 To SQudArrCount(arr$)
Print# h&, "index "+Format$(i)+" = " Format$(SQudArrGet(arr$, i))
Next i
Print# h&, ""
Print# h&, "Sub SQudArrDelete(container$, ByVal index As Long) ThreadSafe"
Print# h&, " delete value at one-based index : redimension automatic"
Print# h&, " delete value at index 2"
SQudArrDelete arr$, 2
Print# h&, "--- Display Array ---"
For i = 1 To SQudArrCount(arr$)
Print# h&, "index "+Format$(i)+" = " Format$(SQudArrGet(arr$, i))
Next i
Print# h&, ""
Print# h&, "Sub SQudArrFastDelete(container$, ByVal index As Long) ThreadSafe"
Print# h&, " fast delete value at one-based index : redimension automatic"
Print# h&, " fast on massive array but destroys array order"
Print# h&, " traverse back to front to use fast delete"
Print# h&, " fast delete value at index 1"
SQudArrFastDelete arr$, 1
Print# h&, "--- Display Array ---"
For i = 1 To SQudArrCount(arr$)
Print# h&, "index "+Format$(i)+" = " Format$(SQudArrGet(arr$, i))
Next i
Print# h&, ""
Print# h&, "Sub SQudArrSort(container$) ThreadSafe"
Print# h&, " non-recursive quick sort"
Print# h&, " clear array"
SQudArrClear arr$
Print# h&, " add 4, 2, 5, 2, 5, 1, 4"
SQudArrAdd arr$, 4
SQudArrAdd arr$, 2
SQudArrAdd arr$, 5
SQudArrAdd arr$, 2
SQudArrAdd arr$, 5
SQudArrAdd arr$, 1
SQudArrAdd arr$, 4
Print# h&, "--- Display Array ---"
For i = 1 To SQudArrCount(arr$)
Print# h&, "index "+Format$(i)+" = " Format$(SQudArrGet(arr$, i))
Next i
Print# h&, " sort array"
SQudArrSort arr$
Print# h&, "--- Display Array ---"
For i = 1 To SQudArrCount(arr$)
Print# h&, "index "+Format$(i)+" = " Format$(SQudArrGet(arr$, i))
Next i
Print# h&, ""
Print# h&, "Function SQudArrSortSearch(container$, ByVal value As Quad) ThreadSafe As Long "
Print# h&, " binary search for value : return index : zero if not found : array must be sorted"
For i = 0 To 6
Print# h&, "sort search for "+Format$(i)+" = " + Format$(SQudArrSortSearch(arr$, i))
Next i
Print# h&, ""
Print# h&, "Sub SQudArrSortInsert(container$, ByVal value As Quad) ThreadSafe "
Print# h&, " insert value at sort position : added if empty : array must be sorted or empty"
Print# h&, " sort insert 6, 5, 4, 3, 2, 1"
For i = 6 To 1 Step -1
SQudArrSortInsert arr$, i
Next i
Print# h&, "--- Display Array ---"
For i = 1 To SQudArrCount(arr$)
Print# h&, "index "+Format$(i)+" = " Format$(SQudArrGet(arr$, i))
Next i
Print# h&, ""
Print# h&, "Sub SQudArrSortDelete(container$, ByVal value As Quad) ThreadSafe"
Print# h&, " binary search for value : delete one instance if found : array must be sorted"
Print# h&, " sort delete 4"
SQudArrSortDelete arr$, 4
Print# h&, "--- Display Array ---"
For i = 1 To SQudArrCount(arr$)
Print# h&, "index "+Format$(i)+" = " Format$(SQudArrGet(arr$, i))
Next i
Print# h&, ""
Print# h&, "Sub SQudArrUnique(container$)"
Print# h&, " delete all duplicates : not sorted when done"
SQudArrUnique arr$
Print# h&, "--- Display Array ---"
For i = 1 To SQudArrCount(arr$)
Print# h&, "index "+Format$(i)+" = " Format$(SQudArrGet(arr$, i))
Next i
Print# h&, ""
Print# h&, "Sub SQudArrReverse(container$) ThreadSafe"
Print# h&, " reverse array"
SQudArrReverse arr$
Print# h&, "--- Display Array ---"
For i = 1 To SQudArrCount(arr$)
Print# h&, "index "+Format$(i)+" = " Format$(SQudArrGet(arr$, i))
Next i
Print# h&, ""
Print# h&, "Sub SQudArrPushFirst(container$, ByVal value As Quad) ThreadSafe"
Print# h&, " add value at front of array"
Print# h&, "Sub SQudArrPushLast(container$, ByVal value As Quad) ThreadSafe"
Print# h&, " append value to end of array"
Print# h&, "Function SQudArrPopFirst(container$) ThreadSafe As Quad"
Print# h&, " get and delete first value in array"
Print# h&, "Function SQudArrPopLast(container$) ThreadSafe As Quad "
Print# h&, " get and delete last value in array "
Print# h&, ""
Print# h&, "Stack: SQudArrPushLast(), SQudArrPopLast()"
Print# h&, " push 1, 2, 3 on stack"
SQudArrClear arr$
SQudArrPushLast arr$, 1
SQudArrPushLast arr$, 2
SQudArrPushLast arr$, 3
Print# h&, "--- Display Array ---"
For i = 1 To SQudArrCount(arr$)
Print# h&, "index "+Format$(i)+" = " Format$(SQudArrGet(arr$, i))
Next i
Print# h&, " pop stack"
While SQudArrCount(arr$)
Print# h&, "pop = " + Format$(SQudArrPopLast(arr$))
Wend
Print# h&, ""
Print# h&, "Queue: SQudArrPushLast(), SQudArrPopFirst()"
Print# h&, " add 1, 2, 3 to queue"
SQudArrClear arr$
SQudArrPushLast arr$, 1
SQudArrPushLast arr$, 2
SQudArrPushLast arr$, 3
Print# h&, "--- Display Array ---"
For i = 1 To SQudArrCount(arr$)
Print# h&, "index "+Format$(i)+" = " Format$(SQudArrGet(arr$, i))
Next i
Print# h&, " pop queue"
While SQudArrCount(arr$)
Print# h&, "pop = " + Format$(SQudArrPopFirst(arr$))
Wend
''
Print# h&, ""
Print# h&, ""
Print# h&, "empty array"
SQudArrClear arr$
Print# h&, "set buffer = " + Format$(%TestCount / 10, "#,")
SQudArrBuffer arr$, %TestCount / 10
Print# h&, "add "+Format$(%TestCount, "#,")+" random values to empty array"
d = Timer
For i = 1 To %TestCount
SQudArrAdd arr$, a(i)
Next i
Print# h&, "Time = " + Format$(Timer - d, "000.000")
Print# h&, "Host String Size = " + Format$(Len(arr$), "#,") + " bytes"
Print# h&, ""
Print# h&, "sort array of "+Format$(%TestCount, "#,")+" random values"
d = Timer
SQudArrSort arr$
Print# h&, "Time = " + Format$(Timer - d, "000.000")
Print# h&, ""
Print# h&, "binary search array of "+Format$(%TestCount, "#,")+" values for all "+Format$(%TestCount, "#,")+" values"
d = Timer
For i = 1 To %TestCount
If IsFalse SQudArrSortSearch(arr$, a(i)) Then
? "SQudArrSortSearch() 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�