|
Warning: this is an htmlized version!
The original is here, and the conversion rules are here. |
#!/usr/bin/env rexx
------------------------------------------------------------------------------
-- sc: a simple rpn calculator leveraging (oo)rexx's algorism --
------------------------------------------------------------------------------
-- entry ---------------------------------------------------------------------
calculator=.calculator~new
file=.stream~new('~/.scrc')
loop while file~lines<>0
if \calculator~evaluate(file~linein) then exit 1
end
signal on notready
signal on user bye
loop forever
calculator~evaluate(linein())
end
bye:
notready:
exit
-- evaluation ----------------------------------------------------------------
::options digits 12
::class Calculator
::method init
expose stack macro register binops digits fuzz comparator
stack=.stack~new -- data stack
macro=.table~new -- bundled and user defined macros
register=.table~new -- user registers (variables)
-- binary operators (these pass through to rexx)
binopWords='<= ** <> % & | * // + < = - > >= /'
binops=.set~new~~putAll(binopWords~makeArray(' '))
digits=digits() -- used for sharing digits across methods
fuzz=fuzz() -- " " " fuzz across methods
comparator=.alnumcomparator~new
::method evaluate
expose stack macro
signal on user bye
signal on user hiccup
signal on user underflow
-- remove comments, trim
parse arg line '#' .
stripped=strip(line)
-- interpret line
select
-- macro definitions
when pos(':', stripped)=1 then do
parse lower value substr(stripped, 2) with name body
select
when body='' then macro~remove(name)
when wordpos(name, body)>0 then say '[macro recursion disallowed]'
otherwise
macro[name]=body
end
return 1
end
-- normal evaluation
otherwise
loop while line<>''
parse lower var line word line
if \self~evalWord(word) then return 0
end
end
return 1
bye:
raise propagate
underflow:
say '[stack underflow]'
hiccup:
if \stack~isEmpty then say 'stack was:' stack~image
stack~empty
return 0
::method evalWord
expose stack macro register digits fuzz
use arg word
signal on syntax
signal on user bye
signal on user hiccup
signal on user underflow
numeric digits digits -- we might want to factor out consumers
select
-- numbers always self evaluate
when isNumber?(word) then stack~push(asDecimal(word))
-- special purpose register syntax (word prefixes)
when pos('->', word)=1 then register[substr(word, 3)]=stack~pop
when pos('<-', word)=1 then self~fetchRegister(substr(word, 3))
-- macros expand before primitives, after registers
when macro~hasIndex(word) then return self~evaluate(macro[word])
-- primitives
when word='!' then stack~push(factorial(stack~pop, digits))
when word='.' then say stack~pop
when word='.bin' then say '0b'd2b(stack~pop)
when word='.hex' then say '0x'd2x(stack~pop)
when word='.oct' then say '0o'd2o(stack~pop)
when word='.p' then say self~withPlaces
when word='.s' then say stack~image
when word='2drop' then stack~~pop~pop
when word='2dup' then stack~~over~over
when word='bye' then raise user bye
when word='ceil' then stack~push(stack~pop~ceiling)
when word='choose' then stack~push(choose(stack~pop, stack~pop, digits))
when word='clear' then register~empty
when word='digits' then stack~push(digits)
when word='drop' then stack~pop
when word='dup' then stack~push(stack~peek)
when word='floor' then stack~push(stack~pop~floor)
when word='fuzz' then stack~push(fuzz)
when word='max' then stack~push(max(stack~pop, stack~pop))
when word='min' then stack~push(min(stack~pop, stack~pop))
when word='negate' then stack~push(-stack~pop)
when word='nip' then stack~~swap~pop
when word='not' then stack~push(\stack~pop)
when word='over' then stack~over
when word='rand' then stack~push(random(stack~pop-1))
when word='round' then stack~push(stack~pop~round)
when word='set-digits' then digits=stack~pop
when word='set-fuzz' then fuzz=stack~pop
when word='swap' then stack~swap
when word='tuck' then stack~~swap~over
when self~isBinop?(word) then self~binop(word)
-- constants
when word='e' then stack~push(.constants~e+0)
when word='pi' then stack~push(.constants~pi+0)
-- non-decimal primitives
when word='acos' then self~rxMathUnary('RxCalcArcCos')
when word='asin' then self~rxMathUnary('RxCalcArcSin')
when word='atan' then self~rxMathUnary('RxCalcArcTan')
when word='cos' then self~rxMathUnary('RxCalcCos')
when word='log' then self~rxMathUnary('RxCalcLog')
when word='log10' then self~rxMathUnary('RxCalcLog10')
when word='sin' then self~rxMathUnary('RxCalcSin')
when word='sqrt' then self~rxMathUnary('RxCalcSqrt')
when word='tan' then self~rxMathUnary('RxCalcTan')
-- usage
when word='.macros' then self~showMacros
when word='.registers' then self~showRegisters
when word='.version' then self~showRexxVersion
when word='help' then self~showHelp
when word='words' then self~showHelp
otherwise
say '["'word'" is not defined]'
raise user hiccup
end
return 1
syntax:
say '[(syntax)' errortext(rc)']'
raise user hiccup array ('syntax', errortext(rc), rc)
bye: hiccup: underflow: raise propagate
::method fetchRegister private
expose stack register
parse lower arg name
select
when register~hasIndex(name) then stack~push(register[name])
otherwise
say '[unknown register "'name'"]'
raise user hiccup
end
::method withPlaces private
expose stack
signal on user underflow
stack~swap
return format(stack~pop,, stack~pop)
underflow: raise propagate
::method isBinop? private
expose binops
use arg op
return binops~hasItem(op)
::method binop private
expose stack digits fuzz
signal on user underflow
use arg op
b=stack~pop
a=stack~pop
numeric digits digits
numeric fuzz fuzz
stack~push(a~send(op, b))
return
underflow: raise propagate
::method rxMathUnary private
expose stack digits
parse arg fn
signal on user underflow
precision=digits
if precision>16 then precision=16
call (fn) stack~pop, precision
stack~push(result)
return
underflow: raise propagate
::method showMacros
expose macro comparator
names=macro~allIndexes~sortWith(comparator)
width=maxOver(names, 'length')+1
loop name over names
say ':'left(name, width) strip(macro[name])
end
return
::method showRegisters
expose register comparator
names=register~allIndexes~sortWith(comparator)
width=maxOver(names, 'length')+1
loop name over names
say left(name, width) register[name]
end
return
::method showHelp
expose binops macro register comparator
ms=macro~items; rs=register~items
-- primitives are manually populated for now, since they aren't indexes
prims=('! . .bin .hex .macros .oct .p .registers .s .version 2drop 2dup',
'acos asin atan ceil choose clear cos digits drop dup e floor',
'fuzz help log log10 max min negate nip not over pi rand',
'round set-digits set-fuzz sin sqrt swap tan tuck words'),
~makeArray(' ')
-- combine primitives, binary operators and currently defined macros
words=.set~new~~putAll(prims)~~putAll(binops)~~putAll(macro~allIndexes)
say words~allItems~sortWith(comparator)~makeString(, ' ')
say '(see also .macros ['ms 'defined] and .registers ['rs 'defined])'
::method showRexxVersion
parse version v
say v
-- numbers -------------------------------------------------------------------
::routine isNumber?
use arg word
return datatype(word, 'n')=1 | isOctal?(word) | isHex?(word) | isBin?(word)
::routine asDecimal
use arg word
select
when isBin?(word) then return x2d(b2x(substr(word, 3)))
when isHex?(word) then return x2d(substr(word, 3))
when isOctal?(word) then return o2d(substr(word, 3))
when datatype(word, 'n')=1 then return word+0
otherwise
raise user hiccup
end
::routine isBin?
parse lower arg word
return pos('0b', word)=1 & verify(substr(word, 3), '01')=0
::routine isOctal?
parse lower arg word
return pos('0o', word)=1 & verify(substr(word, 3), '01234567')=0
::routine isHex?
parse lower arg word
return pos('0x', word)=1 & verify(substr(word, 3), '0123456789abcdef')=0
::routine o2d
parse arg n
total=0
r=n~reverse
loop i=1 to n~length
d=r[i]
total+=d*(8**(i-1))
end
return total
::routine d2o
parse arg n
digits=''
loop while n>0
digits=(n//8)digits
n%=8
end
return digits
::routine d2b
parse arg n
return strip(x2b(d2x(n)), 'l', 0)
-- calculations --------------------------------------------------------------
::routine factorial
parse arg n, digits
numeric digits digits
f=1
loop i=2 to n
f*=i
end
return f
::routine fallingFactorial
parse arg x, n, digits
numeric digits digits
ff=x
loop k=1 to n-1
ff*=x-k
end
return ff
::routine choose
parse arg n, k, digits
return fallingFactorial(n, k, digits)/factorial(k, digits)
-- utils ---------------------------------------------------------------------
::routine maxOver -- generalise if necessary
use arg xs, msg
m=0
loop x over xs
m=max(m, x~send(msg))
end
return m
-- stack ---------------------------------------------------------------------
::class Stack
::method init
expose queue
queue=.queue~new
::method isEmpty
expose queue
return queue~isEmpty
::method push
expose queue
use arg v
queue~push(v)
::method pop
expose queue
if queue~isEmpty then raise user underflow
else return queue~pull
::method peek
expose queue
if queue~isEmpty then raise user underflow
else return queue~peek
::method swap
expose queue
if queue~items<2 then raise user underflow
a=queue[1]; b=queue[2]
queue[1]=b; queue[2]=a
::method over
expose queue
if queue~items<2 then raise user underflow
queue~push(queue[2])
::method empty
expose queue
queue~empty
::method image
expose queue
img='<'queue~items'>'
i=queue~last
loop while i<>.nil
img=img queue~at(i)
i=queue~previous(i)
end
return img
-- sorting -------------------------------------------------------------------
::class AlnumComparator mixinclass Comparator
::method alnum?
return arg(1)~verify(,
'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz')=0
::method symbol?
return \self~alnum?(arg(1))
::method compare
use strict arg left, right
ll=left~length; rl=right~length
-- compare min length characters (or fewer, if possible)
loop i=1 to min(ll, rl)
l=left~substr(i, 1); r=right~substr(i, 1)
select
when l=r then iterate
when self~symbol?(l) & self~alnum?(r) then return -1
when self~symbol?(r) & self~alnum?(l) then return 1
otherwise return l~compareTo(r)
end
end
-- one string is a prefix of the other, so use length to order them
return ll~compareTo(rl)
------------------------------------------------------------------------------
::class constants
-- https://oeis.org/A001113
::constant e 2.71828182845904523536028747135266249775724709369995957496696762772407663035354759457138217852516642742746
-- https://oeis.org/A000796
::constant pi 3.14159265358979323846264338327950288419716939937510582097494459230781640628620899862803482534211706798214
::requires 'rxmath' LIBRARY
/*
* (eepitch-shell)
* (eepitch-kill)
* (eepitch-shell)
./repl.rexx
.routine~newFile('sc.rexx')~call
1 2 + .
bye
-- foo
-- (find-oorexxrefpage)
-- (find-oorexxreftext)
-- (find-oorexxrefpage (+ 22 91) "3.2. ::CLASS")
-- (find-oorexxreftext (+ 22 91) "3.2. ::CLASS")
*/