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

Reverse Polish Notation Implementation

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

  • Reverse Polish Notation Implementation

    Hi everyone,

    This is the full implementation of RPN. It includes the functions
    SQR, COS, SIN, TAN, LOG (the others can be added very easily).

    I have used the optimized function of Paul Squires in order to implement
    a stack using a linked list. However, it is only a subset of Paul's work
    included in this.

    So, have fun if you think of using this.

    It will compile out of the box with PB/CC 4.0

    Cheers

    Steven

    Code:
    #Dim All
    #Debug Error On
    '#include "d:\appdev\pwr\pbcc40\winapi\win32api.inc"
    '#Include "pbmem.inc"
    
    %DLL_PROCESS_DETACH = 0
    %DLL_PROCESS_ATTACH = 1
    %DLL_THREAD_ATTACH  = 2
    %DLL_THREAD_DETACH  = 3
    
    %HEAP_GENERATE_EXCEPTIONS        = &H00000004
    %HEAP_NO_SERIALIZE               = &H00000001
    %HEAP_REALLOC_IN_PLACE_ONLY      = &H00000010
    %HEAP_ZERO_MEMORY                = &H00000008
    
    %STATUS_ACCESS_VIOLATION         = &HC0000005???
    %STATUS_NO_MEMORY                = &HC0000017???
    
    %FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
    %FORMAT_MESSAGE_IGNORE_INSERTS  = &H200
    %FORMAT_MESSAGE_FROM_STRING     = &H400
    %FORMAT_MESSAGE_FROM_HMODULE    = &H800
    %FORMAT_MESSAGE_FROM_SYSTEM     = &H1000
    %FORMAT_MESSAGE_ARGUMENT_ARRAY  = &H2000
    %FORMAT_MESSAGE_MAX_WIDTH_MASK  = &HFF
    
    %LANG_NEUTRAL     = &H00
    %SUBLANG_DEFAULT  = &H01  ' user default
    
    %TRUE  = 1
    %FALSE = 0
    %Null  = 0
    ' ======================================================================================================
    Type PROGRAM_SECTION
         bDimAll            As Byte
         bDebugError        As Byte
         pRPN               As Dword  ' Reverse Polish Notation
         pRPNPostFix        As Dword  ' Reverse Polish Notation Postfix
    End Type
    ' ======================================================================================================
    Type RPN_STACK         ' Reverse Polish Notation Stack
         pOperand           As Dword
         nLevel             As Integer
    End Type
    ' ======================================================================================================
    Type RPN_EVALUATOR
         dValue             As Double
    End Type
    ' ======================================================================================================
    ' Double linked list structure.  Can be used as either a list head, or
    ' as link words.
    
    TYPE LIST_ENTRY
        Flink AS LIST_ENTRY PTR
        Blink AS LIST_ENTRY PTR
    END TYPE
    ' ======================================================================================================
    TYPE RTL_CRITICAL_SECTION_DEBUG
        wType AS WORD
        CreatorBackTraceIndex AS WORD
        CriticalSection AS DWORD  ' actually, CRITICAL_SECTION PTR, but we can't do a circular reference
        ProcessLocksList AS LIST_ENTRY
        EntryCount AS DWORD
        ContentionCount AS DWORD
        Spare(0 TO 1) AS DWORD
    END TYPE
    
    TYPE CRITICAL_SECTION
        DebugInfo AS RTL_CRITICAL_SECTION_DEBUG PTR
        ' The following three fields control entering and exiting the critical
        ' section for the resource
        LockCount AS LONG
        RecursionCount AS LONG
        OwningThread AS DWORD    ' from the thread's ClientId->UniqueThread
        LockSemaphore AS DWORD
        SpinCount AS DWORD       ' force size on 64-bit systems when packed
    END TYPE
    
    Type LINKED_LIST_TYPE
       pNext As LINKED_LIST_TYPE Ptr
       pPrev As LINKED_LIST_TYPE Ptr
       zKey  As Asciiz Ptr
       zData As Long
       nType As Integer             ' 0 = Long, 1 = String
    End Type
    
    Type LINKED_LIST_HEADER_TYPE
       pFirst     As LINKED_LIST_TYPE Ptr
       pLast      As LINKED_LIST_TYPE Ptr
       UseStrings As Byte   ' TRUE if zData is pointer to a string
       SortList   As Byte   ' TRUE if zData is to maintained in sorted order
       Count      As Long
    End Type
    
    %LINKED_LIST_INSERT_START    = 1
    %LINKED_LIST_INSERT_END      = 2
    %LINKED_LIST_INSERT_BEFORE   = 3
    %LINKED_LIST_INSERT_AFTER    = 4
    
    DECLARE SUB      EnterCriticalSection LIB "KERNEL32.DLL" ALIAS "EnterCriticalSection" (lpCriticalSection AS CRITICAL_SECTION)
    DECLARE SUB      DeleteCriticalSection LIB "KERNEL32.DLL" ALIAS "DeleteCriticalSection" (lpCriticalSection AS CRITICAL_SECTION)
    DECLARE SUB      LeaveCriticalSection LIB "KERNEL32.DLL" ALIAS "LeaveCriticalSection" (lpCriticalSection AS CRITICAL_SECTION)
    DECLARE SUB      InitializeCriticalSection LIB "KERNEL32.DLL" ALIAS "InitializeCriticalSection" (lpCriticalSection AS CRITICAL_SECTION)
    
    Declare Function GetProcessHeap Lib "KERNEL32.DLL" Alias "GetProcessHeap" () As Long
    Declare Function HeapAlloc      Lib "KERNEL32.DLL" Alias "HeapAlloc" (ByVal hHeap As Dword, ByVal dwFlags As Dword, ByVal dwBytes As Dword) As Dword
    Declare Function HeapCompact    Lib "KERNEL32.DLL" Alias "HeapCompact" (ByVal hHeap As Dword, ByVal dwFlags As Dword) As Dword
    Declare Function HeapCreate     Lib "KERNEL32.DLL" Alias "HeapCreate" (ByVal flOptions As Dword, ByVal dwInitialSize As Dword, ByVal dwMaximumSize As Dword) As Dword
    Declare Function HeapDestroy    Lib "KERNEL32.DLL" Alias "HeapDestroy" (ByVal hHeap As Dword) As Long
    Declare Function HeapFree       Lib "KERNEL32.DLL" Alias "HeapFree" (ByVal hHeap As Dword, ByVal dwFlags As Dword, ByVal lpMem As Dword) As Long
    Declare Function HeapLock       Lib "KERNEL32.DLL" Alias "HeapLock" (ByVal hHeap As Dword) As Long
    Declare Function HeapReAlloc    Lib "KERNEL32.DLL" Alias "HeapReAlloc" (ByVal hHeap As Dword, ByVal dwFlags As Dword, ByVal lpMem As Dword, ByVal dwBytes As Dword) As Dword
    Declare Function HeapSize       Lib "KERNEL32.DLL" Alias "HeapSize" (ByVal hHeap As Dword, ByVal dwFlags As Dword, ByVal lpMem As Dword) As Dword
    Declare Function HeapValidate   Lib "KERNEL32.DLL" Alias "HeapValidate" (ByVal hHeap As Dword, ByVal dwFlags As Dword, lpMem As Any) As Long
    Declare Function FormatMessage  Lib "KERNEL32.DLL" Alias "FormatMessageA" (ByVal dwFlags As Dword, lpSource As Any, ByVal dwMessageId As Dword, ByVal dwLanguageId As Dword, lpBuffer As Asciiz, ByVal nSize As Dword, Arguments As Any) As Dword
    Declare Function LocalFree      Lib "KERNEL32.DLL" Alias "LocalFree" (ByVal hMem As Dword) As Long
    Declare Function GetLastError   Lib "KERNEL32.DLL" Alias "GetLastError" () As Long
    
    Declare Function memWriteDebugFile(ByVal outText As String) As Long
    Declare Function WinErrorMsg Alias "WinErrorMsgA" (ByVal Derror As Dword) As String
    
    DECLARE FUNCTION lstrcmp LIB "KERNEL32.DLL" ALIAS "lstrcmpA" (lpString1 AS ASCIIZ, lpString2 AS ASCIIZ) AS LONG
    DECLARE FUNCTION lstrcmpi LIB "KERNEL32.DLL" ALIAS "lstrcmpiA" (lpString1 AS ASCIIZ, lpString2 AS ASCIIZ) AS LONG
    
    
    ' ======================================================================================================
    Global g_CS         As CRITICAL_SECTION
    Global g_Find_CS    As CRITICAL_SECTION
    Global g_Delete_CS  As CRITICAL_SECTION
    Global g_Init       As Integer
    
    ' ======================================================================================================
    Global PS  As PROGRAM_SECTION
    '======================================================================================================
    '
    '======================================================================================================
    Function MAKELANGID (ByVal P As Word, ByVal S As Word) Export As Dword
        Local Dresult As Dword
        Dresult = S
        Shift Left Dresult, 10
        Dresult = Dresult Or P
        Function = Dresult
    End Function
    
    ' ======================================================================================================
    '
    '======================================================================================================
    Function WinErrorMsg Alias "WinErrorMsgA" (ByVal Derror As Dword) Export As String
    
        Local Pbuffer   As Asciiz Ptr
        Local Ncbbuffer As Dword
    
        Ncbbuffer = FormatMessage( _
                        %FORMAT_MESSAGE_ALLOCATE_BUFFER _
                     Or %FORMAT_MESSAGE_FROM_SYSTEM _
                     Or %FORMAT_MESSAGE_IGNORE_INSERTS, _
                        ByVal %Null, _
                        Derror, _
                        ByVal MAKELANGID(%LANG_NEUTRAL, %SUBLANG_DEFAULT), _
                        ByVal VarPtr(Pbuffer), _
                        0, _
                        ByVal %Null)
        If Ncbbuffer Then
            Function = Peek$(Pbuffer, Ncbbuffer)
            LocalFree Pbuffer
        End If
    End Function
    
    
    ' ======================================================================================================
    ' memHeapFreeMem
    ' ======================================================================================================
    Function memHeapFreeMem(ByVal MemPtr As Dword) Export As Dword
     Local lResult    As Long
     If MemPtr > 0 Then
        lResult = HeapFree(GetProcessHeap, %Null, ByVal MemPtr)
        If lResult = 0 Then
           Stdout FuncName$ & "-> " & WinErrorMsg(GetLastError)
        End If
        Function = lResult
     End If
    End Function
    
    ' ======================================================================================================
    ' memHeapAlloc
    ' ======================================================================================================
    Function memHeapAlloc(ByVal Size As Dword) Export As Dword
     Local lHeapPtr  As Dword
     Local Retval    As Dword
    
     On Error GoTo ErrorHandler
    
     If Size = 0 Then
        Function = 0
        Exit Function
     End If
    
     'If Size < 4 Then MsgBox FuncName$ & " ->" & Format$(Size)
    
     If Size < 4 Then Size = Size + (4 - Size)
    
     RetVal = HeapAlloc(GetProcessHeap,%HEAP_GENERATE_EXCEPTIONS Or %HEAP_ZERO_MEMORY, Size)
     'RetVal = HeapAlloc(GetProcessHeap,%HEAP_GENERATE_EXCEPTIONS, Size)
     Select Case RetVal
     Case %STATUS_ACCESS_VIOLATION
        Stdout FuncName$ & ": " & "Access Violation !"
        Function = 0
     Case %STATUS_NO_MEMORY
        Stdout FuncName$ & ": " & "No memory !"
        Function = 0
     Case Else
        Function = RetVal
     End Select
     Exit Function
     ErrorHandler:
     Stdout FuncName$ & ": " & Error$(Err)
    End Function
    
    ' ======================================================================================================
    ' memHeapAllocString
    ' ======================================================================================================
    Function memHeapAllocString(ByVal sData As String) Export as Dword
     Local sPtr   As String Ptr
     On Error GoTo ErrorHandler
     sPtr  = memHeapAlloc(Len(sData))
     If sPtr > 0 Then
        @sPtr = sData
        Function = sPtr
     Else
     '   MsgBox "Error in function " & FuncName$ & ": sptr = 0"
        Function = 0
     End If
     Exit Function
     ErrorHandler:
     Stdout FuncName$ & ": " & Error$(Err)
    
    End Function
    
    ' ======================================================================================================
    '  memHeapRetrieveString
    ' ======================================================================================================
    Function memHeapRetrieveString Alias "memHeapRetrieveString" ( ByVal UDTString As String Ptr ) Export As String
     On Error GoTo ErrorHandler
     Local ptrData  As String Ptr
     Local ptrVal   As Dword
     Local retVal   As Long
     Local DataStr  As String
    
     If UDTString = 0 Then
        Function = ""
        Exit Function
     End If
     Try
       ' ========================================================================================================
       ' It seems that the HeapValidate function only works when the HeapAlloc flag has been set to
       ' %HEAP_GENERATE_EXCEPTIONS Or %HEAP_ZERO_MEMORY or the HeapReAlloc flag has been set to
       ' %HEAP_GENERATE_EXCEPTIONS Or %HEAP_REALLOC_IN_PLACE_ONLY Or %HEAP_ZERO_MEMORY
       ' ========================================================================================================
        retval = HeapValidate(GetProcessHeap(), %Null, ByVal UDTString)
        If retVal = 0 Then
           Stdout "Error validating Heap for address " & Format$(udtString) & ". Func: " & FuncName$
           'Function = ""
           Exit Function
        End If
     Catch
        Exit Try
     End Try
    
     Function  = @UDTSTring
    ' Function = DataStr
    
    Exit Function
    ErrorHandler:
    Stdout "Error in " & FuncName$ & ": " & Error$(Err)
    End Function
    
    ' ======================================================================================================
    Function List_Initialize() Export As Long
       g_Init = %True
       InitializeCriticalSection g_CS
       InitializeCriticalSection g_Find_CS
       InitializeCriticalSection g_Delete_CS
    End Function
    ' ======================================================================================================
    '
    ' ======================================================================================================
    Function List_Uninitialize() Export As Long
       DeleteCriticalSection g_CS
       DeleteCriticalSection g_Find_CS
       DeleteCriticalSection g_Delete_CS
    End Function
    
    Function MemAlloc( ByVal nSize As Long ) Export As Dword
       If nSize > 0 Then
          Function = HeapAlloc( GetProcessHeap(), %HEAP_ZERO_MEMORY, nSize)
       End If
    End Function
    
    
    '//
    '//  Free memory located at a specified location
    '//
    Function MemFree( ByRef pMem As Dword ) Export As Long
       If pMem Then
          Function = HeapFree( GetProcessHeap(), 0, ByVal pMem)
          pMem = 0
       End If
    End Function
    
    '//
    '//  List_GetByPosition
    '//  Returns the pointer to the item in the linked list at the specified position
    '//
    Function List_GetByPosition( ByVal pListAddress As Dword, _
                                 ByVal nPosition As Long _
                                 ) Export As Dword
    
       Local pList     As LINKED_LIST_HEADER_TYPE Ptr
       Local pListItem As LINKED_LIST_TYPE Ptr
       Local x         As Long
    
       pList = pListAddress
       If pList = 0 Then Exit Function
    
       EnterCriticalSection g_CS
    
       ' Iterate to the specified ordinal position
       pListItem = @pList.pFirst
       x = 1
       Do Until x >= nPosition
          pListItem = @pListItem.pNext
          If pListItem = 0 Then Exit Do
          Incr x
       Loop
    
       Function = pListItem
    
       LeaveCriticalSection g_CS
    
    End Function
    
    
    '//
    '//  Sub that will assign a string to a memory location
    '//  and free any memory that may have already been allocated.
    '//  pMem must be ByRef.
    '//
    Sub MemString( ByRef pMem As Dword, _
                   ByVal sData As String )
    
        If pMem Then HeapFree( GetProcessHeap(), ByVal 0, ByVal pMem)  ' free any existing memory
        sData = sData & $Nul
        pMem = HeapAlloc( GetProcessHeap(), %HEAP_ZERO_MEMORY, Len( sData ) + 1)
        If pMem Then Poke$ pMem, sData
    
    End Sub
    '//  Handles all of the different ways of Adding an item to the linked list.
    '//  Returns a pointer to the added item.
    '//
    Function List_Add_Internal( ByVal pListAddress     As Dword, _
                                ByVal pListItemAddress As Dword, _
                                ByVal sKey             As String, _
                                ByVal zData            As Long, _
                                ByVal nAddMethod       As Long, _
                                ByVal nDataType        As Integer) Export As Dword
    
       Local pList         As LINKED_LIST_HEADER_TYPE Ptr
       Local pNewItem      As LINKED_LIST_TYPE Ptr
       Local pListItem     As LINKED_LIST_TYPE Ptr
       Local zPtr1         As Asciiz Ptr
       Local zPtr2         As Asciiz Ptr
       Local nFirstElement As Long
       Local nLastElement  As Long
       Local nPos          As Long
       Local nResult       As Long
    
       EnterCriticalSection g_CS
    
       pList = pListAddress
       If pList = 0 Then
          LeaveCriticalSection g_CS
          Exit Function
       End If
       sKey      = lcase$(sKey)
    
       pListItem = pListItemAddress
    
       ' Create memory for the new node to occupy
       pNewItem = MemAlloc( SizeOf(LINKED_LIST_TYPE) )
       If pNewItem = 0 Then
          Function = 0
          LeaveCriticalSection g_CS
          Exit Function
       End If
       ' Assign the Data. The assignment depends on whether the
       ' data being added is a string or a numeric.
       If @pList.UseStrings Then
          zPtr1 = zData
          MemString @pNewItem.zData, @zPtr1
       Else
          @pNewItem.zData = zData
       End If
    
       @pNewItem.nType = nDataType
    
       ' Assign the Key
       MemString @pNewItem.zKey, sKey
    
       ' Determine how this key will be added to the List. The fastest
       ' way is to simply add it to the end of the list. If the user
       ' wants the list in sorted order then we must find where in the
       ' list the new item should be placed.
       ' We will use a binary search type of algoritm because the list
       ' should already be in sorted. This is a little more complicated
       ' then a normal linear search but the performance improvement is
       ' substantial - normally 200% to 300% (especially for large lists).
       If @pList.SortList Then
          nFirstElement = 1
          nLastElement  = @pList.Count
    
          Do
             nPos  = (nFirstElement + nLastElement) \ 2
             pListItem = List_GetByPosition( pList, nPos )
             If pListItem = 0 Then Exit Do
    
             If @pList.UseStrings Then
                ' Do string comparisons (case sensitive)
                zPtr1 = @pListItem.zData
                zPtr2 = zData
                nResult = lstrcmp( @zPtr1, @zPtr2 )
             Else
                ' Do a simple numeric comparison
                If @pListItem.zData = zData Then nResult = 0
                If @pListItem.zData < zData Then nResult = -1
                If @pListItem.zData > zData Then nResult = 1
             End If
    
             Select Case nResult
                Case 0
                   Exit Do ' exact match
                Case > 0
                   nLastElement = nPos - 1
                Case < 0
                   nFirstElement = nPos + 1
             End Select
    
          Loop While nLastElement >= nFirstElement
    
          If pListItem = 0 Then
             nAddMethod = %LINKED_LIST_INSERT_END
          Else
             Select Case nResult
                Case >= 0
                   nAddMethod = %LINKED_LIST_INSERT_BEFORE
                Case Else
                   nAddMethod = %LINKED_LIST_INSERT_AFTER
             End Select
          End If
    
       End If
    
    
       Select Case nAddMethod
    
          Case %LINKED_LIST_INSERT_START
             ' Add the new item at the start of the list
             If @pList.pLast = 0 Then
                @pList.pFirst = pNewItem
                @pList.pLast  = pNewItem
             Else
                @pNewItem.pNext = @pList.pFirst
                If @pList.pFirst Then
                   @[email protected] = pNewItem
                End If
                @pList.pFirst = pNewItem
             End If
    
    
          Case %LINKED_LIST_INSERT_END
             '- Add this item to the end of the list. We save the link to
             ' the last item in pList in order to speed up adding future
             ' items otherwise we need to iterate the entire list for every
             ' add in order to find the last item.
             If @pList.pLast = 0 Then
                @pList.pFirst = pNewItem
             Else
                If @pList.pLast Then
                   @[email protected] = pNewItem
                End If
                @pNewItem.pPrev = @pList.pLast
             End If
             @pList.pLast = pNewItem
    
    
          Case %LINKED_LIST_INSERT_BEFORE
             If @pListItem.pPrev  = 0 Then
                ' Start of list
                If @pList.pFirst Then
                   @[email protected] = pNewItem
                End If
                @pList.pFirst = pNewItem
                @pNewItem.pNext  = pListItem
             Else
                @pNewItem.pPrev  = @pListItem.pPrev
                @pNewItem.pNext  = pListItem
                @pListItem.pPrev = pNewItem
                @[email protected] = pNewItem
             End If
    
    
          Case %LINKED_LIST_INSERT_AFTER
             If @pListItem.pNext = 0 Then
                ' last item in list
                @pListItem.pNext = pNewItem
                @pNewItem.pPrev  = pListItem
                @pList.pLast = pNewItem
             Else
                @[email protected] = pNewItem
                @pNewItem.pNext  = @pListItem.pNext
                @pNewItem.pPrev  = pListItem
                @pListItem.pNext = pNewItem
             End If
    
    
       End Select
    
       Incr @pList.Count
    
       Function = pNewItem
    
       LeaveCriticalSection g_CS
    
    End Function
    
    ' ======================================================================================================
    Function List_AddStr( ByVal pListAddress As Dword, _
                          ByVal sKey         As String, _
                          ByVal zData        As String _
                       ) Export As Dword
    
      Local pData   As Long
    
      pData = memHeapAllocString(zData)
    
      Function = List_Add_Internal( pListAddress, 0, sKey, pData, %LINKED_LIST_INSERT_END, 1)
    
    End Function
    
    '//
    '//  List_Delete
    '//  Removes a node from the list and frees its memory
    '//
    Function List_Delete( ByVal pListAddress As Dword, _
                          ByVal pListItemAddress As Dword _
                          ) Export As Long
    
       Local pList   As LINKED_LIST_HEADER_TYPE Ptr
       Local pDelete As LINKED_LIST_TYPE Ptr
    
       EnterCriticalSection g_Delete_CS
    
       pList = pListAddress
       If pList = 0 Then
          LeaveCriticalSection g_Delete_CS
          Exit Function
       End If
    
       pDelete = pListItemAddress
       If pDelete = 0 Then
          LeaveCriticalSection g_Delete_CS
          Exit Function
       End If
    
       ' If pLast points to the node being deleted then
       ' we need to adjust that to point to the previous node.
       If @pList.pLast = pDelete Then
          @pList.pLast = @pDelete.pPrev
       End If
    
       '- Remove the item from the list
       If @pDelete.pPrev = 0 Then
          @pList.pFirst = @pDelete.pNext
          If @pDelete.pNext Then
             @[email protected] = 0
          End If
       Else
          @[email protected] = @pDelete.pNext
          If @pDelete.pNext Then
             If @pDelete.pNext Then
                @[email protected] = @pDelete.pPrev
             End If
          End If
       End If
    
       '- Free pDelete (and any allocated string memory)
       MemFree @pDelete.zKey
       If @pList.UseStrings Then
          MemFree @pDelete.zData
       Else
          If @pDelete.nType = 1 Then
             MemFree @pDelete.zData
          Else
             @pDelete.zData = 0
          End If
       End If
       MemFree pDelete
    
       Decr @pList.Count
    
       LeaveCriticalSection g_Delete_CS
    
       Function = %TRUE
    
    End Function
    
    ' ======================================================================================================
    Function List_DeleteByPosition( ByVal pListAddress As Dword, _
                                    ByVal nPosition As Long) Export As Dword
    
       Local pList     As LINKED_LIST_HEADER_TYPE Ptr
       Local pListItem As LINKED_LIST_TYPE Ptr
       Local x         As Long
    
       pList = pListAddress
       If pList = 0 Then Exit Function
    
       ' Iterate to the specified ordinal position
       pListItem = @pList.pFirst
       x = 1
       Do Until x >= nPosition
          pListItem = @pListItem.pNext
          If pListItem = 0 Then Exit Do
          Incr x
       Loop
    
       Function = List_Delete(pListAddress, pListItem)
    
    End Function
    
    ' ======================================================================================================
    Function List_FindByKeyString( ByVal pListAddress As Dword, _
                                   ByVal zKey As String _
                                  ) Export As String
    
       Local pList As LINKED_LIST_HEADER_TYPE Ptr
       Local pNext As LINKED_LIST_TYPE Ptr
    
    
       pList = pListAddress
       If pList = 0 Then Exit Function
    
       EnterCriticalSection g_CS
    
       pNext = @pList.pFirst
    
       Do Until pNext = 0
          If @pNext.zKey Then
             If Lstrcmpi( @[email protected], ByCopy zKey ) = 0 Then
                If @pNext.zData Then
                   Function = memHeapRetrieveString(@pNext.zData)
                End If
                Exit Do
             End If
          End If
          pNext = @pNext.pNext
       Loop
    
       LeaveCriticalSection g_CS
    
    End Function
    
    
    
    '//
    '//  Retrieve the number of items in the linked list table
    '//
    Function List_GetCount( ByVal pListAddress As Dword ) Export As Long
    
       Local pList As LINKED_LIST_HEADER_TYPE Ptr
    
       pList = pListAddress
       If pList = 0 Then Exit Function
    
       Function = @pList.Count
    
    End Function
    
    '//
    '//  List_Create
    '//  Returns a pointer to a newly created linked list
    '//
    Function List_Create( ByVal nUseStrings As Long, _
                          ByVal nSortList   As Long _
                          ) Export As Dword
    
       If g_Init = %False Then
          Function = 1 ' Not initialized.
       End If
    
       EnterCriticalSection g_CS
    
       Local pList As LINKED_LIST_HEADER_TYPE Ptr
    
    
    
       pList = MemAlloc( SizeOf(LINKED_LIST_HEADER_TYPE) )
    
       If pList Then
          ' The data in the Linked List items can represent either a
          ' string or a simple numeric value. If you want the list to
          ' hold strings for the Data then set nUseStrings = TRUE
          @pList.UseStrings = nUseStrings
          ' Set flag to determine whether the zData element is maintained
          ' in a sorted order.
          @pList.SortList = nSortList
          Function = pList
       End If
    
       LeaveCriticalSection g_CS
    End Function
    
    ' ======================================================================================================
    '
    ' ======================================================================================================
    Function List_CreateStandard() Export As Dword
      Function = List_Create(%False, %False)
    End Function
    
    
    
    
    ' ======================================================================================================
    ' IsNumeric (With decimal point."
    ' ======================================================================================================
    Function IsNumeric(ByVal InText As String) As Byte
    
     Local n  As Long
     For n = 1 To Len(inText)
         If Instr("0123456789.", Mid$(InText, n, 1)) Then
            Function = 1
         Else
            Function = 0
            Exit Function
         End If
     Next
    
    End Function
    
    ' ======================================================================================================
    '
    ' ======================================================================================================
    Function PopRPN(ByRef Operand As String, ByRef Level As Integer) As Byte
    
     Local Buffer     As String
     Local Count      As Long
     Local tRPN       As RPN_STACK
    
     ' ======================================================================================================
     Count = List_GetCount(PS.pRPN)
    
     If Count Then
    
        Buffer = List_FindByKeyString(PS.pRPN, Format$(Count))
    
        If Len(Buffer) Then
           Lset tRPN = Buffer
           If tRPN.pOperand Then
              Operand = memHeapRetrieveString(tRPN.pOperand)
              Call memHeapFreeMem(tRPN.pOperand)
           End If
           Level = tRPN.nLevel
    
           Call List_DeleteByPosition(PS.pRPN, Count)
    
           Function = 1
    
        End If
    
     Else
    
        Function = 0
    
     End If
    
    End Function
    ' ======================================================================================================
    '
    ' ======================================================================================================
    Function GetRPN(ByRef tRPN As RPN_STACK, ByVal nItem As Long) As Byte
    
     Local Buffer     As String
     Local Count      As Long
    
     Count = List_GetCount(PS.pRPN)
    
     If Count And nItem > 0 And nItem <= Count Then
    
        Buffer = List_FindByKeyString(PS.pRPN, Format$(nItem))
    
        If Len(Buffer) Then
           Lset tRPN = Buffer
        End If
    
        Function  = 1
    
     End If
    
    End Function
    ' ======================================================================================================
    '
    ' ======================================================================================================
    Function PshRPN(ByVal tRPN As RPN_STACK) As Byte
    
     Local Count      As Long
     Local sData      As String
    
     Count = List_GetCount(PS.pRPN)
    
     Incr Count
    
     If tRPN.pOperand Then
        sData = memHeapRetrieveString(tRPN.pOperand)
     End iF
    
     Call List_AddStr(PS.pRPN, Format$(Count), (tRPN))
    
    
    End Function
    ' ======================================================================================================
    '
    ' ======================================================================================================
    Function PopRPNEvaluator() As Double
    
     Local Buffer     As String
     Local Count      As Long
     Local tRPN       As RPN_EVALUATOR
    
     ' ======================================================================================================
     Count = List_GetCount(PS.pRPNPostFix)
    
     If Count Then
    
        Buffer = List_FindByKeyString(PS.pRPNPostFix, Format$(Count))
    
        If Len(Buffer) Then
    
           Lset tRPN = Buffer
    
           Function = tRPN.dValue
    
           Call List_DeleteByPosition(PS.pRPNPostFix, Count)
    
        End If
    
     Else
    
        Function = 0
    
     End If
    
    End Function
    
    ' ======================================================================================================
    '
    ' ======================================================================================================
    Function PshRPNEvaluator(ByVal dValue As Double) As Byte
    
     Local Count      As Long
     Local sData      As String
     Local tRPN       As RPN_EVALUATOR
    
     Count = List_GetCount(PS.pRPNPostFix)
    
     Incr Count
    
     tRPN.dValue = dValue
    
     Call List_AddStr(PS.pRPNPostFix, Format$(Count), (tRPN))
    
    
    End Function
    
    ' ======================================================================================================
    Function ParseTokenSeries(ByVal sTokenSeries As String, ByRef Tokens() As String) As Long
    
     Local Cnt1   As Long
     Local n      As Long
     Local nToken As Long
     Local strPos As Long
     Local endPos As Long
     Local sTxt   As String
     Local sToken As String
     Local bFound As Integer
     Local Buffer As String
    
     bFound = %False
     strPos = 1
     Buffer = ""
     For n = 1 To Len(sTokenSeries)
    
         sToken = Mid$(sTokenSeries, n, 1)
    
         Select Case sToken
         Case "=", "+", "-", "/", "\", "*", "@", "(", ")", "^", "%", "&", "?", "$", ",", "'", "<", ">", "#", Chr$(34)
              bFound = %True
              If len(sTxt) Then
                 Buffer = Buffer & sTxt & "|"
              End If
    
              Buffer = Buffer & sToken
    
              If n < Len(sTokenSeries) Then
                 Buffer = Buffer & "|"
              End If
              sTxt   = ""
              StrPos = n + 1
         'Case Chr$(34)
         Case Else
              sTxt   = sTxt & Mid$(sTokenSeries, n, 1)
         End Select
    
     Next
     If BFound = %True And Len(sTxt) Then
        Buffer = Buffer & sTxt
     End If
    
     If Len(Buffer) Then
        Cnt1 = ParseCount(Buffer, "|")
    
        ReDim Tokens(1 To Cnt1) As String
    
        Parse Buffer, Tokens(), "|"
    
     End If
     Function = Cnt1
    
    End Function
    
    ' ======================================================================================================
    Function Parser(ByVal InLine As String, ByRef aArray() As String) As Long
    
     Local Length      As Long
     Local n           As Long
     Local Char        As String
     Local Buffer      As String
     Local wQuote      As Word
     Local wIndex      As Word
     ReDim aArray(0)   As String
    
     '#TEST Print "'" & InLine & "'"
     '#TEST WaitKey$
    
     Length = Len(InLine)
     wIndex = 1
     wQuote = 0
     n = 1
     Do
    
       Char = Mid$(InLine, n, 1)
    
       If Char = Chr$(34) Then
          Incr wQuote
       End If
    
       Select Case wQuote
       Case 0
    
            If Char <> " " Then
               Buffer = Buffer & Char
            End If
    
            Select Case Char
            Case " ", "<", ">"
    
                If Buffer <> "" Then
    
                   ReDim Preserve aArray(0 To wIndex) As String
    
                   aArray(wIndex) = Buffer
                   Buffer         = ""
    
                   Incr wIndex
    
                End If
    
            End Select
    
       Case 1
            Buffer = Buffer & Char
       Case 2
    
            Buffer = Buffer & Char
    
            ReDim Preserve aArray(0 to wIndex) As String
            aArray(wIndex) = Buffer
            Buffer         = ""
    
            If n < Length Then
               Incr wIndex
            End If
    
    
            wQuote = 0
    
       End Select
    
       Incr n
     Loop until n > Length
     If Buffer <> "" Then
        ReDim Preserve aArray(0 to wIndex) As String
        aArray(wIndex) = Buffer
     End If
    
     Function = wIndex
    
    End Function
    
    ' ======================================================================================================
    '
    ' ======================================================================================================
    Function ParseLine(ByVal InLine As String, ByRef TargetArray() As String, ByRef bResult As Integer) As Long
    
     Local Cnt1        As Long
     Local Cnt2        As Long
     Local n           As Long
     Local k           As Long
     Local Token       As String
     Local TokenSeries As String
     Local Elements    As Dword
    
     Dim   Tokens(0)   As String
    
     Cnt1 = ParseCount(InLine,  " ")
    
     Dim   pArray1(1 To Cnt1) As String
     ReDim TargetArray(0)     As String
    
     ' ======================================================================================================
     ' Replace Parse command with our own parser so that spaces in Quotes are NOT discarded.
     ' ======================================================================================================
     ' Parse InLine, pArray1(), " "
    
     Cnt1 = Parser(InLine, pArray1())
    
     For n = 1 To Cnt1
    
         Token = pArray1(n)
         '#TEST Print "1. Token = " & Token
    
         If Instr("=+-/\*@()^%&?$,<>#", Token) = 0 Then
            bResult = ParseTokenSeries(Token, Tokens())
            If bResult Then
               ReDim Preserve TargetArray(Elements + bResult) As String
               For k = 1 To bResult
                   TargetArray(Elements + k) = Tokens(k)
               Next
               Elements = Elements + bResult
            End If
    
            If bResult = 0 Then
               Incr Elements
               ReDim Preserve TargetArray(Elements) As String
               TargetArray(Elements) = Token
            End If
         Else
            Incr Elements
            ReDim Preserve TargetArray(Elements) As String
    
            TargetArray(Elements) = Token
    
         End If
    
     Next
    
     Function = Elements
    
    End Function
    
    ' ======================================================================================================
    '
    ' ======================================================================================================
    Function MathExpressionNotation(ByRef Tokens() As String) As String
    
     Local n                 As Long
     Local TokenCount        As Dword
     Local Token             As String
     Local wIndex            As Word
     Local Buffer            As String
    
     Local tRPN              As RPN_STACK
     Local CurLevel          As Integer
     Local Level             As Integer
     Local Operand           As String
    
    
     Dim   Tokens(0)         As String
     Dim   Finals(0)         As String
    
     TokenCount = Ubound(Tokens)
    
     ReDim Finals(1 To TokenCount) As String
    
     wIndex = 0
    
     For n = 0 To TokenCount
    
         Token = Ucase$(Tokens(n))
    
         Select Case Token
    
         Case "+", "-"
    
              Do While PopRPN(Operand, Level)
    
                 If tRPN.nLevel = CurLevel Then
                    Incr wIndex
                    Finals(wIndex) = Operand
                 Else
    
                    tRPN.pOperand = memHeapAllocString(Operand)
                    tRPN.nLevel   = Level
    
                    PshRPN tRPN
    
                    Exit Do
    
                 End If
    
              Loop
    
              tRPN.pOperand = memHeapAllocString(Ucase$(Token))
              tRPN.nLevel   = CurLevel
    
              PshRPN tRPN
    
         Case "*", "/"
    
             Do While PopRPN(Operand, Level)
    
                If Level = CurLevel Then
                   Select Case Operand
    
                   CAse "^", "SQR", "COS", "SIN", "TAN", "EXP", "LOG"
    
                      Incr wIndex
                      Finals(wIndex) = Operand
    
                   Case Else
    
                      tRPN.pOperand = memHeapAllocString(Operand)
                      tRPN.nLevel   = Level
    
                      PshRPN tRPN
    
                      Exit Do
    
                   End Select
                Else
    
                   tRPN.pOperand = memHeapAllocString(Operand)
                   tRPN.nLevel   = Level
    
                   PshRPN tRPN
    
                   Exit Do
                End If
    
             Loop
    
             tRPN.pOperand = memHeapAllocString(Ucase$(Token))
             tRPN.nLevel   = CurLevel
    
             Call PshRPN (tRPN)
    
         Case "^"
    
             tRPN.pOperand = memHeapAllocString(Ucase$(Token))
             tRPN.nLevel   = CurLevel
    
             PshRPN tRPN
    
         Case "COS", "SIN", "SQR", "TAN", "LOG"
    
             tRPN.pOperand = memHeapAllocString(Ucase$(Token))
             tRPN.nLevel   = CurLevel
    
             PshRPN tRPN
    
         Case "AND"
    
             tRPN.pOperand = memHeapAllocString(Ucase$(Token))
             tRPN.nLevel   = CurLevel
    
             PshRPN tRPN
    
         Case "("
    
             Incr CurLevel
    
         Case ")"
    
             Do While PopRPN(Operand, Level)
    
                 If Level = CurLevel Then
    
                    Incr wIndex
                    Finals(wIndex) = Operand
    
                 Else
    
                    tRPN.pOperand = memHeapAllocString(Operand)
                    tRPN.nLevel   = Level
    
                    PshRPN tRPN
    
                    Exit Do
    
                 End If
             Loop
    
             Decr CurLevel
    
         Case "="
    
         Case Else
    
             If IsNumeric(Token) Then
                Incr wIndex
                Finals(wIndex) = Token
             End If
    
             'Buffer = Buffer & Ucase$(Trim$(Token)) & " "
             'tRPN.pOperand = memHeapAllocString(Token)
             'tRPN.nLevel   = CurLevel
    
             'PshRPN tRPN
    
         End Select
    
     Next
    
     TokenCount = List_GetCount(PS.pRPN)
    
     Do While PopRPN(Operand, Level)
        Incr wIndex
        Finals(wIndex) = Operand
     Loop
     For n = 1 To wIndex
         Buffer = Buffer & Finals(n)
         If n < wIndex Then
            Buffer = Buffer & " "
         End If
     Next
     Function = Buffer
    ' Print EvaluatePostFix(Buffer)
    End Function
    ' ======================================================================================================
    '
    ' ======================================================================================================
    Function EvaluatePostfix(ByVal Expression As String) As Double
     Local i As Integer
     Local A As Double
     Local C As Double
     Local D As Double
    
     Dim Expn(0 To ParseCount(Expression, " ") - 1) As String
    
     Parse Expression, Expn(), " "
    
     For i = 0 To UBound(Expn())
       Select Case Expn(i)
         Case "+"
           C = PopRPNEvaluator()
           D = PopRPNEvaluator()
           A = D + C
           Call PshRPNEvaluator(A)
         Case "-"
           C = PopRPNEvaluator()
           D = PopRPNEvaluator()
           A = D - C
           Call PshRPNEvaluator(A)
         Case "*"
           C = PopRPNEvaluator()
           D = PopRPNEvaluator()
           A = D * C
           Call PshRPNEvaluator(A)
         Case "/", "\"
           C = PopRPNEvaluator()
           D = PopRPNEvaluator()
           A = D / C
           Call PshRPNEvaluator(A)
         Case "^"
           C = PopRPNEvaluator()
           D = PopRPNEvaluator()
           A = D ^ C
           Call PshRPNEvaluator(A)
         Case "SIN"
           C = PopRPNEvaluator()
           A = Sin(C)
           Call PshRPNEvaluator(A)
         Case "COS"
           C = PopRPNEvaluator()
           A = Cos(C)
           Call PshRPNEvaluator(A)
         Case "TAN"
           C = PopRPNEvaluator()
           A = Tan(C)
           Call PshRPNEvaluator(A)
         Case "SQR"
           C = PopRPNEvaluator()
           A = SQR(C)
           Call PshRPNEvaluator(A)
         Case "LOG"
           C = PopRPNEvaluator()
           A = LOG(C)
           Call PshRPNEvaluator(A)
         Case "AND"
           C = PopRPNEvaluator()
           D = PopRPNEvaluator()
           A = D AND C
           Call PshRPNEvaluator(A)
         Case Else
           A = Val(Expn(i))
           Call PshRPNEvaluator(A)
       End Select
     Next
     Function = A
    End Function
    
    
    ' ======================================================================================================
    '
    ' ======================================================================================================
    Function RPN(ByVal Buffer As String) As Long
    
      Local Elements    As Long
      Local n           As Long
      Local bResult     As Integer
      Local RP          As String
      ' ======================================================================================================
      Dim   TargetArray(0) As String
    
      Elements = ParseLine(Buffer, TargetArray(), bResult)
    
      ' ======================================================================================================
    
      RP = MathExpressionNotation(TargetArray())
    
      ' ======================================================================================================
    
      Print "RPN = " & RP
    
      Print EvaluatePostFix(RP)
    
    End Function
    
    
    Function pbMain() As Long
    
    
      Call List_Initialize()
    
      PS.pRPN              = List_CreateStandard()
      PS.pRPNPostFix       = List_CreateStandard()
    
      Call RPN("(5 + 8 * sin(2 * 15)) / (2 + tan(45))")
    
    End Function
    Last edited by Steven Pringels 3; 28 Apr 2008, 09:42 AM.
    So here we are, this is the end.
    But all that dies, is born again.
    - From The Ashes (In This Moment)
Working...
X