(* Copyright (C) 1992, Digital Equipment Corporation                         *)
(* All rights reserved.                                                      *)
(* See the file COPYRIGHT for a full description.                            *)
(*                                                                           *)
(* Path.mod, by cgn, mkent and msm, Wed Nov 12 17:58:38 1986 *)
(* Last modified on Tue Feb 11 16:22:05 PST 1992 by muller  *)
(*      modified on Wed Oct 23  0:41:01 PDT 1991 by gnelson *)
(*      modified on Fri Sep 13  1:34:30 PDT 1991 by msm *)
(*      modified on Tue Jul 11  9:36:22 PDT 1989 by roberts *)
(*      modified on Fri Sep 16 19:15:52 PDT 1988 by pieper *)
(*      modified on Tue Aug  4 10:26:07 1987 by mkent *)
UNSAFE MODULE Path EXPORTS Path, PathPrivate;
<*PRAGMA LL*>

IMPORT Point, Word, CopyBytes;

CONST InitialSize = 32;

PROCEDURE Freeze(path: T): Lock =
  VAR res: Lock; BEGIN
    IF path.points = NIL THEN RETURN NIL END;
    res := ADR(path.points[0]);
    IF res # path.start THEN
      WITH delta = res - path.start DO
        INC(path.start, delta);
        INC(path.current, delta);
        INC(path.next, delta);
        INC(path.end, delta)
      END
    END;
    RETURN res
  END Freeze;

PROCEDURE Thaw(<*UNUSED*>l: Lock) =
  BEGIN END Thaw;

PROCEDURE ReAllocate(path: T; VAR l: Lock) =
  VAR newPoints: ArrayRef; nl: Lock; BEGIN
    IF path.points = NIL THEN
      newPoints := NEW(ArrayRef, InitialSize);
      nl := ADR(newPoints[0]);
      path.start := nl;
      path.next := nl;
      path.current := nl
    ELSE
      newPoints := NEW(ArrayRef, 2 * NUMBER(path.points^));
      nl := ADR(newPoints[0]);
      SUBARRAY(newPoints^, 0, NUMBER(path.points^)) := path.points^;
      WITH delta = nl - path.start DO
        INC(path.start, delta);
        INC(path.next, delta);
        INC(path.current, delta)
      END
    END;
    path.end := nl + ADRSIZE(Word.T) * NUMBER(newPoints^);
    l := nl;
    path.points := newPoints
  END ReAllocate;

PROCEDURE Reset(path: T) =
  BEGIN
    path.next := path.start;
    path.current := path.start;
    path.curveCount := 0
  END Reset;

CONST 
  LineSize = ADRSIZE (LineRec);
  CurveSize = ADRSIZE (CurveRec);

PROCEDURE MoveTo(path: T; READONLY pt: Point.T) =
  VAR l := Freeze(path); BEGIN
    IF path.end - path.next < LineSize THEN ReAllocate(path, l) END;
    VAR ptr: PLine := path.next; BEGIN
      ptr.ct := Type.Move;
      ptr.p := pt
    END;
    path.current := path.next;
    INC(path.next, LineSize);
    Thaw(l)
  END MoveTo;
      
EXCEPTION FatalError(TEXT); <*FATAL FatalError*>

PROCEDURE LineTo(path: T; READONLY pt: Point.T) =
  VAR l := Freeze(path); BEGIN
    IF path.current = path.next THEN 
      RAISE FatalError("LineTo with no current point")
    END;
    IF path.end - path.next < LineSize THEN ReAllocate(path, l) END;
    VAR ptr: PLine := path.next; BEGIN
      ptr.ct := Type.Line;
      ptr.p := pt
    END;
    INC(path.next, LineSize);
    Thaw(l)
  END LineTo;
      
PROCEDURE Close(path: T) =
  VAR l := Freeze(path); BEGIN
    IF path.current = path.next THEN 
      RAISE FatalError("Close with no current point")
    END;
    IF path.end - path.next < LineSize THEN ReAllocate(path, l) END;
    VAR ptr: PLine := path.next; BEGIN
      ptr.ct := Type.Close;
      ptr.p := LOOPHOLE(path.current, PLine).p
    END;
    INC(path.next, LineSize);
    path.current := path.next;
    Thaw(l)
  END Close;
      
PROCEDURE CurveTo (path: T; READONLY p, q, r: Point.T) =
  VAR l := Freeze(path); BEGIN
    IF path.current = path.next THEN 
      RAISE FatalError("CurveTo with no current point")
    END;
    IF path.end - path.next < CurveSize THEN ReAllocate(path, l) END;
    VAR ptr: PCurve := path.next; BEGIN
      ptr.ct := Type.Curve;
      ptr.p := p;
      ptr.q := q;
      ptr.r := r
    END;
    INC(path.next, CurveSize);
    INC(path.curveCount);
    Thaw(l)
  END CurveTo;

PROCEDURE Map(path: T; map: MapObject) RAISES {Malformed} =
  VAR l := Freeze(path); ptr: PCurve; current: Point.T; BEGIN
    ptr := path.start;
    WHILE ptr < path.next DO
      CASE ptr.ct OF
        Type.Move => 
          map.move(ptr.p); current := ptr.p; INC(ptr, LineSize)
      | Type.Line => 
          map.line(current, ptr.p); 
          current := ptr.p;
          INC(ptr, LineSize)
      | Type.Curve =>
          map.curve(current, ptr.p, ptr.q, ptr.r);
          current := ptr.r;
          INC(ptr, CurveSize)
      | Type.Close =>
          map.close(current, ptr.p);
          INC(ptr, LineSize)
      ELSE
        RAISE Malformed
      END
    END;
    IF ptr # path.next THEN RAISE Malformed END;
    Thaw(l)
  END Map;

PROCEDURE Translate(path: T; READONLY delta: Point.T): T RAISES {Malformed} =
  VAR l := Freeze(path); res := Copy(path); BEGIN
    DTranslate(res, delta);
    Thaw(l);
    RETURN res
  END Translate;
  
PROCEDURE DTranslate(path: T; READONLY delta: Point.T) RAISES {Malformed} =
  VAR ptr: PCurve := path.start; BEGIN
    WHILE ptr < path.next DO
      CASE ptr.ct OF
        Type.Move, Type.Line, Type.Close => 
          ptr.p := Point.Add(ptr.p, delta); INC(ptr, LineSize)
      | Type.Curve =>
          ptr.p := Point.Add(ptr.p, delta);
          ptr.q := Point.Add(ptr.q, delta);
          ptr.r := Point.Add(ptr.r, delta);
          INC(ptr, CurveSize)
      ELSE
        RAISE Malformed
      END
    END;
    IF ptr # path.next THEN RAISE Malformed END
  END DTranslate;

PROCEDURE IsClosed (path: T): BOOLEAN =
  BEGIN
    RETURN path.current = path.next
  END IsClosed;

PROCEDURE IsEmpty (path: T): BOOLEAN =
  BEGIN
    RETURN path.next = path.start
  END IsEmpty;

PROCEDURE CurrentPoint (path: T): Point.T =
  VAR l := Freeze(path); ptr: UNTRACED REF Point.T; res: Point.T; BEGIN
    IF path.next = path.current THEN 
      RAISE FatalError("No currentpoint") 
    END;
    ptr := path.next - ADRSIZE(Point.T);
    res := ptr^;
    Thaw(l);
    RETURN res
  END CurrentPoint;

PROCEDURE Copy(path: T): T =
  VAR 
    l1 := Freeze(path);
    res := NEW(T, points := NEW(ArrayRef, 
      MAX(InitialSize, (path.next - path.start) DIV ADRSIZE(Word.T))));
    l2 := Freeze(res);
  BEGIN
    res.start := ADR(res.points[0]);
    CopyBytes.P(path.start, res.start, path.next - path.start);
    WITH delta = res.start - path.start DO
      res.next := path.next + delta;
      res.current := path.current + delta
    END;
    res.end := res.start + ADRSIZE(Word.T) * NUMBER(res.points^);
    res.curveCount := path.curveCount;
    Thaw(l1);
    Thaw(l2);
    RETURN res
  END Copy;

PROCEDURE Flatten(p: T): T RAISES {Malformed} =
  VAR flat: FlatMap;
  BEGIN
    IF p.curveCount = 0 THEN RETURN p END;
    flat := NEW(FlatMap, res := NEW(T));
    Map(p, flat);
    RETURN flat.res
  END Flatten;

TYPE FlatMap = 
  MapObject OBJECT 
    res: T;
  OVERRIDES
    line := FlatLine;
    move := FlatMove;
    close := FlatClose;
    curve := FlatCurve
  END;

PROCEDURE FlatLine(self: FlatMap; <*UNUSED*> 
  READONLY p: Point.T; READONLY q: Point.T) = 
  BEGIN
    LineTo(self.res, q)
  END FlatLine;

PROCEDURE FlatClose(self: FlatMap; <*UNUSED*> READONLY p, q: Point.T) = 
  BEGIN
    Close(self.res)
  END FlatClose;

PROCEDURE FlatMove(self: FlatMap; READONLY q: Point.T) = 
  BEGIN
    MoveTo(self.res, q)
  END FlatMove;

TYPE Bezier = RECORD ph, pv, qh, qv, rh, rv, sh, sv: INTEGER END;

PROCEDURE FlatCurve(self: FlatMap; READONLY pp, qq, rr, ss: Point.T) =
  BEGIN
    NonMonotonicFlatCurve(self, 4*pp.h, 4*pp.v, 4*qq.h, 4*qq.v,
      4*rr.h, 4*rr.v, 4*ss.h, 4*ss.v)
  END FlatCurve;
      
PROCEDURE NonMonotonicFlatCurve(self: FlatMap; 
  ph, pv, qh, qv, rh, rv, sh, sv: INTEGER) =
  VAR st: ARRAY [0..20] OF Bezier; n := 0;
      ah, av, bh, bv, ch, cv, dh, dv, eh, ev, fh, fv: INTEGER;
  BEGIN
    LOOP
      IF ( ph <= qh AND qh <= rh AND rh <= sh
        OR ph >= qh AND qh >= rh AND rh >= sh )
      AND
         ( pv <= qv AND qv <= rv AND rv <= sv
        OR pv >= qv AND qv >= rv AND rv >= sv )
      THEN
        MonotonicFlatCurve(self, ph, pv, qh, qv, rh, rv, sh, sv);
        IF n = 0 THEN RETURN END;
        DEC(n);
        WITH top = st[n] DO
          ph := top.ph; pv := top.pv;
          qh := top.qh; qv := top.qv;
          rh := top.rh; rv := top.rv;
          sh := top.sh; sv := top.sv
        END
      ELSE
        (* subdivide *)
        ah := (ph + qh) DIV 2; av := (pv + qv) DIV 2;
        bh := (qh + rh) DIV 2; bv := (qv + rv) DIV 2;
        ch := (rh + sh) DIV 2; cv := (rv + sv) DIV 2;
        dh := (ah + bh) DIV 2; dv := (av + bv) DIV 2;
        eh := (bh + ch) DIV 2; ev := (bv + cv) DIV 2;
        fh := (dh + eh) DIV 2; fv := (dv + ev) DIV 2;
        IF n = NUMBER(st) THEN
          NonMonotonicFlatCurve(self, ph, pv, ah, av, dh, dv, fh, fv);
          ph := fh; pv := fv; 
          qh := eh; qv := ev; 
          rh := ch; rv := cv
        ELSE
          WITH top = st[n] DO
            top.ph := fh; top.pv := fv;
            top.qh := eh; top.qv := ev; 
            top.rh := ch; top.rv := cv; 
            top.sh := sh; top.sv := sv
          END;
          INC(n);
          qh := ah; qv := av; 
          rh := dh; rv := dv; 
          sh := fh; sv := fv
        END
      END
    END
  END NonMonotonicFlatCurve;

PROCEDURE MonotonicFlatCurve(self: FlatMap; 
    ph, pv, qh, qv, rh, rv, sh, sv: INTEGER) =
  VAR st: ARRAY [0..20] OF Bezier; n := 0;
      res := self.res;  
      ah, av, bh, bv, ch, cv, dh, dv, eh, ev, fh, fv: INTEGER;
  BEGIN
    LOOP
      ah := qh - ph;
      av := qv - pv;
      bh := rh - ph;
      bv := rv - pv;
      ch := sh - ph;
      cv := sv - pv;
      dh := ah * cv - av * ch;
      dv := bh * cv - bv * ch;
      eh := ABS(ch) + ABS(cv);
      IF ABS(dh) <= eh AND ABS(dv) <= eh THEN
        LineTo(res, Point.T{sh DIV 4, sv DIV 4});
        IF n = 0 THEN RETURN END;
        DEC(n);
        WITH top = st[n] DO
          ph := top.ph; pv := top.pv;
          qh := top.qh; qv := top.qv;
          rh := top.rh; rv := top.rv;
          sh := top.sh; sv := top.sv
        END
      ELSE
        (* subdivide *)
        ah := (ph + qh) DIV 2; av := (pv + qv) DIV 2;
        bh := (qh + rh) DIV 2; bv := (qv + rv) DIV 2;
        ch := (rh + sh) DIV 2; cv := (rv + sv) DIV 2;
        dh := (ah + bh) DIV 2; dv := (av + bv) DIV 2;
        eh := (bh + ch) DIV 2; ev := (bv + cv) DIV 2;
        fh := (dh + eh) DIV 2; fv := (dv + ev) DIV 2;
        IF n = NUMBER(st) THEN
          MonotonicFlatCurve(self, ph, pv, ah, av, dh, dv, fh, fv);
          ph := fh; pv := fv; 
          qh := eh; qv := ev; 
          rh := ch; rv := cv
        ELSE
          WITH top = st[n] DO
            top.ph := fh; top.pv := fv;
            top.qh := eh; top.qv := ev; 
            top.rh := ch; top.rv := cv; 
            top.sh := sh; top.sv := sv
          END;
          INC(n);
          qh := ah; qv := av; 
          rh := dh; rv := dv; 
          sh := fh; sv := fv
        END
      END
    END
  END MonotonicFlatCurve;
    
BEGIN
END Path.