<> <> <> DIRECTORY Complex, IO, List, Misp, Real, RealFns, Rope, Vector; MispNumbers: CEDAR PROGRAM IMPORTS Complex, IO, RealDefs: Real, RealFns, Misp, Vector EXPORTS Misp = BEGIN OPEN Misp; DefineNumberStuff: EnvironmentProc = BEGIN Defun[environment, $complex, EvalComplex]; Defun[environment, $re, EvalRe]; Defun[environment, $im, EvalIm]; Defun[environment, $reim, EvalReIm]; Defun[environment, $round, EvalRound]; Defun[environment, $floor, EvalFloor]; Defun[environment, $ceiling, EvalCeiling]; Defun[environment, $abs, EvalAbs]; Defun[environment, $sgn, EvalSgn]; Defun[environment, $arg, EvalArg]; Defun[environment, $exp, EvalExp]; Defun[environment, $ln, EvalLn]; Defun[environment, $sin, EvalSin]; Defun[environment, $cos, EvalCos]; Defun[environment, $tan, EvalTan]; Defun[environment, $gcd, EvalGcd]; Defun[environment, $lcm, EvalLcm]; DefIntRealArith[environment, $plus, PlusInts, PlusReals, PlusCxs, 0]; DefIntRealArith[environment, $minus, MinusInts, MinusReals, MinusCxs, 0]; DefIntRealArith[environment, $mult, MultInts, MultReals, MultCxs, 1]; DefIntRealArith[environment, $div, DivInts, DivReals, DivCxs, 1]; DefIntRealArith[environment, $quot, QuotInts, QuotReals, QuotCxs, 1]; DefIntRealArith[environment, $rem, RemInts, RemReals, RemCxs, 1]; DefIntRealArith[environment, $min, MinInts, MinReals, MinCxs, 2000000000]; DefIntRealArith[environment, $max, MaxInts, MaxReals, MaxCxs, -2000000000]; DefIntRealCond[environment, $lt, LtInts, LtReals]; DefIntRealCond[environment, $le, LeInts, LeReals]; DefIntRealCond[environment, $gt, GtInts, GtReals]; DefIntRealCond[environment, $ge, GeInts, GeReals]; END; DefIntRealArith: PROC [environment: Environment, name: ATOM, Ints: IntArithProc, Reals: RealArithProc, Comps: ComplexArithProc, identity: INT, leftToRight: BOOLEAN _ TRUE] = BEGIN Defun[env: environment, name: name, eval: EvalIntRealArith, data: NEW [IntRealArithRep _ [Ints: Ints, Reals: Reals, Comps: Comps, identity: identity, leftToRight: leftToRight]]]; END; DefIntRealCond: PROC [environment: Environment, name: ATOM, Ints: IntCondProc, Reals: RealCondProc] = BEGIN Defun[env: environment, name: name, eval: EvalIntRealCond, data: NEW [IntRealCondRep _ [Ints: Ints, Reals: Reals]]]; END; PickReal: PROC [args: LORA, environment: Environment, stack: Stack] RETURNS [r: REAL, rest: LORA] = { WITH args.first SELECT FROM real: Real => r _ real^; int: Int => r _ int^; ENDCASE => ERROR Error[environment, stack, IO.PutFR["%g not a number", IO.refAny[args.first]]]; rest _ args.rest}; EvalComplex: EvalProc = BEGIN rest: LORA; r, i: REAL; [r, rest] _ PickReal[args, environment, stack]; [i, ] _ PickReal[rest, environment, stack]; cooked _ NEW [COMPLEX _ [r, i]]; END; EvalRe: EvalProc = BEGIN c: Comp _ NARROW[args.first]; cooked _ NEW [REAL _ Re[c^]]; END; EvalIm: EvalProc = BEGIN c: Comp _ NARROW[args.first]; cooked _ NEW [REAL _ Im[c^]]; END; EvalReIm: EvalProc = BEGIN c: Comp _ NARROW[args.first]; cooked _ LIST [NEW [REAL _ Re[c^]], NEW [REAL _ Im[c^]]]; END; EvalRound: EvalProc = BEGIN r: REAL; [r, ] _ PickReal[args, environment, stack]; cooked _ NEW [INT _ RealDefs.RoundLI[r]]; END; EvalFloor: EvalProc = {x: REAL; [x, ] _ PickReal[args, environment, stack]; cooked _ NEW [INT _ Floor[x]]}; EvalCeiling: EvalProc = {x: REAL; [x, ] _ PickReal[args, environment, stack]; cooked _ NEW [INT _ Ceiling[x]]}; Floor: PROC [x: REAL] RETURNS [f: INT] = BEGIN d: INT _ 1 - RealDefs.Fix[x]; f _ RealDefs.Fix[x+d]-d; END; Ceiling: PROC [x: REAL] RETURNS [f: INT] = BEGIN d: INT _ 1 + RealDefs.Fix[x]; f _ RealDefs.Fix[x-d]+d; END; EvalSin: EvalProc = BEGIN WITH args.first SELECT FROM i: Int => cooked _ NEW [REAL _ RealFns.Sin[i^]]; r: Real => cooked _ NEW [REAL _ RealFns.Sin[r^]]; ENDCASE => ERROR Error[environment, stack, IO.PutFR["%g not a number, in %g", IO.refAny[args.first]]]; END; EvalCos: EvalProc = BEGIN WITH args.first SELECT FROM i: Int => cooked _ NEW [REAL _ RealFns.Cos[i^]]; r: Real => cooked _ NEW [REAL _ RealFns.Cos[r^]]; ENDCASE => ERROR Error[environment, stack, IO.PutFR["%g not a number, in %g", IO.refAny[args.first]]]; END; EvalTan: EvalProc = BEGIN WITH args.first SELECT FROM i: Int => cooked _ NEW [REAL _ RealFns.Tan[i^]]; r: Real => cooked _ NEW [REAL _ RealFns.Tan[r^]]; ENDCASE => ERROR Error[environment, stack, IO.PutFR["%g not a number, in %g", IO.refAny[args.first], IO.refAny[environment]]]; END; ToInt: PUBLIC PROC [ra: REF ANY, environment: Environment, stack: Stack] RETURNS [i: INT] = { WITH ra SELECT FROM ri: Int => RETURN[ri^]; rr: Real => {i _ RealDefs.RoundLI[rr^]; IF rr^ = i THEN RETURN}; c: Comp => {i _ RealDefs.RoundLI[Re[c^]]; IF Im[c^] = 0 AND Re[c^] = i THEN RETURN}; ENDCASE; ERROR Error[environment, stack, IO.PutFR["%g not an integer, in %g", IO.refAny[ra], IO.refAny[environment]]]; }; ToReal: PUBLIC PROC [ra: REF ANY, environment: Environment, stack: Stack] RETURNS [r: REAL] = { WITH ra SELECT FROM ri: Int => RETURN[ri^]; rr: Real => RETURN[rr^]; c: Comp => IF Im[c^] = 0 THEN RETURN[Re[c^]]; ENDCASE; ERROR Error[environment, stack, IO.PutFR["%g not a real, in %g", IO.refAny[ra], IO.refAny[environment]]]; }; ToComplex: PUBLIC PROC [ra: REF ANY, environment: Environment, stack: Stack] RETURNS [c: COMPLEX] = { WITH ra SELECT FROM ri: Int => RETURN[[ri^, 0]]; rr: Real => RETURN[[rr^, 0]]; c: Comp => RETURN[c^]; ENDCASE; }; EvalGcd: EvalProc = BEGIN ans: INT _ 1; first: BOOL _ TRUE; FOR args _ args, args.rest WHILE args # NIL DO i: INT _ ToInt[args.first, environment, stack]; IF first THEN {ans _ i; first _ FALSE} ELSE ans _ Gcd[ans, i]; ENDLOOP; cooked _ NEW [INT _ ans]; END; Gcd: PROC [a, b: INT] RETURNS [gcd: INT] = { gcd _ SGNI[a] * SGNI[b]; a _ ABS[a]; b _ ABS[b]; DO SELECT TRUE FROM a = 0 => RETURN [b*gcd]; b = 0 => RETURN [a*gcd]; a = b => RETURN [a*gcd]; a < b => b _ b MOD a; a > b => a _ a MOD b; ENDCASE => ERROR; ENDLOOP; }; Lcm: PROC [a, b: INT] RETURNS [gcd: INT] = { gcd _ IF a # 0 OR b # 0 THEN (a/Gcd[a, b])*b ELSE 0; }; EvalLcm: EvalProc = BEGIN ans: INT _ 1; FOR args _ args, args.rest WHILE args # NIL DO i: INT _ ToInt[args.first, environment, stack]; ans _ Lcm[ans, i]; ENDLOOP; cooked _ NEW [INT _ ans]; END; EvalExp: EvalProc = BEGIN WITH args.first SELECT FROM i: Int => cooked _ NEW [REAL _ RealFns.Exp[i^]]; r: Real => cooked _ NEW [REAL _ RealFns.Exp[r^]]; c: Comp => cooked _ NEW [COMPLEX _ Complex.Exp[c^]]; ENDCASE => ERROR Error[environment, stack, IO.PutFR["%g not a number, in %g", IO.refAny[args.first]]]; END; EvalLn: EvalProc = BEGIN RiaLynn: PROC [r: REAL] RETURNS [ln: REF ANY] = {ln _ IF r > 0 THEN NEW [REAL _ RealFns.Ln[r]] ELSE NEW [COMPLEX _ Complex.Ln[[r, 0]]]}; WITH args.first SELECT FROM i: Int => cooked _ RiaLynn[i^]; r: Real => cooked _ RiaLynn[r^]; c: Comp => cooked _ NEW [COMPLEX _ Complex.Ln[c^]]; ENDCASE => ERROR Error[environment, stack, IO.PutFR["%g not a number, in %g", IO.refAny[args.first]]]; END; EvalAbs: EvalProc = BEGIN WITH args.first SELECT FROM i: Int => cooked _ NEW [INT _ ABS[i^]]; r: Real => cooked _ NEW [REAL _ ABS[r^]]; c: Comp => cooked _ NEW [REAL _ Complex.Abs[c^]]; ENDCASE => ERROR Error[environment, stack, IO.PutFR["%g not a number, in %g", IO.refAny[args.first]]]; END; EvalSgn: EvalProc = BEGIN WITH args.first SELECT FROM i: Int => cooked _ NEW [INT _ SGNI[i^]]; r: Real => cooked _ NEW [INT _ SGN[r^]]; c: Comp => cooked _ NEW [COMPLEX _ Vector.Unit[c^]]; ENDCASE => ERROR Error[environment, stack, IO.PutFR["%g not a number, in %g", IO.refAny[args.first]]]; END; EvalArg: EvalProc = BEGIN WITH args.first SELECT FROM i: Int => cooked _ NEW [REAL _ Arg[i^]]; r: Real => cooked _ NEW [REAL _ Arg[r^]]; c: Comp => cooked _ NEW [REAL _ Complex.Arg[c^]]; ENDCASE => ERROR Error[environment, stack, IO.PutFR["%g not a number, in %g", IO.refAny[args.first]]]; END; SGNI: PROC [x: INT] RETURNS [s: INT] = {s _ IF x < 0 THEN -1 ELSE IF x > 0 THEN 1 ELSE 0}; SGN: PROC [x: REAL] RETURNS [s: INT] = {s _ IF x < 0 THEN -1 ELSE IF x > 0 THEN 1 ELSE 0}; Arg: PROC [x: REAL] RETURNS [s: REAL] = {s _ IF x < 0 THEN 3.141592653589793 ELSE 0}; EvalIntRealArith: EvalProc = BEGIN ir: IntRealArith _ NARROW[data]; IF args = NIL THEN RETURN [NEW [INT _ ir.identity]]; cooked _ args.first; IF args.rest = NIL THEN RETURN; IF ir.leftToRight THEN BEGIN FOR args _ args.rest, args.rest WHILE args # NIL DO next: REF ANY _ args.first; WITH cooked SELECT FROM i1: Int => WITH next SELECT FROM i2: Int => cooked _ NEW [INT _ ir.Ints[i1^, i2^]]; r2: Real => cooked _ NEW [REAL _ ir.Reals[i1^, r2^]]; c2: Comp => cooked _ NEW [COMPLEX _ ir.Comps[[i1^, 0], c2^]]; ENDCASE => ERROR Error[environment, stack, IO.PutFR["%g not a number", IO.refAny[next]]]; r1: Real => WITH next SELECT FROM i2: Int => cooked _ NEW [REAL _ ir.Reals[r1^, i2^]]; r2: Real => cooked _ NEW [REAL _ ir.Reals[r1^, r2^]]; c2: Comp => cooked _ NEW [COMPLEX _ ir.Comps[[r1^, 0], c2^]]; ENDCASE => ERROR Error[environment, stack, IO.PutFR["%g not a number", IO.refAny[next]]]; c1: Comp => WITH next SELECT FROM i2: Int => cooked _ NEW [COMPLEX _ ir.Comps[c1^, [i2^, 0]]]; r2: Real => cooked _ NEW [COMPLEX _ ir.Comps[c1^, [r2^, 0]]]; c2: Comp => cooked _ NEW [COMPLEX _ ir.Comps[c1^, c2^]]; ENDCASE => ERROR Error[environment, stack, IO.PutFR["%g not a number", IO.refAny[next]]]; ENDCASE => ERROR Error[environment, stack, IO.PutFR["%g not a number", IO.refAny[cooked]]]; ENDLOOP; END ELSE BEGIN next: REF ANY _ EvalIntRealArith[args.rest, environment, ir, stack]; WITH cooked SELECT FROM i1: Int => WITH next SELECT FROM i2: Int => cooked _ NEW [INT _ ir.Ints[i1^, i2^]]; r2: Real => cooked _ NEW [REAL _ ir.Reals[i1^, r2^]]; c2: Comp => cooked _ NEW [COMPLEX _ ir.Comps[[i1^, 0], c2^]]; ENDCASE => ERROR Error[environment, stack, IO.PutFR["%g not a number", IO.refAny[next]]]; r1: Real => WITH next SELECT FROM i2: Int => cooked _ NEW [REAL _ ir.Reals[r1^, i2^]]; r2: Real => cooked _ NEW [REAL _ ir.Reals[r1^, r2^]]; c2: Comp => cooked _ NEW [COMPLEX _ ir.Comps[[r1^, 0], c2^]]; ENDCASE => ERROR Error[environment, stack, IO.PutFR["%g not a number", IO.refAny[next]]]; c1: Comp => WITH next SELECT FROM i2: Int => cooked _ NEW [COMPLEX _ ir.Comps[c1^, [i2^, 0]]]; r2: Real => cooked _ NEW [COMPLEX _ ir.Comps[c1^, [r2^, 0]]]; c2: Comp => cooked _ NEW [COMPLEX _ ir.Comps[c1^, c2^]]; ENDCASE => ERROR Error[environment, stack, IO.PutFR["%g not a number", IO.refAny[next]]]; ENDCASE => ERROR Error[environment, stack, IO.PutFR["%g not a number", IO.refAny[cooked]]]; END; END; IntRealArith: TYPE = REF IntRealArithRep; IntRealArithRep: TYPE = RECORD [ Ints: IntArithProc, Reals: RealArithProc, Comps: ComplexArithProc, identity: INT, leftToRight: BOOLEAN]; IntArithProc: TYPE = PROCEDURE [left, right: INT] RETURNS [INT]; RealArithProc: TYPE = PROCEDURE [left, right: REAL] RETURNS [REAL]; ComplexArithProc: TYPE = PROC [left, right: COMPLEX] RETURNS [ans: COMPLEX]; PlusInts: IntArithProc = {RETURN [left+right]}; PlusReals: RealArithProc = {RETURN [left+right]}; PlusCxs: ComplexArithProc = {RETURN [Complex.Add[left, right]]}; MinusInts: IntArithProc = {RETURN [left-right]}; MinusReals: RealArithProc = {RETURN [left-right]}; MinusCxs: ComplexArithProc = {RETURN [Complex.Sub[left, right]]}; MultInts: IntArithProc = {RETURN [left*right]}; MultReals: RealArithProc = {RETURN [left*right]}; MultCxs: ComplexArithProc = {RETURN [Complex.Mul[left, right]]}; DivInts: IntArithProc = {RETURN [left/right]}; DivReals: RealArithProc = {RETURN [left/right]}; DivCxs: ComplexArithProc = {RETURN [Complex.Div[left, right]]}; QuotInts: IntArithProc = { neg: BOOLEAN _ (left < 0) # (right < 0); ans: INT _ left / right; RETURN [IF neg THEN -ans ELSE ans]}; QuotReals: RealArithProc = { RETURN [Floor[left/right]]}; QuotCxs: ComplexArithProc = { ans _ Complex.Div[left, right]; ans _ [Floor[Re[ans]], Floor[Im[ans]]]}; RemInts: IntArithProc = { RETURN [IF right = 0 THEN left ELSE (((left MOD right)+right) MOD right)]}; RemReals: RealArithProc = { q: INT _ IF right = 0.0 THEN 0 ELSE Floor[left/right]; RETURN [left - right*q]}; ComplexZero: COMPLEX = [x: 0, y: 0]; RemCxs: ComplexArithProc = { q: COMPLEX _ IF right = ComplexZero THEN ComplexZero ELSE Complex.Div[left, right]; ans _ Complex.Sub[left, Complex.Mul[[Floor[Re[q]], Floor[Im[q]]], right]]}; MinInts: IntArithProc = {RETURN [MIN[left, right]]}; MaxInts: IntArithProc = {RETURN [MAX[left, right]]}; MinReals: RealArithProc = {RETURN [MIN[left, right]]}; MaxReals: RealArithProc = {RETURN [MAX[left, right]]}; MinCxs: ComplexArithProc = {ans _ IF Re[right] < Re[left] THEN right ELSE left}; MaxCxs: ComplexArithProc = {ans _ IF Re[right] > Re[left] THEN right ELSE left}; EvalIntRealCond: EvalProc = BEGIN ir: IntRealCond _ NARROW[data]; ans: BOOLEAN _ TRUE; left: REF ANY; IF args = NIL THEN RETURN [$T]; left _ args.first; IF args.rest = NIL THEN RETURN [$T]; FOR args _ args.rest, args.rest WHILE args # NIL DO next: REF ANY _ args.first; WITH left SELECT FROM i1: Int => WITH next SELECT FROM i2: Int => ans _ ans AND ir.Ints[i1^, i2^]; r2: Real => ans _ ans AND ir.Reals[i1^, r2^]; ENDCASE => ERROR Error[environment, stack, IO.PutFR["%g not a number", IO.refAny[next]]]; r1: Real => WITH next SELECT FROM i2: Int => ans _ ans AND ir.Reals[r1^, i2^]; r2: Real => ans _ ans AND ir.Reals[r1^, r2^]; ENDCASE => ERROR Error[environment, stack, IO.PutFR["%g not a number", IO.refAny[next]]]; ENDCASE => ERROR Error[environment, stack, IO.PutFR["%g not a number", IO.refAny[left]]]; ENDLOOP; cooked _ IF ans THEN $T ELSE NIL; END; IntRealCond: TYPE = REF IntRealCondRep; IntRealCondRep: TYPE = RECORD [Ints: IntCondProc, Reals: RealCondProc]; IntCondProc: TYPE = PROC [left, right: INT] RETURNS [BOOLEAN]; RealCondProc: TYPE = PROC [left, right: REAL] RETURNS [BOOLEAN]; LtInts: IntCondProc = {RETURN [left < right]}; LeInts: IntCondProc = {RETURN [left <= right]}; GtInts: IntCondProc = {RETURN [left > right]}; GeInts: IntCondProc = {RETURN [left >= right]}; LtReals: RealCondProc = {RETURN [left < right]}; LeReals: RealCondProc = {RETURN [left <= right]}; GtReals: RealCondProc = {RETURN [left > right]}; GeReals: RealCondProc = {RETURN [left >= right]}; Setup: PROC = BEGIN RegisterPrimitiveDefiner[DefineNumberStuff, front]; END; Setup[]; END.