<< JunoAlgebraImpl.mesa (ex JunoAlgebraImplB.mesa)>> <<>> <> <> <> <> << This module is concerned with the interpretation of Juno symbolic expressions. It defines the semantics of the Juno language.>> << THINGS TO FIX:.>> << TO FIX: Parser: check priority of $rel (must be greater than approx, but less than constraints).>> << TO FIX: Add more intrinsics?>> << TO FIX: Parser: justified, font, size, face as separate operators.>> << TO FIX: Body: handle state-pushing actions correctly. Note their nesting structure.>> << TO FIX: Parse window: make proc alist private. Should return lambda expressions.>> << TO FIX: more operations: xcoord, ycoord, plus, minus, times, div, floor, dec, inc, first, rest, cons (infix), dist (infix).>> << TO FIX: accept a pair of coordinates everywhere a point is needed (create a detached point with fixed=true). In local declarations, fully evaluate hint. In constraints, fully evaluate arguments and coerce them to points.>> DIRECTORY JunoStorage USING [Point, PointList, Coords, Frame, Item, ItemList, ItemArgs, Cons, GcList, GcPoints, GcItems, NewPoint, InsertPoint, NewItem, InsertItem, ItemKind, ConstrKind], JunoAlgebra, JunoUserEvents USING [Blink], JunoMatrix USING [Matrix, GetFrameMatrix, MapCoords], JunoOldSolver USING [Solve, Outcome], JunoGraphics USING [DrawEdge, DrawArc, AppendEdge, AppendArc, FillTrajectory, GcTrajectory, SetColor, SetEnds, SetWidth, SetFontName, SetFontSize, SetFontFace, Color, Trajectory, DrawRope, IntensityToColor, RGBToColor, black, white, SetJustification], JunoExpressions, JunoGlobalAlist USING[GetDef], List USING [Length], Real USING [RoundI, SqRt, Fix], Rope USING [ROPE], Atom USING [GetPName]; JunoAlgebraImpl: PROGRAM IMPORTS List, JunoGraphics, JunoExpressions, JunoStorage, JunoOldSolver, JunoUserEvents, JunoMatrix, JunoGlobalAlist, Atom, Real EXPORTS JunoAlgebra = BEGIN OPEN JunoExpressions, JunoAlgebra, Stor: JunoStorage, Gr: JunoGraphics, Evs: JunoUserEvents, Solv: JunoOldSolver, Glob: JunoGlobalAlist, Mat: JunoMatrix, Atom, Rope; << - - - - IMPORTED TYPES>> Frame: TYPE = Stor.Frame; << - - - - ALISTS >> GetDef: PUBLIC PROC [name: ATOM, alist: AList] RETURNS [value: Value] = BEGIN WHILE alist # NIL DO IF alist.first = name THEN RETURN [alist.rest.first]; alist _ alist.rest.rest ENDLOOP; RETURN [NIL] END; AddDef: PUBLIC PROC [name: ATOM, value: Value, alist: AList] RETURNS [newAlist: AList] = BEGIN newAlist _ Stor.Cons[name, Stor.Cons[value, alist]] END; << - - - - EVAL >> Eval: PUBLIC PROC [expr: Se, alist: AList, cmd: BOOL _ FALSE] RETURNS [value: Value] = BEGIN IF expr=NIL THEN {value _ NIL; RETURN}; WITH expr SELECT FROM atom: ATOM => {IF atom = skip THEN {value _ NIL; RETURN}; IF cmd THEN {value _ EvalFunc[atom, alist]; IF Cadr[value] # NIL THEN {value _ SIGNAL EvError[GetPName[atom], " requires arguments"]} ELSE {value _ Eval[Caddr[value], NIL, cmd]}} ELSE {value _ GetDef[atom, alist]; IF value = NIL THEN {value _ SIGNAL EvError["Undefined variable: ", GetPName[atom]]}}}; rr: REF REAL => {Must[NOT cmd]; value _ rr}; ri: REF INT => {Must[NOT cmd]; value _ ri}; rope: ROPE => {Must[NOT cmd]; value _ rope}; list: LIST OF Se => {atom: ATOM _ NARROW[list.first]; IF list.rest = NIL THEN -- empty matchfix (?) {Must[NOT cmd]; value _ IF atom # leftPren THEN SIGNAL EvError ["Missing operand(s) of ", GetPName[atom]] ELSE NIL} ELSE IF atom = comma THEN {Must[NOT cmd]; value _ EvArgList[expr, alist]} ELSE IF list.rest.rest = NIL THEN {value _ EvalUnary[atom, list.rest.first, alist, cmd]} ELSE {value _ EvalBinary[atom, list.rest.first, list.rest.rest.first, alist, cmd]}}; ENDCASE => {value _ SIGNAL EvError["Invalid expression"]} END; EvError: PUBLIC SIGNAL [item1, item2, item3: ROPE _ NIL] RETURNS [value: Value] = CODE; Must: PROC [bool: BOOL] = {IF NOT bool THEN [] _ SIGNAL EvError ["Operation not valid in this context"]}; EvalUnary: PROC [op: ATOM, arg: Se, alist: AList, cmd: BOOL] RETURNS [value: Value] = <).>> <> <> BEGIN SELECT op FROM if => {value _ EvalIf[arg, alist, cmd]}; do => {Must[cmd]; value _ EvalDo[arg, alist]}; leftPren => {-- grouping parentheses value _ Eval[arg, alist, cmd]}; draw, stroke, fill => {t: Gr.Trajectory _ NIL; HandlePiece: PROC [a: Se] = {-- a is (leftPren (comma )) -- or (leftparen (comma (comma (comma )))) b: ValueList = EvArgList[Cadr[a], alist]; IF b.rest.rest = NIL THEN {p: Coords = CoerceToCoords[b.first]; q: Coords = CoerceToCoords[b.rest.first]; SELECT op FROM draw, stroke => {Gr.DrawEdge[p, q, FALSE]}; fill => {t _ Gr.AppendEdge[t, p, q]}; ENDCASE} ELSE {p: Coords = CoerceToCoords[b.first]; r: Coords = CoerceToCoords[b.rest.first]; s: Coords = CoerceToCoords[b.rest.rest.first]; q: Coords = CoerceToCoords[b.rest.rest.rest.first]; SELECT op FROM draw, stroke => {Gr.DrawArc[p, r, s, q, FALSE]}; fill => {t _ Gr.AppendArc[t, p, r, s, q]}; ENDCASE}; Stor.GcList[b]}; Must[cmd]; MapNest [arg, comma, HandlePiece]; IF op = fill THEN {Gr.FillTrajectory[t]; Gr.GcTrajectory[t]}}; ENDCASE => {value _ ApplyUnaryOp [op: op, arg: Eval[arg, alist, FALSE], cmd: cmd]} END; EvalBinary: PROC [op: ATOM, larg, rarg: Se, alist: AList, cmd: BOOL] RETURNS [value: Value] = < ).>> <> <> BEGIN SELECT op FROM semicolon => {[] _ Eval[larg, alist, TRUE]; value _ Eval[rarg, alist, cmd]}; assign => {a: ValueList = EvArgList[larg, alist]; b: ValueList = EvArgList[rarg, alist]; AssignPoint: PROC [p, q: Point] = {p.coords _ q.coords}; al: ValueList _ a; bl: ValueList _ b; Must[cmd]; WHILE al # NIL DO AssignPoint[NARROW[al.first], NARROW[bl.first]]; al _ al.rest; bl _ bl.rest ENDLOOP; Stor.GcList[a]; Stor.GcList[b]; value _ NIL}; leftPren => {-- matchfix parenthesis (function call) args: ValueList = EvArgList[rarg, alist]; [] _ Apply[EvalFunc[NARROW[larg], alist], args]; Stor.GcList[args]}; paint => {old: Gr.Color = Gr.SetColor[EvalColor[larg, alist]]; value _ Eval[rarg, alist, cmd]; [] _ Gr.SetColor[old]}; ends => {old: ATOM = Gr.SetEnds[NARROW[larg]]; value _ Eval[rarg, alist, cmd]; [] _ Gr.SetEnds[old]}; width => {old: REAL = Gr.SetWidth[EvalWidth[larg, alist]]; value _ Eval[rarg, alist, cmd]; [] _ Gr.SetWidth[old]}; font => {old: ROPE = Gr.SetFontName[NARROW[Eval[larg, alist, FALSE]]]; value _ Eval[rarg, alist, cmd]; [] _ Gr.SetFontName[old]}; size => {old: REAL = Gr.SetFontSize[CoerceToReal[Eval[larg, alist]]]; value _ Eval[rarg, alist, cmd]; [] _ Gr.SetFontSize[old]}; face => {old: ATOM = Gr.SetFontFace[NARROW[larg]]; value _ Eval[rarg, alist]; [] _ Gr.SetFontFace[old]}; justified => {old: ATOM = Gr.SetJustification[NARROW[larg]]; value _ Eval[rarg, alist]; [] _ Gr.SetJustification[old]}; ENDCASE => {value _ ApplyBinaryOp [op: op, larg: Eval[larg, alist, FALSE], rarg: Eval[rarg, alist, FALSE], cmd: cmd]} END; EvArgList: PROC [expr: Se, alist: AList] RETURNS [vlist: LIST OF Value] = <> <> <> <> <> <> BEGIN elist: LIST OF Se _ UnNest[expr, comma]; vlist _ elist; WHILE elist # NIL DO elist.first _ Eval[elist.first, alist, FALSE]; elist _ elist.rest ENDLOOP END; EvalVar: PUBLIC PROC[atom: ATOM, alist: AList] RETURNS [value: Se] = <> <> <> BEGIN value _ GetDef[atom, alist]; IF value = NIL THEN {value _ SIGNAL EvError["Undefined variable: ", GetPName[atom]]} END; EvalFunc: PUBLIC PROC[atom: ATOM, alist: AList] RETURNS [value: Se] = <> <> BEGIN value _ Glob.GetDef[atom]; IF value = NIL THEN {value _ SIGNAL EvError["Undefined function: ", GetPName[atom]]} ELSE IF NOT ISTYPE [value, LIST OF Se] OR Car[value] # lambda THEN {value _ SIGNAL EvError["Invalid definition: ", GetPName[atom]]} END; colorAlist: AList _ InitColorAlist[]; <> EvalColor: PUBLIC PROC [expr: Se, alist: AList] RETURNS [color: Gr.Color] = <> BEGIN w: Value; << Is it a reserved color name? >> WITH expr SELECT FROM atom: ATOM => {cr: REF _ GetDef[atom, colorAlist]; IF cr # NIL THEN RETURN[NARROW[cr]]} ENDCASE; << Didn't find it - evaluate and coerce to color>> w _ Eval[expr, alist, FALSE]; WITH w SELECT FROM wr: REF REAL => {RETURN [Gr.IntensityToColor[wr^]]}; wi: REF INT => {RETURN [Gr.IntensityToColor[wi^]]}; wl: LIST OF Value => {ToByte: PROC[r: Value] RETURNS [REAL] = {RETURN[Real.RoundI[MAX[0.0, MIN[255.0, CoerceToReal[r]]]]]}; red: REAL = CoerceToReal[wl.first]; green: REAL = IF wl.rest = NIL THEN 0 ELSE CoerceToReal[wl.rest.first]; blue: REAL = IF wl.rest = NIL OR wl.rest.rest = NIL THEN 0 ELSE CoerceToReal[wl.rest.rest.first]; RETURN [Gr.RGBToColor[red, green, blue]]} ENDCASE => {[] _ SIGNAL EvError["Invalid color specification"]; RETURN [Gr.IntensityToColor[1]]} END; InitColorAlist: PROC RETURNS [AList] = BEGIN Nc: PROC [r, g, b: REAL] RETURNS [color: Gr.Color] = INLINE {RETURN[Gr.RGBToColor[r, g, b]]}; RETURN [LIST[ -- color values $black, Gr.black, $white, Gr.white, $grey, Gr.IntensityToColor[0.5], $gray, Gr.IntensityToColor[0.5], $red, Nc[1.0, 0.0, 0.0], $blue, Nc[0.0, 0.0, 1.0], $green, Nc[0.0, 1.0, 0.0], $darkRed, Nc[0.8, 0.3, 0.0], $darkBlue, Nc[0.0, 0.3, 0.8], $darkGreen, Nc[0.0, 0.8, 0.3], $lightRed, Nc[1.0, 0.5, 0.5], $lightBlue, Nc[0.5, 0.8, 1.0], $lightGreen, Nc[0.8, 1.0, 0.5], $yellow, Nc[1.0, 1.0, 0.0], $cyan, Nc[0.0, 1.0, 1.0], $magenta, Nc[1.0, 0.0, 1.0], $darkYellow, Nc[0.9, 0.8, 0.0], $darkCyan, Nc[0.0, 0.8, 0.8], $darkMagenta, Nc[0.8, 0.0, 0.8], $lightYellow, Nc[1.0, 1.0, 0.5], $lightCyan, Nc[0.5, 1.0, 1.0], $lightMagenta, Nc[1.0, 0.5, 1.0] ]] END; EvalWidth: PROC [expr: Se, alist: AList] RETURNS [width: REAL] = <> BEGIN w: Value _ Eval[expr, alist, FALSE]; WITH w SELECT FROM wr: REF REAL => {RETURN [wr^]}; wi: REF INT => {RETURN [wi^]}; wl: LIST OF Value => {p: Coords = CoerceToCoords[wl.first]; q: Coords = CoerceToCoords[wl.rest.first]; RETURN [Real.SqRt[(p.x - q.x) * (p.x - q.x) + (p.y - q.y) * (p.y - q.y)]]} ENDCASE => {[] _ SIGNAL EvError["Invalid width specification"]; RETURN [1]} END; EvalIf: PROC [expr: Se, alist: AList, cmd: BOOL] RETURNS [value: Value] = <> < ) )>> BEGIN OPEN Stor; alternatives: LIST OF Se = UnNest[expr, obox]; bestOutcome: Solv.Outcome _ false; choice: Se _ NIL; -- last alternative whose outcome wasn't false choiceSol: AList _ alist; -- solution corresponding to choice choicePts: PointList _ [NIL, NIL]; -- points corresponding to choice FOR alts: LIST OF Se _ alternatives, alts.rest WHILE alts # NIL AND bestOutcome#true DO outcome: Solv.Outcome; solution: AList; points: PointList; stNode: Se _ Cadr[alts.first]; -- (st ) [outcome, solution, points] _ TryToSolve [stNode, alist]; IF outcome=false OR outcome<=bestOutcome THEN {Stor.GcList[start: solution, lim: alist]; Stor.GcPoints[points.first]} ELSE {IF choice # NIL THEN -- reclaim best previous choice and replace it {GcList[start: choiceSol, lim: alist]; Stor.GcPoints[choicePts.first]}; bestOutcome _ outcome; choice _ alts.first; choiceSol _ solution; choicePts _ points} ENDLOOP; IF bestOutcome = false THEN {Evs.Blink["IF statement aborted!"]; value _ NIL} ELSE {IF bestOutcome # true THEN Evs.Blink["IF statement didn't converge!"]; value _ Eval [Caddr[choice], choiceSol, cmd]; Stor.GcList[start: choiceSol, lim: alist]; Stor.GcPoints[choicePts.first]}; Stor.GcList [alternatives] END; EvalDo: PROC [expr: Se, alist: AList] RETURNS [value: Value] = <> < ) )>> BEGIN OPEN Stor; alternatives: LIST OF Se = UnNest[expr, obox]; bestOutcome: Solv.Outcome _ true; WHILE bestOutcome = true DO bestOutcome _ false; FOR alts: LIST OF Se _ alternatives, alts.rest WHILE alts # NIL DO outcome: Solv.Outcome; solution: AList; points: PointList; stNode: Se _ Cadr[alts.first]; -- (st ) [outcome, solution, points] _ TryToSolve [stNode, alist]; IF outcome=true THEN {[] _ Eval [Caddr[alts.first], solution, TRUE]}; Stor.GcList[start: solution, lim: alist]; Stor.GcPoints[points.first]; IF outcome > bestOutcome THEN {bestOutcome _ outcome} ENDLOOP; IF bestOutcome=uncertain THEN {Evs.Blink["IF statement didn't converge!"]}; ENDLOOP; Stor.GcList [alternatives]; value _ NIL END; TryToSolve: PROC [stNode: Se, alist: AList] RETURNS [outcome: Solv.Outcome, newAlist: AList, newPoints: Stor.PointList] = < ) or just >> BEGIN locals: LIST OF Se _ NIL; constrs: Stor.ItemList; IF ISTYPE[stNode, LIST OF Se] AND Car[stNode] = suchThat THEN {localDecls: LIST OF Se _ UnNest[Cadr[stNode], comma]; -- Create all local points (at hinted positions) and put them in front of the alist [newPoints, newAlist] _ CreateLocals [localDecls, alist]; constrs _ UnNestConstrs[Caddr[stNode], newAlist]; Stor.GcList[localDecls]} ELSE {newAlist _ alist; newPoints _ [NIL, NIL]; constrs _ UnNestConstrs[stNode, newAlist]}; -- Solve the constraints for the local points, and fix them outcome _ Solv.Solve[constrs, 0.1]; FOR p: Point _ newPoints.first, p.link WHILE p # NIL DO p.fixed _ TRUE ENDLOOP; Stor.GcItems[constrs.first] END; CreateLocals: PROC [localDecls: LIST OF Se, alist: AList] RETURNS [newPoints: Stor.PointList, newAlist: AList] = <> <> < ) or just >> < must evaluate to a point or a pair of numeric values.>> <> BEGIN decls: LIST OF Se _ localDecls; coords: Coords; point: Point; name: ATOM; newAlist _ alist; newPoints _ [NIL, NIL]; UNTIL decls = NIL DO WITH decls.first SELECT FROM atom: ATOM => {coords _ [0, 0]; name _ atom}; list: LIST OF Se => {IF list.first # approx THEN {[] _ ERROR EvError["Invalid declaration"]}; coords _ EvalCoords[list.rest.rest.first, newAlist]; name _ NARROW[list.rest.first]}; ENDCASE => {[] _ ERROR EvError["Invalid declaration"]}; point _ Stor.NewPoint[coords: coords, visible: FALSE]; newAlist _ Stor.Cons[name, Stor.Cons[point, newAlist]]; newPoints _ Stor.InsertPoint[p: point, ant: newPoints.last, list: newPoints]; decls _ decls.rest ENDLOOP END; EvalCoords: PROC [expr: Se, alist: AList] RETURNS [coords: Coords] = <> <> < ), to avoid allocation. >> BEGIN RETURN[CoerceToCoords[Eval[expr, alist, FALSE]]] END; EvalFrame: PROC [expr: Se, alist: AList] RETURNS [frame: Frame] = <> <> < ), to avoid allocation. >> BEGIN RETURN[CoerceToFrame[Eval[expr, alist, FALSE]]] END; UnNestConstrs: PROC [cNest: Se, alist: AList] RETURNS [constrs: Stor.ItemList] = <> <> BEGIN ExpandSimpleConstr: PROC [cex: Se] RETURNS [constr: Stor.Item] = <> < ) or ( ) or where the args must evaluate to lists of points.>> BEGIN WITH cex SELECT FROM cl: LIST OF REF ANY => BEGIN op: ATOM = NARROW[cl.first]; kind: Stor.ConstrKind _ SELECT op FROM hor => hor, ver => ver, para => para, perp => perp, cong => cong, at => at, ccw => ccw, ENDCASE => ERROR; SELECT kind FROM hor, ver => {largs: Stor.ItemArgs = CoerceToPoints[Eval[cl.rest.first, alist, FALSE]]; constr _ Stor.NewItem[kind: kind, args: largs]}; para, cong, perp => {largs: Stor.ItemArgs = CoerceToPoints[Eval[cl.rest.first, alist, FALSE]]; rargs: Stor.ItemArgs = CoerceToPoints[Eval[cl.rest.rest.first, alist, FALSE]]; constr _ Stor.NewItem [kind: kind, args: CONS[largs.first, CONS[largs.rest.first, rargs]]]}; at => {p: Point = CoerceToPoint[Eval[cl.rest.first, alist, FALSE]]; coords: Coords = CoerceToCoords[Eval[cl.rest.rest.first, alist, FALSE]]; constr _ Stor.NewItem [kind: kind, args: LIST [p, NEW [REAL _ coords.x], NEW [REAL _ coords.y]]]}; ccw => {largs: Stor.ItemArgs = CoerceToPoints[Eval[cl.rest.first, alist, FALSE]]; constr _ Stor.NewItem [kind: kind, args: largs]}; ENDCASE => {[] _ ERROR EvError["Invalid constraint: ", GetPName[op]]} END; ENDCASE => {[] _ ERROR EvError ["Invalid constraint"]}; END; ProcessConstr: PROC [cex: Se] = <> {IF cex # true THEN {constr: Stor.Item; IF Car[cex] = rel THEN {constr _ ExpandSimpleConstr[Cadr[cex]]; constr.frame _ CoerceToFrame[Eval[Caddr[cex], alist, FALSE]]} ELSE {constr _ ExpandSimpleConstr[cex]}; constrs _ Stor.InsertItem [item: constr, ant: constrs.last, list: constrs]}}; constrs _ [NIL, NIL]; MapNest[cNest, and, ProcessConstr] END; << - - - - APPLY >> Apply: PUBLIC PROC[op: Se, args: ValueList, cmd: BOOL _ FALSE] RETURNS [value: Value] = BEGIN WITH op SELECT FROM list: LIST OF Se => {IF list.first = lambda THEN {parms: Se = list.rest.first; -- a nest of atoms separated by commas body: Se = list.rest.rest.first; alist: AList = BindArgs [parms, args]; -- Note: free variables are not allowed value _ Eval[body, alist, cmd]} ELSE {[] _ ERROR EvError ["Invalid function"]}}; atom: ATOM => {value _ ApplyUnaryOp[atom, args, cmd]}; ENDCASE => {value _ SIGNAL EvError["Invalid operation"]}; END; ApplyUnaryOp: PROC[op: ATOM, arg: Value, cmd: BOOL] RETURNS [value: Value] = BEGIN SELECT op FROM print => {args: LIST OF Se = NARROW[arg]; rope: ROPE = NARROW[args.first]; p: Point = NARROW[args.rest.first]; Must[cmd]; Gr.DrawRope [coords: p.coords, rope: rope]; value _ NIL}; minus, dec, inc => {a: INTEGER = SELECT op FROM minus=>-1, dec, inc=>1, ENDCASE => ERROR; b: INTEGER = SELECT op FROM minus=>0, dec=>-1, inc=>1, ENDCASE => ERROR; Must[NOT cmd]; WITH arg SELECT FROM rr: REF REAL => {value _ NEW[REAL _ a*rr^+b]}; ri: REF INT => {value _ NEW[INT _ a*ri^+b]}; ENDCASE => {[] _ ERROR EvError ["Number expected"]}}; floor => {x: REAL = CoerceToReal [arg]; flr: INT = Real.Fix[x]; Must[NOT cmd]; value _ NEW[INT _ (IF x < flr THEN flr-1 ELSE flr)]}; first, rest => {list: LIST OF Value = NARROW [arg]; Must[NOT cmd]; value _ IF op = first THEN list.first ELSE list.rest}; xcoord, ycoord => {coords: Coords = CoerceToCoords[arg]; Must[NOT cmd]; value _ NEW[REAL _ IF op = xcoord THEN coords.x ELSE coords.y]}; ENDCASE => {value _ SIGNAL EvError["Unknown operator: ", GetPName[op]]}; END; fMat: REF Mat.Matrix _ NEW [Mat.Matrix]; ApplyBinaryOp: PROC[op: ATOM, larg, rarg: Value, cmd: BOOL] RETURNS [value: Value] = BEGIN SELECT op FROM rel => {coords: Coords _ CoerceToCoords [larg]; frame: Frame _ CoerceToFrame[rarg]; Must[NOT cmd]; fMat _ Mat.GetFrameMatrix[frame, fMat]; coords _ Mat.MapCoords[coords, fMat]; value _ LIST[NEW[REAL _ coords.x], NEW[REAL _ coords.y]]}; plus, minus, times, div => {x: REAL = CoerceToReal[larg]; y: REAL = CoerceToReal[rarg]; Must[NOT cmd]; value _ NEW[REAL _ SELECT op FROM plus => x+y, minus => x-y, times => x*y, div => x/y, ENDCASE => ERROR]}; cons => {Must[NOT cmd]; value _ CONS[larg, NARROW [rarg, LIST OF Value]]}; dist => {p: Coords = CoerceToCoords [larg]; q: Coords = CoerceToCoords [rarg]; Must[NOT cmd]; value _ NEW[REAL _ Real.SqRt[(p.x-q.x)*(p.x-q.x)+ (p.y-q.y)*(p.y-q.y)]]}; ENDCASE => {value _ SIGNAL EvError["Unknown operator: ", GetPName[op]]}; END; BindArgs: PROC [parms: Se, args: ValueList] RETURNS [alist: AList] = BEGIN WITH parms SELECT FROM list: LIST OF Se => {IF list.first = comma THEN {IF args=NIL THEN {[] _ ERROR EvError["Missing arguments"]}; alist _ Stor.Cons[list.rest.first, Stor.Cons[args.first, BindArgs[list.rest.rest.first, args.rest]]]} ELSE {[] _ ERROR EvError["Invalid formal parameters"]}}; atom: ATOM => {IF args=NIL THEN {[] _ ERROR EvError["Missing arguments"]}; IF args.rest # NIL THEN {[] _ SIGNAL EvError["Excess arguments"]}; alist _ LIST[atom, args.first]}; ENDCASE => {[] _ ERROR EvError["Invalid formal parameters"]}; END; << - - - - PROCEDURE CALL>> Call: PUBLIC PROC [func: ATOM, args: ValueList] = {[] _ Apply[EvalFunc[func, NIL], args, TRUE]}; << - - - - MISCELLANEOUS SUPPORT ROUTINES >> UnNest: PROC [expr: Se, op: ATOM] RETURNS [list: LIST OF Se] = <> <> <> BEGIN DoUnNest: PROC [e: Se] RETURNS [LIST OF Se] = {er: LIST OF Se _ NIL; WITH e SELECT FROM list: LIST OF Se => {IF list # NIL AND list.first = op THEN {e _ list.rest.first; er _ list}}; ENDCASE; RETURN [Stor.Cons [e, IF er = NIL THEN NIL ELSE DoUnNest[er.rest.rest.first]]]}; RETURN[DoUnNest[expr]] END; MapNest: PROC [expr: Se, op: ATOM, Proc: PROC[Se]] = <> BEGIN DoMapNest: PROC [e: Se] = {er: LIST OF Se; WITH e SELECT FROM list: LIST OF Se => {IF list # NIL AND list.first = op THEN {e _ list.rest.first; er _ list}}; ENDCASE; Proc[e]; IF er # NIL THEN DoMapNest[er.rest.rest.first]}; DoMapNest[expr] END; CoerceToCoords: PROC [val: Value] RETURNS [coords: Coords] = <> <> BEGIN WITH val SELECT FROM pp: Point => {coords _ pp.coords}; list: LIST OF Value => {IF list=NIL OR list.rest=NIL OR list.rest.rest # NIL THEN {[] _ ERROR EvError["Invalid coordinates"]}; coords.x _ CoerceToReal[list.first]; coords.y _ CoerceToReal[list.rest.first]}; ENDCASE => {[] _ ERROR EvError["Invalid point hint"]} END; CoerceToReal: PROC[r: Value] RETURNS [real: REAL] = BEGIN WITH r SELECT FROM ri: REF INT => real _ ri^; rr: REF REAL => real _ rr^; ENDCASE => [] _ ERROR EvError["Number expected"] END; CoerceToPoint: PROC[r: Value] RETURNS [p: Point] = BEGIN WITH r SELECT FROM pp: Point => p _ pp; list: LIST OF Value => {IF list.rest = NIL THEN {p _ CoerceToPoint[list.first]} ELSE {coords: Coords _ CoerceToCoords[r]; p _ Stor.NewPoint[coords: coords, visible: FALSE]; p.fixed _ TRUE}}; ENDCASE => [] _ ERROR EvError["Point expected"] END; CoerceToPoints: PROC[r: Value] RETURNS [pl: LIST OF REF ANY] = BEGIN IF r = NIL THEN {RETURN[NIL]}; WITH r SELECT FROM pp: Point => pl _ LIST[pp]; list: LIST OF Value => {IF list.rest = NIL THEN {pl _ LIST[CoerceToPoint[list.first]]} ELSE IF ISTYPE [list.first, REF INT] OR ISTYPE [list.first, REF REAL] THEN {pl _ LIST[CoerceToPoint[list]]} ELSE {Crc: PROC [x: LIST OF Value] RETURNS [z: LIST OF REF ANY] = {RETURN[IF x=NIL THEN NIL ELSE CONS [CoerceToPoint[x.first], Crc[x.rest]]]}; pl _ Crc[list]}}; ENDCASE => [] _ ERROR EvError["Point list expected"] END; CoerceToFrame: PROC[r: Value] RETURNS [f: Frame] = BEGIN list: LIST OF REF ANY = CoerceToPoints[r]; f _ [NIL, NIL, NIL]; IF list = NIL THEN RETURN; f.org _ NARROW [list.first]; IF list.rest = NIL THEN RETURN; f.hor _ NARROW [list.rest.first]; IF list.rest.rest = NIL THEN RETURN; f.ver _ NARROW [list.rest.rest.first]; IF list.rest.rest.rest # NIL THEN [] _ ERROR EvError["Invalid frame"] END; Length: PROC [l: REF ANY] RETURNS [INT] = {RETURN[List.Length[NARROW[l]]]}; Atomp: PROC [f: REF ANY] RETURNS [BOOL] = {RETURN[ISTYPE[f, ATOM]]}; UndefinedCommand: ERROR [name: ATOM] = CODE; UnboundPointName: ERROR[name: ATOM] = CODE; Atomic: PROC [f: Se] RETURNS [BOOL] = {RETURN[ ~ ISTYPE[f, LIST OF REF ANY]]}; --! should return FALSE on any list type END.