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
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • Stanley Durham
    replied
    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

    Leave a comment:


  • Stanley Durham
    started a topic PBWin/PBCC FSSList1.inc, File Based: String List

    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
    '
Working...
X