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

[Stanley Durham]

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.

' 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
'

[Stanley Durham]

test/sample app

#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