Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

FSSList1.inc, File Based: String List

Collapse
X
Collapse
 
  • Page of 1
  • Filter
  • Time
  • Show
Clear All
new posts
Previous template Next
  • #1

    PBWin/PBCC FSSList1.inc, File Based: String List

    comments
    Uses: FileMap2.inc, FileMemMang2.inc, FLLList1.inc, FStr16.inc

    String/String ~ Key/Value ~ file-based List
    Unlimited string length.

    Uses the Long List to store string handles.

    get and test 10,000 Key/Value strings 0.047 seconds
    traverse 10,000 items = 0.0 seconds

    Code:
    'pb 5/9
'FSSList1.inc
    '
    '   File Based: String/String ~ Key/Value ~ List
    '
    '   unlimited string length - nulls OK
    '
    '   add 10,000 Key/Value strings = 0.18 seconds
    '   get and test 10,000 Key/Value strings 0.047 seconds
    '
    '   traverse 10,000 items = 0.0 seconds
    '   add 10,000 Key/Value strings after file expanded = 0.08 seconds
    '
'
#Include Once "C:\PB9\FileMapping\FileMap2.inc"
#Include Once "C:\PB9\FileMapping\FileMemMang2.inc"
#Include Once "C:\PB9\FileMapping\FStr16.inc"
#Include Once "C:\PB9\FileMapping\FLLList1.inc"
'
'
$FSSList_Err_FileNotOpen = "FSSList: file not open"
$FSSList_Err_NullHandle = "FSSList: null handle"
$FSSList_Err_NullPointer = "FSSList: null pointer"
'
Macro FSSList_ExitFalse(test, procedure, msg)
    If test Then
    Else
        #Debug Print FuncName$ +": "+ msg
        t.isErr = %TRUE
        t.errMsg = msg
        Exit procedure
    End If
End Macro
Macro FSSList_ExitTrue(test, procedure, msg)
    If test Then
        #Debug Print FuncName$ +": "+ msg
        t.isErr = %TRUE
        t.errMsg = msg
        Exit procedure
    End If
End Macro
Macro FSSList_GoFalse(test, MARKER, msg)
    If test Then
    Else
        #Debug Print FuncName$ +": "+ msg
        t.isErr = %TRUE
        t.errMsg = msg
        GoTo MARKER
    End If
End Macro
Macro FSSList_GoTrue(test, MARKER, msg)
    If test Then
        #Debug Print FuncName$ +": "+ msg
        t.isErr = %TRUE
        t.errMsg = msg
        GoTo MARKER
    End If
End Macro
'
'
'
Type FSSListT
    list As FLLListT
    str As FStr16T
    isOpen As Long
    isErr As Long
    errMsg As Asciiz * 256
End Type
'
'
'
Function FSSList_Create(t As FSSListT, ByVal file As String) As Long
    'create new file - open for use - True/False success
    t.isErr = %FALSE
    t.isOpen = %FALSE
    FSSList_ExitFalse(FLLList_Create(t.list, file), Function, t.list.errMsg)
    If t.str.pMem = %NULL Then t.str.pMem = VarPtr(t.list.mem)
    t.isOpen = %TRUE
    Function = %TRUE
End Function
'
Function FSSList_Open(t As FSSListT, ByVal file As String) As Long
    'open existing file - True/False success
    t.isErr = %FALSE
    t.isOpen = %FALSE
    FSSList_ExitFalse(FLLList_Open(t.list, file), Function, t.list.errMsg)
    If t.str.pMem = %NULL Then t.str.pMem = VarPtr(t.list.mem)
    t.isOpen = %TRUE
    Function = %TRUE
End Function
'
Sub FSSList_Close(t As FSSListT)
    'close file
    t.isErr = %FALSE
    FSSList_ExitFalse(t.isOpen, Sub, $FSSList_Err_FileNotOpen)
    FLLList_Close t.list
    t.isOpen = %FALSE
    FSSList_ExitTrue(t.list.isErr, Sub, t.list.errMsg)
End Sub
'
Sub FSSList_Clear(t As FSSListT)
    'delete all data - shrink file
    t.isErr = %FALSE
    FSSList_ExitFalse(t.isOpen, Sub, $FSSList_Err_FileNotOpen)
    FLLList_Clear t.list
    FSSList_ExitTrue(t.list.isErr, Sub, t.list.errMsg)
End Sub
'
Function FSSList_Count(t As FSSListT) As Long
    'get stack count
    t.isErr = %FALSE
    FLLList_ExitFalse(t.isOpen, Function, $FSSList_Err_FileNotOpen)
    Function = t.list.hdr.count
End Function
'
Function FSSList_Add(t As FSSListT, ByRef key As String, ByRef value As String) As Long
    'append Key/Value to end of list
    'return node handle - False if fail
    Local hNode As Long
    '
    t.isErr = %FALSE
    FSSList_ExitFalse(t.isOpen, Function, $FSSList_Err_FileNotOpen)
    hNode = FLLList_Add(t.list, %NULL, %NULL)
    FSSList_ExitFalse(hNode, Function, t.list.errMsg)
    FLLList_SetKeyAt t.list, hNode, FStr16_Put(t.str, key)
    FLLList_SetValueAt t.list, hNode, FStr16_Put(t.str, value)
    Function = hNode
End Function
'
Function FSSList_Insert(t As FSSListT, ByRef key As String, ByRef value As String) As Long
    'insert Key/Value in front of list
    'return node handle - False if fail
    Local hNode As Long
    '
    t.isErr = %FALSE
    FSSList_ExitFalse(t.isOpen, Function, $FSSList_Err_FileNotOpen)
    hNode = FLLList_Insert(t.list, %NULL, %NULL)
    FSSList_ExitFalse(hNode, Function, t.list.errMsg)
    FLLList_SetKeyAt t.list, hNode, FStr16_Put(t.str, key)
    FLLList_SetValueAt t.list, hNode, FStr16_Put(t.str, value)
    Function = hNode
End Function
'
Function FSSList_InsertAt(t As FSSListT, ByVal hNode As Long, ByRef key As String, ByRef value As String) As Long
    'insert Key/Value before hNode
    'return node handle - False if fail
    Local hNew As Long
    '
    t.isErr = %FALSE
    FSSList_ExitFalse(t.isOpen, Function, $FSSList_Err_FileNotOpen)
    hNew = FLLList_InsertAt(t.list, hNode, %NULL, %NULL)
    FSSList_ExitFalse(hNew, Function, t.list.errMsg)
    FLLList_SetKeyAt t.list, hNew, FStr16_Put(t.str, key)
    FLLList_SetValueAt t.list, hNew, FStr16_Put(t.str, value)
    Function = hNew
End Function
'
Sub FSSList_DeleteAt(t As FSSListT, ByVal hNode As Long)
    'remove node from list
    Local hKey, hValue As Long
    '
    t.isErr = %FALSE
    FSSList_ExitFalse(t.isOpen, Sub, $FSSList_Err_FileNotOpen)
    FSSList_ExitFalse(hNode, Sub, $FSSList_Err_NullHandle)
    hKey = FLLList_GetKeyAt(t.list, hNode)
    hValue = FLLList_GetValueAt(t.list, hNode)
    If hKey Then FStr16_Remove(t.str, hKey)
    If hValue Then FStr16_Remove(t.str, hValue)
    FLLList_DeleteAt t.list, hNode
    FSSList_ExitTrue(t.list.isErr, Sub, t.list.errMsg)
End Sub
'
Function FSSList_First(t As FSSListT) As Long
    'move to first node in list - return node handle - False if fail
    t.isErr = %FALSE
    FSSList_ExitFalse(t.isOpen, Function, $FSSList_Err_FileNotOpen)
    Function = t.list.hdr.hFirst
End Function
'
Function FSSList_Last(t As FSSListT) As Long
    'move to last node in list - return node handle - False if fail
    t.isErr = %FALSE
    FSSList_ExitFalse(t.isOpen, Function, $FSSList_Err_FileNotOpen)
    Function = t.list.hdr.hLast
End Function
'
Function FSSList_Right(t As FSSListT, ByVal hNode As Long) As Long
    'move right from current node - return node handle - False if fail
    t.isErr = %FALSE
    FSSList_ExitFalse(t.isOpen, Function, $FSSList_Err_FileNotOpen)
    If hNode Then Function = FLLList_Node_GetRight(t.list, hNode)
End Function
'
Function FSSList_Left(t As FSSListT, ByVal hNode As Long) As Long
    'move left from current node - return node handle - False if fail
    t.isErr = %FALSE
    FSSList_ExitFalse(t.isOpen, Function, $FSSList_Err_FileNotOpen)
    If hNode Then Function = FLLList_Node_GetLeft(t.list, hNode)
End Function
'
Sub FSSList_SetKeyAt(t As FSSListT, ByVal hNode As Long, ByRef key As String)
    'change Key at current position
    t.isErr = %FALSE
    FSSList_ExitFalse(t.isOpen, Sub, $FSSList_Err_FileNotOpen)
    FSSList_ExitFalse(hNode, Sub, $FSSList_Err_NullHandle)
    Local pNode As FLLListNodeT Ptr
    pNode = FMem_Get(t.list.mem, hNode) : FSSList_ExitFalse(pNode, Sub, $FSSList_Err_NullPointer)
    If @pNode.key Then @pNode.key = FStr16_Remove(t.str, @pNode.key)
    @pNode.key = FStr16_Put(t.str, key)
End Sub
'
Function FSSList_GetKeyAt(t As FSSListT, ByVal hNode As Long) As String
    'get Key at current position
    t.isErr = %FALSE
    FSSList_ExitFalse(t.isOpen, Function, $FSSList_Err_FileNotOpen)
    FSSList_ExitFalse(hNode, Function, $FSSList_Err_NullHandle)
    Local pNode As FLLListNodeT Ptr
    pNode = FMem_Get(t.list.mem, hNode) : FSSList_ExitFalse(pNode, Function, $FSSList_Err_NullPointer)
    If @pNode.key Then Function = FStr16_Get(t.str, @pNode.key)
End Function
'
Sub FSSList_SetValueAt(t As FSSListT, ByVal hNode As Long, ByRef value As String)
    'change Value at current position
    t.isErr = %FALSE
    FSSList_ExitFalse(t.isOpen, Sub, $FSSList_Err_FileNotOpen)
    FSSList_ExitFalse(hNode, Sub, $FSSList_Err_NullHandle)
    Local pNode As FLLListNodeT Ptr
    pNode = FMem_Get(t.list.mem, hNode) : FSSList_ExitFalse(pNode, Sub, $FSSList_Err_NullPointer)
    If @pNode.value Then @pNode.value = FStr16_Remove(t.str, @pNode.value)
    @pNode.value = FStr16_Put(t.str, value)
End Sub
'
Function FSSList_GetValueAt(t As FSSListT, ByVal hNode As Long) As String
    'get Value at current position
    t.isErr = %FALSE
    FSSList_ExitFalse(t.isOpen, Function, $FSSList_Err_FileNotOpen)
    FSSList_ExitFalse(hNode, Function, $FSSList_Err_NullHandle)
    Local pNode As FLLListNodeT Ptr
    pNode = FMem_Get(t.list.mem, hNode) : FSSList_ExitFalse(pNode, Function, $FSSList_Err_NullPointer)
    If @pNode.value Then Function = FStr16_Get(t.str, @pNode.value)
End Function
'
Function FSSList_IsErr(t As FSSListT) As Long
    'True/False if last operation caused an error
    Function = t.isErr
End Function
'
Function FSSList_ErrMsg(t As FSSListT) As String
    'get error message
    If t.isErr Then Function = t.errMsg
End Function
'
    stanthemanstan~gmail
    Dead Theory Walking
    Range Trie Tree
    HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes
    Tags: None
  • #2
    test/sample app
    Code:
    #PBForms CREATED V1.51
'pbwin 9
$TestSource = "FSSListTest.bas"
$TestTitle = "File Based: String/String ~ Key/Value List Test"
#Compile Exe "FSSListTest.exe"
#Dim All
#Optimize Speed
#Include Once "..\FSSList1.inc"
#PBForms BEGIN INCLUDES
#If Not %Def(%WINAPI)
    #Include Once "WIN32API.INC"
#EndIf
#Include Once "PBForms.INC"
#PBForms END INCLUDES
#PBForms BEGIN CONSTANTS
%Dlg1    =  101
%BtnTest = 1002
%Lbx1    = 1001
#PBForms END CONSTANTS
Declare CallBack Function ShowDlg1Proc()
Declare Function ShowDlg1(ByVal hParent As Dword) As Long
#PBForms DECLARATIONS
Global lbx As LBxI
Global tmr As TimerI
Function PBMain()
    ShowDlg1 %HWND_Desktop
End Function
Sub BtnTest(ByVal hDlg As Long)
    Local i, Count, hNode, hDel As Long
    Local file As String : file = "FSSList.dat"
    Local s As String
    Local t As FSSListT
    '
    lbx.Clear(2)
    Count = 10000
    '
    If IsFile(file) Then Kill file
    '
    If IsFalse FSSList_Create(t, file) Then Exit Sub
    '
    lbx.Add("add "+Format$(Count, "#,")+" items")
    tmr.Start()
    For i = 1 To Count
        s = Format$(i)
        FSSList_Add(t, s, s)
    Next i
    lbx.Add(tmr.Get())
    '
    lbx.Add("")
    lbx.Add("Count = " + Format$(FSSList_Count(t)))
    '
    lbx.Add("")
    lbx.Add("close and reopen file")
    FSSList_Close t
    If IsFalse FSSList_Open(t, file) Then Exit Sub
    '
    lbx.Add("")
    lbx.Add("traverse all "+Format$(Count, "#,")+" items")
    lbx.Add("    make sure data correct")
    i = 0
    tmr.Start()
    hNode = FSSList_First(t)
    While hNode
        Incr i
        s = Format$(i)
        If FSSList_GetKeyAt(t, hNode) <> s Or FSSList_GetValueAt(t, hNode) <> s Then
            ? "fail at: " + Format$(i) : Exit Loop
        End If
        hNode = FSSList_Right(t, hNode)
    Wend
    lbx.Add(tmr.Get())
    '
    ' =============
    '
    lbx.Add("")
    lbx.Add("insert after file already expanded")
    hNode = FSSList_First(t)
    While hNode
        FSSList_DeleteAt t, hNode
        hNode = FSSList_First(t)
    Wend
    lbx.Add("add "+Format$(Count, "#,")+" items")
    tmr.Start()
    For i = 1 To Count
        s = Format$(i)
        FSSList_Add(t, s, s)
    Next i
    lbx.Add(tmr.Get())
    '
    '
    lbx.Add("")
    lbx.Add("traverse all "+Format$(Count, "#,")+" items")
    lbx.Add("    without testing data")
    tmr.Start()
    hNode = FSSList_First(t)
    While hNode
        hNode = FSSList_Right(t, hNode)
    Wend
    lbx.Add(tmr.Get())
    '
    '=========================
    '
    '
    lbx.Add("")
    lbx.Add("clear list - add 5 items")
    FSSList_Clear t
    For i = 1 To 5
        s = Format$(i * 100)
        FSSList_Add(t, s, s)
    Next i
    '
    lbx.Add("")
    lbx.Add("traverse forward")
    lbx.Add("  changing Key/Value as we go")
    hNode = FSSList_First(t)
    While hNode
        'FSSList_SetKeyAt t, hNode, FSSList_GetKeyAt(t, hNode) + "changed"
        FSSList_SetValueAt t, hNode, FSSList_GetValueAt(t, hNode) + "changed"
        s = "  Key = "
        s += FSSList_GetKeyAt(t, hNode)
        s += " | "
        s += "Value = "
        s += FSSList_GetValueAt(t, hNode)
        lbx.Add(s)
        hNode = FSSList_Right(t, hNode)
    Wend
    lbx.Add("traverse backward")
    hNode = FSSList_Last(t)
    While hNode
        s = "  Key = "
        s += FSSList_GetKeyAt(t, hNode)
        s += " | "
        s += "Value = "
        s += FSSList_GetValueAt(t, hNode)
        lbx.Add(s)
        hNode = FSSList_Left(t, hNode)
    Wend
    '
    lbx.Add("")
    lbx.Add("insert value before 100, 300 and 500")
    FSSList_Insert(t, "111", "11111")
    hNode = FSSList_First(t)
    While hNode
        If FSSList_GetKeyAt(t, hNode) = "300" Then
            FSSList_InsertAt(t, hNode, "333", "33333")
        ElseIf FSSList_GetKeyAt(t, hNode) = "500" Then
            FSSList_InsertAt(t, hNode, "555", "55555")
        End If
        hNode = FSSList_Right(t, hNode)
    Wend
    hNode = FSSList_First(t)
    While hNode
        s = "  Key = "
        s += FSSList_GetKeyAt(t, hNode)
        s += " | "
        s += "Value = "
        s += FSSList_GetValueAt(t, hNode)
        lbx.Add(s)
        hNode = FSSList_Right(t, hNode)
    Wend
    '
    lbx.Add("")
    lbx.Add("delete 111, 333, 555")
    hNode = FSSList_First(t)
    While hNode
        hDel = hNode
        'can't delete node while sitting on it (if you want to continue traversing)
        hNode = FSSList_Right(t, hNode)
        If FSSList_GetKeyAt(t, hDel) = "111" Or FSSList_GetKeyAt(t, hDel) = "333" Or FSSList_GetKeyAt(t, hDel) = "555" Then
            FSSList_DeleteAt t, hDel
        End If
    Wend
    hNode = FSSList_First(t)
    While hNode
        s = "  Key = "
        s += FSSList_GetKeyAt(t, hNode)
        s += " | "
        s += "Value = "
        s += FSSList_GetValueAt(t, hNode)
        lbx.Add(s)
        hNode = FSSList_Right(t, hNode)
    Wend
    '
    '
    ' - close list
    FSSList_Close t
    '
    lbx.Add("")
    lbx.Add("done...")
End Sub
CallBack Function ShowDlg1Proc()
    Select Case As Long CbMsg
        Case %WM_InitDialog
             lbx = Class "LBxC"
             lbx.INI(Cb.Hndl, %Lbx1)
             lbx.SetHorizontal(1000)
             tmr = Class "TimerC"
        Case %WM_NCActivate
            Static hWndSaveFocus As Dword
            If IsFalse CbWParam Then
                hWndSaveFocus = GetFocus()
            ElseIf hWndSaveFocus Then
                SetFocus(hWndSaveFocus)
                hWndSaveFocus = 0
            End If
        Case %WM_Command
            Select Case As Long CbCtl
                Case %BtnTest
                    If CbCtlMsg = %BN_Clicked Or CbCtlMsg = 1 Then
                        BtnTest(Cb.Hndl)
                    End If
            End Select
    End Select
End Function
Function ShowDlg1(ByVal hParent As Dword) As Long
    Local lRslt  As Long
#PBForms BEGIN DIALOG %Dlg1->->
    Local hDlg   As Dword
    Local hFont1 As Dword
    Dialog New hParent, $TestTitle, 67, 61, 341, 241, %WS_Popup _
        Or %WS_Border Or %WS_DlgFrame Or %WS_Caption Or %WS_SysMenu Or _
        %WS_MinimizeBox Or %WS_ClipSiblings Or %WS_Visible Or %DS_ModalFrame _
        Or %DS_3DLook Or %DS_NoFailCreate Or %DS_SetFont, _
        %WS_Ex_ControlParent Or %WS_Ex_Left Or %WS_Ex_LtrReading Or _
        %WS_Ex_RightScrollbar, To hDlg
    Control Add ListBox, hDlg, %Lbx1, , 5, 5, 330, 210, %WS_Child Or _
        %WS_Visible Or %WS_HScroll Or %WS_VScroll Or %LBS_Notify Or _
        %LBS_NoIntegralHeight, %WS_Ex_ClientEdge Or %WS_Ex_Left Or _
        %WS_Ex_LtrReading Or %WS_Ex_RightScrollbar
    Control Add Button,  hDlg, %BtnTest, "Test", 275, 220, 60, 15
    hFont1 = PBFormsMakeFont("Courier New", 9, 400, %FALSE, %FALSE, %FALSE, _
        %ANSI_CHARSET)
    Control Send hDlg, %Lbx1, %WM_SETFONT, hFont1, 0
#PBForms END DIALOG
    Dialog Show Modal hDlg, Call ShowDlg1Proc To lRslt
#PBForms BEGIN CLEANUP %Dlg1
    DeleteObject hFont1
#PBForms END CLEANUP
    Function = lRslt
End Function
Class LBxC
    Instance meHDlg As Long
    Instance meID As Long
    Interface LBxI
        Inherit IUnknown
        Method INI(ByVal hDlg As Long, ByVal Id As Long)
            meHDlg = hDlg
            meID = Id
        End Method
        Method SetHorizontal(ByVal Count As Long)
            Local hCntrl&
            Control Handle meHDlg, meID To hCntrl&
            SendMessage hCntrl&, %LB_SETHORIZONTALEXTENT, Count, 0
        End Method
        Method Clear(Opt doEventsCount As Long)
            ListBox Reset meHDlg, meID
            If VarPtr(doEventsCount) Then me.DoEventsCount(doEventsCount)
        End Method
        Method Add(ByVal s As String, Opt doEventsCount As Long) As String
            ListBox Add meHDlg, meID, s
            If VarPtr(doEventsCount) Then me.DoEventsCount(doEventsCount)
        End Method
    End Interface
    Class Method DoEventsCount(ByVal Count As Long)
        Local i As Long
        For i = 1 To Count
            Dialog DoEvents
        Next i
    End Method
End Class
Class TimerC
    Instance meTime As Double
    Interface TimerI
        Inherit IUnknown
        Method Start()
            meTime = Timer
        End Method
        Method Get() As String
            Method = "    Time: " + Format$(Timer - meTime, "###.###############")
        End Method
    End Interface
End Class
    stanthemanstan~gmail
    Dead Theory Walking
    Range Trie Tree
    HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

    Comment

    Previous template Next
    Working...
    X

    We process personal data about users of our site, through the use of cookies and other technologies, to deliver our services, and to analyze site activity. For additional details, refer to our Privacy Policy.

    By clicking "I AGREE" below, you agree to our Privacy Policy and our personal data processing and cookie practices as described therein. You also acknowledge that this forum may be hosted outside your country and you consent to the collection, storage, and processing of your data in the country where this forum is hosted.

    I Agree