MODULE Dash;

(* A module for drawing dashed lines. *)

IMPORT R2, Geometry, PS, Arrow;

CONST 
  Tiny = ([3], 1.5), 
  Small = ([5], 2.5), 
  Medium = ([10], 5), 
  Big = ([20], 10), 
  Huge = ([40], 20), 
  DefaultPattern = Medium;

(* This modules maintains a dash pattern, which is a 
   pair "(dashlist, offset)". These dash patterns 
   are based on the PostScript model for dashed 
   lines. The "dashlist" is a list of non-negative 
   values that specify alternating distances of dash 
   and gap lengths. The values in the "dashlist" are 
   used cyclically: after reaching the end of the 
   list, the procedures in this module start back at 
   the beginning, alternating the dash parity. 
   Hence, a "dashlist" that contains a single 
   element alternates drawing dashes and gaps of the 
   same size. 

   The dash "offset" may be thought of as the 
   ``phase'' of the dash pattern relative to the 
   start of the segment or curve. It specifies the 
   distance into the dash pattern at which the 
   pattern should be started. Before beginning to 
   draw a dashed segment or curve, the procedures in 
   this module cycle through the elements of the 
   dash pattern, adding up distances and alternating 
   dashes and gaps as usual, but without generating 
   any output. When they have travelled the offset 
   distance into the dash pattern, they start adding 
   segments to the path from the point in the dash 
   pattern that has been reached. *)

PRIVATE VAR 
  dashList := CAR(DefaultPattern), 
  offset := CDR(DefaultPattern);

/* "dashList" and "offset" are the current dash list 
   and offset values. */

PRIVATE PROC res := IsNonNegList(list) IS 
  IF 
    list # NIL -> 
      DO 
        list # NIL -> 
          IF CAR(list) >= 0 -> list := CDR(list) FI 
      OD 
  FI; 
  res := NIL 
END;

/* Fail if "list" contains anything other than 
   non-negative reals. Return "NIL" otherwise. */

PROC SetPattern(dashpat) IS 
  IF 
    VAR list, num IN 
      dashpat = (list, num) -> 
        IF 
          num >= 0 AND IsNonNegList(list) = NIL -> 
            dashList := list; offset := num 
        FI 
    END 
  FI 
END;

UI SetTool(SetPattern);

(* Sets the dash pattern to "dashpat", which must be 
   a pair "(dashlist, offset)". The "dashlist" must 
   be a non-NIL list of non-negative reals. The 
   "offset" must be a non-negative real. *)

UI Param(SetPattern, DefaultPattern);

UI Param(SetPattern, Tiny);

UI Param(SetPattern, Small);

UI Param(SetPattern, Medium);

UI Param(SetPattern, Big);

UI Param(SetPattern, Huge);

PROC dashpat := GetPattern() IS 
  dashpat := (dashList, offset) 
END;

(* Set "dashpat" to the current dash pattern. *)

PRIVATE PROC (pattern, parity):Advance(amt) IS 
  DO 
    amt >= CAR(pattern) -> 
      amt := amt - CAR(pattern); 
      parity := -parity; 
      pattern := CDR(pattern); 
      IF 
        pattern = NIL -> pattern := dashList | SKIP 
      FI 
  OD; 
  IF 
    amt > 0 -> 
      pattern := (CAR(pattern) - amt, CDR(pattern)) 
  | SKIP 
  FI 
END;

/* Let "dashes" denote the logically infinite stream 
   of dashes represented by the initial value of 
   "pattern" concatenated with "dash" repeated an 
   infinite number of times. Then set "pattern" and 
   "parity" to reflect the position reached by 
   advancing through "dashes" by the distance "amt". 
*/

PRIVATE VAR currPat, parity;

/* While constructing a dashed path, "currPat" and 
   "parity" denote the current dash pattern and 
   drawing parity. The "MoveTo" procedure resets 
   these values according to "dash" and "indent". */

PRIVATE PROC Move(p) IS 
  PS.MoveTo(p); 
  currPat := dashList; 
  parity := 1; 
  (currPat, parity):Advance(offset) 
END;

/* Start a new dashed path at "p" using the current 
   dash pattern. */

PRIVATE PROC Line(p, q) IS 
  VAR r, dv, len, u, dist IN 
    dv := R2.Minus(q, p); 
    len := Geometry.Dist(p, q); 
    u := R2.Times(1 / len, dv); 
    dist := CAR(currPat); 
    DO 
      (dist < len) -> 
        r := R2.Plus(p, R2.Times(dist, u)); 
        IF 
          parity < 0 -> PS.MoveTo(r) | PS.LineTo(r) 
        FI; 
        (currPat, parity):Advance(CAR(currPat)); 
        dist := dist + CAR(currPat) 
    OD; 
    IF parity > 0 -> PS.LineTo(q) | PS.MoveTo(q) FI; 
    VAR amt IN 
      amt := len - (dist - CAR(currPat)); 
      (currPat, parity):Advance(amt) 
    END 
  END 
END;

/* Extend the current path with a dashed line 
   segment from "p" to "q"; "q" becomes the current 
   point. The style of the dash is determined by the 
   current dash pattern. It is a checked run-time 
   error for the current point to be undefined. */

PRIVATE PROC Curve(p, q, r, s) IS 
  VAR t, amt IN 
    t := 0; 
    DO 
      t < 1 -> 
        amt := CAR(currPat); 
        (t, amt):CurvedDash(p, q, r, s, parity); 
        (currPat, parity):Advance(amt) 
    OD 
  END 
END;

/* Extend the current path with a dashed Bezier 
   curve determined by "p", "q", "r", and "s"; "s" 
   becomes the current point. The style of the dash 
   is determined by the current dash pattern. It is 
   a checked run-time error for the current point to 
   be undefined. */

PRIVATE PRED 
  Trellis(t, p, q, r, s, pq, qr, rs, pqr, qrs, pqrs) IS 
  pq = (t, 0) REL (p, q) AND 
  qr = (t, 0) REL (q, r) AND 
  rs = (t, 0) REL (r, s) AND 
  pqr = (t, 0) REL (pq, qr) AND 
  qrs = (t, 0) REL (qr, rs) AND 
  pqrs = (t, 0) REL (pqr, qrs) 
END;

PRIVATE PROC 
  (t, len):CurvedDash(p, q, r, s, parity) IS 
  IF 
    VAR 
      pq, qr, rs, pqr, qrs, pqrs, velocity, speed, 
      endt 
    IN 
      Trellis(t, p, q, r, s, pq, qr, rs, pqr, qrs, 
              pqrs) AND 
      velocity = R2.Times(3, R2.Minus(qrs, pqr)) AND 
      speed = R2.Length(velocity) AND 
      endt = t + len / speed -> 
        IF 
          endt > 1 -> 
            len := len * (1 - t) / (endt - t); 
            endt := 1 | SKIP 
        FI; 
        VAR t2 IN 
          t2 := (endt - t) / (1 - t); 
          CurvedDashBit(pqrs, qrs, rs, s, t2, parity) 
        END; 
        t := endt 
    END 
  FI 
END;

/* CurvedDash draws a piece of the Bezier 
   "[p,q,r,s]" starting from "t" of length "len", 
   and advances "t". However, if a piece of length 
   "len" would extend past "s", the piece is drawn 
   to "s", and "len" is set to the length of the 
   segment that was drawn. */

PRIVATE PROC CurvedDashBit(p, q, r, s, t, parity) IS 
  IF 
    VAR pq, qr, rs, pqr, qrs, pqrs IN 
      Trellis(t, p, q, r, s, pq, qr, rs, pqr, qrs, 
              pqrs) -> 
        IF 
          parity > 0 -> PS.CurveTo(pq, pqr, pqrs) 
        | PS.MoveTo(pqrs) 
        FI 
    END 
  FI 
END;

/* CurvedDashBit(p,q,r,s,t) draws the piece of 
   Bezier(p,q,r,s) from 0 to t. */

PROC Stroke() IS 
  VAR path, currPt, startPt IN 
    path := PS.CurrentPath(); 
    PS.NewPath(); 
    currPt, startPt := NIL, NIL; 
    DO 
      path # NIL -> 
        IF 
          VAR op, args IN 
            CAR(path) = (op, args) -> 
              IF 
                op = "MoveTo" -> 
                  startPt := CAR(args); 
                  Move(startPt); 
                  currPt := startPt 
              | op = "LineTo" -> 
                  Line(currPt, CAR(args)); 
                  currPt := CAR(args) 
              | op = "CurveTo" -> 
                  VAR b, c, d IN 
                    args = [b, c, d] -> 
                      Curve(currPt, b, c, d); 
                      currPt := d 
                  END 
              | op = "Close" -> 
                  Line(currPt, startPt); 
                  currPt, startPt := NIL, NIL 
              FI 
          END 
        FI; 
        path := CDR(path) 
    OD; 
    PS.Stroke() 
  END 
END;

UI PointTool(Stroke);

(* Stroke the current path in the current line width 
   using this module's current dash pattern. *)

PROC Straight1(a, b) IS 
  VAR c IN 
    c := Arrow.StraightEnd(a, b, Arrow.HeadSize()); 
    PS.MoveTo(a); 
    PS.LineTo(c); 
    Stroke(); 
    Arrow.Head(a, b) 
  END 
END;

UI PointTool(Straight1);

(* Draw a dashed directed line from "a" to "b". The 
   arrow head size is determined using the 
   "Arrow.HeadSize" procedure. *)

PROC Straight2(a, b) IS 
  VAR sz, c, d IN 
    sz := Arrow.HeadSize(); 
    c := Arrow.StraightEnd(b, a, sz); 
    d := Arrow.StraightEnd(a, b, sz); 
    Arrow.Head(b, a); 
    PS.MoveTo(c); 
    PS.LineTo(d); 
    Stroke(); 
    Arrow.Head(a, b) 
  END 
END;

UI PointTool(Straight2);

(* Draw a dashed directed line between "a" and "b". 
   The arrow head size is determined using the 
   "Arrow.HeadSize" procedure. *)

PROC Curved1(a, b, c, d) IS 
  VAR e IN 
    e := Arrow.StraightEnd(c, d, Arrow.HeadSize()); 
    PS.MoveTo(a); 
    PS.CurveTo(b, c, e); 
    Stroke(); 
    Arrow.Head(c, d) 
  END 
END;

UI PointTool(Curved1);

(* Draw a dashed directed curve from "a" to "d" 
   using "b" and "c" as control points. The arrow 
   head size is determined using the 
   "Arrow.HeadSize" procedure. *)

PROC Curved2(a, b, c, d) IS 
  VAR sz, e, f IN 
    sz := Arrow.HeadSize(); 
    e := Arrow.StraightEnd(b, a, sz); 
    f := Arrow.StraightEnd(c, d, sz); 
    Arrow.Head(b, a); 
    PS.MoveTo(e); 
    PS.CurveTo(b, c, f); 
    Stroke(); 
    Arrow.Head(c, d) 
  END 
END;

UI PointTool(Curved2);

(* Draw a dashed directed curve between "a" and "d" 
   using "b" and "c" as control points. The arrow 
   head size is determined using the 
   "Arrow.HeadSize" procedure. *)

PRIVATE VAR history := NIL;

PROC Save() IS 
  history := ((dashList, offset), history) 
END;

PROC Restore() IS 
  VAR state IN 
    state := CAR(history); 
    dashList := CAR(state); 
    offset := CDR(state); 
    history := CDR(history) 
  END 
END;

UI PointTool(Save);

UI PointTool(Restore);

(* Save/restore the "Dash" state, namely the dash 
   pattern and offset. *)