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