MODULE UserFont;

IMPORT Text, BST, R2, PS;

(* A module for painting and measuring 
   user-defined fonts. *)

CONST 
  MoveTo = 0, 
  LineTo = 1, 
  CurveTo = 2, 
  Close = 3, 
  Fill = 4;

(* These are the PostScript operations 
   allowed in character outline 
   descriptions. *)

CONST 
  DefaultFace = NIL, DefaultSize = 10;

(* This module maintains a current 
   user-defined font face and font 
   size (in points). Attempting to 
   paint or measure a text in the 
   default font face will cause a 
   run-time error. Use the procedures 
   "SetFontFace" and "SetFontSize" 
   below to change the current 
   user-defined font face and font 
   size, respectively. *)


PRIVATE VAR 
  fontFace := DefaultFace,
  fontSize := DefaultSize;

/* The current font face and font size 
   (in points). */

PROC SetFontFace(f) IS 
  fontFace := f 
END;

(* Set the current user-defined font 
   face to "f". A user-defined font 
   value must have the structure of a 
   <font> in the grammar below. In 
   this grammar, non-terminals are set 
   off in angle brackets <>, and all 
   other literal characters are 
   terminals. Also, the syntax 

|  <non-terminal> , *

   means zero or more occurrences of 
   the <non-terminal> separated by 
   commas. (Note that since "[]" is 
   not allowed in a Juno-2 literal, 
   zero occurrences of the 
   <non-terminal> in list brackets 
   should be written as "NIL".) 

   Here is the grammar for a 
   user-defined font: 

|  <font>       ::= ( <fontMetric> , <charTree> )
|  <fontMetric> ::= TBD
|  <charTree>   ::= NIL
   | ( <charDef> , ( <charTree> , 
   <charTree> ) ) 

   A <font> is a <fontMetric> paired 
   with a binary search tree of 
   character definitions 
   (<charDef>'s). The format of the 
   <fontMetric> is as yet 
   undetermined. The <charTree> is a 
   binary search tree as produced by 
   "BST.FromList". If it is a pair, 
   the CAR of the pair is the root of 
   the tree, and the CDR is a pair of 
   the left and right subtrees. 

|  <charDef>    ::= ( <charCode> , <char> )
|  <charCode>   ::= <integer>
|  <char>       ::= ( <charMetric> , <charPath> )

   Each <charDef> is a pair of the 
   integer code for the character (the 
   <charCode>) with the description of 
   the character outline (the 
   <charPath>). 

|  <charMetric> ::= ( <width> , <bbox> )
|  <width>      ::= <real>
|  <bbox>       ::= ( <swPoint> , <nePoint> )
|  <swPoint>    ::= <point>
|  <nePoint>    ::= <point>
|  <point>      ::= ( <real> , <real> )

   A <charMetric> describes the size 
   of a particular character. In a 
   user-defined font value, all metric 
   and character data is specified for 
   a 1-point font. When the font is 
   painted or measured at larger point 
   sizes, these values are scaled. The 
   <width> is the amount (in points) 
   to advance the reference point to 
   the right after painting the 
   character. The <bbox> is the 
   smallest rectangle enclosing all of 
   the paint produced by rendering the 
   character with its reference point 
   at the origin. 

|  <charPath>  ::= [ <action>,* ]
|  <action>    ::= ( <actionKind> , <itemData> )

   A character is described by a list 
   of PostScript drawing actions 
   required to render the character. 
   The character is rendered by 
   executing the <action>'s in their 
   listed order. 

   Each <itemKind> must be one of the 
   constants "MoveTo", "LineTo", 
   "CurveTo", "Close", or "Fill". For 
   each kind, there is a different 
   format for the associated 
   <itemData>. Some forms allow an 
   equivalent shorthand, shown here: 

|  Form                  Equivalent Shorthand
|  (MoveTo, p)
|  (LineTo, q)
|  (CurveTo, [q, r, s])  [CurveTo, q, r, s]
|  (Close, NIL)          [Close]
|  (Fill, NIL)           [Fill]

   In these forms, "p", "q", "r", and 
   "s" are pairs of reals. The 
   <integer> and <real> non-terminals 
   denote Juno-2 integer and real 
   values. *)

UI SetTool(SetFontFace);

PROC SetFontSize(s) IS 
  fontSize := s 
END;

UI SetTool(SetFontSize);

(* Set the current user-defined font 
   size to "s" points. *)

UI Param(SetFontSize, DefaultSize);

UI Param(SetFontSize, 8);

UI Param(SetFontSize, 10);

UI Param(SetFontSize, 12);

UI Param(SetFontSize, 14);

UI Param(SetFontSize, 18);

UI Param(SetFontSize, 24);

UI Param(SetFontSize, 48);

UI Param(SetFontSize, 96);

CONST 
  CompleteRendering = 0, 
  BlockRendering = 1, 
  DefaultRendering = CompleteRendering;

(* This module maintains a current 
   rendering style. If the rendering 
   style is "CompleteRendering", then 
   the complete characters are 
   rendered. If the rendering style is 
   "BlockRendering", then only the 
   bounding boxes of the characters 
   are drawn. The latter style is much 
   more efficient. *)

PRIVATE VAR 
  renderStyle := DefaultRendering;

PROC SetRendering(renderType) IS 
  renderStyle := renderType 
END;

UI SetTool(SetRendering);

(* Set the current rendering style to 
   "renderType". *)

UI Param(SetRendering, DefaultRendering);

UI Param(SetRendering, 
         CompleteRendering);

UI Param(SetRendering, BlockRendering);

PRIVATE PROC Action(frame, item) IS 
  IF 
    VAR kind, data IN 
      item = (kind, data) -> 
        IF 
          kind = CurveTo -> 
            IF 
              VAR p1, p2, p3 IN 
                data = [p1, p2, p3] -> 
                  PS.CurveTo(p1 REL 
                             frame, 
                             p2 REL 
                             frame, 
                             p3 REL 
                             frame) 
              END 
            FI 
        | kind = MoveTo -> 
            PS.MoveTo(data REL frame) 
        | kind = LineTo -> 
            PS.LineTo(data REL frame) 
        | kind = Fill -> PS.Fill() 
        | kind = Close -> PS.Close() 
        FI 
    END 
  FI 
END;

PRIVATE PROC 
  RenderChar(frame, data) IS 
  DO 
    data # NIL -> 
      Action(frame, CAR(data)); 
      data := CDR(data) 
  OD 
END;

PRIVATE PROC 
  RenderBBox(frame, bbox) IS 
  VAR sw, se, ne, nw IN 
    sw := CAR(bbox); 
    ne := CDR(bbox); 
    se := (CAR(ne), CDR(sw)); 
    nw := (CAR(sw), CDR(ne)); 
    PS.MoveTo(sw REL frame); 
    PS.LineTo(se REL frame); 
    PS.LineTo(ne REL frame); 
    PS.LineTo(nw REL frame); 
    PS.Close(); 
    PS.Fill() 
  END 
END;

PRIVATE PROC 
  refPt:DrawChar(delta, data) IS 
  VAR frame, metric IN 
    frame := 
      (refPt, R2.Plus(refPt, delta)); 
    metric := CAR(data); 
    IF 
      renderStyle = CompleteRendering -> 
        RenderChar(frame, CDR(data)) 
    | renderStyle = BlockRendering -> 
        RenderBBox(frame, CDR(metric)) 
    FI; 
    refPt := (CAR(metric), 0) REL frame 
  END 
END;

PRIVATE PROC data := LookupChar(ch) IS 
  VAR match IN 
    match := 
      BST.Find(ch, CDR(fontFace)); 
    IF 
      match = NIL -> data := NIL 
    | data := CDR(match) 
    FI 
  END 
END;

/* Return the character data for the 
   character with code "ch" in the 
   current font. If "ch" is unmapped 
   in the current font, return NIL. */

PRIVATE PROC Type1(a, delta, txt) IS 
  SAVE PS IN 
    VAR len, i IN 
      len := Text.Length(txt); 
      i := 0; 
      DO 
        i < len -> 
          a:DrawChar(delta, 
                     LookupChar(Text.GetChar(txt, 
                                             i))); 
          i := i + 1 
      OD 
    END 
  END 
END;

PROC Type(a, txt) IS 
  Type1(a, (fontSize, 0), txt) 
END;

UI TextTool(Type);

(* Type "txt" horizontally to the 
   right from "a" in the current 
   user-defined font and size. *)

PROC TypeToward(a, b, txt) IS 
  VAR delta IN 
    delta := R2.Minus(b, a); 
    Type1(a, 
          R2.Times(fontSize / 
                   R2.Length(delta), 
                   delta), txt) 
  END 
END;

UI TextTool(TypeToward);

(* Type "txt" from "a" along the 
   baseline ray "ab" in the current 
   user-defined font and size. *)

PROC TypeScaled(a, b, txt) IS 
  VAR delta IN 
    delta := R2.Minus(b, a); 
    Type1(a, 
          (CDR(delta), -CAR(delta)), 
          txt) 
  END 
END;

UI TextTool(TypeScaled);

(* Type "txt" from "a" in the current 
   user-defined font. The size of the 
   font is the distance between "a" 
   and "b", and "txt" is oriented so 
   its ``up'' vector is the direction 
   of the ray "ab". *)

PROC w := StringWidth(txt) IS 
  VAR i, len IN 
    w, i, len := 0, 0, Text.Length(txt); 
    DO 
      i < len -> 
        w := 
          w + 
          (fontSize * 
           CAR(CAR(LookupChar(Text.GetChar(txt, 
                                           i))))
           ); 
        i := i + 1 
    OD 
  END 
END;

(* Return the width of the string 
   "txt" typed in the current 
   user-defined font at the current 
   user-defined font size. *)

PRIVATE VAR history := NIL;

PROC Save() IS 
  history := 
    ([fontFace, fontSize, renderStyle], 
     history) 
END;

PROC Restore() IS 
  IF 
    VAR face, size, render IN 
      CAR(history) = 
        [face, size, render] -> 
        fontFace := face; 
        fontSize := size; 
        renderStyle := render 
    END 
  FI; 
  history := CDR(history) 
END;

UI PointTool(Save);

UI PointTool(Restore);

(* Save/restore module state. *)