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

FLStack.inc, File Based: Long Stack

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

  • PBWin/PBCC FLStack.inc, File Based: Long Stack

    comments
    Uses: FileMap2.inc and FileMemMang2.inc

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

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

    Normally it would be a trip to write a file-based stack, and you would expect very poor performance.

    push 100,000 items = 0.3 seconds

    FileMemMang takes care of storing the UDTs.
    FileMap2.inc gives the stack almost full memory speed.

    Code:
    'bp 5/9
    'FLStack.inc
        '
        '   File Based: Long Stack
        '
        '   keep in mind, this is a 100% file-based stack
        '
        '   push 100,000 items = 0.3 seconds
        '   pop 100,000 items = 0.1 seconds
        '   file = 804,864 bytes
        '       8.04864 bytes per itrm : FLStackItemT = 8 bytes
        '
        '   push 100,000 items again = 0.04 seconds
        '       lot faster because file doesn't have to grow
        '
        '   this is a test & and sample for:
        '       File Mapping module; FileMap2.inc
        '       UDT File Memory Manager; FileMemMang2.inc
        '
    '
    #Include Once "C:\PB9\FileMapping\FileMemMang2.inc"
    '
    $FLStack_Validation = Guid$("{7C466D2C-D819-4B13-B41B-45B64E4ED133}")
    '
    $FLStack_Err_InvalidFile = "FLStack: invalid file"
    $FLStack_Err_InvalidFileName = "FLStack: invalid file name"
    $FLStack_Err_FileExist = "FLStack: file exist"
    $FLStack_Err_FileNotFound = "FLStack: file not found"
    $FLStack_Err_FileNotOpen = "FLStack: file not open"
    $FLStack_Err_FileCreateFail = "FLStack: file creation failed"
    $FLStack_Err_FileOpenFail = "FLStack: file open failed"
    $FLStack_Err_NullHandle = "FLStack: null handle"
    $FLStack_Err_NullPointer = "FLStack: null pointer"
    $FLStack_Err_StackEmpty = "FLStack: stack empty"
    $FLStack_Err_FileMemMangErr = "FLStack: file memory manager error"
    '
    Macro FLStack_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 FLStack_ExitTrue(test, procedure, msg)
        If test Then
            #Debug Print FuncName$ +": "+ msg
            t.isErr = %TRUE
            t.errMsg = msg
            Exit procedure
        End If
    End Macro
    Macro FLStack_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 FLStack_GoTrue(test, MARKER, msg)
        If test Then
            #Debug Print FuncName$ +": "+ msg
            t.isErr = %TRUE
            t.errMsg = msg
            GoTo MARKER
        End If
    End Macro
    '
    '
    '
    Type FLStackItemT 'stored in file
        hNext As Long
        value As Long
    End Type
    Type FLStackHeaderT 'stored in file
        validate As Guid
        Count As Long
        hFirst As Long
    End Type
    Type FLStackT
        hdr As FLStackHeaderT
        mem As FMemT
        isOpen As Long
        isErr As Long
        errMsg As Asciiz * 256
    End Type
    '
    '
    '
    Function FLStack_Create(t As FLStackT, ByVal file As String) As Long
        'create new file - open for use - True/False success
        Local hHdr As Long
        Local pHdr As FLStackHeaderT Ptr
        '
        t.isErr = %FALSE
        t.isOpen = %FALSE
        FLStack_ExitTrue(file = "", Function, $FLStack_Err_InvalidFileName)
        FLStack_ExitTrue(IsFile(file), Function, $FLStack_Err_FileExist)
        FLStack_ExitFalse(FMem_Create(t.mem, file), Function, $FLStack_Err_FileCreateFail)
        t.hdr.validate = $FLStack_Validation
        t.hdr.count = 0
        t.hdr.hFirst = %NULL
        ' - allocate space to store header
        hHdr = FMem_Alloc(t.mem, SizeOf(FLStackHeaderT)) : FLStack_GoFalse(hHdr, CLOSE_FILE, $FLStack_Err_NullHandle)
        ' - set pointer to allocated file memory block
        pHdr = FMem_Get(t.mem, hHdr) : FMem_GoFalse(pHdr, CLOSE_FILE, $FMem_Err_NullPtr)
        ' - store header in file
        @pHdr = t.hdr
        ' - store memory block handle in File Memory Manager; user slot 1
        '       need handle to header to get header whenever file opened
        FMem_SetUser t.mem, 1, hHdr
        '
        t.isOpen = %TRUE
        Function = %TRUE
        Exit Function
        '
        CLOSE_FILE:
        FMem_Close t.mem
    End Function
    '
    Function FLStack_Open(t As FLStackT, ByVal file As String) As Long
        'open existing file created with, FLStack_Create()
        'True/False success
        Local hHdr As Long
        Local pHdr As FLStackHeaderT Ptr
        '
        t.isErr = %FALSE
        t.isOpen = %FALSE
        FLStack_ExitTrue(file = "", Function, $FLStack_Err_InvalidFileName)
        FLStack_ExitFalse(IsFile(file), Function, $FLStack_Err_FileNotFound)
        FLStack_ExitFalse(FMem_Open(t.mem, file), Function, $FLStack_Err_FileOpenFail)
        ' - get header handle
        hHdr = FMem_GetUser(t.mem, 1) : FLStack_GoFalse(hHdr, CLOSE_FILE, $FLStack_Err_NullHandle)
        ' - set pointer to header in File Mapping View
        pHdr = FMem_Get(t.mem, hHdr) : FLStack_GoFalse(pHdr, CLOSE_FILE, $FLStack_Err_NullPointer)
        ' - get header contents
        t.hdr = @pHdr
        FLStack_GoFalse(t.hdr.validate = $FLStack_Validation, CLOSE_FILE, $FLStack_Err_InvalidFile)
        '
        t.isOpen = %TRUE
        Function = %TRUE
        Exit Function
        '
        CLOSE_FILE:
        FMem_Close t.mem
    End Function
    '
    Sub FLStack_Close(t As FLStackT)
        'close file
        Local hHdr As Long
        Local pHdr As FLStackHeaderT Ptr
        '
        t.isErr = %FALSE
        FLStack_ExitFalse(t.isOpen, Sub, $FLStack_Err_FileNotOpen)
        ' - get header handle
        hHdr = FMem_GetUser(t.mem, 1) : FLStack_GoFalse(hHdr, CLOSE_FILE, $FLStack_Err_NullHandle)
        ' - set pointer to header
        pHdr = FMem_Get(t.mem, hHdr) : FLStack_GoFalse(pHdr, CLOSE_FILE, $FLStack_Err_NullPointer)
        ' - store header in file
        @pHdr = t.hdr
        CLOSE_FILE:
        FMem_Close t.mem
        t.isOpen = %FALSE
    End Sub
    '
    Function FLStack_Count(t As FLStackT) As Long
        'get stack count
        t.isErr = %FALSE
        FLStack_ExitFalse(t.isOpen, Function, $FLStack_Err_FileNotOpen)
        Function = t.hdr.count
    End Function
    '
    Sub FLStack_Clear(t As FLStackT)
        'delete all data - shrink file
        '   file = 4K, one page for File Memory Manager header, one page for stack header
        Local hHdr As Long
        Local pHdr As FLStackHeaderT Ptr
        '
        t.isErr = %FALSE
        FLStack_ExitFalse(t.isOpen, Sub, $FLStack_Err_FileNotOpen)
        While t.hdr.count
            FLStack_Pop(t)
        Wend
        FMem_Clear t.mem : FMem_ExitTrue(t.mem.isErr, Sub, $FLStack_Err_FileMemMangErr)
        t.hdr.count = 0
        t.hdr.hFirst = %NULL
        ' - have to allocate space and restore header
        hHdr = FMem_Alloc(t.mem, SizeOf(FLStackHeaderT)) : FLStack_ExitFalse(hHdr, Sub, $FLStack_Err_NullHandle)
        pHdr = FMem_Get(t.mem, hHdr) : FLStack_ExitFalse(pHdr, Sub, $FLStack_Err_NullPointer)
        @pHdr = t.hdr
        ' - restore header handle in File Memory Manager user slot 1
        FMem_SetUser t.mem, 1, hHdr
    End Sub
    '
    Sub FLStack_Push(t As FLStackT, ByVal value As Long)
        'push value on stack
        Local hItem As Long
        '
        t.isErr = %FALSE
        FLStack_ExitFalse(t.isOpen, Sub, $FLStack_Err_FileNotOpen)
        hItem = FLStack_Item_Alloc(t) : FLStack_ExitFalse(hItem, Sub, $FLStack_Err_NullHandle)
        FLStack_Item_SetValue t, hItem, value
        FLStack_Item_SetNext t, hItem, t.hdr.hFirst
        t.hdr.hFirst = hItem
    End Sub
    '
    Function FLStack_Peek(t As FLStackT) As Long
        'get top value on stack
        t.isErr = %FALSE
        FLStack_ExitFalse(t.isOpen, Function, $FLStack_Err_FileNotOpen)
        FLStack_ExitFalse(t.hdr.count, Function, $FLStack_Err_StackEmpty)
        Function = FLStack_Item_GetValue(t, t.hdr.hFirst)
    End Function
    '
    Function FLStack_Pop(t As FLStackT) As Long
        'pop top value off stack
        Local hItem As Long
        '
        t.isErr = %FALSE
        FLStack_ExitFalse(t.isOpen, Function, $FLStack_Err_FileNotOpen)
        FLStack_ExitFalse(t.hdr.count, Function, $FLStack_Err_StackEmpty)
        Function = FLStack_Item_GetValue(t, t.hdr.hFirst)
        hItem = t.hdr.hFirst
        t.hdr.hFirst = FLStack_Item_GetNext(t, hItem)
        FLStack_Item_Free t, hItem
    End Function
    '
    Function FLStack_IsErr(t As FLStackT) As Long
        'True/False if last operation caused an error
        Function = t.isErr
    End Function
    '
    Function FLStack_ErrMsg(t As FLStackT) As String
        'get error message
        If t.isErr Then Function = t.errMsg
    End Function
    '
    '   -----------------------------------
    '               internal
    '   -----------------------------------
    '
    Function FLStack_Item_Alloc(t As FLStackT) As Long
        'internal - allocate file space for item node
        Local hItem As Long
        Local pItem As FLStackItemT Ptr
        hItem = FMem_Alloc(t.mem, SizeOf(FLStackItemT)) : FLStack_ExitFalse(hItem, Function, $FLStack_Err_NullHandle)
        pItem = FMem_Get(t.mem, hItem) : FLStack_ExitFalse(pItem, Function, $FLStack_Err_NullPointer)
        @pItem.hNext = %NULL
        @pItem.value = 0
        Incr t.hdr.count
        Function = hItem
    End Function
    '
    Sub FLStack_Item_Free(t As FLStackT, ByVal hItem As Long)
        'internal - free item node's allocate file memory block
        FLStack_ExitFalse(hItem, Sub, $FLStack_Err_NullHandle)
        FMem_Free t.mem, hItem, SizeOf(FLStackItemT)
        Decr t.hdr.count
    End Sub
    '
    Sub FLStack_Item_SetNext(t As FLStackT, ByVal hItem As Long, ByVal hNext As Long)
        FLStack_ExitFalse(hItem, Sub, $FLStack_Err_NullHandle)
        Local pItem As FLStackItemT Ptr
        pItem = FMem_Get(t.mem, hItem) : FLStack_ExitFalse(pItem, Sub, $FLStack_Err_NullPointer)
        @pItem.hNext = hNext
    End Sub
    '
    Function FLStack_Item_GetNext(t As FLStackT, ByVal hItem As Long) As Long
        FLStack_ExitFalse(hItem, Function, $FLStack_Err_NullHandle)
        Local pItem As FLStackItemT Ptr
        pItem = FMem_Get(t.mem, hItem) : FLStack_ExitFalse(pItem, Function, $FLStack_Err_NullPointer)
        Function = @pItem.hNext
    End Function
    '
    Sub FLStack_Item_SetValue(t As FLStackT, ByVal hItem As Long, ByVal value As Long)
        FLStack_ExitFalse(hItem, Sub, $FLStack_Err_NullHandle)
        Local pItem As FLStackItemT Ptr
        pItem = FMem_Get(t.mem, hItem) : FLStack_ExitFalse(pItem, Sub, $FLStack_Err_NullPointer)
        @pItem.value = value
    End Sub
    '
    Function FLStack_Item_GetValue(t As FLStackT, ByVal hItem As Long) As Long
        FLStack_ExitFalse(hItem, Function, $FLStack_Err_NullHandle)
        Local pItem As FLStackItemT Ptr
        pItem = FMem_Get(t.mem, hItem) : FLStack_ExitFalse(pItem, Function, $FLStack_Err_NullPointer)
        Function = @pItem.value
    End Function
    '
    Last edited by Stanley Durham; 16 Aug 2009, 10:23 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 = "FLStackTest.bas"
    $TestTitle = "File Based: Long Stack Test"
    #Compile Exe "FLStackTest.exe"
    #Dim All
    #Optimize Speed
    #Include "..\FLStack.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 FLStackT
        '
        lbx.Clear(2)
        Count = 100000
        '
        If IsFile(file) Then Kill file
        '
        If IsFalse FLStack_Create(t, file) Then Exit Sub
        '
        lbx.Add("push "+Format$(Count, "#,")+" items on stack")
        tmr.Start()
        For i = 1 To Count
            FLStack_Push t, i
        Next i
        lbx.Add(tmr.Get())
        '
        lbx.Add("")
        lbx.Add("Count = " + Format$(FLStack_Count(t),"#,"))
        '
        lbx.Add("")
        lbx.Add("close and reopen stack - make sure data saved")
        FLStack_Close t
        FLStack_Open(t, file)
        '
        lbx.Add("")
        lbx.Add("pop all "+Format$(Count, "#,")+" items")
        i = Count + 1
        tmr.Start()
        While FLStack_Count(t)
            Decr i
            If FLStack_Pop(t) <> i Then
                ? "fail at: " + Format$(i) : Exit Loop
            End If
        Wend
        lbx.Add(tmr.Get())
        '
        lbx.Add("")
        lbx.Add("file size = 804,864 bytes")
        '
        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
            FLStack_Push t, i
        Next i
        lbx.Add(tmr.Get())
        '
        lbx.Add("")
        lbx.Add("file size = 804,864 bytes - 100% recovery of deleted blocks")
        '
        lbx.Add("")
        lbx.Add("Clear() file")
        FLStack_Clear t
        lbx.Add("push 5 items")
        For i = 1 To 5
            FLStack_Push t, i * 1000
        Next i
        '
        While FLStack_Count(t)
            s = "Peek = "
            s += Format$(FLStack_Peek(t))
            s += " | "
            s += "Pop = "
            s += Format$(FLStack_Pop(t))
            lbx.Add(s)
        Wend
        '
        '
        lbx.Add("")
        lbx.Add("file size now = 6,144 bytes")
        '
        '- close stack
        FLStack_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