In-File Dynamic String Array

[Theo Gottwald]

It's about a dynamic string array within a file. 🚀💾🧮

#DynamicArray #InFile #Programming #Coding #ComputerScience #Tech #DeveloperTools #CodeNewbie #TechCommunity #ArrayHandling 

🚀💻🧩💾📊🖥�🔍👨�💻👩�💻✨

Es geht um ein dynamisches String-Array in einer Datei. 📄💻

#DynamischesArray #InFile #Programmierung #Coding #Computerscience #Tech 🚀👨�💻👩�💻🖥�🔍💾

Results for lurkers:

Function FStrArrOpen(t As FViewT, ByRef file As WString)
create new file or open existing file : true/false success

Sub FStrArrAdd(t As FViewT, ByVal value As String)
append value to end of array
add values
-------
1 = "A"
2 = "B"
3 = "C"
4 = "D"

Function FStrArrGet(t As FViewT, ByVal index As Long) As String
get value at one-based index
Sub FStrArrSet(t As FViewT, ByVal index As Long, ByVal value As String)
set value at one-based index
Get/Set values
-------
1 = "AA"
2 = "BB"
3 = "CC"
4 = "DD"

Sub FStrArrInsert(t As FViewT, ByVal index As Long, ByVal value As String)
insert value at one-based index
insert value at index 2
-------
1 = "AA"
2 = "INSERT"
3 = "BB"
4 = "CC"
5 = "DD"

Sub FStrArrDelete(t As FViewT, ByVal index As Long)
delete value at one-based index
delete value at index 2
-------
1 = "AA"
2 = "BB"
3 = "CC"
4 = "DD"

add 1,000 random strings 5 to 10 characters
Time = 000.047
Count = 1,000

change 1,000 random strings 5 to 10 characters
Time = 000.095

store 100, 1,000,000 character strings
Time = 000.221

get 100, 1,000,000 character strings
Time = 000.284

Sub FStrArrClose(t As FViewT)
close file

Code Select Expand

'Public domain, use at own risk. SDurham

    'In-File Dynamic String Array
    'values may contain any kind of binary data
    'use ChrToUtf8$()/Utf8ToChr$() for WStrings
    'may be UDTs
    'may be Mkl$()/Cvl(), ... etc
    'may be BMP or icon

    'add 1,000 random strings 5 to 10 characters = 0.031 seconds
    'change 1,000 random strings 5 to 10 characters = 0.095 seconds

    'add 5,000 random strings 5 to 10 characters = 0.141 seconds
    'change 5,000 random strings 5 to 10 characters = 0.912 seconds

    'store 100, 1,000,000 character strings = 0.219 seconds
    'get 100, 1,000,000 character strings = 0.329 seconds

    'store 100, 5,000,000 character strings = 0.661 seconds
    'get 100, 5,000,000 character strings = 1.194 seconds

#If Not %Def(%FStrArr231203)
    %FStrArr231203 = 1
    'In-File String Array
    Type FViewT
        size As Quad    'memory size
        hFile As Long
        hWinFile As Long
        hMap As Long
        hView As Long   'memory address
    End Type
    Function FStrArrOpen(t As FViewT, ByRef file As WString) As Long
        'create new file or open existing file : true/false success
        If IsFile(file) Then
            Function = FVOpenFile(t, file)
        ElseIf FVNewFile(t, file, 4) Then
            Poke Long, t.hView, 0 : Function = 1
        End If
    End Function
    Sub FStrArrClose(t As FViewT)
        'close file
        FVClose(t)
    End Sub
    Sub FStrArrClear(t As FViewT)
        'empty container
        If t.hView Then
            FVResize t, 4
            Poke Long, t.hView, 0
        End If
    End Sub
    Function FStrArrCount(t As FViewT) As Long
        'get item count
        If t.hView Then Function = Peek(Long, t.hView)
    End Function
    Sub FStrArrAdd(t As FViewT, ByVal value As String)
        'append value to end of array
        Local lenstr, oldsize, newsize, items As Long : Local p As Long Ptr
        lenstr = Len(value)
        If t.hView Then
            oldsize = t.size
            newsize = oldsize + lenstr + 4
            If IsFalse FVResize(t, newsize) Then Exit Sub
            p = t.hView + oldsize
            @p = lenstr : Incr p
            Memory Copy StrPtr(value), p, lenstr
            p = t.hView : Incr @p
        End If
    End Sub
    Function FStrArrGet(t As FViewT, ByVal index As Long) As String
        'get value at one-based index
        Local x As Long : Local p As Long Ptr
        If index > 0 And index <= FStrArrCount(t) Then
            x = 0
            p = t.hView + 4
            While x < index - 1
                Incr x
                p += 4 + @p
            Wend
            Function = Peek$(p + 4, @p)
        End If
    End Function
    Sub FStrArrSet(t As FViewT, ByVal index As Long, ByVal value As String)
        'set value at one-based index
        Local x, bytes As Long : Local p As Long Ptr : Local s As String
        If index > 0 And index <= FStrArrCount(t) Then
            x = 0 : bytes = 4 : p = t.hView + 4
            While x < index - 1
                Incr x
                bytes += 4 + @p
                p += 4 + @p
            Wend
            s = Peek$(t.hView, t.size)
            s = Left$(s, bytes) + Mkl$(Len(value)) + value + Mid$(s, bytes + 1 + 4 + @p)
            If IsFalse FVResize(t, Len(s)) Then Exit Sub
            Memory Copy StrPtr(s), t.hView, Len(s)
        End If
    End Sub
    Sub FStrArrInsert(t As FViewT, ByVal index As Long, ByVal value As String)
        'insert value at one-based index
        Local x, bytes, items As Long : Local p As Long Ptr : Local s As String
        If index > 0 And index <= FStrArrCount(t) Then
            x = 0 : bytes = 4 : p = t.hView + 4
            While x < index - 1
                Incr x
                bytes += 4 + @p
                p += 4 + @p
            Wend
            s = Peek$(t.hView, t.size)
            s = Left$(s, bytes) + Mkl$(Len(value)) + value + Mid$(s, bytes + 1)
            If IsFalse FVResize(t, Len(s)) Then Exit Sub
            Memory Copy StrPtr(s), t.hView, Len(s)
            items = Peek(Long, t.hView) : Incr items : Poke Long, t.hView, items
        End If
    End Sub
    Sub FStrArrDelete(t As FViewT, ByVal index As Long)
        'delete value at one-based index
        Local x, bytes, items As Long : Local p As Long Ptr : Local s As String
        If index > 0 And index <= FStrArrCount(t) Then
            x = 0 : bytes = 4 : p = t.hView + 4
            While x < index - 1
                Incr x
                bytes += 4 + @p
                p += 4 + @p
            Wend
            s = Peek$(t.hView, t.size)
            s = Left$(s, bytes) + Mid$(s, bytes + 1 + 4 + @p)
            If IsFalse FVResize(t, Len(s)) Then Exit Sub
            Memory Copy StrPtr(s), t.hView, Len(s)
            items = Peek(Long, t.hView) : Decr items : Poke Long, t.hView, items
        End If
    End Sub
#EndIf '%FStrArr231203

#If Not %Def(%FView231112)
    %FView231112 = 1
    #Include Once "WIN32API.INC"
    #If Not %Def(%Unicode)
        %Unicode = 1
    #EndIf '%Unicode
    Type FViewT
        size As Quad    'memory size
        hFile As Long
        hWinFile As Long
        hMap As Long
        hView As Long   'memory address
    End Type
    Function FVNewFile(t As FViewT, ByVal file As WString, ByVal fileSize As Long) As Long
        'create new file and open for use : can't be zero length : true/false success
        t.size = 0 : t.hFile = 0 : t.hWinFile = 0 : t.hMap = 0 : t.hView = 0
        t.hFile = FreeFile
        If t.hFile Then
            Open file For Binary As t.hFile
            Seek t.hFile, fileSize + 1
            SetEof t.hFile
            t.hWinFile = FileAttr(t.hFile, 2)
            If FVOpenMap(t) And FVOpenView(t) Then
                t.size = fileSize : Function = %true
            Else
                FVCloseView(t) : FVCloseMap(t) : Close t.hFile
                t.size = 0 : t.hFile = 0 : t.hWinFile = 0 : t.hMap = 0 : t.hView = 0
            End If
        End If
    End Function
    Function FVOpenFile(t As FViewT, ByVal file As WString) As Long
        'open existing file : can't be empty file : true/false success
        t.size = 0 : t.hFile = 0 : t.hWinFile = 0 : t.hMap = 0 : t.hView = 0
        If IsFile(file) Then
            t.hFile = FreeFile
            If t.hFile Then
                Open file For Binary As t.hFile
                t.size = Lof(t.hFile)
                If t.size = 0 Then
                    Close t.hFile : t.hFile = 0 : Exit Function
                Else
                    t.hWinFile = FileAttr(t.hFile, 2)
                    If FVOpenMap(t) And FVOpenView(t) Then
                        Function = %true
                    Else
                        FVCloseView(t) : FVCloseMap(t) : Close t.hFile
                        t.size = 0 : t.hFile = 0 : t.hWinFile = 0 : t.hMap = 0 : t.hView = 0
                    End If
                End If
            End If
        End If
    End Function
    Sub FVClose(t As FViewT)
        'close file : file view flushed to disk
        If t.hFile Then
            FVCloseView(t) : FVCloseMap(t) : Close t.hFile
        End If
        t.size = 0 : t.hFile = 0 : t.hWinFile = 0 : t.hMap = 0 : t.hView = 0
    End Sub
    Sub FVFlush(t As FViewT)
        'flush file view to disk : automatically flushed when closed
        If t.hView Then FlushViewOfFile(ByVal t.hView, t.size)
    End Sub
    Function FVResize(t As FViewT, ByVal fileSize As Long) As Long
        'change file view size : must be > 0 : true/false success : view memory address may change
        If t.size And t.hView Then
            FVCloseView(t) : FVCloseMap(t)
            Seek t.hFile, fileSize + 1
            SetEof t.hFile
            t.size = fileSize
            FVOpenMap(t) : FVOpenView(t)
            If IsFalse t.hView Or IsFalse t.hMap Then
                FVCloseView(t) : FVCloseMap(t) : Close t.hFile
                t.size = 0 : t.hFile = 0 : t.hWinFile = 0 : t.hMap = 0 : t.hView = 0
            Else
                Function = %true
            End If
        End If
    End Function
    '-------------------------------
    '   PRIVATE
    '-------------------------------
    Function FVOpenMap(t As FViewT) Private As Long
        'open file mapping : true/false success
        If t.hWinFile Then
            t.hMap = CreateFileMapping(t.hWinFile, ByVal 0, %PAGE_READWRITE, 0, 0, ByVal 0)
            If t.hMap Then Function = %true
        End If
    End Function
    Sub FVCloseMap(t As FViewT) Private
        'close file mapping
        If t.hFile And t.hMap Then
            CloseHandle(t.hMap)
            t.hMap = 0
        End If
    End Sub
    Function FVOpenView(t As FViewT) Private As Byte
        'open file view
        If t.hFile And t.hMap Then
            t.hView = MapViewOfFile(t.hMap, %FILE_MAP_ALL_ACCESS, 0, 0, 0)
            If t.hView Then Function = %true
        End If
    End Function
    Sub FVCloseView(t As FViewT) Private
        'close file view
        If t.hFile And t.hMap And t.hView Then
            UnmapViewOfFile(t.hView)
            t.hView = 0
        End If
    End Sub
#EndIf '%FView231112�


Code Select Expand

#Option LargeMem32
#Dim All
#Compile Exe
#Include Once "WIN32API.INC"
#Include Once "..\FileStrArr231113.inc"

%TextBox = 101
%BtnID = 102
Global gDlg As Long

Macro testcount = 1000
Macro teststrsize = 1000000

Sub SampleCode()
    Register i As Long
    Local arr As FViewT
    Local d As Double
    Local a() As String
    Local s As String

    Randomize
    Control Set Text gDlg, %TextBox, ""

    SS ""
    SS "Function FStrArrOpen(t As FViewT, ByRef file As WString)"
    SS "    create new file or open existing file : true/false success "
    If IsFalse FStrArrOpen(arr, "test.data") Then Exit Sub

    SS ""
    SS "Sub FStrArrAdd(t As FViewT, ByVal value As String)"
    SS "    append value to end of array"
    SS "        add values"
    FStrArrAdd arr, "A"
    FStrArrAdd arr, "B"
    FStrArrAdd arr, "C"
    FStrArrAdd arr, "D"
    SS "-------"
    For i = 1 To FStrArrCount(arr)
        SS Format$(i) +" = "+ $Dq + FStrArrGet(arr, i) + $Dq
    Next i

    SS ""
    SS "Function FStrArrGet(t As FViewT, ByVal index As Long) As String"
    SS "    get value at one-based index"
    SS "Sub FStrArrSet(t As FViewT, ByVal index As Long, ByVal value As String)"
    SS "    set value at one-based index"
    SS "        Get/Set values"
    For i = 1 To FStrArrCount(arr)
        FStrArrSet arr, i, FStrArrGet(arr, i) + FStrArrGet(arr, i)
    Next i
    SS "-------"
    For i = 1 To FStrArrCount(arr)
        SS Format$(i) +" = "+ $Dq + FStrArrGet(arr, i) + $Dq
    Next i

    SS ""
    SS "Sub FStrArrInsert(t As FViewT, ByVal index As Long, ByVal value As String)"
    SS "    insert value at one-based index"
    SS "        insert value at index 2"
    FStrArrInsert arr, 2, "INSERT"
    SS "-------"
    For i = 1 To FStrArrCount(arr)
        SS Format$(i) +" = "+ $Dq + FStrArrGet(arr, i) + $Dq
    Next i

    SS ""
    SS "Sub FStrArrDelete(t As FViewT, ByVal index As Long)"
    SS "    delete value at one-based index"
    SS "        delete value at index 2"
    FStrArrDelete arr, 2
    SS "-------"
    For i = 1 To FStrArrCount(arr)
        SS Format$(i) +" = "+ $Dq + FStrArrGet(arr, i) + $Dq
    Next i

    ReDim a(1 To testcount)
    For i = 1 To testcount
        a(i) = RandomString()
    Next i

    SS ""
    SS "add "+Format$(testcount,"#,")+" random strings 5 to 10 characters"
    FStrArrClear arr
    d = Timer
    For i = 1 To testcount
        FStrArrAdd arr, a(i)
    Next i
    SS "Time = " + Format$(Timer - d,"000.000")
    SS "Count = " + Format$(FStrArrCount(arr),"#,")

    For i = 1 To testcount
        If FStrArrGet(arr, i) <> a(i) Then ? "array mismatch" : Exit For
    Next i

    For i = 1 To testcount
        a(i) = RandomString()
    Next i

    SS ""
    SS "change "+Format$(testcount,"#,")+" random strings 5 to 10 characters"
    For i = 1 To testcount
        FStrArrSet arr, i, a(i)
    Next i
    SS "Time = " + Format$(Timer - d,"000.000")

    For i = 1 To testcount
        If FStrArrGet(arr, i) <> a(i) Then ? "array mismatch" : Exit For
    Next i

    SS ""
    SS "store 100, "+Format$(teststrsize,"#,")+" character strings"
    FStrArrClear arr
    s = Repeat$(teststrsize, "X")
    For i = 1 To 100
        FStrArrAdd arr, s
    Next i
    SS "Time = " + Format$(Timer - d,"000.000")

    SS ""
    SS "get 100, "+Format$(teststrsize,"#,")+" character strings"
    For i = 1 To 100
        If FStrArrGet(arr, i) <> s Then
            ? "array fail" : Exit For
        End If
    Next i
    SS "Time = " + Format$(Timer - d,"000.000")

    SS ""
    SS "Sub FStrArrClose(t As FViewT)"
    SS "    close file"
    FStrArrClose arr
    Kill "test.data"

    SS ""
    SS ""

    Control Send gDlg, %TextBox, %EM_SETSEL, 1, 1
    Control Send gDlg, %TextBox, %EM_SCROLLCARET, 0, 0
End Sub

Function RandomString() As String
    Register i As Long
    Local s As String
    For i = 1 To Rnd(5, 10)
        Select Case As Const Rnd(1, 2)
            Case 1 : s += Chr$(Rnd(65, 90))
            Case 2 : s += Chr$(Rnd(97, 122))
        End Select
    Next i
    Function = s
End Function

Sub SS(ByVal value As WString)
    'appends without the overhead of getting the text
    Local characterCount As Long
    Local hWin As Long : hWin = GetDlgItem(gDlg, %TextBox)
    value += $CrLf
    characterCount =  SendMessageW(hWin, %WM_GETTEXTLENGTH, 0, 0)
    SendMessageW(hWin, %EM_SETSEL, characterCount, characterCount)
    SendMessageW(hWin, %EM_REPLACESEL, 1, StrPtr(value))
End Sub

Function PBMain()
    Local clientW, clientH As Long
    Desktop Get Client To clientW, clientH
    Dialog Default Font "consolas", 13, 0, 0
    Dialog New 0, Exe.Name$, 0, 0, clientW \ 7, clientH \ 4, %WS_Caption Or %WS_ClipSiblings Or %WS_MinimizeBox Or %WS_SysMenu Or %WS_ThickFrame Or %DS_Center, %WS_Ex_AppWindow To gDlg
    Control Add TextBox, gDlg, %TextBox, "", 0, 0, 0, 0, %ES_AutoHScroll Or %ES_AutoVScroll Or %ES_MultiLine Or %ES_NoHideSel Or %ES_WantReturn Or %WS_HScroll Or %WS_VScroll Or %WS_Border, 0
    Control Add Button,  gDlg, %BtnID, "Run", 275, 220, 60, 15, %BS_Flat, 0
    SendMessageW(GetDlgItem(gDlg, %TextBox), %EM_SETLIMITTEXT, 4000000, 0)
    Dialog Show Modeless gDlg, Call DlgCB
    Do
        Dialog DoEvents
    Loop While IsWin(gDlg)
End Function

CallBack Function DlgCB()
    Select Case As Long Cb.Msg
        Case %WM_Size
            WM_Size()
        Case %WM_Command
            Select Case As Long Cb.Ctl
                Case %BtnID : If Cb.CtlMsg = %BN_Clicked Then SampleCode()
            End Select
    End Select
End Function

Sub WM_Size()
    Local clientW, clientH As Long
    Local marg As Long
    Local buttonW, buttonH As Long
    Local txtWidth, txtHeight As Long
    Local fromLeft, fromBottom As Long
    Dialog Get Client gDlg To clientW, clientH
    marg = 3 : buttonW = 25 : buttonH = 10
    fromLeft = clientW - marg - buttonW
    fromBottom = clientH - marg - buttonH
    Control Set Size gDlg, %BtnID, buttonW, buttonH
    Control Set Loc gDlg, %BtnID, fromLeft, fromBottom
    txtWidth = clientW - marg - marg
    txtHeight = clientH - marg - buttonH - marg - marg
    Control Set Size gDlg, %TextBox, txtWidth, txtHeight
    Control Set Loc gDlg, %TextBox, marg, marg
End Sub�