home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Boot Disc 8
/
boot-disc-1997-04.iso
/
PDA_Soft
/
Psion
/
utils
/
Rpn3a
/
RPNCALC.OPL
< prev
next >
Wrap
Text File
|
1994-10-11
|
16KB
|
831 lines
rem*************************************************************************
rem
rem RPN Calculator for the Psion Series 3a
rem Version 1.0
rem Copyright (c) 1992 Jaime Pereira
rem
rem This program is free software; you can redistribute it and/or modify
rem it under the terms of the GNU General Public License as published by
rem the Free Software Foundation; either version 1, or (at your option)
rem any later version.
rem
rem This program is distributed in the hope that it will be useful,
rem but WITHOUT ANY WARRANTY; without even the implied warranty of
rem MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
rem GNU General Public License for more details.
rem
rem You should have received a copy of the GNU General Public License
rem along with this program; if not, write to the Free Software
rem Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
rem
rem Revision: $Id: rpncalc.opl 1.3 92/12/10 00:32:02 jaime Exp Locker: jaime $
rem Ported to the Series 3A by Victor Alvarado 10/10/94
rem
rem*************************************************************************
app RPNcalc
type $1000
icon "\opl\rpncalc.pic"
enda
proc rpncalc:
global stack(20), tos%, wid%
global memory(10)
global editstr$(30), editpos%, udpos%
global frmtype%, frmprec&, frmtrig%
local k%, c$(1), inedit%
rem
rem Relocate the base window so we can see the
rem status window.
rem
screen 35,9
gsetwin 416, 160
statuswin on
gupdate off
rem
rem Create the display window
rem
wid% = gcreate(0, 0, 416, 160, 1)
guse wid%
gstyle 16
rem
rem Add the adornments
rem
gborder $200
k% = 0
gat 0, 140
while (k% < 416)
glineby 2, 0
gmove 2,0
k% = k% + 4
endwh
rem
rem Initialize asorted stuff
rem
tos% = 1
editpos% = 1
editstr$ = ""
frmtype% = 1
frmtrig% = 1
frmprec& = 12
udpos% = 0
showstk:
rem
rem The Loop!
rem
do
rem
rem Read from the keyboard
rem
guse wid%
k% = get
c$ = upper$(chr$(k%))
rem
rem Decode keystroke
rem
if k% = 632 rem Psion-X
break
elseif k% = 13 rem CR
rem
rem CR doubles as DUP if editstr is empty
rem
if len(editstr$) = 0 and tos% > 1
push:(stack(tos%-1))
else
pushstr:
endif
showstk:
rem Drop
elseif k% = 8 and len(editstr$) = 0
pop:
showstk:
elseif k% = 27 rem Escape key
inedit% = 0
editstr$ = ""
editpos% = 1
elseif k% = 290 rem Menu
menuop:
elseif k% = 291 rem Help
helpfunc:
elseif loc("+-/*X", c$) rem Math operation
binop:(c$)
showstk:
elseif k% > 512 rem Special Psion operation
psionop:(k%)
showstk:
rem Change sign
elseif c$ = "C" and len(editstr$)
chsop:
showcmd:
elseif loc("CSRIOP", c$) rem General manupulation
stkop:(c$)
showstk:
rem Up and Down arrows
elseif (k% = 257 or k% = 256) and tos% > 1
if len(editstr$) and inedit%
continue
endif
inedit% = 0
if (k% = 256)
udpos% = udpos% + 1
if udpos% >= tos% : udpos% = 0: endif
else
udpos% = udpos% - 1
if udpos% < 0 : udpos% = tos% - 1: endif
endif
if udpos% = 0
editstr$ = ""
editpos% = 1
else
editstr$ = gen$(stack(tos% - udpos%), 25)
editpos% = len(editstr$)+1
endif
showcmd:
else rem Otherwise to the edit box
inedit% = 1
myedit:(k%)
showcmd:
endif
until 0
endp
rem*******************************************
rem
rem My own field editor routine
rem
rem*******************************************
proc myedit:(k%)
local hstr$(40), tstr$(40)
local length%
length% = len(editstr$)
hstr$ = mid$(editstr$, 1, editpos%-1)
tstr$ = mid$(editstr$, editpos%, length%)
if k%=8
length% = len(hstr$)
if length% > 0
editstr$ = left$(hstr$, length%-1) + tstr$
editpos% = editpos% - 1
endif
elseif k% = 259
editpos% = editpos% - 1
if editpos% < 1
editpos% = 1
endif
elseif k% = 258
editpos% = editpos% + 1
if editpos% > length%+1
editpos% = length%+1
endif
elseif (length% > 22)
return
elseif (k% >= 48 and k% <= 57) or k% = 69 or k% = 101 or k% = 46
editstr$ = hstr$ + chr$(k%) + tstr$
editpos% = editpos% + 1
endif
endp
rem************************************************
rem
rem Show the stack display
rem
rem************************************************
proc showstk:
local i%, k%
local numstr$(25)
local xo%, yo%
cursor off
xo% = 5: yo% = 3
gat xo%, yo%
gfill 356, 136, 1
if tos% = 1
gat 220, yo% + 130
gprint " ** Empty **"
endif
i% = 10
k% = tos% - 1
while i% > 0 and k% > 0
gat xo%, i% * 13 + yo%
gprint fix$(tos% - k%, 0, -2);":"
if frmtype% = 1
numstr$ = gen$(stack(k%), 25)
elseif frmtype% = 2
numstr$ = fix$(stack(k%), frmprec&, 25)
elseif frmtype% = 3
numstr$ = sci$(stack(k%), frmprec&, 25)
endif
gprintb numstr$, 320, 1
i% = i% - 1
k% = k% - 1
endwh
showcmd:
endp
rem*******************************************
rem
rem Show the edit box
rem
rem*******************************************
proc showcmd:
local x%, cwidth%
local xo%, yo%
cwidth% = gtwidth("A")
xo% = 7: yo% = 145
cursor off
gat xo%, yo% - 1
gfill 356, 12, 1
gtmode 3
gat xo%, yo% + 10
gprint "Rpn:"
x% = gx + 3
gat x%, gy
gprint editstr$
gat x% + cwidth% * (editpos%-1), gy
cursor wid%
gupdate
endp
rem*******************************************
rem
rem Format window
rem
rem*******************************************
proc formatop:
dinit "Set RPN Calculator format"
dchoice frmtype%, "Format:", "General,Fixed,Scientific"
dlong frmprec&, "Decimal places:", 0, 12
dchoice frmtrig%, "Trigonometry units:", "Degrees,Radians"
if dialog
showstk:
endif
endp
rem*******************************************
rem
rem Push the edit box string into the
rem stack.
rem
rem*******************************************
proc pushstr:
onerr errhand
if len(editstr$)
push:(eval(editstr$))
endif
onerr off
editstr$ = ""
editpos% = 1
return 0
errhand::
onerr off
problem:(err$(err))
return 1
endp
rem*******************************************
rem
rem Push a number in the stack
rem
rem*******************************************
proc push:(data)
udpos% = 0
if tos% > 19
problem:("Stack Full")
else
stack(tos%) = data
tos% = tos% + 1
endif
endp
rem*******************************************
rem
rem Pop a number from the stack
rem
rem*******************************************
proc pop:
udpos% = 0
if tos% = 1
problem:("Stack empty")
return 0
endif
tos% = tos% - 1
return stack(tos%)
endp
rem*******************************************
rem
rem Clear the stack
rem
rem*******************************************
proc clrstk:
tos% = 1
showstk:
endp
rem*******************************************
rem
rem Stack operations
rem
rem*******************************************
proc stkop:(op$)
local mem, value
rem
rem Put the edit box in the stack
rem
if pushstr:
return
endif
if op$ = "S" and tos% > 2 rem Swap
stack(tos%) = stack(tos%-1)
stack(tos%-1) = stack(tos%-2)
stack(tos%-2) = stack(tos%)
elseif op$ = "R" and tos% > 3 rem Rot
stack(tos%) = stack(tos%-1)
stack(tos%-1) = stack(tos%-2)
stack(tos%-2) = stack(tos%-3)
stack(tos%-3) = stack(tos%)
elseif op$ = "I" and tos% > 2 rem Into memory
mem = pop:
if (mem >= 1 and mem <= 10)
value = stack(tos%-1)
memory(mem) = value
else
problem:("Illegal memory number")
endif
elseif op$ = "O" and tos% > 1 rem Out from memory
mem = pop:
if (mem >= 1 and mem <= 10)
push:(memory(mem))
else
problem:("Illegal memory number")
endif
elseif op$ = "C" and tos% > 1 rem Change sign
stack(tos%-1) = -stack(tos%-1)
elseif op$ = "P" rem Pi constant
push:(pi)
else
problem:("Stack empty")
endif
endp
rem*******************************************
rem
rem Psion key operations
rem
rem*******************************************
proc psionop:(ki%)
local result, val1, tval, k%
local op$(1)
local temp$(30)
rem
rem Put the edit box in the stack
rem
temp$ = editstr$
if pushstr:
return
endif
rem
rem Get the character withoud the Psion key
rem
k% = ki% and 511
op$ = upper$(chr$(k%))
rem
rem Process the menu keys
rem
if op$ = "I"
about:
return
elseif op$ = "F"
formatop:
return
elseif op$ = "N"
clrstk:
return
endif
rem
rem All this operations require at least
rem one element
rem
if tos% < 2
problem:("Stack empty")
return
endif
rem
rem Get the element and keep an exta copy just
rem in case the operation goes sour
rem
val1 = pop:
tval = val1
onerr errhand
rem
rem If this is a trig operation convert
rem the value to the trig format selected
rem
if loc("SCT", op$) and frmtrig% = 1
val1 = rad(val1)
endif
rem
rem Decode the operation
rem
if op$ = "S"
result = sin(val1)
elseif op$ = "C"
result = cos(val1)
elseif op$ = "T"
result = tan(val1)
elseif op$ = "A"
result = asin(val1)
elseif op$ = "K"
result = acos(val1)
elseif op$ = "J"
result = atan(val1)
elseif op$ = "L"
result = ln(val1)
elseif op$ = "G"
result = log(val1)
elseif op$ = "E"
result = exp(val1)
elseif op$ = "P"
result = val1 ** 2
elseif op$ = "Q"
result = sqr(val1)
elseif op$ = "V"
result = 1 / val1
endif
rem
rem If this is an inverse trig opeation
rem conver to the trig format slected
rem
if loc("AKJ", op$) and frmtrig% = 1
result = deg(result)
endif
onerr off
rem
rem Put the result back in the stack
rem and get out
rem
push:(result)
return
rem
rem Error handler. Complain and
rem resotre the stack to its previous state.
rem
errhand::
onerr off
problem:(err$(err))
if len(temp$)
editstr$ = temp$
editpos% = len(temp$)+1
else
push:(tval)
endif
endp
rem*******************************************
rem
rem Basic arithmetic operations
rem
rem*******************************************
proc binop:(op$)
local result, val1, val2
local temp$(30)
rem
rem Put the edit box in the stack
rem
temp$ = editstr$
if pushstr:
return
endif
if tos% < 3
problem:("Stack empty")
return
endif
val2 = pop:
val1 = pop:
onerr errhand
if op$ = "+"
result = val1 + val2
elseif op$ = "-"
result = val1 - val2
elseif op$ = "*"
result = val1 * val2
elseif op$ = "/"
result = val1 / val2
elseif op$ = "X"
result = val1 ** val2
endif
onerr off
push:(result)
return
rem
rem Error handler. Complain and
rem resotre the stack to its previous state.
rem
errhand::
onerr off
problem:(err$(err))
push:(val1)
if len(temp$)
editstr$ = temp$
editpos% = len(temp$)+1
else
push:(val2)
endif
endp
rem*******************************************
rem
rem Change Sign operation
rem
rem*******************************************
proc chsop:
local epos%, echar$(1)
local base, expon, length%
epos% = loc(editstr$, "E")
length% = len(editstr$)
onerr errhand
base = eval(editstr$)
if epos% = 0
base = eval(editstr$)
expon = 0
else
echar$ = mid$(editstr$, epos%, 1)
base = eval(left$(editstr$, epos%-1))
epos% = epos% + 1
if mid$(editstr$, epos%, 1) = "+"
epos% = epos% + 1
endif
expon = eval(right$(editstr$, length% - epos%+1))
endif
if epos% = 0 or editpos% < epos%
base = -base
else
expon = -expon
endif
if epos%
editstr$ = gen$(base, 25) + echar$ + gen$(expon, 25)
else
editstr$ = gen$(base,25)
endif
if len(editstr$) < length%
editpos% = editpos% -1
if editpos% < 1
editpos% = 1
endif
elseif len(editstr$) > length%
editpos% = editpos% + 1
endif
onerr off
return
errhand::
onerr off
problem:(err$(err))
endp
rem*******************************************
rem
rem Attend to the menu
rem
rem*******************************************
proc menuop:
local k%, c$(1)
minit
mcard "Options", "Format", %f
mcard "Special", "New stack", %n, "About", -%i, "Exit", %x
k% = menu
c$ = chr$(k%)
if k% = 0
return
elseif c$ = "x"
stop
elseif c$ = "i"
about:
elseif c$ = "f"
formatop:
elseif c$ = "n"
clrstk:
endif
endp
rem*******************************************
rem
rem Format and display the about window
rem
rem*******************************************
proc about:
dinit "RPN 3a Calculator Version 1.0"
dtext "", "Original program:", 2
dtext "", "RPN Calculator Ver 1.01 for the Series 3", 2
dtext "", "Copyright (c) 1992 Jaime Pereira", 2
dtext "", "jep@world.std.com", 2
dtext "", "Compuserve 70441,465", 2
dtext "", "Ported to the Series 3a by:", 2
dtext "", "Victor Alvarado vma@mvuts.att.com", 2
dialog
endp
rem*******************************************
rem
rem Format and display the help window
rem
rem*******************************************
proc helpfunc:
global hcmd$(5,7), hkey$(5,2)
local id%
id% = gcreate(0, 10, 480, 140, 0, 1)
guse id%
gxborder 1,$203
gat 120, 24 : glineby 0, 116
gat 240, 24 : glineby 0, 116
gat 360, 24 : glineby 0, 116
gat 0, 24 : glineby 480, 0
gat 180, 20: gprint "Keyboard Usage"
rem
rem first column
rem
hcmd$(1) = "Swap" : hkey$(1) = "S"
hcmd$(2) = "Rot" : hkey$(2) = "R"
hcmd$(3) = "Sto" : hkey$(3) = "I"
hcmd$(4) = "Rcl" : hkey$(4) = "O"
hcmd$(5) = "Pi" : hkey$(5) = "P"
hcolput:(12)
rem
rem Second column
rem
hcmd$(1) = "sin(x)" : hkey$(1) = chr$(2) + "S"
hcmd$(2) = "cos(x)" : hkey$(2) = chr$(2) + "C"
hcmd$(3) = "tan(x)" : hkey$(3) = chr$(2) + "T"
hcmd$(4) = "ln(x)" : hkey$(4) = chr$(2) + "L"
hcmd$(5) = "e"+chr$(3) : hkey$(5) = chr$(2) + "E"
hcolput:(132)
rem
rem third column
rem
hcmd$(1) = "asin(x)" : hkey$(1) = chr$(2) + "A"
hcmd$(2) = "acos(x)" : hkey$(2) = chr$(2) + "K"
hcmd$(3) = "atan(x)" : hkey$(3) = chr$(2) + "J"
hcmd$(4) = "log(x)" : hkey$(4) = chr$(2) + "G"
hcmd$(5) = "y"+chr$(3) : hkey$(5) = "X"
hcolput:(252)
rem
rem fourth column
rem
hcmd$(1) = "1/x" : hkey$(1) = chr$(2) + "V"
hcmd$(2) = "sqrt(x)" : hkey$(2) = chr$(2) + "Q"
hcmd$(3) = "-x" : hkey$(3) = "C"
hcmd$(4) = "" : hkey$(4) = ""
hcmd$(5) = "" : hkey$(5) = ""
hcolput:(372)
gvisible on
get
gclose id%
endp
rem*******************************************
rem
rem A helper function for the
rem help display
rem
rem*******************************************
proc hcolput:(xpos%)
local ypos%, cnt%
ypos% = 48
cnt% = 1
while cnt% <= 5
gat xpos%, ypos%
gprint hcmd$(cnt%)
gat xpos% + 78, gy
gprint hkey$(cnt%)
ypos% = ypos% + 20
cnt% = cnt% + 1
endwh
endp
rem*******************************************
rem
rem My error handler
rem
rem*******************************************
proc problem:(info$)
giprint info$
beep 5, 300
endp