Copyright (C) 1994, Digital Equipment Corp.
Path.mod, by cgn, mkent and msm, Wed Nov 12 17:58:38 1986
UNSAFE MODULEPath EXPORTSPath ,PathPrivate ; <*PRAGMA LL*> IMPORT Point, Rect, Word; CONST InitialSize = 32; PROCEDUREFreeze (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; PROCEDUREThaw (<*UNUSED*>l: Lock) = BEGIN END Thaw; PROCEDUREReAllocate (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; PROCEDUREReset (path: T) = BEGIN path.next := path.start; path.current := path.start; path.curveCount := 0 END Reset; CONST LineSize = ADRSIZE (LineRec); CurveSize = ADRSIZE (CurveRec); PROCEDUREMoveTo (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*> PROCEDURELineTo (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; PROCEDUREClose (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; PROCEDURECurveTo (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; PROCEDUREMap (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; PROCEDURETranslate (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; PROCEDUREDTranslate (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; PROCEDUREIsClosed (path: T): BOOLEAN = BEGIN RETURN path.current = path.next END IsClosed; PROCEDUREIsEmpty (path: T): BOOLEAN = BEGIN RETURN path.next = path.start END IsEmpty; PROCEDURECurrentPoint (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; PROCEDURECopy (path: T): T = BEGIN IF path.next # path.start THEN (* this code doesn't actually copy the data! IF (path.points = NIL) THEN RETURN NEW(T, points := NIL, start := path.start, next := path.next, current := path.current, end := path.end, curveCount := path.curveCount); END; *) WITH l1 = Freeze(path), pathWords = (path.next - path.start) DIV ADRSIZE(Word.T), res = NEW( T, points := NEW(ArrayRef, MAX(InitialSize, pathWords))), l2 = Freeze(res) DO res.start := ADR(res.points[0]); IF path.points # NIL THEN SUBARRAY(res.points^, 0, pathWords) := SUBARRAY(path.points^, 0, pathWords) ELSE VAR p,q: UNTRACED REF Word.T; BEGIN p := path.start; q := res.start; FOR i := 1 TO pathWords DO q^ := p^; p := p + ADRSIZE(Word.T); q := q + ADRSIZE(Word.T) END END END; 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 ELSE RETURN NEW(T) END; END Copy; PROCEDUREFlatten (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; PROCEDUREFlatLine (self: FlatMap; <*UNUSED*> READONLY p: Point.T; READONLY q: Point.T) = BEGIN LineTo(self.res, q) END FlatLine; PROCEDUREFlatClose (self: FlatMap; <*UNUSED*> READONLY p, q: Point.T) = BEGIN Close(self.res) END FlatClose; PROCEDUREFlatMove (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; PROCEDUREFlatCurve (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; PROCEDURENonMonotonicFlatCurve (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; PROCEDUREMonotonicFlatCurve (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; TYPE BBClosure = MapObject OBJECT res: Rect.T OVERRIDES move := BBMove; line := BBLine; close := BBClose; curve := BBCurve END; PROCEDUREBBMove ( bbc: BBClosure; READONLY pt: Point.T) = BEGIN WITH r = bbc.res DO IF Rect.IsEmpty(r) THEN r := Rect.FromPoint(pt) ELSE r.west := MIN(r.west, pt.h); r.east := MAX(r.east, pt.h+1); r.north := MIN(r.north, pt.v); r.south := MAX(r.south, pt.v+1) END END END BBMove; PROCEDUREBBClose ( <*UNUSED*> bbc: BBClosure; <*UNUSED*> READONLY pt1, pt2: Point.T) = BEGIN END BBClose; PROCEDUREBBLine ( bbc: BBClosure; <*UNUSED*> READONLY pt1: Point.T; READONLY pt2: Point.T) = BEGIN WITH r = bbc.res DO r.west := MIN(r.west, pt2.h); r.east := MAX(r.east, pt2.h+1); r.north := MIN(r.north, pt2.v); r.south := MAX(r.south, pt2.v+1) END END BBLine; PROCEDUREBBCurve (bbc: BBClosure; READONLY p, q, r, s: Point.T) = VAR psRect := RectHull(p, s); BEGIN IF Rect.Member(q, psRect) AND Rect.Member(r, psRect) THEN bbc.res := Rect.Join(bbc.res, psRect) ELSE VAR ah, av, bh, bv, ch, cv, dh, dv, eh, ev, fh, fv: INTEGER; BEGIN (* quadruple and subdivide *) ah := (p.h + q.h) * 2; av := (p.v + q.v) * 2; bh := (q.h + r.h) * 2; bv := (q.v + r.v) * 2; ch := (r.h + s.h) * 2; cv := (r.v + s.v) * 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; WITH res = bbc.res DO JoinPoint(res, p); JoinPoint(res, Point.T{ah DIV 4, av DIV 4}); JoinPoint(res, Point.T{dh DIV 4, dv DIV 4}); JoinPoint(res, Point.T{fh DIV 4, fv DIV 4}); JoinPoint(res, Point.T{eh DIV 4, ev DIV 4}); JoinPoint(res, Point.T{ch DIV 4, cv DIV 4}); JoinPoint(res, s) END END END END BBCurve; PROCEDURERectHull (READONLY p, q: Point.T): Rect.T = BEGIN RETURN Rect.T{ MIN(p.h, q.h), MAX(p.h, q.h) + 1, MIN(p.v, q.v), MAX(p.v, q.v) + 1} END RectHull; PROCEDUREJoinPoint (VAR r: Rect.T; READONLY pt: Point.T) =
Requires NOT Rect.IsEmpty(r)
.
BEGIN r.west := MIN(r.west, pt.h); r.east := MAX(r.east, pt.h + 1); r.north := MIN(r.north, pt.v); r.south := MAX(r.south, pt.v + 1) END JoinPoint; PROCEDUREBoundingBox (p: T): Rect.T RAISES {Malformed} = VAR cl := NEW(BBClosure, res := Rect.Empty); BEGIN Map(p, cl); RETURN cl.res END BoundingBox; BEGIN END Path.