DIRECTORY
  HerculesStorage,
  HerculesAlgebra,
  HerculesImage,
  HerculesSolver,
  HerculesGraphics,
  Graphics USING[black, white, Color, StrokeEnds],
  Real USING [RoundLI, RoundI, FRem, SqRt],
  Rope,
  Convert USING [RopeFromInt, RopeFromReal],
  Atom;

HerculesAlgebraImpl: PROGRAM

  IMPORTS
     HerculesGraphics, HerculesImage, HerculesStorage, HerculesSolver, Atom, Real, Convert
  EXPORTS
     HerculesAlgebra

=

BEGIN

OPEN
  Stor: HerculesStorage,
  Gr: HerculesGraphics,
  Im: HerculesImage,
  Solv: HerculesSolver,
  HerculesAlgebra;

and: PUBLIC ATOM _ $and;
approx: PUBLIC ATOM _ Atom.MakeAtom["=="];
assign: PUBLIC ATOM _ Atom.MakeAtom[":="];
at: PUBLIC ATOM _ $at;
blow: PUBLIC ATOM _ Atom.MakeAtom["!"];
ccw: PUBLIC ATOM _ $ccw;
colon: PUBLIC ATOM _ Atom.MakeAtom[":"];
comma: PUBLIC ATOM _ Atom.MakeAtom[","];
cong: PUBLIC ATOM _ $cong;
div: PUBLIC ATOM _ $div;
do: PUBLIC ATOM _ $do;
draw: PUBLIC ATOM _ $draw;
ends: PUBLIC ATOM _ $ends;
equals: PUBLIC ATOM _ Atom.MakeAtom["="];
fill: PUBLIC ATOM _ $fill;
font: PUBLIC ATOM _ $font;
gtr: PUBLIC ATOM _ Atom.MakeAtom[">"];
hor: PUBLIC ATOM _ $hor;
if: PUBLIC ATOM _ $if;
is: PUBLIC ATOM _ $is;
leftBrack: PUBLIC ATOM _ Atom.MakeAtom["["];
leftPren: PUBLIC ATOM _ Atom.MakeAtom["("];
lss: PUBLIC ATOM _ Atom.MakeAtom["<"];
minus: PUBLIC ATOM _ Atom.MakeAtom["-"];
mod: PUBLIC ATOM _ $mod;
obox: PUBLIC ATOM _ Atom.MakeAtom["//"];
paint: PUBLIC ATOM _ $paint;
para: PUBLIC ATOM _ $para;
perp: PUBLIC ATOM _ $perp;
plus: PUBLIC ATOM _ Atom.MakeAtom["+"];
print: PUBLIC ATOM _ $print;
rel: PUBLIC ATOM _ $rel;
rightArrow: PUBLIC ATOM _ Atom.MakeAtom["->"];
rightBrack: PUBLIC ATOM _ Atom.MakeAtom["]"];
semicolon: PUBLIC ATOM _ Atom.MakeAtom[";"];
size: PUBLIC ATOM _ $size;
skip: PUBLIC ATOM _ $skip;
slash: PUBLIC ATOM _ Atom.MakeAtom["/"];
stroke: PUBLIC ATOM _ $stroke;
style: PUBLIC ATOM _ $style;
suchThat: PUBLIC ATOM _ Atom.MakeAtom["|"];
times: PUBLIC ATOM _ Atom.MakeAtom["*"];
true: PUBLIC ATOM _ $T;
ver: PUBLIC ATOM _ $ver;
width: PUBLIC ATOM _ $width;

basicGlobals: PUBLIC Alist  _ InitGlobals[];  -- (name value   name value   ... ) 

InitGlobals: PROC RETURNS [Alist] = 

BEGIN
   N000: NumPtr = NEW [NumCell _ [val: 000, const: TRUE, int: TRUE]];
   N064: NumPtr = NEW [NumCell _ [val: 064, const: TRUE, int: TRUE]];
   N128: NumPtr = NEW [NumCell _ [val: 128, const: TRUE, int: TRUE]];
   N192: NumPtr = NEW [NumCell _ [val: 192, const: TRUE, int: TRUE]];
   N224: NumPtr = NEW [NumCell _ [val: 224, const: TRUE, int: TRUE]];
   N255: NumPtr = NEW [NumCell _ [val: 255, const: TRUE, int: TRUE]];

   RETURN [LIST[

      -- color values
      $black,			LIST [N000, N000, N000],
      $white,			LIST [N255, N255, N255],
      $grey,				LIST [N128, N128, N128],
      $red,				LIST [N255, N000, N000],
      $blue,				LIST [N000, N000, N255],
      $green,			LIST [N000, N255, N000],
      $darkred,			LIST [N192, N064, N000],
      $darkblue,		LIST [N000, N064, N192],
      $darkgreen,		LIST [N000, N192, N064],
      $lightred,			LIST [N255, N128, N128],
      $lightblue,		LIST [N128, N192, N255],
      $lightgreen,		LIST [N192, N255, N128],
      $yellow,			LIST [N255, N255, N000],
      $cyan,				LIST [N000, N255, N255],
      $magenta,			LIST [N255, N000, N255],
      $darkyellow,		LIST [N224, N192, N000],
      $darkcyan,		LIST [N000, N192, N192],
      $darkmagenta,	LIST [N192, N000, N192],
      $lightyellow,		LIST [N255, N255, N128],
      $lightcyan,		LIST [N128, N255, N255],
      $lightmagenta,	LIST [N255, N128, N255],

      -- styles and fonts
      $TimesRoman, "TimesRoman",
      $Helvetica,     "Helvetica",
      $Gacha,         "Gacha",
      $roman,     NEW[NumCell _ [val:0]],
      $italic,      NEW[NumCell _ [val:1]],
      $bold,       NEW[NumCell _ [val:2]],
      $boldItalic,  NEW[NumCell _ [val:3]]

      -- stroke end types
      $butt, $butt,
      $square, $square,
      $round, $round,

      -- basic operators
      comma, comma,
      semicolon, semicolon,
      plus, plus,
      minus, minus,
      times, times,
      slash, slash,
      div, div,
      mod, mod,
      paint, paint,
      draw, draw,
      fill, fill,
      print, print,
      leftPren, leftPren,
      leftBrack, leftBrack,
      assign, assign,
      quote, quote,
      blow, blow,
      skip, skip,
      size, size,
      font, font,
      style, style,
      colon, colon,
      if, if,
      do, do,
      list, list]]
END;

globals: PUBLIC Alist  _ basicGlobals;  -- (name value   name value   ... ) 

AddGlobalDef: PUBLIC PROC [name: ATOM, value: Value] =

BEGIN
    p: Alist _ globals;
    WHILE p # NIL DO
      IF p.first = name THEN
        {p.rest.first _ value; RETURN};
      p _ p.rest.rest
     ENDLOOP;
    globals _ InsertDef[name, value, globals]
END;

EvApError: PUBLIC ERROR [why: ROPE] = CODE;

Eval: PUBLIC PROC [e: Se, alist: Alist] RETURNS [results: Results] =
  -- NOTE: assumes/guarantees that each call to Eval allocates fresh cells for the
  --    topmost level of results.

BEGIN

  IF e = NIL THEN -- what should it be?
   {ERROR}
  ELSE WITH e SELECT FROM

   ee: FunPtr =>

   {results _ LIST[ee]};

   ee: NumPtr =>

   {results _ LIST[ee]};

   ee: RopePtr =>

   {results _ LIST[ee]};

   ee: ATOM =>

   {results _ EvalAtom[ee, alist, mode]};

   ee: LIST OF Se =>

   BEGIN

  len: INT = List.Length[ee];
  funcs: Results = Eval[ee.first, alist]; -- usually with only one element
  IF funcs = NIL OR funcs.rest # NIL THEN
    {ERROR EvApError};

  SELECT len FROM

   1 => -- zerofix operator ([] and () only)

  BEGIN
    SELECT TRUE FROM

   func.first = leftPren =>

   {results _ NIL};

   func.first = leftBrack =>

   {results _ LIST[NIL]};

   ENDCASE => ERROR EvApError;

  END;

   2 => -- matchfix or prefix (or postfix) operator

  BEGIN
    SELECT TRUE FROM

   func.first = if =>

   {results _ EvalIfList[Unnest[ee.rest.first, obox, NIL], alist]};

   func.first = do =>

   {results _ EvalDoList[Unnest[ee.rest.first, obox, NIL], alist]};

   func.first = quote =>

   {results _ LIST[ee.rest.first]};

   ENDCASE =>

   {-- Other prefix/postfix operators.
    -- Evaluate function and arguments and call apply.
    args: Results _ Eval[ee.rest.first, alist];
    result _ Apply [funcs.first, args]};

  END;

   3 => -- infix operator

  BEGIN
    SELECT TRUE FROM

   func.first = colon =>

   {results _ LIST [NEW[FunRec _
       [body: ee.rest.rest.first,
        parms: Unnest[ee.rest.first, comma, NIL],
        alist: alist]]]};

   List.Memb[func.first, pushStateOps] =>

      {-- Must push the graphics context before evaluating
       --    the right argument, and pop it afterwards
       largs: Results _ Eval[ee.rest.first, alist, value];
       IF largs = NIL OR largs.rest # NIL THEN ERROR EvApError;
       PushGraphicsParm[NARROW[func.first], largs.first];
       results _ Eval [ee.rest.rest.first, alist, mode];
       PopGraphicsParm[NARROW[func.first]]};

   ENDCASE =>

   {-- Other infix operators
    largs: Results _ Eval [ee.rest.first, alist];
    rargs: Results _ Eval [ee.rest.rest.first, alist];
    results _ ApplyBinary [funcs.first, largs, rargs]};

  END;

   ENDCASE => ERROR EvApError;

   END;

   ENDCASE => ERROR EvApError

END;

EvalAtom: PUBLIC PROC [atom: ATOM, alist: Alist] RETURNS [results: Results] =

BEGIN
   -- Atoms normally evaluate to a single value, obtained from alist or globals.
   -- However, the primitive atom skip evaluates to no value.
   val: Se = GetDef[atom, alist, globals];
   IF val = skip THEN results _ NIL
   ELSE results _ LIST[val]
END;

EvalIfList: PROC [elist: LIST OF Se, alist: Alist] RETURNS [results: Results] =

BEGIN
  -- Each element of elist is of the form (then (st <locals> <constaints>) <command>)
  alts: LIST OF Se _ elist;
  success, impossible: BOOL _ FALSE;
  solution: Alist;
  stNode: Se _ NIL; --  (st <locals> <constaints>)
  choice: Se _ NIL; --  last alternative that wasn't success or impossible
  choiceSol: Alist;   -- solution corresponding to choice
  WHILE alts # NIL AND NOT success DO
     stNode _ Cadr[alts.first];
     [success, impossible, solution] _ TryToSolve [stNode, alist];
     IF NOT impossible THEN
        {choice _ alts.first; choiceSol _ solution};
     IF success OR alts.rest = NIL THEN -- about to finish
        {IF choice = NIL THEN -- all alternatives returned impossible
            {Gr.Blink["IF statement aborted!"];
             results _ NIL}
         ELSE
            {results _ Eval [Caddr[choice], choiceSol]}};
     alts _ alts.rest;
    ENDLOOP
END;

EvalDoList: PROC [elist: LIST OF Se, alist: Alist] RETURNS [results: Results] =

BEGIN
  -- Each element of f is of the form (then (st <locals> <constaints>) <command>)
  alts: LIST OF Se;
  success, impossible: BOOL _ FALSE;
  solution: Alist;
  stNode: Se _ NIL; --  (st <locals> <constaints>)
  results _ NIL;
  DO
    alts _ elist;
    UNTIL success OR alts = NIL DO
       stNode _ Cadr[alts.first];
       [success, impossible, solution] _ TryToSolve [stNode, alist];
       IF success THEN
          {results _ List.NConc [results, Eval [Caddr[alts.first], solution]]};
       alts _ alts.rest
      ENDLOOP;
    IF NOT success THEN RETURN
    ENDLOOP
END;

TryToSolve: PROC [stNode: Se, alist: LIST OF Se]
  RETURNS [success, impossible: BOOL _ FALSE, newAlist: Alist] =

BEGIN
  -- stNode is of the form (st <locals> <constraints>) or just <constraints>
  localDecls, constrs: LIST OF Se _ NIL;
  newCells: LIST OF NumPtr; -- variables (& point coords) to be adjusted by the solver
  IF IsBinAppl[suchThat].fits THEN
     {localDecls: LIST OF Se _ Unnest[Cadr[stNode], comma, NIL];
      -- Create all local points (at hinted positions) and put them in front of the alist
      [newCells, newAlist] _ CreateLocals [locals, alist];
      constrs _ Unnest[Caddr[stNode], and, true]}
  ELSE
     {newAlist _ alist;
      newCells _ NIL;
      constrs _ Unnest[stNode, and, true]};
    
  -- Solve the constraints for the local points 
  [success, impossible] _ Solv.Solve[newCells, constrs];
  -- return
  RETURN[success, impossible, newAlist]
END; 

CreateLocals: PROC [localDecls: LIST OF Se, alist: Alist]
  RETURNS [newCells: LIST OF NumPtr, newAlist: Alist] =
   -- Creates local variables (adding them to the alist) and makes a list of all NumCells
   --   occuring in thir defined value.
   -- Those are the NumCells whose val fields the solver will try to adjust.

BEGIN
  -- Each element of locals has the forms
  --    (<approx> <name> <value>)
  --  where <value> is some expression.
  -- Acceptable <value>s are: NumPtr, RopePtr, atom, or list of acceptable values
  --   (in other words, no FunPtrs!). 
  -- Now allows hints to be relative to previous hints. May Greg forgive me for this... [JS] 
  decls: LIST OF Se _ localDecls;
  var, hint, hintVal: Se;
  fits: BOOL;
  newAlist _ alist;
  newCells _ NIL;
  UNTIL decls = NIL DO
     [var, hint, fits] _ IsBinAppl[decls.first, approx];
     IF NOT fits THEN ERROR;
     [hintVal, newCells] _ CreateVariable[Eval[hint, newAlist], newCells];
     newAlist _ CONS[var,  CONS[hintVal, newAlist]];
     decls _ decls.rest
    ENDLOOP
END;

CreateVariable: PROC [val: Se, prevCells: LIST OF NumPtr]
   RETURNS [cval: Se, newCells: LIST OF NumPtr] =
    -- Creates a copy of val, copying all NumCells contained in it. 
    -- Prepends to prevCells a list of all NumCells created during the copy.

BEGIN
   newCells _ prevCells;
   IF val = NIL THEN
      {cval _ NIL}
   ELSE WITH val SELECT FROM
      nn: NumPtr =>
         {cval _ NEW [NumCell _ [val: nn.val, int: FALSE, const: FALSE]];
          newCells _ CONS [cval, newCells]};
      rr: RopePtr =>
         {cval _ NEW [RopeCell _ [val: rr.val, const: FALSE]]};
      aa: ATOM =>
         {cval _ aa};
      ll: LIST OF Se =>
         {rval: LIST OF Se;
          fval: Se;
          [fval, newCells] _ CreateVariable[ll.first, newCells];
          [rval, newCells] _ CreateVariable[ll.rest, newCells];
          cval _ IF fval # ll.first OR rval#ll.rest THEN CONS [fval, rval] ELSE val};
     ENDCASE => Gr.Error["invalid hint for local variable"]
END;

PushGraphicsParm: PROC [parm: ATOM, value: Se] =

BEGIN
   -- Sets a graphics parameter to a new value, saving the old one.

   SELECT parm FROM

   font => Gr.PushFont[ToRope[value]];

   size =>  Gr.PushSize[ToNum[value]];

   style => Gr.PushStyle[ToStyle[value]];

   ends => Gr.PushEnds[ToStrokeEnds[value]];

   paint => Gr.PushColor[ToColor[value]];

   width => Gr.PushWidth[ToWidth[value]];

   ENDCASE => ERROR EvApError

END;

PopGraphicsParm: PROC [parm: ATOM] =

BEGIN
   -- Restores a graphics parameter to its old value.

   SELECT parm FROM

   font => Gr.PopFont[];

   size =>  Gr.PopSize[];

   style => Gr.PopStyle[];

   ends => Gr.PopEnds[];

   paint => Gr.PopColor[];

   width => Gr.PopWidth[];

   ENDCASE => ERROR EvApError

END;

ToStyle: PROC[s: Se] RETURNS [style: Gr.Style] =

BEGIN
  ss: INT = ToInt[s]; 
  style.italic _ (ss MOD 2 # 0);
  style.bold _ ((ss DIV 2) MOD 2 # 0);
END;

ToWidth: PROC[w: Se] RETURNS [REAL] =

BEGIN
  WITH w SELECT FROM
     fr: NumPtr => RETURN [fr.val];
     ff: LIST OF Value =>
        {p, q: Coords;
         CheckForm[w, pointPairMold];
         p _ ToCoords [ff.first];
         q _ ToCoords [ff.rest.first];
         RETURN [Real.SqRt[(p.x - q.x) * (p.x - q.x) + (p.y - q.y) * (p.y - q.y)]]};
    ENDCASE => ERROR
END;

ToColor: PROC[c: Se] RETURNS [Graphics.Color] =

BEGIN
  ToByte: PROC[r: REF ANY] RETURNS [[0..256)] =
      {RETURN[Real.RoundI[MAX[0.0, MIN[255.0, ToReal[r]]]]]};

  triple: LIST OF Se _ ToList[c, 3, 3]];
  RETURN 
        [[r: ToByte[triple.first],
          g: ToByte[triple.rest.first],
          b: ToByte[triple.rest.rest.first] ]]
END;

ToStrokeEnds: PROC[r: Se] RETURNS [Graphics.StrokeEnds] =

BEGIN
  SELECT TRUE FROM
    r = $butt => RETURN[butt];
    r = $square => RETURN[square];
    r = $round => RETURN[round]
  ENDCASE => ERROR
END;

Apply: PUBLIC PROC [function: Se, args: Results] RETURNS [results: Results] =

BEGIN
   WITH function SELECT FROM
      ff: ATOM =>
         {results _ ApplyAtom[ff, args]};
      ff: NumPtr =>
         {<require length[args] = 1, n=ff.val to be integer;
            fetch Cad^{n-1}r[args.first] or Cd^{-n}r[args.first], as appropriate>}
      ff: FunPtr =>
         {results _ ApplyFunVal [ff, args]};
      ENDCASE =>
         {Gr.Error["Invalid function"]; result _ NIL}
END;

ApplyBinary: PUBLIC PROC [function: Se, largs, rargs: Results] RETURNS [results: Results] =

BEGIN
   WITH function SELECT FROM
      ff: ATOM =>
         {results _ ApplyBinaryAtom[ff, args]};
      ff: FunPtr =>
         {results _ ApplyFunVal [ff, largs];
          IF results = NIL OR results.rest # NIL OR NOT ISTYPE[results.first, FunPtr]
             THEN ERROR;
          results _ApplyFunVal [NARROW[results.first], rargs]};
      ENDCASE =>
         {Gr.Error["Invalid function"]; result _ NIL}
END;

ApplyAtom: PUBLIC PROC [function: ATOM, args: Results]  RETURNS [results: Results] = 

BEGIN
   SELECT function FROM

     blow =>

     {-- args should be a LIST[<a single list L>] 
      IF args = NIL OR args.rest # NIL THEN ERROR EvApError;
      results _ List.Copy[NARROEW[args.first]};

     minus =>

     {-- arg should be a NumPtr or list thereof
      MinusIt: LeafMapProc =
         {RETURN[WITH e SELECT FROM
            nn: NumPtr => NEW[NumCell _ [val: -nn.val, int: nn.int, const: TRUE]],
            ENDCASE => e]};

      results _ MapLeaves[args, MinusIt]};

     print =>

     {-- arg should be a list (text, pt)
      IF List.Length[args] # 2 THEN ERROR ParmNumberError;
      r: Rope.ROPE _ ToRope[g.first];
      p: Coords _ ToNumPair[g.rest.first];
      Gr.DrawString[p.x, p.y, r];
      results _ NIL};

     draw, stroke, fill =>

     {-- arg should be a list of lists of points
      patch: LIST OF Se;
      DrawTwo: PROC [p, q: Coords] =
          {IF function = draw THEN
              {Gr.DrawEdge[p.x, p.y, q.x, q.y]}
           ELSE
              {Gr.EdgeStroke[p.x, p.y, q.x, q.y]}};
      DrawFour: PROC [p, r, s, q: Coords] =
          {IF function = draw THEN
              {Gr.DrawArc[p.x, p.y, r.x, r.y, s.x, s.y, q.x, q.y]}
           ELSE
              {Gr.ArcStroke[p.x, p.y, r.x, r.y, s.x, s.y, q.x, q.y]}};
      results _ NIL;
      IF function = stroke OR function = fill THEN
          {Gr.BeginStroke[]};
      WHILE args # NIL DO
          patch _ ToList[args.first, 2, 4];
          IF patch.rest.rest = NIL THEN
             {DrawTwo[ToCoords[patch.first], ToCoords[patch.rest.first]]}
          ELSE IF patch.rest.rest.rest = NIL THEN Gr.Error ["draw: wrong number of args"]
          ELSE IF patch.rest.rest.rest.rest = NIL THEN
             {DrawFour
                 [ToCoords [patch.first], ToCoords [patch.rest.first],
                  ToCoords [patch.rest.rest.first], ToCoords [patch.rest.rest.rest.first]]}
          ELSE Gr.Error ["draw: wrong number of args"];
          args _ args.rest
         ENDLOOP;
       IF function = stroke THEN
          {Gr.DrawStroke[]}
       ELSE IF function = fill THEN
          {Gr.DrawArea}};

     leftPren =>

     {results _ args};

     leftBrack, list =>

     {results _ LIST[args]};

    ENDCASE =>

     {Gr.Error["Unknown function: ", Atom.GetPName[function]]}

END;

ApplyBinaryAtom: PROC [op: ATOM, largs, rargs: Results] RETURNS [results: Results] =

BEGIN
   SELECT op FROM

      assign =>

      {DoAssign: PROC [p, q: Se] =
          BEGIN
            WITH p SELECT FROM
               pp: NumPtr =>
                  {WITH q SELECT FROM
                       qq: NumPtr =>
                           {IF NOT qq.const THEN 
                               {qq.val _ pp.val;
                                IF qq.int AND pp.val < ???
                                     THEN qq.val _ Real.RoundLI[qq.val]}};
                       ENDCASE => ERROR ???};
               pp: RopePtr =>
                  {WITH q SELECT FROM
                       qq: RopePtr =>
                           {IF NOT qq.const THEN 
                               {qq.val _ pp.val}};
                       ENDCASE => ERROR ???};
               pp: LIST OF Se =>
                  {WITH q SELECT FROM
                       qq: LIST OF Se =>
                           {WHILE pp # NIL AND qq # NIL DO
                               DoAssign[pp.first, qq.first];
                               pp _ pp.rest;  qq _ qq.rest
                              ENDLOOP;
                            IF pp# NIL OR qq # NIL THEN
                               {Gr.Error["Assignment length mismatch"]}};
                       ENDCASE => ERROR ???};
               ENDCASE => ERROR ??? -- Oh wonderful Cedar...
          END;
       results _ NIL;
       DoAssign[largs, rargs]};

      plus, times, minus, slash, div, mod =>

     {<do this for each component>
      a: REAL _ ToReal[largs];
      b: REAL _ ToReal[rargs];
      c: REAL _ SELECT op FROM
         plus => a+b,
         minus => a-b,
         times => a*b,
         slash => a/b,
         div => (a - Real.FRem[a, b])/b,
         mod => Real.FRem[a, b],
       ENDCASE => ERROR;
      ValueOnly[mode];
      result _ MakeNumber
        [c, ISTYPE [largs, REF INT] AND ISTYPE[rargs, REF INT] AND op # slash]};

      rel =>

     {<check that largs is a single argument>
      -- in actions or hints (not in constraints).
      -- Transforms number pair to specified frame.
      coords: Coords  = ToCoords[largs];
      frame: Frame _ ToFrame[rargs];
      newc: Coords;
      mFrame _ GetFrameMatrix[frame, mFrame];
      newc _ TransformPoint [coords, mFrame];
      results _ ~~~};

      comma  =>

      {results _ DConc[largs, rargs]};

      semicolon =>

      {results _ rargs};

     ENDCASE =>

     {Gr.Error["Unknown infix operator: ", Atom.GetPName[op]]}

END;

ApplyFunVal: PUBLIC PROC[funVal: FunPtr, args: Results] RETURNS [results: Results] =

BEGIN
   newAlist: Alist =  BindArgs !!! CATCH ERROR
      [funVal.parms, args, funVal.alist];
   results _ Eval[funVal.body, newAlist]
END;

listOfPointMold: Mold =  NEW [ListMoldRec _ [min: 1, eMold: $PointPtr]];

mFrame: REF Matrix _ NEW[Matrix]; -- temp for frame conversion









drawParmsMold: Mold = NEW [ListMoldRec _ [min: 1, eMold: patchMold]];


patchMold: Mold = NEW [UnionRec _
[alts: LIST
   [LIST [$PointPtr, $PointPtr],
    LIST [$PointPtr, $PointPtr, $PointPtr, $PointPtr]]]];




pointPairMold: Mold = LIST [$PointPtr, $PointPtr];

widthSpecMold: Mold = NEW [UnionRec _ [alts: LIST[$REFNUM, pointPairMold]]];

numTripletMold: Mold _ LIST [$REFNUM, $REFNUM, $REFNUM];


pointMold: PUBLIC Mold _ LIST [$NUM, $NUM];

frameMold: PUBLIC Mold _ NEW [VectorMoldRec _ [min: 1, max: 3,  elm: pointMold]]; 

edgeMold: PUBLIC Mold _ NEW [VectorMoldRec _ [min: 2, max: 2,  elm: pointMold]];

arcMold: PUBLIC Mold _ NEW [VectorMoldRec _ [min: 4, max: 4,  elm: pointMold]]; 

pathMold: PUBLIC Mold _ NEW [VectorMoldRec _ [min: 1, elm: pointMold]]; 

ToNumPair: PUBLIC PROC [e: Se] RETURNS [p: NumPair] =

  {ee: LIST OF Se _ ToList[e, 2, 2];
   IF ee.first = NIL OR NOT ISTYPE [ee.first, NumPtr] OR
      ee.rest.first = NIL OR NOT ISTYPE [ee.rest.first, NumPtr] THEN
       ERROR InvalidSe[e];
   p.x _ NARROW[ee.first];
   p.y _ NARROW[ee.rest.first]};

nullFrame: PUBLIC Frame _ [0, [NIL, NIL], [NIL, NIL], [NIL, NIL]];

ToFrame: PUBLIC PROC [e: Se] RETURNS [frame: Frame] =

BEGIN
    list: LIST OF Se _ ToList [e, 1, 3];
    frame _ nullFrame;
    frame.np _ 1;
    frame.org _ ToNumPair[list.first];
    list _ list.rest;
    IF list # NIL THEN
      {frame.np _ 2;
       frame.hor _ NARROW[list.first];
       list _ list.rest;
       IF list # NIL THEN
         {frame.np _ 3;
          frame.ver _ NARROW[list.first]}}
END;

ToReal: PUBLIC PROC [e: Se] RETURNS [r: REAL] =

  {WITH e SELECT FROM
     en: NumPtr => RETURN[en.val]
   ENDCASE => ERROR InvalidSe[e]};

ToCoords: PUBLIC PROC [e: Se] RETURNS [c: Coords] =

  {p: NumPair _ ToNumPair[e];
   RETURN[p.x.val, p.y.val]};

m1: REF Matrix _ NEW[Matrix]; -- Work matrices

mInv: REF Matrix _ NEW[Matrix];

GetFrameMatrix: PUBLIC PROC [frame: Frame, m: REF Matrix _ NIL]
 RETURNS [mr: REF Matrix] =
  -- Returns the coordinate transform matrix for the frame determined
  --   by the points frame.org, frame.xP, frame.yP (the last one or two may be NIL).
  --   The resulting matrix satisfies m*[0,0,1]^T= org, m*[1,0,1]^T= xP, m*[1,0,1]^T= yP. 
  -- The optional matrix m^ is used if not NIL, otherwise a new one is allocated.

BEGIN
  IF m = NIL THEN m _ NEW [Matrix];
  m^[1][3] _ frame.org.x;
  m^[2][3] _ frame.org.y;
  m^[3][3] _ 1;
  
  IF frame.xP=NIL THEN
    {m^[1][1] _ 300;
     m^[2][1] _ 0} 
  ELSE
    {m^[1][1] _ frame.xP.x-frame.org.x;
     m^[2][1] _ frame.xP.y-frame.org.y}; 
  m^[3][1] _ 0;
  IF frame.yP=NIL THEN
    {m^[1][2] _ -m^[2][1];
     m^[2][2] _ m^[1][1]} 
  ELSE
    {m^[1][2] _ frame.yP.x-frame.org.x;
     m^[2][2] _ frame.yP.y-frame.org.y}; 
  m^[3][2] _ 0;
  RETURN[m]
END;

InvertMatrix: PUBLIC PROC [m: REF Matrix, work: REF Matrix _ NIL]
 RETURNS [mInv: REF Matrix, singular: BOOL] =

  BEGIN
    -- Inverts m^ into mInv^ by pivoting three times; or sets "singular" flag.
    -- Uses work if not NIL, otherwise allocates new matrix for result.
    i, j, k, l: INTEGER;
    c: ARRAY [1..3] OF INTEGER;
    pivoted: ARRAY [1..3] OF BOOLEAN _ [FALSE, FALSE, FALSE];
    p: REAL;
    -- k is the row in which we are pivoting.
    -- l is the column in which we are pivoting.
    -- i and j are miscellaneous row and column indices respectively
    -- c[i] is the column of the pivot in the ith row.
    -- p is the reciprocal of the pivot element; also used as temp for swapping.
    IF work = NIL THEN work _ NEW[Matrix];
    FOR k IN [1..3] DO
      -- set l so m^[k,l] is largest of m^[k,1], m^[k, 2], m^[k, 3], excluding
      -- columns in which we have already pivoted.
      p _ 0;
      FOR j IN [1 .. 3] 
        DO IF ABS[m^[k][j]] >= p AND NOT pivoted[j] THEN {l _ j; p _ ABS[m^[k][l]]} ENDLOOP;
      -- We will pivot at m^[k,l], if it is not too small:
      IF ABS[m^[k][l]] < .0001 THEN RETURN[NIL, TRUE];
      c[k] _ l; pivoted[l] _ TRUE; 
      p _ 1.0 / m^[k][l]; m^[k][l] _ 1.0;
      -- divide everything in pivot row by the pivot element:
      FOR j IN [1..3] DO m^[k][j] _ m^[k][j] * p ENDLOOP;
      FOR i IN [1..3] DO 
        IF i # k THEN 
	  FOR j IN [1..3] DO 
	    IF j # l THEN -- for each m^[i,j] outside the pivot row and column
	      m^[i][j] _ m^[i][j] - m^[i][l] * m^[k][j]; -- note that m^[k,j] was already * p.
      ENDLOOP ENDLOOP;
      -- Finally process pivot column:
      FOR i IN [1..3] DO IF i # k THEN m^[i][l] _ -m^[i][l] * p ENDLOOP;
    ENDLOOP;
  -- Now we permute rows and columns:
  FOR i IN [1..3] DO FOR j IN [1..3] DO work^[c[i]][j] _ m^[i][c[j]] ENDLOOP ENDLOOP; 
  RETURN[work, FALSE]
END;

MultiplyMatrix: PUBLIC PROC [ma, mb: REF Matrix, mc: REF Matrix _ NIL]
  RETURNS [mr: REF Matrix] =
   -- Multiply ma^ * mb^.
   -- Matrix mc is used if not NIL, otherwise allocates new one.

BEGIN
  i, j, k: INTEGER;
  sum: REAL;
  IF mc = NIL THEN mc _ NEW [Matrix];
     FOR i IN [1..3] DO FOR j IN [1..3] DO
       sum _ 0.0;
       FOR k IN [1..3] DO sum _ sum + ma^[i][k] * mb^[k][j] ENDLOOP;
       mc^[i][j] _ sum
      ENDLOOP ENDLOOP;
  RETURN[mc]
END;

ComputeTransform: PUBLIC PROC
  [src, dest: Frame, mm: REF Matrix _ NIL]
 RETURNS [mat: REF Matrix, singular: BOOL] =

BEGIN
  -- We want
  --       mat * [ src.org, src.xP, src.yP ] = [ dest.org, dest.xP, dest.yP ],
  --   where the points are viewed as
  --   column vectors with third component 1. Hence we compute the inverse
  --   of src and multipy on the left by dest. But the pairs
  --   (dest.xP, src.xP), (dest.yP, src.yP) may be missing, in which case they 
  --   are filled in by default to make the transformation a
  --   translation (if both are missing) or a Euclidean motion (if just (c, sc) is missing).
  -- The matrix mm is optional, and is used to store the result: if NIL, a new one is allocated. 
  -- Uses m1, mInv as work areas.
  sing: BOOL;
  mm _ GetFrameMatrix[src, mm];
  [mInv, sing] _ InvertMatrix[mm, mInv];
  IF sing THEN RETURN [NIL, sing];
  m1 _ GetFrameMatrix[dest, m1];
  mm _ MultiplyMatrix[m1, mInv, mm];
  RETURN [mm, sing]
END;

ComputeSomeTransform: PUBLIC PROC
  [src, dest: Frame, mm: REF Matrix _ NIL]
RETURNS [mat: REF Matrix, singular: BOOL] =

BEGIN
  -- Similar to the above, except that tries simpler transforms (by dropping
  --    last one or two pairs) if the given frames specify a aingular transformation.
  [mat, singular] _ ComputeTransform [src, dest, mm];
  IF singular THEN [mat, singular] _ ComputeTransform
      [src: [src.org, src.xP, NIL], dest: [dest.org, dest.xP, NIL], mm: mat];
  IF singular THEN [mat, singular] _ ComputeTransform
      [src: [src.org, NIL, NIL], dest: [dest.org, NIL, NIL], mm: mat]
END;   

TransformPoint: PUBLIC PROC [x, y: REAL, mat: REF Matrix] RETURNS [xT, yT: REAL] = 

BEGIN
  -- Transforms x, y by the given matrix
  xT _ x * mat^[1][1] + y * mat^[1][2] + mat^[1][3];
  yT _ x * mat^[2][1] + y * mat^[2][2] + mat^[2][3]
END;

frameMold: Mold =  NEW [ListMoldRec _ [min: 1, max: 3, eMold: $PointPtr]];

END.
¤
HerculesAlgebraImpl.mesa

Last Edited by: Stolfi, February 28, 1984 2:40:47 am PST

Was (mostly) JunoAlgebraImplB
Written July, 1982 by Donna M. Auguste and Greg Nelson
Last Edited by: Gnelson, October 11, 1983 9:50 pm

Evaluator/interpreter for symbolic expressions. This module defines the semantics of Juno/Hercules language (and, implicitly, its syntax) 

To do: Procedure for expanding an IF statement or a simple statement and adding its contents to the current image. (February 15, 1984 1:21 am)

- - - - RESERVED ATOMS

- - - -  GLOBAL ALIST

- - - -  EVAL

- - - -  APPLY

- - - - SOME USEFUL MOLDS AND PREDICATES

- - - - COORDINATE TRANSFORMATION MATRICES

�Ê?˜Jš
œ™š
œ9™9š
œ™Jš
œ6™6Jš
œ1™1—Jš
œ‹
™‹
JšÏbœˆ
™�
JšÏk
œižœ*žœ2žœ%˜ƒ—šœž˜Jšœžœ^žœ˜„
—Jš
œ˜š
ž˜Jšœ
žœq˜v—šÏn
œ™J˜Jšœžœ˜Jšœžœ˜*Jšœžœ˜*Jšœžœ˜Jšœžœ
žœ˜'Jšœžœ˜Jšœžœ˜(Jšœžœ˜(Jšœžœ	˜Jšœžœ
žœ˜Jšœžœ˜Jšœžœ	˜Jšœžœ	˜Jšœžœ˜)Jšœžœ	˜Jšœžœ
žœ	˜Jšœžœ
žœ˜&Jšœžœ˜Jšœžœ˜Jšœžœ
žœ˜Jšœžœ
žœ˜,Jšœ
žœ˜+Jšœžœ
žœ˜&Jšœžœ˜(Jšœžœ
žœ˜Jšœžœ˜(Jšœžœ
˜Jšœžœ	˜Jšœžœ	˜Jšœžœ˜'Jšœžœ
˜Jšœžœ˜Jšœžœ˜.Jšœžœ
žœ˜-Jšœžœ˜,Jšœžœ	˜Jšœžœ	˜Jšœžœ˜(Jšœžœ˜Jšœžœ
˜Jšœ
žœ˜+Jšœžœ˜(Jšœžœ˜Jšœžœ˜Jšœžœ
˜—šŸ
œ™JšŸ
�œžœÏc$˜SšŸœžœ˜%Jšgœ
žœžœžœžœžœžœžœžœžœžœžœžœžœžœžœžœžœžœžœžœžœ	 œžœ%žœ%žœ$žœ%žœ%žœ'žœ'žœ(žœ(žœ(žœ)žœ&žœ%žœ'žœ)žœ'žœ)žœ*žœ(žœ*žœ œužœ)žœ(žœ)žœ œI œéžœ
˜é—JšŸ
�œžœ $˜Mš
Ÿ
œžœ
žœžœž
œ
˜7JšŸ
žœžœžœ
žœžœžœ žœžœ0žœ
˜Ï
——šŸ
œ
™Jšœ
�	œžœ
žœžœžœ
˜,šœ
Ÿœžœ
žœžœ jÐcr 
˜º
šœ
ž˜Jšœžœžœ
žœžœžœ
žœžœ
ž˜Mš
œ˜Jšœžœ˜—š
œ˜Jšœžœ˜—š
œ˜Jšœžœ˜—šœžœ˜Jš
œ*˜*—šœžœ
žœ˜šœž˜	Jšœžœ> !œžœ	žœ
žœžœ
žœžœ˜ª
šœžœž˜šœ	 ¡ ¡ ˜-šœžœžœž˜š
œ˜Jšœžœ˜—š
œ˜Jšœžœ
žœ˜—Jšœžœžœ˜—Jšœžœ
˜—šœ	 +˜4šœžœžœž˜š
œ˜Jšœ6žœ˜D—š
œ˜Jšœ6žœ˜D—š
œ˜Jšœžœ˜$—šœžœ˜Jšœ #œ 4œX˜·
——Jšœžœ
˜—šœ	 ˜šœžœžœ
žœ
ž˜š
œ˜JšœžœžœXžœ˜�
—š
œ*˜*Jšœ kœBžœ	žœ
žœžœ
žœ
žœ$žœlžœ˜�—šœžœ˜Jšœ œ 
˜¾
——Jšœžœ
˜—Jšœžœžœ˜——Jšœžœ
˜—Jšœžœžœ
˜—Jšœ
žœ
˜—šŸ	œžœžœžœ˜NJšœ
žœ p¡ œ.žœžœžœžœžœžœ
˜…—š
Ÿœžœ	žœ
žœžœ˜PJšMŸ
žœ Ïr <œžœ
žœ¢œžœžœ$žœ œžœ !¡ ¡
 
œ ¡ 
œžœžœ
žœ
žœ	žœižœ
žœžœ;žœ	žœ
žœ
žœ
 œ	žœ
žœ
žœ
 ¡
 
œGžœžœVžœ
žœ
˜ÿ—š
Ÿœžœ	žœ
žœžœ˜PJš/œ
žœ Pœžœ
žœžœžœ$žœ œžœžœžœ	žœžœ
žœožœ	žœožœžœ
žœ	žœ
žœžœ
žœ
˜Ç—šŸœžœžœ
žœžœžœžœ˜rJš/œ
žœ œ Bœžœ
žœžœžœ
žœ	 ;œžœžœžœ
žœ"žœ	 Sœpžœ*žœžœ! 
œ /œ; 
œžœ žœ˜ˆ—šœ
Ÿœžœžœ
žœžœžœ
žœ Wœ q˜ÁJš*œ
ž 
œ ¢ ¡ ¢
œ \œ	žœ
žœ4žœ#žœžœ	žœ
žœ?žœ
žœžœ
žœ]žœžœ2žœ
žœ
˜×—šœ
Ÿœžœžœ
žœžœžœ
žœ Aœ H˜þ
Jš7œ
žœžœžœ
žœžœžœ
žœžœ
žœ&žœžœ	žœžœ:žœ"žœžœ$žœ
žœžœ
žœ«
žœžœžœ
žœžœžœ0žœ
˜Ì—šœ
Ÿœžœžœ˜1Jšœ
žœ @˜Jšœžœž˜Jš
œ'˜'Jš
œ'˜'Jš
œ*˜*Jš
œ-˜-Jš
œ*˜*Jš
œ*˜*Jšœžœžœ
˜—Jšœ
žœ
˜—šœ
Ÿœžœžœ˜%Jšœ
žœ 2˜<šœžœž˜Jš
œ˜Jš
œ˜Jš
œ˜Jš
œ˜Jš
œ˜Jš
œ˜Jšœžœžœ
˜—Jšœ
žœ
˜—šœ
Ÿœžœžœ˜1Jš
œ
žœžœ#žœžœžœ	žœ
˜j—šŸœžœžœžœ˜&Jšœ
žœžœžœ
žœžœžœ
žœ™
žœJžœžœ
žœ
˜Î—šŸœžœžœ˜0JšŸ
žœŸœžœžœ
žœžœžœ
žœžœ#žœ
žœžœ|žœ
˜§—šŸ
œžœžœ˜:JšŸ
žœžœ
žœ
žœžœžœžœ
žœžœ
žœ
˜“
——šŸ
œ™šŸœžœ
žœžœ˜NJšœ
žœžœ
žœ
žœžœ™žœ5žœžœ
˜�—šŸœžœ
žœ&žœ˜\Jš%œ
žœžœ
žœ
žœžœžœžœ
žœžœ
žœ
žœ
žœ%žœ
žœ"žœ žœ5žœžœ
˜¡—šŸ
œžœ
žœžœžœ 
˜VJšŸ
žœžœ
ž˜šŸ
œ˜
JšŸ
œ -œžœžœ
žœ
žœ
žœ
žœ&žœ˜ 
—šŸ
œ
˜JšŸ
œ *œ�œžœ
žœžœ
žœžœ.žœžœ4˜Œ—šŸ
œ
˜JšŸ
œ #œžœžœ
žœ žœqžœ˜í
—šŸ
œ˜JšNŸ
œ +œ
žœ
žœŸœžœžœžœ<žœ;Ÿœžœ#žœžœOžœXžœžœžœžœ%žœžœ
žœ7žœžœ
žœUžœ
žœžœ
žœ3žœ
žœžœ
žœÅ
žœNžœ	žœžœ$žœ
žœžœ˜¸
—š
œ˜Jš
œ˜—š
œ˜Jš
œ˜—šŸ
œžœ˜JšŸ
œ>˜?—JšŸ
žœ
˜—šŸœžœžœžœ˜UšŸ
žœžœž˜šŸ
œ˜JšeœŸœžœžœ
žœžœ
žœ1žœžœ
žœBžœ
žœ
žœSžœžœ3žœ9žœžœ8žœžœ
žœCžœ
žœ
žœLžœžœžœ
žœžœžœ
žœžœ
žœ#žœžœ
žœžœ
žœ—
žœžœžœ
žœžœ
žœbžœžœžœžœ œ
žœžœ!˜Ê
—šŸ
œ,˜-Jš Ÿ
œ,žœžœžœžœžœ­
žœžœ?žœ	žœ
žœžœ
žœžœ
žœžœ˜À—šŸ
œ˜
JšŸ
œ Ž
œžœžœ³
˜é—š
œ˜Jš
œ'˜'—š
œ˜Jš
œ˜—šŸ
œžœ˜JšŸ
œ>˜?——JšŸ
žœ
˜—šŸœžœ
žœ žœ˜UJšŸ
žœƒ
žœ
˜�
—JšŸ
œžœ,˜IJšŸ
œžœ
žœ
 ˜?J˜J˜J˜J˜J˜J˜J˜J˜JšŸ
œE˜FJ˜Jš
Ÿ
œžœžœžœžœ1˜‰
J˜J˜J˜JšŸ
œžœ˜3JšŸ
œžœžœ˜MJšŸ
œžœ˜9J˜—š
œ)™)Jšœžœžœ˜,Jšœžœžœ6˜SJšœžœžœ5˜QJšœ
žœžœ6˜QJšœžœžœ-˜IšŸ
œžœ
žœ	žœ˜6Jš!œžœ
žœžœžœ
žœ
žœ
žœžœžœ
žœ
žœ
žœžœžœžœžœ˜ú
—Jšœžœžœžœžœžœžœžœ˜CšŸœžœ
žœ	žœ˜6Jšœ
žœžœ
žœ$ž	œUžœžœ
žœ)žœ.žœžœ
žœ/žœžœ
˜ã—š
Ÿœžœ
žœ	žœžœ˜0Jš
œžœžœ
žœžœžœžœ˜[—šŸ	œžœ
žœ	žœ˜4Jšœ"žœ˜<——šŸ
œ*™+JšŸ
œžœ
žœ
 ˜/JšŸ
œžœ
žœ	˜ š!Ÿœžœ
žœžœ
žœžœžœ
 Yœ Iœ œ œ œ œ œ œ œ 6˜¤JšŸ
žœžœžœ
žœžœTžœ
žœ
žœ,žœežœ
žœ
žœ9žœežœžœ
˜á—šŸ
œžœ
žœžœžœ
žœžœžœžœ˜pJš¬
Ÿ
œžœ Kœ Dœžœ	žœžœ
žœžœžœ
žœžœžœžœ
žœ *œ -œ Aœ 3œ Mœžœžœ
žœžœžœžœžœ Iœ -œžœžœžœ
žœ
žœžœ
žœžœ
žœžœ 5œžœ
žœžœ
žœ
žœžœ žœ3 8œžœžœžœžœžœžœžœ
žœžœžœžœžœžœžœ
 5œ2 &œžœ
žœ !œžœžœžœ
žœžœžœžœ $œžœžœžœ
žœžœžœžœ
žœžœžœžœ
˜â
—šŸœžœ
žœ
žœ
žœ
žœžœžœ $œ 1˜¿
Jš+Ÿ
žœžœ	žœžœžœ
žœžœžœžœžœ
žœžœžœžœžœžœ#žœžœ
žœžœžœ
˜�—šŸœžœ
žœžœ
žœžœžœžœ˜vJš)Ÿ
žœ œ gœ Iœ ¡ ¡ œ Nœ ;œ kœ Z¢ ¢ œžœMžœžœ
žœžœQžœžœ
˜×—šŸœžœ
žœžœ
žœžœžœžœ˜yJšŸ
žœ  
œ9žœ
žœBžœžœžœ
žœ:žœžœžœžœžœ˜ç—šŸœžœ
žœžœžœ	žœ
žœ˜TJšŸ
žœ 'œižœ
˜�
—JšŸ
œžœ4˜K—JšŸ
žœ
˜J™—…—j¨ƒ‹