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

UDT Dynamic Arrays and Strings – Lite Objects

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

  • PBWin/PBCC UDT Dynamic Arrays and Strings – Lite Objects

    Lot of discussion about arrays in UDTs.

    These are some simple Lite Object arrays that may be stored in a UDT, or any LONG.

    Also, dynamic string: StrBuff.inc
    String stored in buffer – hold any value

    Lite Object = allocated UDT referenced with pointer or LONG handle.

    You must allocate a new instance before use: h = …Alloc()
    Free handle before it goes out of scope: h = …Free(h)

    Added: arrays ReDim automatically. Arrays grow on Add() and Insert().
    Arrays shrink on Delete()

    Public domain – use at own risk
    Last edited by Stanley Durham; 23 Jul 2009, 01:29 PM.
    stanthemanstan~gmail
    Dead Theory Walking
    Range Trie Tree
    HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

  • #2
    Code:
    'GMem1.inc
    'used by all files
        'allocate global memory
    %GMemGMEM_FIXED    = &H0
    %GMemGMEM_ZEROINIT = &H40
    %GMemGMEM_MOVEABLE = &H2
    %GMemGPTR = %GMemGMEM_FIXED Or %GMemGMEM_ZEROINIT
    #If Not %Def(%WINAPI)
        Declare Function GlobalAlloc Lib "KERNEL32.DLL" Alias "GlobalAlloc" (ByVal wFlags As Dword, ByVal dwBytes As Dword) As Long
        Declare Function GlobalFree Lib "KERNEL32.DLL" Alias "GlobalFree" (ByVal hMem As Dword) As Long
        Declare Function GlobalReAlloc Lib "KERNEL32.DLL" Alias "GlobalReAlloc" (ByVal hMem As Dword, ByVal dwBytes As Dword, ByVal uFlags As Dword) As Dword
        Declare Sub MoveMemory Lib "KERNEL32.DLL" Alias "RtlMoveMemory" (pDestination As Any, pSource As Any, ByVal cbLength As Long)
    #EndIf
    'if %WINAPI isn't included, won't have %TRUE, %FALSE, %NULL
    Macro boolTrue = 1
    Macro boolFalse = 0
    Macro boolNull = 0
    Macro boolExitIfFalse(test, SubOrFun, msg)
        If test Then
        Else
            #Debug Print FuncName$ +": "+ msg
            Exit SubOrFun
        End If
    End Macro
    Macro boolExitIfTrue(test, SubOrFun, msg)
        If test Then
            #Debug Print FuncName$ +": "+ msg
            Exit SubOrFun
        End If
    End Macro
    Macro boolGoToIfFalse(test, marker, msg)
        If test Then
        Else
            #Debug Print FuncName$ +": "+ msg
            GoTo marker
        End If
    End Macro
    Macro boolGoToIfTrue(test, marker, msg)
        If test Then
            #Debug Print FuncName$ +": "+ msg
            GoTo marker
        End If
    End Macro
    Function GMemAlloc(ByVal memSize As Long) As Long
        'allocate memory
        Function = GlobalAlloc(ByVal %GMemGPTR, ByVal memSize)
    End Function
    Function GMemFree(ByRef hMem As Long) As Long
        'free allocated memory
        If hMem Then GlobalFree(ByVal hMem)
        Function = boolNull
    End Function
    Function GMemReAlloc(ByVal hMem As Long, ByVal newSize As Long) As Long
        'reallocate block of memory
        'USE: hMem = GMemReAlloc(hMem, newSize)
        If newSize = 0 Then
            If hMem Then GlobalFree(ByVal hMem)
            Function = boolNull
        Else
            If hMem Then
                Function = GlobalReAlloc(ByVal hMem, ByVal newSize, ByVal %GMemGMEM_MOVEABLE Or %GMemGMEM_ZEROINIT)
            Else
                Function = GlobalAlloc(ByVal %GMemGPTR, ByVal newSize)
            End If
        End If
    End Function
    Sub GMemCopy(ByVal copyTo As Long, ByVal copyFrom As Long, ByVal byteCount As Long)
        'copy/move block of memory
        MoveMemory(ByVal copyTo, ByVal copyFrom, ByVal byteCount)
    End Sub
    stanthemanstan~gmail
    Dead Theory Walking
    Range Trie Tree
    HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

    Comment


    • #3
      Code:
       'LArr.inc
      #Include Once "GMem1.inc"
      ' ------------------------------------------------------------------------
      Macro McLArrType = Long
      Macro McLArrSize = 4
      ' ------------------------------------------------------------------------
          '
          'Dynamic Long Array lite Obj
          '   access array with Long Handle - store in UDT
          '   ZERO based index
          '
          '   ReDim automatic
          '       insert, add ~ array automatically grows
          '       delete      ~ array automatically shrinks
          '
      ' ------------------------------------------------------------------------
      Type LArrT
          Count As Long
          pa As McLArrType Ptr
      End Type
      ' ------------------------------------------------------------------------
       
      Function LArrAlloc() As Long
          'allocate new array - return handle
          '   MUST be freed: LArrFree()
          Function = GMemAlloc(SizeOf(LArrT))
      End Function
      Function LArrFree(ByVal p As LArrT Ptr) As Long
          'free allocated array
          '   h = LArrFree(h)
          If p Then
              LArrClear p
              GMemFree(p)
          End If
          Function = 0
      End Function
      Sub LArrClear(ByVal p As LArrT Ptr)
          'delete all data
          If p Then
              If @p.count Then @p.pa = GMemFree(@p.pa)
              @p.pa = boolNull
              @p.count = 0
          End If
      End Sub
      Function LArrCount(ByVal p As LArrT Ptr) As Long
          'get item count
          If p Then
              Function = @p.count
          End If
      End Function
      Sub LArrReDim(ByVal p As LArrT Ptr, ByVal Count As Long)
          'ReDim array - data preserved
          If p Then
              If Count = 0 Then
                  LArrClear p
              ElseIf Count <> @p.count Then
                  @p.pa = GMemReAlloc(@p.pa, Count * McLArrSize)
                  @p.count = IIf&(@p.pa, Count, 0)
              End If
          End If
      End Sub
      Sub LArrAdd(ByVal p As LArrT Ptr, ByVal item As McLArrType)
          'append item to end of array
          '   ReDim automatic
          If p Then
              LArrReDim p, @p.count + 1
              If @p.count Then @[email protected][@p.count - 1] = item
          End If
      End Sub
      Sub LArrInsert(ByVal p As LArrT Ptr, ByVal index As Long, ByVal item As McLArrType)
          'insert item before index
          '   ReDim automatic
          If p Then
              If index >= 0 And index < @p.count Then
                  LArrReDim p, @p.count + 1
                  If @p.count Then
                      LArrMove(p, index + 1, index, @p.count - index - 1)
                      @[email protected][index] = item
                  End If
              End If
          End If
      End Sub
      Sub LArrDelete(ByVal p As LArrT Ptr, ByVal index As Long)
          'delete item at index
          '   ReDim automatic
          If p Then
              If index >= 0 And index < @p.count Then
                  If @p.count = 1 Then
                      LArrClear p
                  Else
                      If index < @p.count - 1 Then LArrMove(p, index, index + 1, @p.count - index - 1)
                      LArrReDim p, @p.count - 1
                  End If
              End If
          End If
      End Sub
      Sub LArrSet(ByVal p As LArrT Ptr, ByVal index As Long, ByVal item As McLArrType)
          'set item at index
          If p Then
              If index >= 0 And index < @p.count Then
                  @[email protected][index] = item
              End If
          End If
      End Sub
      Function LArrGet(ByVal p As LArrT Ptr, ByVal index As Long) As McLArrType
          'get item
          If p Then
              If index >= 0 And index < @p.count Then
                  Function = @[email protected][index]
              End If
          End If
      End Function
      ' ------------------------------------------------------------------------
          'stack functions
      ' ------------------------------------------------------------------------
      Sub LArrPush(ByVal p As LArrT Ptr, ByVal item As McLArrType)
          'push item on stack
          If p Then
              LArrReDim p, @p.count + 1
              If @p.count Then @[email protected][@p.count - 1] = item
          End If
      End Sub
      Function LArrPeek(ByVal p As LArrT Ptr) As McLArrType
          'get item on top of stack
          If p Then
              If @p.count Then
                  Function = @[email protected][@p.count - 1]
              End If
          End If
      End Function
      Function LArrPop(ByVal p As LArrT Ptr) As McLArrType
          'pop item off top of stack
          If p Then
              If @p.count Then
                  Function = @[email protected][@p.count - 1]
                  LArrReDim p, @p.count - 1
              End If
          End If
      End Function
      Sub LArrMove(ByVal p As LArrT Ptr, ByVal toIndex As Long, ByVal fromIndex As Long, ByVal Count As Long)
          'internal - move block of elements
          GMemCopy @p.pa + (toIndex * McLArrSize), @p.pa + (fromIndex * McLArrSize), Count * McLArrSize
      End Sub
      Last edited by Stanley Durham; 23 Jul 2009, 01:02 PM.
      stanthemanstan~gmail
      Dead Theory Walking
      Range Trie Tree
      HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

      Comment


      • #4
        Code:
        'BArr.inc
        #Include Once "GMem1.inc"
        ' ------------------------------------------------------------------------
        Macro McBArrType = Byte
        Macro McBArrSize = 1
        ' ------------------------------------------------------------------------
            '
            'Dynamic Byte Array lite Obj
            '   access array with Long Handle
            '   ZERO based index
            '
            '   ReDim automatic
            '       insert, add ~ array automatically grows
            '       delete      ~ array automatically shrinks
            '
        ' ------------------------------------------------------------------------
        Type BArrT
            Count As Long
            pa As McBArrType Ptr
        End Type
        ' ------------------------------------------------------------------------
         
        Function BArrAlloc() As Long
            'allocate new array - return handle
            '   MUST be freed: BArrFree()
            Function = GMemAlloc(SizeOf(BArrT))
        End Function
        Function BArrFree(ByVal p As BArrT Ptr) As Long
            'free allocated array
            '   h = BArrFree(h)
            If p Then
                BArrClear p
                GMemFree(p)
            End If
            Function = 0
        End Function
        Sub BArrClear(ByVal p As BArrT Ptr)
            'delete all data
            If p Then
                If @p.count Then @p.pa = GMemFree(@p.pa)
                @p.pa = boolNull
                @p.count = 0
            End If
        End Sub
        Function BArrCount(ByVal p As BArrT Ptr) As Long
            'get item count
            If p Then
                Function = @p.count
            End If
        End Function
        Sub BArrReDim(ByVal p As BArrT Ptr, ByVal Count As Long)
            'ReDim array - data preserved
            If p Then
                If Count = 0 Then
                    BArrClear p
                ElseIf Count <> @p.count Then
                    @p.pa = GMemReAlloc(@p.pa, Count * McBArrSize)
                    @p.count = IIf&(@p.pa, Count, 0)
                End If
            End If
        End Sub
        Sub BArrAdd(ByVal p As BArrT Ptr, ByVal item As McBArrType)
            'append item to end of array
            '   ReDim automatic
            If p Then
                BArrReDim p, @p.count + 1
                If @p.count Then @[email protected][@p.count - 1] = item
            End If
        End Sub
        Sub BArrInsert(ByVal p As BArrT Ptr, ByVal index As Long, ByVal item As McBArrType)
            'insert item before index
            '   ReDim automatic
            If p Then
                If index >= 0 And index < @p.count Then
                    BArrReDim p, @p.count + 1
                    If @p.count Then
                        BArrMove(p, index + 1, index, @p.count - index - 1)
                        @[email protected][index] = item
                    End If
                End If
            End If
        End Sub
        Sub BArrDelete(ByVal p As BArrT Ptr, ByVal index As Long)
            'delete item at index
            '   ReDim automatic
            If p Then
                If index >= 0 And index < @p.count Then
                    If @p.count = 1 Then
                        BArrClear p
                    Else
                        If index < @p.count - 1 Then BArrMove(p, index, index + 1, @p.count - index - 1)
                        BArrReDim p, @p.count - 1
                    End If
                End If
            End If
        End Sub
        Sub BArrSet(ByVal p As BArrT Ptr, ByVal index As Long, ByVal item As McBArrType)
            'set item at index
            If p Then
                If index >= 0 And index < @p.count Then
                    @[email protected][index] = item
                End If
            End If
        End Sub
        Function BArrGet(ByVal p As BArrT Ptr, ByVal index As Long) As McBArrType
            'get item
            If p Then
                If index >= 0 And index < @p.count Then
                    Function = @[email protected][index]
                End If
            End If
        End Function
        ' ------------------------------------------------------------------------
            'stack functions
        ' ------------------------------------------------------------------------
        Sub BArrPush(ByVal p As BArrT Ptr, ByVal item As McBArrType)
            'push item on stack
            If p Then
                BArrReDim p, @p.count + 1
                If @p.count Then @[email protected][@p.count - 1] = item
            End If
        End Sub
        Function BArrPeek(ByVal p As BArrT Ptr) As McBArrType
            'get item on top of stack
            If p Then
                If @p.count Then
                    Function = @[email protected][@p.count - 1]
                End If
            End If
        End Function
        Function BArrPop(ByVal p As BArrT Ptr) As McBArrType
            'pop item off top of stack
            If p Then
                If @p.count Then
                    Function = @[email protected][@p.count - 1]
                    BArrReDim p, @p.count - 1
                End If
            End If
        End Function
        Sub BArrMove(ByVal p As BArrT Ptr, ByVal toIndex As Long, ByVal fromIndex As Long, ByVal Count As Long)
            'internal - move block of elements
            GMemCopy @p.pa + (toIndex * McBArrSize), @p.pa + (fromIndex * McBArrSize), Count * McBArrSize
        End Sub
        Last edited by Stanley Durham; 23 Jul 2009, 01:03 PM.
        stanthemanstan~gmail
        Dead Theory Walking
        Range Trie Tree
        HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

        Comment


        • #5
          Code:
          'StrBuff.inc
           
              'Dynamic String lite obj
              '   store dynamic strings in UDTs
              '
              '   strings stored in buffer - hold any kind of data
              '
              '   uses Byte array to hold characters
           
          #Include Once "GMem1.inc"
          #Include Once "BArr.inc"
          'inherit Byte array :)
          Macro StrBuffT = BArrT
          Function StrBuffAlloc() As Long
              'allocate new string - return handle
              Function = BArrAlloc()
          End Function
          Function StrBuffFree(ByVal p As StrBuffT Ptr) As Long
              'close string - free resources
              Function = BArrFree(p)
          End Function
          Function StrBuffLen(ByVal p As StrBuffT Ptr) As Long
              'get string length
              If p Then Function = @p.count
          End Function
          Sub StrBuffSet(ByVal p As StrBuffT Ptr, ByRef s As String)
              'store string
              If p Then
                  BArrReDim p, Len(s)
                  If @p.count Then Poke$ @p.pa, s
              End If
          End Sub
          Function StrBuffGet(ByVal p As StrBuffT Ptr) As String
              'get stored string
              If p And @p.count Then Function = Peek$(@p.pa, @p.count)
          End Function
          Function StrBuffAllocSet(ByRef s As String) As Long
              'allocate new string buffer
              '   set string
              '   return handle
              Local h As Long
              h = StrBuffAlloc()
              StrBuffSet h, s
              Function = h
          End Function
          Last edited by Stanley Durham; 23 Jul 2009, 01:04 PM.
          stanthemanstan~gmail
          Dead Theory Walking
          Range Trie Tree
          HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

          Comment


          • #6
            Code:
             
            'SArr.inc
             
                'Dynamic String Array lite obj
                '   access array with Long Handle - store in UDT
                '   ZERO based index
                '
                '   strings stored in buffer - hold any kind of data
                '
                '   ReDim automatic
                '       insert, add ~ array automatically grows
                '       delete      ~ array automatically shrinks
                '
                '   String Array = Long Array of Byte Arrays
             
            ' ------------------------------------------------------------------------
            #Include Once "GMem1.inc"
            #Include Once "LArr.inc"
            #Include Once "BArr.inc"
            #Include Once "StrBuff.inc"
            ' ------------------------------------------------------------------------
            'inherit Long Array :)
            Macro SArrT = LArrT
            ' ------------------------------------------------------------------------
             
            Function SArrAlloc() As Long
                'allocate new array - return handle
                '   MUST be freed: SArrFree()
                Function = LArrAlloc()
            End Function
            Function SArrFree(ByVal p As SArrT Ptr) As Long
                'free allocated array
                '   h = SArrFree(h)
                If p Then
                    SArrClear p
                    p = LArrFree(p)
                End If
                Function = 0
            End Function
            Sub SArrClear(ByVal p As SArrT Ptr)
                'delete all data
                If p Then
                    If @p.count Then
                        Local i As Long
                        For i = 0 To @p.count - 1
                            StrBuffFree(@[email protected][i]) 'free strings
                        Next i
                        @p.pa = GMemFree(@p.pa)
                    End If
                    @p.pa = boolNull
                    @p.count = 0
                End If
            End Sub
            Function SArrCount(ByVal p As SArrT Ptr) As Long
                'get item count
                If p Then Function = @p.count
            End Function
            Sub SArrAdd(ByVal p As SArrT Ptr, ByRef item As String)
                'append item to end of array
                '   ReDim automatic
                LArrAdd p, StrBuffAllocSet(item)
            End Sub
            Sub SArrInsert(ByVal p As SArrT Ptr, ByVal index As Long, ByRef item As String)
                'insert item before index
                '   ReDim automatic
                LArrInsert p, index, StrBuffAllocSet(item)
            End Sub
            Sub SArrDelete(ByVal p As SArrT Ptr, ByVal index As Long)
                'delete item at index
                '   ReDim automatic
                StrBuffFree(LArrGet(p, index))
                LArrDelete p, index
            End Sub
            Sub SArrSet(ByVal p As SArrT Ptr, ByVal index As Long, ByRef item As String)
                'set item at index
                StrBuffSet LArrGet(p, index), item
            End Sub
            Function SArrGet(ByVal p As SArrT Ptr, ByVal index As Long) As String
                'get item
                Function = StrBuffGet(LArrGet(p, index))
            End Function
            ' ------------------------------------------------------------------------
                'stack functions
            ' ------------------------------------------------------------------------
            Sub SArrPush(ByVal p As SArrT Ptr, ByRef item As String)
                'push item on stack
                SArrAdd p, item
            End Sub
            Function SArrPeek(ByVal p As SArrT Ptr) As String
                'get item on top of stack
                Function = StrBuffGet(LArrPeek(p))
            End Function
            Function SArrPop(ByVal p As SArrT Ptr) As String
                'pop item off top of stack
                Function = StrBuffGet(LArrPeek(p))
                StrBuffFree(LArrPop(p))
            End Function
            Last edited by Stanley Durham; 23 Jul 2009, 01:04 PM.
            stanthemanstan~gmail
            Dead Theory Walking
            Range Trie Tree
            HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

            Comment


            • #7
              Code:
              'DArr.inc
               
              #Include Once "GMem1.inc"
              ' ------------------------------------------------------------------------
              Macro McDArrType = Double
              Macro McDArrSize = 8
              ' ------------------------------------------------------------------------
                  '
                  'Dynamic Double Array lite Obj
                  '   access array with Long Handle - store in UDT
                  '   ZERO based index
                  '
                  '   ReDim automatic
                  '       insert, add ~ array automatically grows
                  '       delete      ~ array automatically shrinks
                  '
              ' ------------------------------------------------------------------------
              Type DArrT
                  Count As Long
                  pa As McDArrType Ptr
              End Type
              ' ------------------------------------------------------------------------
               
              Function DArrAlloc() As Long
                  'allocate new array - return handle
                  '   MUST be freed: DArrFree()
                  Function = GMemAlloc(SizeOf(DArrT))
              End Function
              Function DArrFree(ByVal p As DArrT Ptr) As Long
                  'free allocated array
                  '   h = DArrFree(h)
                  If p Then
                      DArrClear p
                      GMemFree(p)
                  End If
                  Function = 0
              End Function
              Sub DArrClear(ByVal p As DArrT Ptr)
                  'delete all data
                  If p Then
                      If @p.count Then @p.pa = GMemFree(@p.pa)
                      @p.pa = boolNull
                      @p.count = 0
                  End If
              End Sub
              Function DArrCount(ByVal p As DArrT Ptr) As Long
                  'get item count
                  If p Then
                      Function = @p.count
                  End If
              End Function
              Sub DArrReDim(ByVal p As DArrT Ptr, ByVal Count As Long)
                  'ReDim array - data preserved
                  If p Then
                      If Count = 0 Then
                          DArrClear p
                      ElseIf Count <> @p.count Then
                          @p.pa = GMemReAlloc(@p.pa, Count * McDArrSize)
                          @p.count = IIf&(@p.pa, Count, 0)
                      End If
                  End If
              End Sub
              Sub DArrAdd(ByVal p As DArrT Ptr, ByVal item As McDArrType)
                  'append item to end of array
                  '   ReDim automatic
                  If p Then
                      DArrReDim p, @p.count + 1
                      If @p.count Then @[email protected][@p.count - 1] = item
                  End If
              End Sub
              Sub DArrInsert(ByVal p As DArrT Ptr, ByVal index As Long, ByVal item As McDArrType)
                  'insert item before index
                  '   ReDim automatic
                  If p Then
                      If index >= 0 And index < @p.count Then
                          DArrReDim p, @p.count + 1
                          If @p.count Then
                              DArrMove(p, index + 1, index, @p.count - index - 1)
                              @[email protected][index] = item
                          End If
                      End If
                  End If
              End Sub
              Sub DArrDelete(ByVal p As DArrT Ptr, ByVal index As Long)
                  'delete item at index
                  '   ReDim automatic
                  If p Then
                      If index >= 0 And index < @p.count Then
                          If @p.count = 1 Then
                              DArrClear p
                          Else
                              If index < @p.count - 1 Then DArrMove(p, index, index + 1, @p.count - index - 1)
                              DArrReDim p, @p.count - 1
                          End If
                      End If
                  End If
              End Sub
              Sub DArrSet(ByVal p As DArrT Ptr, ByVal index As Long, ByVal item As McDArrType)
                  'set item at index
                  If p Then
                      If index >= 0 And index < @p.count Then
                          @[email protected][index] = item
                      End If
                  End If
              End Sub
              Function DArrGet(ByVal p As DArrT Ptr, ByVal index As Long) As McDArrType
                  'get item
                  If p Then
                      If index >= 0 And index < @p.count Then
                          Function = @[email protected][index]
                      End If
                  End If
              End Function
              ' ------------------------------------------------------------------------
                  'stack functions
              ' ------------------------------------------------------------------------
              Sub DArrPush(ByVal p As DArrT Ptr, ByVal item As McDArrType)
                  'push item on stack
                  If p Then
                      DArrReDim p, @p.count + 1
                      If @p.count Then @[email protected][@p.count - 1] = item
                  End If
              End Sub
              Function DArrPeek(ByVal p As DArrT Ptr) As McDArrType
                  'get item on top of stack
                  If p Then
                      If @p.count Then
                          Function = @[email protected][@p.count - 1]
                      End If
                  End If
              End Function
              Function DArrPop(ByVal p As DArrT Ptr) As McDArrType
                  'pop item off top of stack
                  If p Then
                      If @p.count Then
                          Function = @[email protected][@p.count - 1]
                          DArrReDim p, @p.count - 1
                      End If
                  End If
              End Function
              Sub DArrMove(ByVal p As DArrT Ptr, ByVal toIndex As Long, ByVal fromIndex As Long, ByVal Count As Long)
                  'internal - move block of elements
                  GMemCopy @p.pa + (toIndex * McDArrSize), @p.pa + (fromIndex * McDArrSize), Count * McDArrSize
              End Sub
              Last edited by Stanley Durham; 23 Jul 2009, 01:05 PM.
              stanthemanstan~gmail
              Dead Theory Walking
              Range Trie Tree
              HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

              Comment


              • #8
                Code:
                #PBForms CREATED V1.51
                'pbwin 9
                $TestSource = "LArrTest.bas"
                $TestTitle = "Dynamic UDT Long Array Test"
                #Compile Exe "LArrTest.exe"
                #Dim All
                #Optimize Speed
                #Include Once "LArr.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
                Type MyUDT
                    h1 As Long 'array handles
                    h2 As Long
                    h3 As Long
                End Type
                Sub BtnTest(ByVal hDlg As Long)
                    Local i, Count, top As Long
                    lbx.Clear(2)
                    'store arrays handles in UDT
                    Local t As MyUDT
                    'allocate new array instance
                    t.h1 = LArrAlloc()
                    t.h2 = LArrAlloc()
                    t.h3 = LArrAlloc()
                    Count = 1000000
                    top = Count - 1
                    lbx.Add("ReDim array "+Format$(Count,"#,"))
                    LArrReDim t.h1, Count
                    lbx.Add("fill array")
                    tmr.Start()
                    For i = 0 To top
                        LArrSet(t.h1, i, i)
                    Next i
                    lbx.Add(tmr.Get())
                    lbx.Add("Count = " + Format$(LArrCount(t.h1)))
                    lbx.Add("")
                    lbx.Add("make sure values are in array")
                    tmr.Start()
                    For i = 0 To top
                        If LArrGet(t.h1, i) <> i Then
                            lbx.Add("   !!! failed ad "+Format$(i)+" !!!")
                        End If
                    Next i
                    lbx.Add(tmr.Get())
                    lbx.Add("")
                    lbx.Add("clear array - delete all data")
                    LArrClear t.h1
                    lbx.Add("Count = " + Format$(LArrCount(t.h1)))
                    Count = 10000
                    top = Count - 1
                    lbx.Add("")
                    lbx.Add("append "+Format$(Count,"#,")+" items to empty array")
                    lbx.Add("    ReDim automatic")
                    tmr.Start()
                    For i = 0 To top
                        LArrAdd(t.h1, i)
                    Next i
                    lbx.Add(tmr.Get())
                    lbx.Add("")
                    lbx.Add("Count = " + Format$(LArrCount(t.h1)))
                    lbx.Add("")
                    lbx.Add("delete every odd index in array")
                    lbx.Add("    ReDim always automatic")
                    tmr.Start()
                    For i = top To 0 Step - 1
                        If i Mod 2 Then LArrDelete(t.h1, i)
                    Next i
                    lbx.Add(tmr.Get())
                    lbx.Add("")
                    lbx.Add("Count = " + Format$(LArrCount(t.h1)))
                    lbx.Add("")
                    lbx.Add("use array #2 and #3")
                    For i = 0 To 5
                        LArrAdd t.h2, i + 100
                        LArrAdd t.h3, i + 100000
                    Next i
                    For i = 0 To 5
                        lbx.Add( "array #2 = " + Format$(LArrGet(t.h2, i)) + " | array #3 = " +  Format$(LArrGet(t.h3, i)) )
                    Next i
                    lbx.Add("")
                    lbx.Add("stack functions")
                    LArrClear t.h1
                    For i = 100 To 300 Step 50
                        LArrPush t.h1, i
                    Next i
                    While LArrCount(t.h1)
                        lbx.Add( "peek = " + Format$(LArrPeek(t.h1)) + " | pop = " + Format$(LArrPop(t.h1)) )
                    Wend
                    'free array handle before it goes out of scope
                    t.h1 = LArrFree(t.h1)
                    t.h2 = LArrFree(t.h2)
                    t.h3 = LArrFree(t.h3)
                    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


                • #9
                  Code:
                   
                  #PBForms CREATED V1.51
                  'pbwin 9
                  $TestSource = "StrBuffTest.bas"
                  $TestTitle = "Dynamic String Buffer Test"
                  #Compile Exe "StrBuffTest.exe"
                  #Dim All
                  #Optimize Speed
                  #Include Once "StrBuff.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
                  Type MyUDT
                      h1 As Long 'string handles
                      h2 As Long
                      h3 As Long
                  End Type
                  Sub BtnTest(ByVal hDlg As Long)
                      lbx.Clear(2)
                      'store string handles in UDT
                      Local t As MyUDT
                      'allocate new instance
                      t.h1 = StrBuffAlloc()
                      t.h2 = StrBuffAlloc()
                      t.h3 = StrBuffAlloc()
                      StrBuffSet t.h1, "testing 123"
                      StrBuffSet t.h2, "testing 456"
                      StrBuffSet t.h3, "testing 789"
                      lbx.Add(StrBuffGet(t.h1))
                      lbx.Add(StrBuffGet(t.h2))
                      lbx.Add(StrBuffGet(t.h3))
                      lbx.Add("")
                      lbx.Add("modify strings")
                      StrBuffSet t.h1, StrBuffGet(t.h1) + ", " + StrBuffGet(t.h1)
                      StrBuffSet t.h2, StrBuffGet(t.h2) + ", " + StrBuffGet(t.h2)
                      StrBuffSet t.h3, StrBuffGet(t.h3) + ", " + StrBuffGet(t.h3)
                      lbx.Add("")
                      lbx.Add(StrBuffGet(t.h1))
                      lbx.Add(StrBuffGet(t.h2))
                      lbx.Add(StrBuffGet(t.h3))
                  
                      'free string handle before it goes out of scope
                      t.h1 = StrBuffFree(t.h1)
                      t.h2 = StrBuffFree(t.h2)
                      t.h3 = StrBuffFree(t.h3)
                      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


                  • #10
                    Code:
                     
                    #PBForms CREATED V1.51
                    'pbwin 9
                    $TestSource = "SArrTest.bas"
                    $TestTitle = "Dynamic UDT String Array Test"
                    #Compile Exe "SArrTest.exe"
                    #Dim All
                    #Optimize Speed
                    #Include Once "SArr.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
                    Type MyUDT
                        h1 As Long 'array handles
                        h2 As Long
                        h3 As Long
                    End Type
                    Sub BtnTest(ByVal hDlg As Long)
                        Local i, Count, top As Long
                        lbx.Clear(2)
                        'store arrays handles in UDT
                        Local t As MyUDT
                        'allocate new array instance
                        t.h1 = SArrAlloc()
                        t.h2 = SArrAlloc()
                        t.h3 = SArrAlloc()
                        Count = 10000
                        top = Count - 1
                        lbx.Add("")
                        lbx.Add("append "+Format$(Count,"#,")+" items to empty array")
                        lbx.Add("    ReDim automatic")
                        tmr.Start()
                        For i = 0 To top
                            SArrAdd(t.h1, Format$(i))
                        Next i
                        lbx.Add(tmr.Get())
                        lbx.Add("")
                        lbx.Add("Count = " + Format$(SArrCount(t.h1)))
                        lbx.Add("")
                        lbx.Add("make sure values are in array")
                        tmr.Start()
                        For i = 0 To top
                            If SArrGet(t.h1, i) <> Format$(i) Then
                                lbx.Add("   !!! failed ad "+Format$(i)+" !!!")
                            End If
                        Next i
                        lbx.Add(tmr.Get())
                        lbx.Add("")
                        lbx.Add("delete every odd index in array")
                        lbx.Add("    ReDim always automatic")
                        tmr.Start()
                        For i = top To 0 Step - 1
                            If i Mod 2 Then SArrDelete(t.h1, i)
                        Next i
                        lbx.Add(tmr.Get())
                        lbx.Add("")
                        lbx.Add("Count = " + Format$(SArrCount(t.h1)))
                        lbx.Add("")
                        lbx.Add("use array #2 and #3")
                        For i = 0 To 5
                            SArrAdd t.h2, Format$(i, "000")
                            SArrAdd t.h3, Format$(i * 1000, "00000000")
                        Next i
                        For i = 0 To 5
                            lbx.Add( "array #2 = " + SArrGet(t.h2, i) + " | array #3 = " +  SArrGet(t.h3, i) )
                        Next i
                        lbx.Add("")
                        lbx.Add("stack functions")
                        SArrClear t.h1
                        For i = 100 To 300 Step 50
                            SArrPush t.h1, Format$(i, "0000000000")
                        Next i
                        While SArrCount(t.h1)
                            lbx.Add( "peek = " + SArrPeek(t.h1) + " | pop = " + SArrPop(t.h1) )
                        Wend
                        'free array handle before it goes out of scope
                        t.h1 = SArrFree(t.h1)
                        t.h2 = SArrFree(t.h2)
                        t.h3 = SArrFree(t.h3)
                        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


                    • #11
                      Code:
                      #PBForms CREATED V1.51
                      'pbwin 9
                      $TestSource = "DArrTest.bas"
                      $TestTitle = "Dynamic UDT Double Array Test"
                      #Compile Exe "DArrTest.exe"
                      #Dim All
                      #Optimize Speed
                      #Include Once "DArr.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
                      Type MyUDT
                          h1 As Long 'array handles
                          h2 As Long
                          h3 As Long
                      End Type
                      Sub BtnTest(ByVal hDlg As Long)
                          Local i, Count, top As Long
                          Local d As Double
                          lbx.Clear(2)
                          'store arrays handles in UDT
                          Local t As MyUDT
                          'allocate new array instance
                          t.h1 = DArrAlloc()
                          t.h2 = DArrAlloc()
                          t.h3 = DArrAlloc()
                          Count = 100000
                          top = Count - 1
                          lbx.Add("ReDim array "+Format$(Count,"#,"))
                          DArrReDim t.h1, Count
                          lbx.Add("fill array")
                          tmr.Start()
                          For i = 0 To top
                              d = i * 1.33
                              DArrSet(t.h1, i, d)
                          Next i
                          lbx.Add(tmr.Get())
                          lbx.Add("Count = " + Format$(DArrCount(t.h1)))
                          lbx.Add("")
                          lbx.Add("make sure values are in array")
                          tmr.Start()
                          For i = 0 To top
                              If DArrGet(t.h1, i) <> i * 1.33 Then
                                  lbx.Add("   !!! failed ad "+Format$(i)+" !!!")
                              End If
                          Next i
                          lbx.Add(tmr.Get())
                          lbx.Add("")
                          lbx.Add("clear array - delete all data")
                          DArrClear t.h1
                          lbx.Add("Count = " + Format$(DArrCount(t.h1)))
                          Count = 10000
                          top = Count - 1
                          lbx.Add("")
                          lbx.Add("append "+Format$(Count,"#,")+" items to empty array")
                          lbx.Add("    ReDim automatic")
                          tmr.Start()
                          For i = 0 To top
                              d = i * 1.33
                              DArrAdd(t.h1, d)
                          Next i
                          lbx.Add(tmr.Get())
                          lbx.Add("")
                          lbx.Add("Count = " + Format$(DArrCount(t.h1)))
                          lbx.Add("")
                          lbx.Add("delete every odd index in array")
                          lbx.Add("    ReDim always automatic")
                          tmr.Start()
                          For i = top To 0 Step - 1
                              If i Mod 2 Then DArrDelete(t.h1, i)
                          Next i
                          lbx.Add(tmr.Get())
                          lbx.Add("")
                          lbx.Add("Count = " + Format$(DArrCount(t.h1)))
                          lbx.Add("")
                          lbx.Add("use array #2 and #3")
                          For i = 0 To 5
                              DArrAdd t.h2, (1 * 100) / .33
                              DArrAdd t.h3, (i * 10000) / 1.66
                          Next i
                          For i = 0 To 5
                              lbx.Add( "array #2 = " + Format$(DArrGet(t.h2, i)) + " | array #3 = " +  Format$(DArrGet(t.h3, i)) )
                          Next i
                          lbx.Add("")
                          lbx.Add("stack functions")
                          DArrClear t.h1
                          For i = 100 To 300 Step 50
                              d = i * 1.33
                              DArrPush t.h1, d
                          Next i
                          While DArrCount(t.h1)
                              lbx.Add( "peek = " + Format$(DArrPeek(t.h1)) + " | pop = " + Format$(DArrPop(t.h1)) )
                          Wend
                          'free array handle before it goes out of scope
                          t.h1 = DArrFree(t.h1)
                          t.h2 = DArrFree(t.h2)
                          t.h3 = DArrFree(t.h3)
                          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