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

FSStack.inc, File Based: String Stack

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • PBWin/PBCC FSStack.inc, File Based: String Stack

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

    This is basically and example for the File Mapping module and the UDT Memory Manager.

    It’s a 100% file-based, very fast, String Stack.

    Pop 10,000 string in 0.06 seconds: file based string stack

    This just uses FLStack.inc to push/pop string handles on a Long Stack.
    The string storage taken care of by FStr16.inc.
    FileMap2.inc gives us incredible speed for a file based string stack.

    FileMemMang2.inc makes building file based structures, such as stacks, simple.

    Strings can be any length.

    Code:
    ' pb 5/9
    'FSStack.inc
        '
        '   File Based: String Stack
        '
        '
    #Include Once "C:\PB9\FileMapping\FileMap2.inc"
    #Include Once "C:\PB9\FileMapping\FileMemMang2.inc"
    #Include Once "C:\PB9\FileMapping\FLStack.inc"
    #Include Once "C:\PB9\FileMapping\FStr16.inc"
    '
    Type FSStackT
        stack As FLStackT
        str As FStr16T
    End Type
    '
    Function FSStack_Create(t As FSStackT, ByVal file As String) As Long
        'create new file - open for use - True/False success
        If FLStack_Create(t.stack, file) Then
            If t.str.pMem = %NULL Then FStr16_Initiate t.str, t.stack.mem
            Function = %TRUE
        End If
    End Function
    '
    Function FSStack_Open(t As FSStackT, ByVal file As String) As Long
        'open existing file - True/False success
        If FLStack_Open(t.stack, file) Then
            If t.str.pMem = %NULL Then FStr16_Initiate t.str, t.stack.mem
            Function = %TRUE
        End If
    End Function
    '
    Sub FSStack_Close(t As FSStackT)
        'close file
        FLStack_Close t.stack
    End Sub
    '
    Sub FSStack_Clear(t As FSStackT)
        'delete all data - trim file
        FLStack_Clear t.stack
    End Sub
    '
    Function FSStack_Count(t As FSStackT) As Long
        'get stack count
        Function = FLStack_Count(t.stack)
    End Function
    '
    Sub FSStack_Push(t As FSStackT, ByRef s As String)
        'push value on stack
        FLStack_Push t.stack, FStr16_Put(t.str, s)
    End Sub
    '
    Function FSStack_Peek(t As FSStackT) As String
        'get top item on stack
        Function = FStr16_Get(t.str, FLStack_Peek(t.stack))
    End Function
    '
    Function FSStack_Pop(t As FSStackT) As String
        'pop top item off stack
        Local hStr As Long
        hStr = FLStack_Pop(t.stack)
        Function = FStr16_Get(t.str, hStr)
        FStr16_Remove(t.str, hStr)
    End Function
    '
    Last edited by Stanley Durham; 16 Aug 2009, 10:22 AM.
    stanthemanstan~gmail
    Dead Theory Walking
    Range Trie Tree
    HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

  • #2
    test/sample app
    Code:
    #PBForms CREATED V1.51
    'pbwin 9
    $TestSource = "FSStackTest.bas"
    $TestTitle = "File Based: String Stack Test"
    #Compile Exe "FSStackTest.exe"
    #Dim All
    #Optimize Speed
    #Include "..\FSStack.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, x, Count As Long
        Local file As String : file = "StackTest.dat"
        Local s As String
        Local t As FSStackT
        '
        lbx.Clear(2)
        Count = 10000
        '
        If IsFile(file) Then Kill file
        '
        If IsFalse FSStack_Create(t, file) Then Exit Sub
        '
        lbx.Add("push "+Format$(Count, "#,")+" items on stack")
        tmr.Start()
        For i = 1 To Count
            FSStack_Push t, Format$(i)
        Next i
        lbx.Add(tmr.Get())
        '
        lbx.Add("")
        lbx.Add("Count = " + Format$(FSStack_Count(t),"#,"))
        '
        lbx.Add("")
        lbx.Add("close and reopen stack - make sure data saved")
        FSStack_Close t
        FSStack_Open(t, file)
        '
        lbx.Add("")
        lbx.Add("pop all "+Format$(Count, "#,")+" items")
        i = Count + 1
        tmr.Start()
        While FSStack_Count(t)
            Decr i
            If FSStack_Pop(t) <> Format$(i) Then
                ? "fail at: " + Format$(i) : Exit Loop
            End If
        Wend
        lbx.Add(tmr.Get())
        '
        lbx.Add("")
        lbx.Add("push "+Format$(Count, "#,")+" items on stack; again")
        lbx.Add("   test to see that freed file blocks are being reused")
        tmr.Start()
        For i = 1 To Count
            FSStack_Push t, Format$(i)
        Next i
        lbx.Add(tmr.Get())
        '
        lbx.Add("")
        lbx.Add("Clear() file")
        FSStack_Clear t
        lbx.Add("push 5 items")
        For i = 1 To 5
            FSStack_Push t, Format$(i * 1000)
        Next i
        '
        While FSStack_Count(t)
            s = "Peek = "
            s += FSStack_Peek(t)
            s += " | "
            s += "Pop = "
            s += FSStack_Pop(t)
            lbx.Add(s)
        Wend
        '
        '
        '- close stack
        FSStack_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

    Working...
    X