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