(FILECREATED "30-Nov-84 18:26:24" {ERIS}<LISPNEW>PATCHES>PRESSCURVEPATCH.;2 10630
changes to: (FNS \CURVESLOPE)
previous date: "30-Nov-84 17:40:47" {ERIS}<LISPNEW>PATCHES>PRESSCURVEPATCH.;1)
(* Copyright (c) 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT PRESSCURVEPATCHCOMS)
(RPAQQ PRESSCURVEPATCHCOMS ((FNS VECFONTINIT PARAMETRICSPLINE \CURVESLOPE)))
(DEFINEQ
(VECFONTINIT
[LAMBDA NIL (* rmk: "30-Nov-84 16:53")
(* Initialize \VecFontDir, a list of lists of dummy font descriptors for the ReDraw vector fonts.
The structure is ((round brushes) (square brushes) (horizontal brushes) (vertical brushes)))
(DECLARE (GLOBALVARS \VecFontDir))
(* WIDTHS is a dummy array descriptor so that \DSPFONT.PRESS doesn't get confused. If any real character output were
done with this descriptor in force, the results would be disastrous. But the RESETSAVE in \PRESSCURVE2 should
prevent this.)
(OR \VecFontDir (SETQ \VecFontDir (for FMLY (WIDTHS ←(ARRAY 256 (QUOTE SMALLP)
1 0))
in (QUOTE (NEWVEC SNEWVEC HNEWVEC VNEWVEC))
collect (for BRUSH in (QUOTE (4 8 16 32 64))
collect (create FONTDESCRIPTOR
FONTDEVICE ←(QUOTE PRESS)
FONTFAMILY ← FMLY
FONTSIZE ← BRUSH
FONTFACE ←(QUOTE (MEDIUM REGULAR
REGULAR))
ROTATION ← 0
\SFWidths ← WIDTHS])
(PARAMETRICSPLINE
[LAMBDA (KNOTS CLOSEDFLG SPLINE) (* rmk: "30-Nov-84 17:02")
(* KNOTS is a non-NIL list of knots, CLOSEDFLG =>
closed curve)
(PROG (DX DY DDX DDY DDDX DDDY #KNOTS A BX BY X Y SX SY A C R D2X D2Y I)
[COND
(CLOSEDFLG (* Wrap around)
(push KNOTS (CAR (LAST KNOTS]
(SETQ #KNOTS (LENGTH KNOTS))
(SETQ DX (ARRAY #KNOTS 0 0.0))
(SETQ DDX (ARRAY #KNOTS 0 0.0))
(SETQ DDDX (ARRAY #KNOTS 0 0.0))
(SETQ DY (ARRAY #KNOTS 0 0.0))
(SETQ DDY (ARRAY #KNOTS 0 0.0))
(SETQ DDDY (ARRAY #KNOTS 0 0.0))
(SETQ X (ARRAY #KNOTS 0 0.0))
(SETQ Y (ARRAY #KNOTS 0 0.0))
(for KNOT in KNOTS as I from 1 to #KNOTS
do (OR (type? POSITION KNOT)
(ERROR "bad knot" KNOT))
(SETA X I (CAR KNOT))
(SETA Y I (CDR KNOT)))
(SETQ A (ARRAY #KNOTS 0 0.0))
(SETQ BX (ARRAY #KNOTS 0 0.0))
(SETQ BY (ARRAY #KNOTS 0 0.0))
[COND
(CLOSEDFLG (SETQ C (ARRAY #KNOTS 0 0.0))
(SETQ R (ARRAY #KNOTS 0 0.0))
(SETQ SX (ARRAY #KNOTS 0 0.0))
(SETQ SY (ARRAY #KNOTS 0 0.0]
(SETA A 1 4.0)
[for I from 2 to (IDIFFERENCE #KNOTS 2) do (SETA A I (FDIFFERENCE
4.0
(FQUOTIENT 1.0 (ELT A (SUB1 I]
[COND
(CLOSEDFLG (SETA C 1 1.0)
(for I from 2 to (IDIFFERENCE #KNOTS 2)
do (SETA C I (FMINUS (FQUOTIENT (ELT C (SUB1 I))
(ELT A (SUB1 I]
[COND
((IGEQ #KNOTS 3)
(COND
[CLOSEDFLG [SETA BX 1 (FTIMES 6.0 (FPLUS (ELT X 2)
(FMINUS (FTIMES 2.0 (ELT X 1)))
(ELT X (SUB1 #KNOTS]
[SETA BY 1 (FTIMES 6.0 (FPLUS (ELT Y 2)
(FMINUS (FTIMES 2.0 (ELT Y 1)))
(ELT Y (SUB1 #KNOTS]
[for I from 2 to (IDIFFERENCE #KNOTS 2)
do [SETA BX I (FDIFFERENCE [FTIMES 6.0
(FPLUS (ELT X (ADD1 I))
(FMINUS (FTIMES 2.0
(ELT X I)))
(ELT X (SUB1 I]
(FQUOTIENT (ELT BX (SUB1 I))
(ELT A (SUB1 I]
(SETA BY I (FDIFFERENCE [FTIMES 6.0
(FPLUS (ELT Y (ADD1 I))
(FMINUS (FTIMES 2.0
(ELT Y I)))
(ELT Y (SUB1 I]
(FQUOTIENT (ELT BY (SUB1 I))
(ELT A (SUB1 I]
(SETA R (SUB1 #KNOTS)
1.0)
(SETA SX (SUB1 #KNOTS)
0.0)
(SETA SY (SUB1 #KNOTS)
0.0)
(for I from (IDIFFERENCE #KNOTS 2) to 1 by -1
do [SETA R I (FMINUS (FQUOTIENT (FPLUS (ELT R (ADD1 I))
(ELT C I))
(ELT A I]
(SETA SX I (FQUOTIENT (FDIFFERENCE (ELT BX I)
(ELT SX (ADD1 I)))
(ELT A I)))
(SETA SY I (FQUOTIENT (FDIFFERENCE (ELT BY I)
(ELT SY (ADD1 I)))
(ELT A I]
(T [SETA BX 1 (FTIMES 6.0 (FPLUS (FDIFFERENCE (ELT X 3)
(FTIMES 2.0 (ELT X 2)))
(ELT X 1]
[SETA BY 1 (FTIMES 6.0 (FPLUS (FDIFFERENCE (ELT Y 3)
(FTIMES 2.0 (ELT Y 2)))
(ELT Y 1]
(for I from 2 to (IDIFFERENCE #KNOTS 2)
do [SETA BX I (FDIFFERENCE (FTIMES 6.0
(FPLUS [FDIFFERENCE
(ELT X (IPLUS I 2))
(FTIMES 2 (ELT X (ADD1 I]
(ELT X I)))
(FQUOTIENT (ELT BX (SUB1 I))
(ELT A (SUB1 I]
(SETA BY I (FDIFFERENCE (FTIMES 6.0
(FPLUS [FDIFFERENCE
(ELT Y (IPLUS I 2))
(FTIMES 2 (ELT Y (ADD1 I]
(ELT Y I)))
(FQUOTIENT (ELT BY (SUB1 I))
(ELT A (SUB1 I]
[COND
(CLOSEDFLG [SETQ D2X (FPLUS (ELT X #KNOTS)
[FMINUS (FTIMES 2.0 (ELT X (SUB1 #KNOTS]
(ELT X (IDIFFERENCE #KNOTS 2]
[SETQ D2Y (FPLUS (ELT Y #KNOTS)
[FMINUS (FTIMES 2.0 (ELT Y (SUB1 #KNOTS]
(ELT Y (IDIFFERENCE #KNOTS 2]
(SETA DDX (SUB1 #KNOTS)
(FQUOTIENT (FDIFFERENCE (FDIFFERENCE (FTIMES D2X 6.0)
(ELT SX 1))
(ELT SX (IDIFFERENCE #KNOTS 2)))
(FPLUS (ELT R 1)
(ELT R (IDIFFERENCE #KNOTS 2))
4.0)))
(SETA DDY (SUB1 #KNOTS)
(FQUOTIENT (FDIFFERENCE (FDIFFERENCE (FTIMES D2Y 6.0)
(ELT SY 1))
(ELT SY (IDIFFERENCE #KNOTS 2)))
(FPLUS (ELT R 1)
(ELT R (IDIFFERENCE #KNOTS 2))
4.0)))
[for I from 1 to (IDIFFERENCE #KNOTS 2)
do [SETA DDX I (FPLUS (ELT SX I)
(FTIMES (ELT R I)
(ELT DDX (SUB1 #KNOTS]
(SETA DDY I (FPLUS (ELT SY I)
(FTIMES (ELT R I)
(ELT DDY (SUB1 #KNOTS]
(SETA DDX #KNOTS (ELT DDX 1))
(SETA DDY #KNOTS (ELT DDY 1)))
(T (* COMPUTE SECOND DERIVATIVES.)
[SETA DDX 1 (SETA DDY 1 (SETA DDX #KNOTS (SETA DDY #KNOTS 0.0]
(for I from (SUB1 #KNOTS) to 2 by -1
do [SETA DDX I (FQUOTIENT (FDIFFERENCE (ELT BX (SUB1 I))
(ELT DDX (ADD1 I)))
(ELT A (SUB1 I]
(SETA DDY I (FQUOTIENT (FDIFFERENCE (ELT BY (SUB1 I))
(ELT DDY (ADD1 I)))
(ELT A (SUB1 I]
[for I from 1 to (SUB1 #KNOTS)
do (* COMPUTE 1ST & 3RD DERIVATIVES)
(SETA DX I (FDIFFERENCE (FDIFFERENCE (ELT X (ADD1 I))
(ELT X I))
(FQUOTIENT (FPLUS (FTIMES 2 (ELT DDX I))
(ELT DDX (ADD1 I)))
6.0)))
(SETA DY I (FDIFFERENCE (FDIFFERENCE (ELT Y (ADD1 I))
(ELT Y I))
(FQUOTIENT (FPLUS (FTIMES 2 (ELT DDY I))
(ELT DDY (ADD1 I)))
6.0)))
(SETA DDDX I (FDIFFERENCE (ELT DDX (ADD1 I))
(ELT DDX I)))
(SETA DDDY I (FDIFFERENCE (ELT DDY (ADD1 I))
(ELT DDY I]
(SETQ SPLINE
(create SPLINE
#KNOTS ← #KNOTS
SPLINEX ← X
SPLINEY ← Y
SPLINEDX ← DX
SPLINEDY ← DY
SPLINEDDX ← DDX
SPLINEDDY ← DDY
SPLINEDDDX ← DDDX
SPLINEDDDY ← DDDY))
(RETURN SPLINE])
(\CURVESLOPE
[LAMBDA (KNOTS ENDFLG) (* rrb "30-Nov-84 18:17")
(* returns a CONS of DX DY that gives the slope of the curve thru KNOTS. If ENDFLG is NIL, it is at the beginning.
If ENDFLG is T, it is at the last point.)
(PROG (DX DY PARAMS (#KNOTS (LENGTH KNOTS)))
(RETURN (SELECTQ #KNOTS
((0 1) (* define slope as horizontal)
(QUOTE (1 . 0)))
[2 (CONS (DIFFERENCE (fetch (POSITION XCOORD) of (CADR KNOTS))
(fetch (POSITION XCOORD) of (CAR KNOTS)))
(DIFFERENCE (fetch (POSITION YCOORD) of (CADR KNOTS))
(fetch (POSITION YCOORD) of (CAR KNOTS]
(PROGN [SETQ PARAMS (COND
[ENDFLG (PARAMETRICSPLINE (REVERSE (NLEFT KNOTS
(IMIN #KNOTS 4]
(T (PARAMETRICSPLINE (COND
((EQ #KNOTS 3)
(LIST (CAR KNOTS)
(CADR KNOTS)
(CADDR KNOTS)))
(T (LIST (CAR KNOTS)
(CADR KNOTS)
(CADDR KNOTS)
(CADDDR KNOTS]
(SETQ DX (ELT (fetch (SPLINE SPLINEDX) of PARAMS)
1))
(SETQ DY (ELT (fetch (SPLINE SPLINEDY) of PARAMS)
1))
(if ENDFLG
then (CONS (MINUS DX)
(MINUS DY))
else (CONS DX DY])
)
(PUTPROPS PRESSCURVEPATCH COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (402 10544 (VECFONTINIT 412 . 1579) (PARAMETRICSPLINE 1581 . 9001) (\CURVESLOPE 9003 .
10542)))))
STOP