(FILECREATED " 9-Oct-85 16:10:13" {PHYLUM}<PAPERWORKS>SKETCHELEMENTS.;52 291799
changes to: (FNS SK.GUESS.FONTSAVAILABLE)
previous date: " 4-Oct-85 17:37:14" {PHYLUM}<PAPERWORKS>SKETCHELEMENTS.;50)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT SKETCHELEMENTSCOMS)
(RPAQQ SKETCHELEMENTSCOMS ((* contains the functions need to implement the sketch basic element
types)
(FNS INIT.SKETCH.ELEMENTS CREATE.SKETCH.ELEMENT.TYPE SKETCH.ELEMENT.TYPEP
SKETCH.ELEMENT.NAMEP)
(COMS (* color and filling stuff)
(FNS SKETCHINCOLORP READ.COLOR.CHANGE)
(INITVARS (SKETCHINCOLORFLG)
(FILLPOLYGONFLG T))
(VARS (SK.DEFAULT.BACKCOLOR))
(GLOBALVARS SKETCHINCOLORFLG SK.DEFAULT.BACKCOLOR)
(RECORDS SKFILLING)
(* fns included until system is fixed so that it is ok to call DSPCOLOR in a system
without color loaded. Should be removed after J release.)
(FNS \POSSIBLECOLOR RGBP HLSP)
(FNS SKFILLINGP SK.INSURE.FILLING))
(COMS (FNS CIRCLE.EXPANDFN CIRCLE.DRAWFN CIRCLE.INPUTFN CIRCLE.INSIDEFN CIRCLE.REGIONFN
CIRCLE.TRANSLATE CIRCLE.TRANSFORMFN CIRCLE.TRANSLATEPTS SK.CIRCLE.CREATE
SET.CIRCLE.SCALE SK.BRUSH.READCHANGE)
(RECORDS BRUSH)
(DECLARE: DONTCOPY (RECORDS LOCALCIRCLE CIRCLE))
(UGLYVARS CIRCLEICON)
(CURSORS CIRCLE.CENTER CIRCLE.EDGE)
(VARS SKETCHELEMENTSCOMS (SK.DEFAULT.BRUSH (create BRUSH BRUSHSHAPE ← (QUOTE ROUND)
BRUSHSIZE ← 1 BRUSHCOLOR ←
BLACKCOLOR))
(SK.DEFAULT.DASHING)
(SK.DEFAULT.TEXTURE))
(GLOBALVARS SK.DEFAULT.BRUSH SK.DEFAULT.DASHING))
(COMS (FNS ELLIPSE.EXPANDFN ELLIPSE.DRAWFN ELLIPSE.INPUTFN ELLIPSE.INSIDEFN ELLIPSE.CREATE
ELLIPSE.REGIONFN ELLIPSE.TRANSLATEFN ELLIPSE.TRANSFORMFN ELLIPSE.TRANSLATEPTS
MARK.SPOT DISTANCEBETWEEN SQUARE COMPUTE.ELLIPSE.ORIENTATION
SK.COMPUTE.ELLIPSE.MINOR.RADIUS.PT)
(DECLARE: DONTCOPY (RECORDS LOCALELLIPSE ELLIPSE))
(UGLYVARS ELLIPSEICON)
(CURSORS ELLIPSE.CENTER ELLIPSE.SEMI.MAJOR ELLIPSE.SEMI.MINOR))
(COMS (FNS KNOTS.INSIDEFN OPENCURVE.INPUTFN SK.CURVE.CREATE MAXXEXTENT MAXYEXTENT
KNOT.SET.SCALE.FIELD OPENCURVE.DRAWFN OPENCURVE.EXPANDFN OPENCURVE.READCHANGEFN
OPENCURVE.TRANSFORMFN OPENCURVE.TRANSLATEPTSFN CLOSEDCURVE.DRAWFN
CLOSEDCURVE.EXPANDFN CLOSEDCURVE.REGIONFN READ.LIST.OF.POINTS CLOSEDCURVE.INPUTFN
CLOSEDCURVE.TRANSFORMFN CLOSEDCURVE.TRANSLATEPTSFN INVISIBLEPARTP SHOWSKETCHPOINT
SHOWSKETCHXY KNOTS.REGIONFN CURVE.REGIONFN KNOTS.TRANSLATEFN REGION.CONTAINING.PTS)
(FNS CHANGE.ELTS.BRUSH.SIZE CHANGE.ELTS.BRUSH CHANGE.ELTS.BRUSH.SHAPE
SK.CHANGE.BRUSH.SHAPE SK.CHANGE.BRUSH.COLOR SK.CHANGE.BRUSH.SIZE SK.CHANGE.ANGLE
SK.CHANGE.ARC.DIRECTION SK.SET.DEFAULT.BRUSH.SIZE READSIZECHANGE)
(DECLARE: DONTCOPY (RECORDS KNOTELT LOCALCURVE OPENCURVE CLOSEDCURVE LOCALKNOTS))
(UGLYVARS OPENCURVEICON CLOSEDCURVEICON)
(CURSORS CURVE.KNOT))
(COMS (FNS KNOTS.EXPANDFN OPEN.WIRE.DRAWFN OPEN.KNOTS.EXPANDFN OPENWIRE.READCHANGEFN
OPENWIRE.TRANSFORMFN OPENWIRE.TRANSLATEPTSFN SK.EXPAND.ARROWHEADS WIRE.INPUTFN
CLOSEDWIRE.REGIONFN SK.WIRE.CREATE WIRE.ADD.POINT.TO.END READ.ARROW.CHANGE
CHANGE.ELTS.ARROWHEADS)
(FNS CLOSED.WIRE.INPUTFN CLOSED.WIRE.DRAWFN CLOSEDWIRE.READCHANGEFN
CLOSEDWIRE.TRANSFORMFN CLOSEDWIRE.TRANSLATEPTSFN)
(FNS CHANGED.ARROW SK.CHANGE.ARROWHEAD SK.CHANGE.ARROWHEAD1 SK.CREATE.ARROWHEAD
SK.ARROWHEAD.CREATE SK.ARROWHEAD.END.TEST READ.ARROWHEAD.END ARROW.HEAD.POSITIONS
ARROWHEAD.POINTS.LIST CURVE.ARROWHEAD.POINTS LEFT.MOST.IS.BEGINP
WIRE.ARROWHEAD.POINTS DRAWARROWHEADS SK.SET.ARROWHEAD.LENGTH
SK.SET.ARROWHEAD.ANGLE SK.SET.ARROWHEAD.TYPE SK.SET.LINE.ARROWHEAD
SK.UPDATE.ARROWHEAD.FORMAT SK.SET.LINE.LENGTH.MODE)
(DECLARE: DONTCOPY (RECORDS LOCALWIRE WIRE CLOSEDWIRE LOCALCLOSEDWIRE ARROWHEAD))
(UGLYVARS WIREICON CLOSEDWIREICON)
(INITVARS (SK.ARROWHEAD.ANGLE.INCREMENT 10)
(SK.ARROWHEAD.LENGTH.INCREMENT 2))
(VARS (SK.DEFAULT.ARROWHEAD (LIST (QUOTE LINE)
30.0 12)))
(GLOBALVARS SK.DEFAULT.ARROWHEAD)
(INITVARS (SK.ARROW.END.MENU)
(SK.ARROW.EDIT.MENU)))
(COMS (* stuff to support the text element type.)
(FNS TEXT.CHANGEFN TEXT.READCHANGEFN \SK.READ.FONT.SIZE1 SK.TEXT.ELT.WITH.SAME.FIELDS
SK.READFONTFAMILY CLOSE.PROMPT.WINDOW TEXT.DRAWFN TEXT.DRAWFN1 TEXT.INSIDEFN
TEXT.EXPANDFN SK.TEXT.LINE.REGIONS SK.PICK.FONT SK.NEXTSIZEFONT
SK.DECREASING.FONT.LIST SK.GUESS.FONTSAVAILABLE TEXT.UPDATE.GLOBAL.REGIONS
REL.MOVE.REGION LTEXT.LINE.REGIONS TEXT.INPUTFN READ.TEXT TEXT.POSITION.AND.CREATE
CREATE.TEXT.ELEMENT SK.TEXT.FROM.TEXTBOX TEXT.SET.GLOBAL.REGIONS TEXT.REGIONFN
TEXT.TRANSLATEFN TEXT.TRANSFORMFN TEXT.TRANSLATEPTSFN TEXT.UPDATEFN SK.CHANGE.TEXT
TEXT.SET.SCALES SK.FONT.LIST)
(DECLARE: DONTCOPY (RECORDS TEXT LOCALTEXT))
(FNS SK.SET.FONT SK.SET.TEXT.FONT SK.SET.TEXT.SIZE SK.SET.TEXT.HORIZ.ALIGN
SK.READFONTSIZE SK.COLLECT.FONT.SIZES SK.SET.TEXT.VERT.ALIGN SK.SET.TEXT.LOOKS
SK.SET.DEFAULT.TEXT.FACE)
(FNS CREATE.SKETCH.TERMTABLE)
(VARS INDICATE.TEXT.SHADE)
[INITVARS (SK.DEFAULT.FONT)
(SK.DEFAULT.TEXT.ALIGNMENT (QUOTE (CENTER BASELINE]
(INITVARS \FONTSONFILE)
(VARS (SKETCH.TERMTABLE (CREATE.SKETCH.TERMTABLE)))
(GLOBALVARS SKETCH.TERMTABLE SK.DEFAULT.TEXT.ALIGNMENT INDICATE.TEXT.SHADE \FONTSONFILE)
)
(COMS (* stuff for supporting the TEXTBOX sketch element.)
(FNS SK.BREAK.INTO.LINES SK.BRUSH.SIZE SK.TEXTBOX.CREATE SK.TEXTBOX.CREATE1
SK.TEXTBOX.POSITION.IN.BOX TEXTBOX.CHANGEFN TEXTBOX.DRAWFN
SK.TEXTURE.AROUND.REGIONS TEXTBOX.EXPANDFN TEXTBOX.INPUTFN TEXTBOX.INSIDEFN
TEXTBOX.REGIONFN TEXTBOX.SET.GLOBAL.REGIONS TEXTBOX.TRANSLATEFN
TEXTBOX.TRANSLATEPTSFN TEXTBOX.TRANSFORMFN TEXTBOX.UPDATEFN TEXTBOX.READCHANGEFN
SK.TEXTBOX.TEXT.POSITION SK.TEXTBOX.FROM.TEXT ADD.EOLS)
(RECORDS LOCALTEXTBOX TEXTBOX)
(COMS (* stuff to handle default alignment for text boxes)
(FNS SK.SET.TEXTBOX.VERT.ALIGN SK.SET.TEXTBOX.HORIZ.ALIGN)
(VARS TEXTBOXICON)
[INITVARS (SK.DEFAULT.TEXTBOX.ALIGNMENT (QUOTE (CENTER CENTER]
(GLOBALVARS SK.DEFAULT.TEXTBOX.ALIGNMENT)))
(COMS (* functions to implement the box sketch element.)
(FNS SK.BOX.DRAWFN BOX.DRAWFN1 KNOTS.OF.REGION SK.DRAWAREABOX SK.BOX.EXPANDFN
SK.BOX.GETREGIONFN BOX.SET.SCALES SK.BOX.INPUTFN SK.BOX.CREATE SK.BOX.INSIDEFN
SK.BOX.REGIONFN SK.BOX.READCHANGEFN SK.CHANGE.FILLING SK.CHANGE.FILLING.COLOR
SK.BOX.TRANSLATEFN SK.BOX.TRANSFORMFN SK.BOX.TRANSLATEPTSFN
UNSCALE.REGION.FROM.SKETCHW UNSCALE.REGION.TO.GRID INCREASEREGION INSUREREGIONSIZE
EXPANDREGION REGION.FROM.COORDINATES)
(DECLARE: DONTCOPY (RECORDS BOX LOCALBOX))
(UGLYVARS BOXICON))
(COMS (* fns for the arc sketch element type)
(FNS ARC.DRAWFN ARC.EXPANDFN ARC.INPUTFN ARC.CREATE ARC.MOVEFN ARC.TRANSLATEPTS
ARC.INSIDEFN ARC.REGIONFN ARC.TRANSLATE ARC.TRANSFORMFN ARC.READCHANGEFN)
(FNS SK.COMPUTE.ARC.ANGLE.PT SK.COMPUTE.ARC.PTS SK.SET.ARC.DIRECTION
SK.SET.ARC.DIRECTION.CW SK.SET.ARC.DIRECTION.CCW SK.COMPUTE.SLOPE.OF.LINE
SK.CREATE.ARC.USING SET.ARC.SCALES)
(INITVARS (SK.NUMBER.OF.POINTS.IN.ARC 8))
(GLOBALVARS SK.NUMBER.OF.POINTS.IN.ARC)
(DECLARE: DONTCOPY (RECORDS ARC LOCALARC))
(CURSORS ARC.RADIUS.CURSOR ARC.ANGLE.CURSOR)
(UGLYVARS ARCICON))
(P (INIT.SKETCH.ELEMENTS))))
(* contains the functions need to implement the sketch basic element types)
(DEFINEQ
(INIT.SKETCH.ELEMENTS
[LAMBDA NIL (* rrb "28-Sep-85 19:07")
(* sets up the initial sketch element types.)
(* put the datatype for the element on the property
list of the name and use the name in the instances.)
[COND
((NOT (SKETCH.ELEMENT.TYPEP (QUOTE CIRCLE)))
(CREATE.SKETCH.ELEMENT.TYPE (QUOTE CIRCLE)
CIRCLEICON "Adds a circle to the figure." (FUNCTION CIRCLE.DRAWFN)
(FUNCTION CIRCLE.EXPANDFN)
(QUOTE OBSOLETE)
(FUNCTION SK.ELEMENTS.CHANGEFN)
(FUNCTION CIRCLE.INPUTFN)
(FUNCTION CIRCLE.INSIDEFN)
(FUNCTION CIRCLE.REGIONFN)
(FUNCTION CIRCLE.TRANSLATE)
NIL
(FUNCTION CLOSEDWIRE.READCHANGEFN)
(FUNCTION CIRCLE.TRANSFORMFN)
(FUNCTION CIRCLE.TRANSLATEPTS]
[COND
((NOT (SKETCH.ELEMENT.TYPEP (QUOTE ELLIPSE)))
(CREATE.SKETCH.ELEMENT.TYPE (QUOTE ELLIPSE)
ELLIPSEICON "Adds an ellipse to the figure."
(FUNCTION ELLIPSE.DRAWFN)
(FUNCTION ELLIPSE.EXPANDFN)
(QUOTE OBSOLETE)
(FUNCTION SK.ELEMENTS.CHANGEFN)
(FUNCTION ELLIPSE.INPUTFN)
(FUNCTION ELLIPSE.INSIDEFN)
(FUNCTION ELLIPSE.REGIONFN)
(FUNCTION ELLIPSE.TRANSLATEFN)
NIL
(FUNCTION SK.BRUSH.READCHANGE)
(FUNCTION ELLIPSE.TRANSFORMFN)
(FUNCTION ELLIPSE.TRANSLATEPTS]
[COND
((NOT (SKETCH.ELEMENT.TYPEP (QUOTE ARC)))
(CREATE.SKETCH.ELEMENT.TYPE (QUOTE ARC)
ARCICON "Adds an arc to the figure." (FUNCTION ARC.DRAWFN)
(FUNCTION ARC.EXPANDFN)
(QUOTE OBSOLETE)
(FUNCTION SK.ELEMENTS.CHANGEFN)
(FUNCTION ARC.INPUTFN)
(FUNCTION ARC.INSIDEFN)
(FUNCTION ARC.REGIONFN)
(FUNCTION ARC.TRANSLATE)
NIL
(FUNCTION ARC.READCHANGEFN)
(FUNCTION ARC.TRANSFORMFN)
(FUNCTION ARC.TRANSLATEPTS]
[COND
((NOT (SKETCH.ELEMENT.TYPEP (QUOTE OPENCURVE)))
(CREATE.SKETCH.ELEMENT.TYPE (QUOTE OPENCURVE)
OPENCURVEICON
"Adds a curve by accepting points the curve goes through."
(FUNCTION OPENCURVE.DRAWFN)
(FUNCTION OPENCURVE.EXPANDFN)
(QUOTE OBSOLETE)
(FUNCTION SK.ELEMENTS.CHANGEFN)
(FUNCTION OPENCURVE.INPUTFN)
(FUNCTION KNOTS.INSIDEFN)
(FUNCTION CURVE.REGIONFN)
(FUNCTION KNOTS.TRANSLATEFN)
NIL
(FUNCTION OPENCURVE.READCHANGEFN)
(FUNCTION OPENCURVE.TRANSFORMFN)
(FUNCTION OPENCURVE.TRANSLATEPTSFN]
[COND
((NOT (SKETCH.ELEMENT.TYPEP (QUOTE CLOSEDCURVE)))
(CREATE.SKETCH.ELEMENT.TYPE (QUOTE CLOSEDCURVE)
CLOSEDCURVEICON
"Adds a closed curve by accepting points that it goes though."
(FUNCTION CLOSEDCURVE.DRAWFN)
(FUNCTION CLOSEDCURVE.EXPANDFN)
(QUOTE OBSOLETE)
(FUNCTION SK.ELEMENTS.CHANGEFN)
(FUNCTION CLOSEDCURVE.INPUTFN)
(FUNCTION KNOTS.INSIDEFN)
(FUNCTION CLOSEDCURVE.REGIONFN)
(FUNCTION KNOTS.TRANSLATEFN)
NIL
(FUNCTION SK.BRUSH.READCHANGE)
(FUNCTION CLOSEDCURVE.TRANSFORMFN)
(FUNCTION CLOSEDCURVE.TRANSLATEPTSFN]
[COND
((NOT (SKETCH.ELEMENT.TYPEP (QUOTE WIRE)))
(CREATE.SKETCH.ELEMENT.TYPE (QUOTE WIRE)
WIREICON "Adds a series of lines by accepting points."
(FUNCTION OPEN.WIRE.DRAWFN)
(FUNCTION OPEN.KNOTS.EXPANDFN)
(QUOTE OBSOLETE)
(FUNCTION SK.ELEMENTS.CHANGEFN)
(FUNCTION WIRE.INPUTFN)
(FUNCTION KNOTS.INSIDEFN)
(FUNCTION KNOTS.REGIONFN)
(FUNCTION KNOTS.TRANSLATEFN)
NIL
(FUNCTION OPENCURVE.READCHANGEFN)
(FUNCTION OPENWIRE.TRANSFORMFN)
(FUNCTION OPENWIRE.TRANSLATEPTSFN]
[COND
((NOT (SKETCH.ELEMENT.TYPEP (QUOTE CLOSEDWIRE)))
(CREATE.SKETCH.ELEMENT.TYPE (QUOTE CLOSEDWIRE)
CLOSEDWIREICON "Adds a closed polygon by accepting the corners."
(FUNCTION CLOSED.WIRE.DRAWFN)
(FUNCTION KNOTS.EXPANDFN)
(QUOTE OBSOLETE)
(FUNCTION SK.ELEMENTS.CHANGEFN)
(FUNCTION CLOSED.WIRE.INPUTFN)
(FUNCTION KNOTS.INSIDEFN)
(FUNCTION CLOSEDWIRE.REGIONFN)
(FUNCTION KNOTS.TRANSLATEFN)
NIL
(FUNCTION CLOSEDWIRE.READCHANGEFN)
(FUNCTION CLOSEDWIRE.TRANSFORMFN)
(FUNCTION CLOSEDWIRE.TRANSLATEPTSFN]
[COND
((NOT (SKETCH.ELEMENT.TYPEP (QUOTE TEXT)))
(CREATE.SKETCH.ELEMENT.TYPE (QUOTE TEXT)
NIL "text is added by pointing to its position and typing."
(FUNCTION TEXT.DRAWFN)
(FUNCTION TEXT.EXPANDFN)
(QUOTE OBSOLETE)
(FUNCTION SK.ELEMENTS.CHANGEFN)
(FUNCTION TEXT.INPUTFN)
(FUNCTION TEXT.INSIDEFN)
(FUNCTION TEXT.REGIONFN)
(FUNCTION TEXT.TRANSLATEFN)
(FUNCTION TEXT.UPDATEFN)
(FUNCTION TEXT.READCHANGEFN)
(FUNCTION TEXT.TRANSFORMFN)
(FUNCTION TEXT.TRANSLATEPTSFN]
[COND
((NOT (SKETCH.ELEMENT.TYPEP (QUOTE BOX)))
(CREATE.SKETCH.ELEMENT.TYPE (QUOTE BOX)
BOXICON "Adds a box by accepting two corners."
(FUNCTION SK.BOX.DRAWFN)
(FUNCTION SK.BOX.EXPANDFN)
(QUOTE OBSOLETE)
(FUNCTION SK.ELEMENTS.CHANGEFN)
(FUNCTION SK.BOX.INPUTFN)
(FUNCTION SK.BOX.INSIDEFN)
(FUNCTION SK.BOX.REGIONFN)
(FUNCTION SK.BOX.TRANSLATEFN)
NIL
(FUNCTION SK.BOX.READCHANGEFN)
(FUNCTION SK.BOX.TRANSFORMFN)
(FUNCTION SK.BOX.TRANSLATEPTSFN]
(COND
((NOT (SKETCH.ELEMENT.TYPEP (QUOTE TEXTBOX)))
(CREATE.SKETCH.ELEMENT.TYPE (QUOTE TEXTBOX)
TEXTBOXICON "Adds a box into which text can be typed."
(FUNCTION TEXTBOX.DRAWFN)
(FUNCTION TEXTBOX.EXPANDFN)
(QUOTE OBSOLETE)
(FUNCTION SK.ELEMENTS.CHANGEFN)
(FUNCTION TEXTBOX.INPUTFN)
(FUNCTION TEXTBOX.INSIDEFN)
(FUNCTION TEXTBOX.REGIONFN)
(FUNCTION TEXTBOX.TRANSLATEFN)
(FUNCTION TEXTBOX.UPDATEFN)
(FUNCTION TEXTBOX.READCHANGEFN)
(FUNCTION TEXTBOX.TRANSFORMFN)
(FUNCTION TEXTBOX.TRANSLATEPTSFN])
(CREATE.SKETCH.ELEMENT.TYPE
[LAMBDA (SKETCHTYPE LABEL DOCSTR DRAWFN EXPANDFN OBSOLETE CHANGEFN INPUTFN INSIDEFN REGIONFN
TRANSLATEFN UPDATEFN READCHANGEFN TRANSFORMFN TRANSLATEPTSFN)
(* rrb "11-Jul-85 14:53")
(* creates a new sketch element type.)
(COND
((AND OBSOLETE (NEQ OBSOLETE (QUOTE OBSOLETE)))
(printout T OBSOLETE " will never be called. CREATE.SKETCH.ELEMENT.TYPE")))
(SETQ SKETCH.ELEMENT.TYPES
(CONS (PUTPROP SKETCHTYPE (QUOTE SKETCHTYPE)
(create SKETCHTYPE
LABEL ← LABEL
DOCSTR ← DOCSTR
DRAWFN ← DRAWFN
EXPANDFN ← EXPANDFN
CHANGEFN ← CHANGEFN
INPUTFN ← INPUTFN
INSIDEFN ← INSIDEFN
REGIONFN ← REGIONFN
TRANSLATEFN ← TRANSLATEFN
UPDATEFN ← UPDATEFN
READCHANGEFN ← READCHANGEFN
TRANSFORMFN ← TRANSFORMFN
TRANSLATEPTSFN ← TRANSLATEPTSFN))
SKETCH.ELEMENT.TYPES))
(OR (MEMB SKETCHTYPE SKETCH.ELEMENT.TYPE.NAMES)
(SETQ SKETCH.ELEMENT.TYPE.NAMES (CONS SKETCHTYPE SKETCH.ELEMENT.TYPE.NAMES)))
SKETCHTYPE])
(SKETCH.ELEMENT.TYPEP
[LAMBDA (SKETCHTYPE) (* rrb "28-Dec-84 15:39")
(* is SKETCHTYPE a sketch element type?)
(AND (MEMB SKETCHTYPE SKETCH.ELEMENT.TYPE.NAMES)
(GETPROP SKETCHTYPE (QUOTE SKETCHTYPE])
(SKETCH.ELEMENT.NAMEP
[LAMBDA (X) (* rrb "18-MAR-83 11:53")
(* is X a sketch element type name?)
(FMEMB X SKETCH.ELEMENT.TYPE.NAMES])
)
(* color and filling stuff)
(DEFINEQ
(SKETCHINCOLORP
[LAMBDA NIL (* rrb "12-Jul-85 10:11")
(* hook to determine if sketch should allow color.)
SKETCHINCOLORFLG])
(READ.COLOR.CHANGE
[LAMBDA (MSG ALLOWNONEFLG) (* rrb "18-Jul-85 11:03")
(* reads a color from the user and returns it)
(READCOLOR1 MSG ALLOWNONEFLG])
)
(RPAQ? SKETCHINCOLORFLG )
(RPAQ? FILLPOLYGONFLG T)
(RPAQQ SK.DEFAULT.BACKCOLOR NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS SKETCHINCOLORFLG SK.DEFAULT.BACKCOLOR)
)
[DECLARE: EVAL@COMPILE
(RECORD SKFILLING (FILLING.TEXTURE FILLING.COLOR))
]
(* fns included until system is fixed so that it is ok to call DSPCOLOR in a system without
color loaded. Should be removed after J release.)
(DEFINEQ
(\POSSIBLECOLOR
[LAMBDA (COLOR?) (* rrb "22-FEB-83 11:38")
(* could COLOR? be a color indicator. True if it is a number in the right range or a LITATOM that could be a name.)
(PROG ((MAXIMUMCOLOR 255))
(RETURN (SELECTQ (TYPENAME COLOR?)
(LITATOM COLOR?)
(SMALLP (AND (IGEQ COLOR? 0)
(ILEQ COLOR? MAXIMUMCOLOR)
COLOR?))
(LISTP (OR (RGBP COLOR?)
(HLSP COLOR?)))
NIL])
(RGBP
[LAMBDA (X) (* rrb "27-OCT-82 10:15")
(* return X if it is a red green blue triple.)
(PROG (TMP)
(RETURN (AND (LISTP X)
(SMALLP (SETQ TMP (CAR X)))
(IGREATERP TMP -1)
(IGREATERP 256 TMP)
(SMALLP (SETQ TMP (CADR X)))
(IGREATERP TMP -1)
(IGREATERP 256 TMP)
(SMALLP (SETQ TMP (CADDR X)))
(IGREATERP TMP -1)
(IGREATERP 256 TMP)
X])
(HLSP
[LAMBDA (X) (* rrb "27-OCT-82 10:10")
(* return T if X is a hue lightness saturation triple.)
(AND (LISTP X)
(IGREATERP (CAR X)
-1)
(IGREATERP 361 (CAR X))
(FLOATP (CADR X))
(FLOATP (CADDR X))
X])
)
(DEFINEQ
(SKFILLINGP
[LAMBDA (FILLING) (* rrb "26-Sep-85 18:01")
(* determines if FILLING is a legal sketch filling.)
(COND
((AND (LISTP FILLING)
(TEXTUREP (fetch (SKFILLING FILLING.TEXTURE) of FILLING))
(NULL (CDDR FILLING))) (* should also check if (fetch
(SKFILLING FILLING.COLOR)) is a color.)
FILLING])
(SK.INSURE.FILLING
[LAMBDA (FILLING SKW) (* rrb "26-Sep-85 18:01")
(* converts several possible legal filling
specifications into a sketch filling)
(COND
((SKFILLINGP FILLING))
(T (PROG [(DEFAULTFILLING (fetch (SKETCHCONTEXT SKETCHFILLING) of (WINDOWPROP SKW (QUOTE
SKETCHCONTEXT]
(RETURN (COND
((NULL FILLING)
DEFAULTFILLING)
((TEXTUREP FILLING)
(create SKFILLING using DEFAULTFILLING FILLING.TEXTURE ← FILLING))
(T (* should be a check here for a color too.)
(\ILLEGAL.ARG FILLING])
)
(DEFINEQ
(CIRCLE.EXPANDFN
[LAMBDA (GCIRCLE SCALE) (* rrb " 9-Aug-85 09:53")
(* returns a screen elt that has a circle screen
element calculated from the global part.)
(PROG (CENTER RADIUSPT BRUSH (INDGCIRCLE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GCIRCLE)))
(* check to make sure there is an initial scale field. This change was introduced on Apr 27 and can be taken out the
release after Jazz It can also be taken out of the other expand fns as well.)
[COND
((fetch (CIRCLE CIRCLEINITSCALE) of INDGCIRCLE))
(T (* old format didn't have an initial scale, default it
to 1.0)
(replace (GLOBALPART INDIVIDUALGLOBALPART) of GCIRCLE
with (SETQ INDGCIRCLE (create CIRCLE using INDGCIRCLE CIRCLEINITSCALE ← 1.0]
(RETURN (create SCREENELT
LOCALPART ←(create LOCALCIRCLE
CENTERPOSITION ←(SETQ CENTER (
SK.SCALE.POSITION.INTO.VIEWER (fetch (CIRCLE
CENTERLATLON)
of INDGCIRCLE)
SCALE))
RADIUSPOSITION ←(SETQ RADIUSPT
(SK.SCALE.POSITION.INTO.VIEWER (fetch (CIRCLE
RADIUSLATLON)
of INDGCIRCLE)
SCALE))
RADIUS ←(DISTANCEBETWEEN CENTER RADIUSPT)
LOCALCIRCLEBRUSH ←(SCALE.BRUSH
(COND
([NOT (NUMBERP (SETQ BRUSH (fetch (CIRCLE BRUSH)
of INDGCIRCLE]
(* new format, old format had brush width only.)
BRUSH)
(T [replace (CIRCLE BRUSH) of INDGCIRCLE
with (SETQ BRUSH
(create BRUSH
BRUSHSIZE ← BRUSH
BRUSHSHAPE ←(QUOTE ROUND]
BRUSH))
(fetch (CIRCLE CIRCLEINITSCALE) of INDGCIRCLE)
SCALE))
GLOBALPART ← GCIRCLE])
(CIRCLE.DRAWFN
[LAMBDA (CIRCLEELT WINDOW REGION) (* rrb " 9-Aug-85 10:07")
(* draws a circle from a circle element.)
(PROG ((GCIRCLE (fetch (SCREENELT INDIVIDUALGLOBALPART) of CIRCLEELT))
(LCIRCLE (fetch (SCREENELT LOCALPART) of CIRCLEELT))
CPOS RPOS DASHING FILLING)
(SETQ CPOS (fetch (LOCALCIRCLE CENTERPOSITION) of LCIRCLE))
(SETQ DASHING (fetch (CIRCLE DASHING) of GCIRCLE))
(SETQ FILLING (fetch (CIRCLE CIRCLEFILLING) of GCIRCLE))
(COND
((fetch (SKFILLING FILLING.COLOR) of FILLING)
(* if the circle is filled with a color call FILLCIRCLE with both the texture and the color.
This allows iris to do its thing before textures and colors are merged.)
(FILLCIRCLE (fetch (POSITION XCOORD) of CPOS)
(fetch (POSITION YCOORD) of CPOS)
(fetch (LOCALCIRCLE RADIUS) of LCIRCLE)
FILLING WINDOW))
((fetch (SKFILLING FILLING.TEXTURE) of FILLING)
(* if the circle is filled with texture, call
FILLCIRCLE.)
(FILLCIRCLE (fetch (POSITION XCOORD) of CPOS)
(fetch (POSITION YCOORD) of CPOS)
(fetch (LOCALCIRCLE RADIUS) of LCIRCLE)
(fetch (SKFILLING FILLING.TEXTURE) of FILLING)
WINDOW)))
(RETURN (COND
(DASHING (* draw it with the arc drawing code which does
dashing.)
(DRAWCURVE (SK.COMPUTE.ARC.PTS CPOS (SETQ RPOS (fetch (LOCALCIRCLE
RADIUSPOSITION)
of LCIRCLE))
(PTPLUS RPOS
(CONSTANT (create POSITION
XCOORD ← 0
YCOORD ← -1)))
NIL)
T
(fetch (LOCALCIRCLE LOCALCIRCLEBRUSH) of LCIRCLE)
DASHING WINDOW))
(T (DRAWCIRCLE (fetch (POSITION XCOORD) of CPOS)
(fetch (POSITION YCOORD) of CPOS)
(fetch (LOCALCIRCLE RADIUS) of LCIRCLE)
(fetch (LOCALCIRCLE LOCALCIRCLEBRUSH) of LCIRCLE)
DASHING WINDOW])
(CIRCLE.INPUTFN
[LAMBDA (WINDOW) (* rrb " 4-Sep-85 15:44")
(* reads a two points from the user and returns a
circle element that it represents.)
(PROG [CENTERPT RADIUSPT (SKETCHCONTEXT (WINDOWPROP WINDOW (QUOTE SKETCHCONTEXT]
(STATUSPRINT WINDOW "
" "Indicate center of circle")
(COND
((NOT (SETQ CENTERPT (GETSKWPOSITION WINDOW CIRCLE.CENTER)))
(CLOSEPROMPTWINDOW WINDOW)
(RETURN NIL)))
(MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of CENTERPT)
NIL WINDOW)
(STATUSPRINT WINDOW "
" "Indicate a point of the circumference of the circle")
(SETQ RADIUSPT (GETSKWPOSITION WINDOW CIRCLE.EDGE))
(* erase center mark)
(MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of CENTERPT)
NIL WINDOW)
(CLOSEPROMPTWINDOW WINDOW)
(OR RADIUSPT (RETURN NIL))
(SETQ CENTERPT (SK.MAP.INPUT.PT.TO.GLOBAL CENTERPT WINDOW))
(SETQ RADIUSPT (SK.MAP.INPUT.PT.TO.GLOBAL RADIUSPT WINDOW))
(RETURN (SK.CIRCLE.CREATE CENTERPT RADIUSPT (fetch (SKETCHCONTEXT SKETCHBRUSH)
of SKETCHCONTEXT)
(fetch (SKETCHCONTEXT SKETCHDASHING) of SKETCHCONTEXT)
(SK.INPUT.SCALE WINDOW)
(fetch (SKETCHCONTEXT SKETCHFILLING) of SKETCHCONTEXT])
(CIRCLE.INSIDEFN
[LAMBDA (GCIRCLE WREG) (* rrb " 5-AUG-83 17:34")
(* determines if the global circle GCIRCLE is inside of
WREG.)
(* consider a circle inside only if one of its control points is inside. {old code (PROG ((CPOS
(fetch (CIRCLE CENTERLATLON) of LCIRCLE)) CX CY RAD) (SETQ RAD (DISTANCEBETWEEN CPOS (fetch
(CIRCLE RADIUSLATLON) of LCIRCLE))) (RETURN (AND (ILESSP (FETCH (REGION BOTTOM) OF WREG) (DIFFERENCE
(SETQ CY (FETCH (POSITION YCOORD) OF CPOS)) RAD)) (ILESSP (FETCH (REGION LEFT) OF WREG) (DIFFERENCE
(SETQ CX (FETCH (POSITION XCOORD) OF CPOS)) RAD)) (IGREATERP (FETCH (REGION TOP) OF WREG) (IPLUS CY RAD))
(IGREATERP (FETCH (REGION RIGHT) OF WREG) (IPLUS CX RAD))))) })
(PROG ((INDGCIRCLE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GCIRCLE)))
(RETURN (OR (INSIDEP WREG (fetch (CIRCLE CENTERLATLON) of INDGCIRCLE))
(INSIDEP WREG (fetch (CIRCLE RADIUSLATLON) of INDGCIRCLE])
(CIRCLE.REGIONFN
[LAMBDA (CIRCSCRELT) (* rrb " 3-Oct-85 17:12")
(* returns the region occuppied by a circle.)
(PROG ((LOCALCIRCLE (fetch (SCREENELT LOCALPART) of CIRCSCRELT))
RADIUS)
(SETQ RADIUS (IPLUS (FIX (ADD1 (fetch (LOCALCIRCLE RADIUS) of LOCALCIRCLE)))
(LRSH [ADD1 (MAX 1 (fetch (BRUSH BRUSHSIZE)
of (fetch (LOCALCIRCLE
LOCALCIRCLEBRUSH)
of LOCALCIRCLE]
1)))
(RETURN (CREATEREGION (IDIFFERENCE (fetch (POSITION XCOORD)
of (SETQ LOCALCIRCLE (fetch
(LOCALCIRCLE CENTERPOSITION)
of LOCALCIRCLE))
)
RADIUS)
(IDIFFERENCE (fetch (POSITION YCOORD) of LOCALCIRCLE)
RADIUS)
(SETQ RADIUS (ITIMES RADIUS 2))
RADIUS])
(CIRCLE.TRANSLATE
[LAMBDA (CIRCLESKELT DELTAPOS) (* rrb " 9-Aug-85 09:53")
(* returns a changed global circle element which has
the circle translated by DELTAPOS.)
(PROG ((GCIRCLE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of CIRCLESKELT)))
(RETURN (create GLOBALPART
COMMONGLOBALPART ←(APPEND (fetch (GLOBALPART COMMONGLOBALPART)
of CIRCLESKELT))
INDIVIDUALGLOBALPART ←(create CIRCLE using GCIRCLE CENTERLATLON ←(PTPLUS
(fetch (CIRCLE CENTERLATLON)
of GCIRCLE)
DELTAPOS)
RADIUSLATLON ←(PTPLUS
(fetch (CIRCLE RADIUSLATLON)
of GCIRCLE)
DELTAPOS])
(CIRCLE.TRANSFORMFN
[LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb " 9-Aug-85 09:53")
(* returns a copy of the global element that has had each of its control points transformed by transformfn.
TRANSFORMDATA is arbitrary data that is passed to tranformfn.)
(PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)))
(RETURN (create GLOBALPART using GELT INDIVIDUALGLOBALPART ←(create CIRCLE
using
INDVPART CENTERLATLON ←(
SK.TRANSFORM.POINT
(fetch (CIRCLE
CENTERLATLON)
of INDVPART)
TRANSFORMFN TRANSFORMDATA)
RADIUSLATLON ←(
SK.TRANSFORM.POINT
(fetch (CIRCLE
RADIUSLATLON)
of INDVPART)
TRANSFORMFN TRANSFORMDATA)
BRUSH ←(SK.TRANSFORM.BRUSH
(fetch (CIRCLE BRUSH)
of INDVPART)
SCALEFACTOR])
(CIRCLE.TRANSLATEPTS
[LAMBDA (CIRCLESPEC SELPTS GLOBALDELTA WINDOW) (* rrb " 9-Aug-85 09:55")
(* returns a changed global circle element which has
the part SELPOS moved to NEWPOS.)
(PROG ((LCIRCLE (fetch (SCREENELT LOCALPART) of CIRCLESPEC))
(GCIRCLE (fetch (SCREENELT INDIVIDUALGLOBALPART) of CIRCLESPEC)))
(RETURN (SK.CIRCLE.CREATE (COND
((MEMBER (fetch (LOCALCIRCLE CENTERPOSITION) of LCIRCLE)
SELPTS) (* move the center)
(PTPLUS (fetch (CIRCLE CENTERLATLON) of GCIRCLE)
GLOBALDELTA))
(T (fetch (CIRCLE CENTERLATLON) of GCIRCLE)))
(COND
((MEMBER (fetch (LOCALCIRCLE RADIUSPOSITION) of LCIRCLE)
SELPTS) (* move the radius point.)
(PTPLUS (fetch (CIRCLE RADIUSLATLON) of GCIRCLE)
GLOBALDELTA))
(T (fetch (CIRCLE RADIUSLATLON) of GCIRCLE)))
(fetch (CIRCLE BRUSH) of GCIRCLE)
(fetch (CIRCLE DASHING) of GCIRCLE)
(fetch (CIRCLE CIRCLEINITSCALE) of GCIRCLE)
(fetch (CIRCLE CIRCLEFILLING) of GCIRCLE])
(SK.CIRCLE.CREATE
[LAMBDA (CENTERPT RADIUSPT BRUSH DASHING INITSCALE FILLING)
(* rrb " 9-Aug-85 10:00")
(* creates a sketch element)
(SET.CIRCLE.SCALE (create GLOBALPART
INDIVIDUALGLOBALPART ←(create CIRCLE
CENTERLATLON ← CENTERPT
RADIUSLATLON ← RADIUSPT
BRUSH ← BRUSH
DASHING ← DASHING
CIRCLEINITSCALE ← INITSCALE
CIRCLEFILLING ← FILLING])
(SET.CIRCLE.SCALE
[LAMBDA (GCIRCELT) (* rrb " 7-Feb-85 12:22")
(* sets the scale fields in a circle.
Sets scale so that it goes from radius 1 to 3000.0)
(PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GCIRCELT))
RAD)
(SETQ RAD (DISTANCEBETWEEN (fetch (CIRCLE CENTERLATLON) of INDVPART)
(fetch (CIRCLE RADIUSLATLON) of INDVPART)))
(replace (GLOBALPART COMMONGLOBALPART) of GCIRCELT
with (create COMMONGLOBALPART
MAXSCALE ← RAD
MINSCALE ←(QUOTIENT RAD 3000.0)))
(RETURN GCIRCELT])
(SK.BRUSH.READCHANGE
[LAMBDA (SKW) (* rrb "12-Jul-85 13:31")
(* changefn for curves)
(PROG (ASPECT HOW)
(SETQ HOW (SELECTQ [SETQ ASPECT (MENU (create MENU
CENTERFLG ← T
TITLE ← "select aspect of brush to change"
ITEMS ←(APPEND
(COND
[(SKETCHINCOLORP)
(QUOTE (("Color" (QUOTE BRUSHCOLOR)
"changes the color of the brush"]
(T NIL))
(QUOTE ((Shape (QUOTE SHAPE)
"changes the shape of the brush")
(Size (QUOTE SIZE)
"changes the size of the brush")
(Dashing (QUOTE DASHING)
"changes the dashing of the line."]
(SIZE (READSIZECHANGE "Change size how?"))
(SHAPE (READBRUSHSHAPE))
(DASHING (READ.DASHING.CHANGE))
(BRUSHCOLOR (READ.COLOR.CHANGE "Change brush color how?"))
NIL))
(RETURN (AND HOW (LIST ASPECT HOW])
)
[DECLARE: EVAL@COMPILE
(RECORD BRUSH (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR)
BRUSHSHAPE ←(QUOTE ROUND)
BRUSHSIZE ← 1)
]
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD LOCALCIRCLE ((CENTERPOSITION RADIUSPOSITION)
RADIUS LOCALCIRCLEBRUSH))
(TYPERECORD CIRCLE (CENTERLATLON RADIUSLATLON BRUSH DASHING CIRCLEINITSCALE CIRCLEFILLING))
]
)
(READVARS CIRCLEICON)
({(READBITMAP)(20 12
"@AOH@@@@"
"@COL@@@@"
"@G@N@@@@"
"@F@F@@@@"
"@N@G@@@@"
"@L@C@@@@"
"@L@C@@@@"
"@N@G@@@@"
"@F@F@@@@"
"@G@N@@@@"
"@COL@@@@"
"@AOH@@@@")})
(RPAQ CIRCLE.CENTER (CURSORCREATE (READBITMAP) 8 8))
(16 16
"@GN@"
"AOOH"
"CLCL"
"G@@N"
"FDBF"
"NJEG"
"LEJC"
"LBDC"
"LBDC"
"LEJC"
"NJEG"
"FDBF"
"G@@N"
"CLCL"
"AOOH"
"@GN@")(RPAQ CIRCLE.EDGE (CURSORCREATE (READBITMAP) 15 8))
(16 16
"@@AL"
"@@@L"
"@@@N"
"@@@F"
"@@BG"
"@@CC"
"@@CK"
"OOOO"
"OOOO"
"@@CK"
"@@CC"
"@@BG"
"@@@F"
"@@@N"
"@@@L"
"@@AL")
(RPAQQ SKETCHELEMENTSCOMS ((* contains the functions need to implement the sketch basic element
types)
(FNS INIT.SKETCH.ELEMENTS CREATE.SKETCH.ELEMENT.TYPE SKETCH.ELEMENT.TYPEP
SKETCH.ELEMENT.NAMEP)
(COMS (* color and filling stuff)
(FNS SKETCHINCOLORP READ.COLOR.CHANGE)
(INITVARS (SKETCHINCOLORFLG)
(FILLPOLYGONFLG T))
(VARS (SK.DEFAULT.BACKCOLOR))
(GLOBALVARS SKETCHINCOLORFLG SK.DEFAULT.BACKCOLOR)
(RECORDS SKFILLING)
(* fns included until system is fixed so that it is ok to call DSPCOLOR in a system
without color loaded. Should be removed after J release.)
(FNS \POSSIBLECOLOR RGBP HLSP)
(FNS SKFILLINGP SK.INSURE.FILLING))
(COMS (FNS CIRCLE.EXPANDFN CIRCLE.DRAWFN CIRCLE.INPUTFN CIRCLE.INSIDEFN CIRCLE.REGIONFN
CIRCLE.TRANSLATE CIRCLE.TRANSFORMFN CIRCLE.TRANSLATEPTS SK.CIRCLE.CREATE
SET.CIRCLE.SCALE SK.BRUSH.READCHANGE)
(RECORDS BRUSH)
(DECLARE: DONTCOPY (RECORDS LOCALCIRCLE CIRCLE))
(UGLYVARS CIRCLEICON)
(CURSORS CIRCLE.CENTER CIRCLE.EDGE)
(VARS SKETCHELEMENTSCOMS (SK.DEFAULT.BRUSH (create BRUSH BRUSHSHAPE ← (QUOTE ROUND)
BRUSHSIZE ← 1 BRUSHCOLOR ←
BLACKCOLOR))
(SK.DEFAULT.DASHING)
(SK.DEFAULT.TEXTURE))
(GLOBALVARS SK.DEFAULT.BRUSH SK.DEFAULT.DASHING))
(COMS (FNS ELLIPSE.EXPANDFN ELLIPSE.DRAWFN ELLIPSE.INPUTFN ELLIPSE.INSIDEFN ELLIPSE.CREATE
ELLIPSE.REGIONFN ELLIPSE.TRANSLATEFN ELLIPSE.TRANSFORMFN ELLIPSE.TRANSLATEPTS
MARK.SPOT DISTANCEBETWEEN SQUARE COMPUTE.ELLIPSE.ORIENTATION
SK.COMPUTE.ELLIPSE.MINOR.RADIUS.PT)
(DECLARE: DONTCOPY (RECORDS LOCALELLIPSE ELLIPSE))
(UGLYVARS ELLIPSEICON)
(CURSORS ELLIPSE.CENTER ELLIPSE.SEMI.MAJOR ELLIPSE.SEMI.MINOR))
(COMS (FNS KNOTS.INSIDEFN OPENCURVE.INPUTFN SK.CURVE.CREATE MAXXEXTENT MAXYEXTENT
KNOT.SET.SCALE.FIELD OPENCURVE.DRAWFN OPENCURVE.EXPANDFN OPENCURVE.READCHANGEFN
OPENCURVE.TRANSFORMFN OPENCURVE.TRANSLATEPTSFN CLOSEDCURVE.DRAWFN
CLOSEDCURVE.EXPANDFN CLOSEDCURVE.REGIONFN READ.LIST.OF.POINTS CLOSEDCURVE.INPUTFN
CLOSEDCURVE.TRANSFORMFN CLOSEDCURVE.TRANSLATEPTSFN INVISIBLEPARTP SHOWSKETCHPOINT
SHOWSKETCHXY KNOTS.REGIONFN CURVE.REGIONFN KNOTS.TRANSLATEFN REGION.CONTAINING.PTS)
(FNS CHANGE.ELTS.BRUSH.SIZE CHANGE.ELTS.BRUSH CHANGE.ELTS.BRUSH.SHAPE
SK.CHANGE.BRUSH.SHAPE SK.CHANGE.BRUSH.COLOR SK.CHANGE.BRUSH.SIZE SK.CHANGE.ANGLE
SK.CHANGE.ARC.DIRECTION SK.SET.DEFAULT.BRUSH.SIZE READSIZECHANGE)
(DECLARE: DONTCOPY (RECORDS KNOTELT LOCALCURVE OPENCURVE CLOSEDCURVE LOCALKNOTS))
(UGLYVARS OPENCURVEICON CLOSEDCURVEICON)
(CURSORS CURVE.KNOT))
(COMS (FNS KNOTS.EXPANDFN OPEN.WIRE.DRAWFN OPEN.KNOTS.EXPANDFN OPENWIRE.READCHANGEFN
OPENWIRE.TRANSFORMFN OPENWIRE.TRANSLATEPTSFN SK.EXPAND.ARROWHEADS WIRE.INPUTFN
CLOSEDWIRE.REGIONFN SK.WIRE.CREATE WIRE.ADD.POINT.TO.END READ.ARROW.CHANGE
CHANGE.ELTS.ARROWHEADS)
(FNS CLOSED.WIRE.INPUTFN CLOSED.WIRE.DRAWFN CLOSEDWIRE.READCHANGEFN
CLOSEDWIRE.TRANSFORMFN CLOSEDWIRE.TRANSLATEPTSFN)
(FNS CHANGED.ARROW SK.CHANGE.ARROWHEAD SK.CHANGE.ARROWHEAD1 SK.CREATE.ARROWHEAD
SK.ARROWHEAD.CREATE SK.ARROWHEAD.END.TEST READ.ARROWHEAD.END ARROW.HEAD.POSITIONS
ARROWHEAD.POINTS.LIST CURVE.ARROWHEAD.POINTS LEFT.MOST.IS.BEGINP
WIRE.ARROWHEAD.POINTS DRAWARROWHEADS SK.SET.ARROWHEAD.LENGTH
SK.SET.ARROWHEAD.ANGLE SK.SET.ARROWHEAD.TYPE SK.SET.LINE.ARROWHEAD
SK.UPDATE.ARROWHEAD.FORMAT SK.SET.LINE.LENGTH.MODE)
(DECLARE: DONTCOPY (RECORDS LOCALWIRE WIRE CLOSEDWIRE LOCALCLOSEDWIRE ARROWHEAD))
(UGLYVARS WIREICON CLOSEDWIREICON)
(INITVARS (SK.ARROWHEAD.ANGLE.INCREMENT 10)
(SK.ARROWHEAD.LENGTH.INCREMENT 2))
(VARS (SK.DEFAULT.ARROWHEAD (LIST (QUOTE LINE)
30.0 12)))
(GLOBALVARS SK.DEFAULT.ARROWHEAD)
(INITVARS (SK.ARROW.END.MENU)
(SK.ARROW.EDIT.MENU)))
(COMS (* stuff to support the text element type.)
(FNS TEXT.CHANGEFN TEXT.READCHANGEFN \SK.READ.FONT.SIZE1 SK.TEXT.ELT.WITH.SAME.FIELDS
SK.READFONTFAMILY CLOSE.PROMPT.WINDOW TEXT.DRAWFN TEXT.DRAWFN1 TEXT.INSIDEFN
TEXT.EXPANDFN SK.TEXT.LINE.REGIONS SK.PICK.FONT SK.NEXTSIZEFONT
SK.DECREASING.FONT.LIST SK.GUESS.FONTSAVAILABLE TEXT.UPDATE.GLOBAL.REGIONS
REL.MOVE.REGION LTEXT.LINE.REGIONS TEXT.INPUTFN READ.TEXT TEXT.POSITION.AND.CREATE
CREATE.TEXT.ELEMENT SK.TEXT.FROM.TEXTBOX TEXT.SET.GLOBAL.REGIONS TEXT.REGIONFN
TEXT.TRANSLATEFN TEXT.TRANSFORMFN TEXT.TRANSLATEPTSFN TEXT.UPDATEFN SK.CHANGE.TEXT
TEXT.SET.SCALES SK.FONT.LIST)
(DECLARE: DONTCOPY (RECORDS TEXT LOCALTEXT))
(FNS SK.SET.FONT SK.SET.TEXT.FONT SK.SET.TEXT.SIZE SK.SET.TEXT.HORIZ.ALIGN
SK.READFONTSIZE SK.COLLECT.FONT.SIZES SK.SET.TEXT.VERT.ALIGN SK.SET.TEXT.LOOKS
SK.SET.DEFAULT.TEXT.FACE)
(FNS CREATE.SKETCH.TERMTABLE)
(VARS INDICATE.TEXT.SHADE)
[INITVARS (SK.DEFAULT.FONT)
(SK.DEFAULT.TEXT.ALIGNMENT (QUOTE (CENTER BASELINE]
(INITVARS \FONTSONFILE)
(VARS (SKETCH.TERMTABLE (CREATE.SKETCH.TERMTABLE)))
(GLOBALVARS SKETCH.TERMTABLE SK.DEFAULT.TEXT.ALIGNMENT INDICATE.TEXT.SHADE \FONTSONFILE)
)
(COMS (* stuff for supporting the TEXTBOX sketch element.)
(FNS SK.BREAK.INTO.LINES SK.BRUSH.SIZE SK.TEXTBOX.CREATE SK.TEXTBOX.CREATE1
SK.TEXTBOX.POSITION.IN.BOX TEXTBOX.CHANGEFN TEXTBOX.DRAWFN
SK.TEXTURE.AROUND.REGIONS TEXTBOX.EXPANDFN TEXTBOX.INPUTFN TEXTBOX.INSIDEFN
TEXTBOX.REGIONFN TEXTBOX.SET.GLOBAL.REGIONS TEXTBOX.TRANSLATEFN
TEXTBOX.TRANSLATEPTSFN TEXTBOX.TRANSFORMFN TEXTBOX.UPDATEFN TEXTBOX.READCHANGEFN
SK.TEXTBOX.TEXT.POSITION SK.TEXTBOX.FROM.TEXT ADD.EOLS)
(RECORDS LOCALTEXTBOX TEXTBOX)
(COMS (* stuff to handle default alignment for text boxes)
(FNS SK.SET.TEXTBOX.VERT.ALIGN SK.SET.TEXTBOX.HORIZ.ALIGN)
(VARS TEXTBOXICON)
[INITVARS (SK.DEFAULT.TEXTBOX.ALIGNMENT (QUOTE (CENTER CENTER]
(GLOBALVARS SK.DEFAULT.TEXTBOX.ALIGNMENT)))
(COMS (* functions to implement the box sketch element.)
(FNS SK.BOX.DRAWFN BOX.DRAWFN1 KNOTS.OF.REGION SK.DRAWAREABOX SK.BOX.EXPANDFN
SK.BOX.GETREGIONFN BOX.SET.SCALES SK.BOX.INPUTFN SK.BOX.CREATE SK.BOX.INSIDEFN
SK.BOX.REGIONFN SK.BOX.READCHANGEFN SK.CHANGE.FILLING SK.CHANGE.FILLING.COLOR
SK.BOX.TRANSLATEFN SK.BOX.TRANSFORMFN SK.BOX.TRANSLATEPTSFN
UNSCALE.REGION.FROM.SKETCHW UNSCALE.REGION.TO.GRID INCREASEREGION INSUREREGIONSIZE
EXPANDREGION REGION.FROM.COORDINATES)
(DECLARE: DONTCOPY (RECORDS BOX LOCALBOX))
(UGLYVARS BOXICON))
(COMS (* fns for the arc sketch element type)
(FNS ARC.DRAWFN ARC.EXPANDFN ARC.INPUTFN ARC.CREATE ARC.MOVEFN ARC.TRANSLATEPTS
ARC.INSIDEFN ARC.REGIONFN ARC.TRANSLATE ARC.TRANSFORMFN ARC.READCHANGEFN)
(FNS SK.COMPUTE.ARC.ANGLE.PT SK.COMPUTE.ARC.PTS SK.SET.ARC.DIRECTION
SK.SET.ARC.DIRECTION.CW SK.SET.ARC.DIRECTION.CCW SK.COMPUTE.SLOPE.OF.LINE
SK.CREATE.ARC.USING SET.ARC.SCALES)
(INITVARS (SK.NUMBER.OF.POINTS.IN.ARC 8))
(GLOBALVARS SK.NUMBER.OF.POINTS.IN.ARC)
(DECLARE: DONTCOPY (RECORDS ARC LOCALARC))
(CURSORS ARC.RADIUS.CURSOR ARC.ANGLE.CURSOR)
(UGLYVARS ARCICON))
(P (INIT.SKETCH.ELEMENTS))))
(RPAQ SK.DEFAULT.BRUSH (create BRUSH BRUSHSHAPE ← (QUOTE ROUND)
BRUSHSIZE ← 1 BRUSHCOLOR ← BLACKCOLOR))
(RPAQQ SK.DEFAULT.DASHING NIL)
(RPAQQ SK.DEFAULT.TEXTURE NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS SK.DEFAULT.BRUSH SK.DEFAULT.DASHING)
)
(DEFINEQ
(ELLIPSE.EXPANDFN
[LAMBDA (GELLIPSE SCALE) (* rrb "27-Apr-85 21:04")
(* returns a screen elt that has a ellipse screen
element calculated from the global part.)
(PROG (CENTER MINRAD MAJRAD BRUSH (INDGELLIPSE (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELLIPSE)))
[COND
((fetch (ELLIPSE ELLIPSEINITSCALE) of INDGELLIPSE))
(T (* old format didn't have an initial scale, create one
and default it to 1.0)
(replace (GLOBALPART INDIVIDUALGLOBALPART) of GELLIPSE
with (SETQ INDGELLIPSE (create ELLIPSE using INDGELLIPSE ELLIPSEINITSCALE ← 1.0]
(RETURN (create SCREENELT
LOCALPART ←(create LOCALELLIPSE
ELLIPSECENTER ←(SETQ CENTER (
SK.SCALE.POSITION.INTO.VIEWER (fetch (ELLIPSE
ELLIPSECENTERLATLON)
of INDGELLIPSE)
SCALE))
MINORRADIUSPOSITION ←(SETQ MINRAD
(SK.SCALE.POSITION.INTO.VIEWER (fetch (ELLIPSE
SEMIMINORLATLON)
of INDGELLIPSE)
SCALE))
MAJORRADIUSPOSITION ←(SETQ MAJRAD
(SK.SCALE.POSITION.INTO.VIEWER (fetch (ELLIPSE
SEMIMAJORLATLON)
of INDGELLIPSE)
SCALE))
SEMIMINORRADIUS ←(DISTANCEBETWEEN CENTER MINRAD)
SEMIMAJORRADIUS ←(DISTANCEBETWEEN CENTER MAJRAD)
LOCALELLIPSEBRUSH ←(SCALE.BRUSH
(COND
([NOT (NUMBERP (SETQ BRUSH (fetch (ELLIPSE BRUSH)
of INDGELLIPSE]
(* new format, old format had brush width only.)
BRUSH)
(T [replace (ELLIPSE BRUSH) of INDGELLIPSE
with (SETQ BRUSH
(create BRUSH
BRUSHSIZE ← BRUSH
BRUSHSHAPE ←(QUOTE ROUND]
BRUSH))
(fetch (ELLIPSE ELLIPSEINITSCALE) of INDGELLIPSE)
SCALE))
GLOBALPART ← GELLIPSE])
(ELLIPSE.DRAWFN
[LAMBDA (ELLIPSEELT WINDOW REGION) (* rrb " 4-Jun-85 20:56")
(* draws a ellipse from a circle element.)
(PROG ((GELLIPSE (fetch (SCREENELT INDIVIDUALGLOBALPART) of ELLIPSEELT))
(LELLIPSE (fetch (SCREENELT LOCALPART) of ELLIPSEELT))
CPOS DASHING ORIENTATION)
(SETQ CPOS (fetch (LOCALELLIPSE ELLIPSECENTER) of LELLIPSE))
(SETQ DASHING (fetch (ELLIPSE DASHING) of GELLIPSE))
(SETQ ORIENTATION (fetch (ELLIPSE ORIENTATION) of GELLIPSE))
(RETURN (COND
(DASHING (* draw it with the curve drawing code which does
dashing.)
(PROG ((SINOR (SIN ORIENTATION))
(COSOR (COS ORIENTATION))
(CENTERX (fetch (POSITION XCOORD) of CPOS))
(CENTERY (fetch (POSITION YCOORD) of CPOS))
(SEMIMINORRADIUS (fetch (LOCALELLIPSE SEMIMINORRADIUS)
of LELLIPSE))
(SEMIMAJORRADIUS (fetch (LOCALELLIPSE SEMIMAJORRADIUS)
of LELLIPSE)))
(DRAWCURVE [LIST (CREATEPOSITION (PLUS CENTERX (FTIMES COSOR
SEMIMAJORRADIUS))
(PLUS CENTERY (FTIMES SINOR
SEMIMAJORRADIUS)))
(CREATEPOSITION (DIFFERENCE CENTERX
(FTIMES SINOR
SEMIMINORRADIUS))
(PLUS CENTERY (FTIMES COSOR
SEMIMINORRADIUS)))
(CREATEPOSITION (DIFFERENCE CENTERX
(FTIMES COSOR
SEMIMAJORRADIUS))
(DIFFERENCE CENTERY
(FTIMES SINOR
SEMIMAJORRADIUS)))
(CREATEPOSITION (PLUS CENTERX (FTIMES SINOR
SEMIMINORRADIUS))
(DIFFERENCE CENTERY
(FTIMES COSOR
SEMIMINORRADIUS]
T
(fetch (LOCALELLIPSE LOCALELLIPSEBRUSH) of LELLIPSE)
DASHING WINDOW)))
(T (DRAWELLIPSE (fetch (POSITION XCOORD) of CPOS)
(fetch (POSITION YCOORD) of CPOS)
(fetch (LOCALELLIPSE SEMIMINORRADIUS) of LELLIPSE)
(fetch (LOCALELLIPSE SEMIMAJORRADIUS) of LELLIPSE)
ORIENTATION
(fetch (LOCALELLIPSE LOCALELLIPSEBRUSH) of LELLIPSE)
DASHING WINDOW])
(ELLIPSE.INPUTFN
[LAMBDA (WINDOW) (* rrb " 4-Sep-85 15:47")
(* reads three points from the user and returns the
ellipse figure element that it represents.)
(PROG (CENTER MAJRAD MINRAD)
(STATUSPRINT WINDOW "
" "Indicate center of ellipse")
(COND
((SETQ CENTER (GETSKWPOSITION WINDOW ELLIPSE.CENTER))
(MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of CENTER)
NIL WINDOW))
(T (CLOSEPROMPTWINDOW WINDOW)
(RETURN NIL)))
(STATUSPRINT WINDOW "
" "Indicate semi-major axis")
(COND
((SETQ MAJRAD (GETSKWPOSITION WINDOW ELLIPSE.SEMI.MAJOR))
(MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of MAJRAD)
NIL WINDOW))
(T (* erase center pt on way out)
(MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of CENTER)
NIL WINDOW)
(CLOSEPROMPTWINDOW WINDOW)
(RETURN NIL)))
(STATUSPRINT WINDOW "
" "Indicate semi-minor axis")
(SETQ MINRAD (GETSKWPOSITION WINDOW ELLIPSE.SEMI.MINOR))
(CLOSEPROMPTWINDOW WINDOW) (* erase the point marks.)
(MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of MAJRAD)
NIL WINDOW)
(MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of CENTER)
NIL WINDOW)
(OR MINRAD (RETURN NIL))
(RETURN (ELLIPSE.CREATE (SK.MAP.INPUT.PT.TO.GLOBAL CENTER WINDOW)
(SK.MAP.INPUT.PT.TO.GLOBAL MINRAD WINDOW)
(SK.MAP.INPUT.PT.TO.GLOBAL MAJRAD WINDOW)
(fetch (SKETCHCONTEXT SKETCHBRUSH) of (WINDOWPROP WINDOW
(QUOTE
SKETCHCONTEXT)))
(fetch (SKETCHCONTEXT SKETCHDASHING) of (WINDOWPROP WINDOW
(QUOTE
SKETCHCONTEXT)))
(SK.INPUT.SCALE WINDOW])
(ELLIPSE.INSIDEFN
[LAMBDA (GELLIPSE WREG) (* rrb " 5-AUG-83 17:20")
(* determines if the global ellipse GELLIPSE is inside
of WREG.)
(* consider an ellipse inside only if one of its
control points is inside.)
(PROG ((INDGELLIPSE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELLIPSE)))
(RETURN (OR (INSIDEP WREG (fetch (ELLIPSE ELLIPSECENTERLATLON) of INDGELLIPSE))
(INSIDEP WREG (fetch (ELLIPSE SEMIMINORLATLON) of INDGELLIPSE))
(INSIDEP WREG (fetch (ELLIPSE SEMIMAJORLATLON) of INDGELLIPSE])
(ELLIPSE.CREATE
[LAMBDA (CENTERPT MINPT MAJPT BRUSH DASHING INITSCALE) (* rrb "19-Jul-85 14:26")
(* creates a global ellipse element.)
(PROG ((MAXRAD (MAX (DISTANCEBETWEEN CENTERPT MINPT)
(DISTANCEBETWEEN CENTERPT MAJPT)))
ORIENTATION)
(RETURN (create GLOBALPART
COMMONGLOBALPART ←(create COMMONGLOBALPART
MAXSCALE ← MAXRAD
MINSCALE ←(QUOTIENT MAXRAD 3000.0))
INDIVIDUALGLOBALPART ←(create ELLIPSE
ORIENTATION ←(SETQ ORIENTATION
(COMPUTE.ELLIPSE.ORIENTATION CENTERPT MAJPT)
)
BRUSH ← BRUSH
DASHING ← DASHING
ELLIPSECENTERLATLON ← CENTERPT
SEMIMINORLATLON ←(
SK.COMPUTE.ELLIPSE.MINOR.RADIUS.PT CENTERPT
MAJPT
MINPT
ORIENTATION)
SEMIMAJORLATLON ← MAJPT
ELLIPSEINITSCALE ← INITSCALE])
(ELLIPSE.REGIONFN
[LAMBDA (ELLIPSCRELT) (* rrb " 3-Oct-85 17:10")
(* returns the region occuppied by an ellipse.)
(PROG ((LOCALELLIPSE (fetch (SCREENELT LOCALPART) of ELLIPSCRELT))
MAJORRADPT CENTERX CENTERY BRUSHADJ HALFWID HALFHGHT RADRATIO DELTAX DELTAY)
(SETQ MAJORRADPT (fetch (LOCALELLIPSE MAJORRADIUSPOSITION) of LOCALELLIPSE))
(SETQ CENTERY (fetch (LOCALELLIPSE ELLIPSECENTER) of LOCALELLIPSE))
[SETQ RADRATIO (ABS (FQUOTIENT (fetch (LOCALELLIPSE SEMIMINORRADIUS)
of LOCALELLIPSE)
(fetch (LOCALELLIPSE SEMIMAJORRADIUS)
of LOCALELLIPSE]
[SETQ DELTAX (ABS (IDIFFERENCE (SETQ CENTERX (fetch (POSITION XCOORD)
of CENTERY))
(fetch (POSITION XCOORD) of MAJORRADPT]
[SETQ DELTAY (ABS (IDIFFERENCE (SETQ CENTERY (fetch (POSITION YCOORD)
of CENTERY))
(fetch (POSITION YCOORD) of MAJORRADPT]
(SETQ BRUSHADJ (LRSH (ADD1 (fetch (BRUSH BRUSHSIZE) of (fetch (LOCALELLIPSE
LOCALELLIPSEBRUSH)
of LOCALELLIPSE)))
1))
(SETQ HALFWID (FIXR (PLUS DELTAX (FTIMES RADRATIO DELTAY)
BRUSHADJ)))
(SETQ HALFHGHT (FIXR (PLUS DELTAY (FTIMES RADRATIO DELTAX)
BRUSHADJ)))
(* use the rectangle that contains the rectangle made by the extreme points of the ellipse.
This gets more than is called for when the orientation isn't 0 or 90.0)
(RETURN (CREATEREGION (IDIFFERENCE CENTERX HALFWID)
(IDIFFERENCE CENTERY HALFHGHT)
(ITIMES HALFWID 2)
(ITIMES HALFHGHT 2])
(ELLIPSE.TRANSLATEFN
[LAMBDA (SKELT DELTAPOS) (* rrb "28-Apr-85 18:44")
(* returns a global ellipse element which has been
translated by DELTAPOS.)
(PROG ((GLOBALEL (fetch (GLOBALPART INDIVIDUALGLOBALPART) of SKELT)))
(RETURN (create GLOBALPART
COMMONGLOBALPART ←(APPEND (fetch (GLOBALPART COMMONGLOBALPART)
of SKELT))
INDIVIDUALGLOBALPART ←(create ELLIPSE using GLOBALEL ORIENTATION ←(fetch
(ELLIPSE ORIENTATION)
of
GLOBALEL)
ELLIPSECENTERLATLON ←(PTPLUS
(fetch (ELLIPSE
ELLIPSECENTERLATLON)
of GLOBALEL)
DELTAPOS)
SEMIMINORLATLON ←(PTPLUS
(fetch (ELLIPSE
SEMIMINORLATLON)
of GLOBALEL)
DELTAPOS)
SEMIMAJORLATLON ←(PTPLUS
(fetch (ELLIPSE
SEMIMAJORLATLON)
of GLOBALEL)
DELTAPOS])
(ELLIPSE.TRANSFORMFN
[LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "26-Apr-85 16:21")
(* returns a copy of the global ellipse element that has had each of its control points transformed by transformfn.
TRANSFORMDATA is arbitrary data that is passed to tranformfn.)
(PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)))
(RETURN (ELLIPSE.CREATE (SK.TRANSFORM.POINT (fetch (ELLIPSE ELLIPSECENTERLATLON)
of INDVPART)
TRANSFORMFN TRANSFORMDATA)
(SK.TRANSFORM.POINT (fetch (ELLIPSE SEMIMINORLATLON) of INDVPART)
TRANSFORMFN TRANSFORMDATA)
(SK.TRANSFORM.POINT (fetch (ELLIPSE SEMIMAJORLATLON) of INDVPART)
TRANSFORMFN TRANSFORMDATA)
(SK.TRANSFORM.BRUSH (fetch (ELLIPSE BRUSH) of INDVPART)
SCALEFACTOR)
(fetch (ELLIPSE DASHING) of INDVPART)
(fetch (ELLIPSE ELLIPSEINITSCALE) of INDVPART])
(ELLIPSE.TRANSLATEPTS
[LAMBDA (ELLIPSESPEC SELPTS GLOBALDELTA WINDOW) (* rrb " 5-May-85 16:41")
(* returns a new global ellipse element which has the
points on SELPTS moved by a global distance.)
(PROG ((LELLIPSE (fetch (SCREENELT LOCALPART) of ELLIPSESPEC))
(GELLIPSE (fetch (SCREENELT INDIVIDUALGLOBALPART) of ELLIPSESPEC)))
(RETURN (ELLIPSE.CREATE (COND
((MEMBER (fetch (LOCALELLIPSE ELLIPSECENTER) of LELLIPSE)
SELPTS) (* move the center)
(PTPLUS (fetch (ELLIPSE ELLIPSECENTERLATLON) of GELLIPSE)
GLOBALDELTA))
(T (fetch (ELLIPSE ELLIPSECENTERLATLON) of GELLIPSE)))
(COND
((MEMBER (fetch (LOCALELLIPSE MINORRADIUSPOSITION) of LELLIPSE)
SELPTS) (* move the radius point.)
(PTPLUS (fetch (ELLIPSE SEMIMINORLATLON) of GELLIPSE)
GLOBALDELTA))
(T (fetch (ELLIPSE SEMIMINORLATLON) of GELLIPSE)))
(COND
((MEMBER (fetch (LOCALELLIPSE MAJORRADIUSPOSITION) of LELLIPSE)
SELPTS) (* move the radius point.)
(PTPLUS (fetch (ELLIPSE SEMIMAJORLATLON) of GELLIPSE)
GLOBALDELTA))
(T (fetch (ELLIPSE SEMIMAJORLATLON) of GELLIPSE)))
(fetch (ELLIPSE BRUSH) of GELLIPSE)
(fetch (ELLIPSE DASHING) of GELLIPSE)
(fetch (ELLIPSE ELLIPSEINITSCALE) of GELLIPSE])
(MARK.SPOT
[LAMBDA (X/POSITION Y WINDOW) (* rrb "14-JAN-83 15:40")
(PROG [X WIDTH HEIGHT (COLORDS (WINDOWPROP WINDOW (QUOTE INCOLOR]
(COND
((POSITIONP X/POSITION)
(SETQ X (fetch (POSITION XCOORD) of X/POSITION))
(SETQ Y (fetch (POSITION YCOORD) of X/POSITION)))
(T (SETQ X X/POSITION)))
(SETQ WIDTH (BITMAPWIDTH SPOTMARKER))
(SETQ HEIGHT (BITMAPHEIGHT SPOTMARKER))
(BITBLT (COND
[COLORDS (COND
((AND (BITMAPP COLORSPOTMARKER)
(EQ (BITSPERPIXEL COLORSPOTMARKER)
(COLORNUMBERBITSPERPIXEL)))
COLORSPOTMARKER)
(T (SETQ COLORSPOTMARKER (COLORIZEBITMAP SPOTMARKER 0 (MAXIMUMCOLOR)
(COLORNUMBERBITSPERPIXEL]
(T SPOTMARKER))
0 0 (OR COLORDS WINDOW)
(IDIFFERENCE X (IQUOTIENT WIDTH 2))
(IDIFFERENCE Y (IQUOTIENT HEIGHT 2))
WIDTH HEIGHT (QUOTE INPUT)
(QUOTE INVERT])
(DISTANCEBETWEEN
[LAMBDA (P1 P2) (* rrb " 5-JAN-83 12:17")
(* returns the distance between two points)
(SQRT (PLUS (SQUARE (DIFFERENCE (fetch (POSITION XCOORD) of P1)
(fetch (POSITION XCOORD) of P2)))
(SQUARE (DIFFERENCE (fetch (POSITION YCOORD) of P1)
(fetch (POSITION YCOORD) of P2])
(SQUARE
[LAMBDA (X)
(TIMES X X])
(COMPUTE.ELLIPSE.ORIENTATION
[LAMBDA (CENTERPT MAJRADPT) (* rrb "12-Oct-84 14:29")
(* computes the orientation of an ellipse from its
center point and its major radius point.)
(ARCTAN2 (IDIFFERENCE (fetch (POSITION YCOORD) of MAJRADPT)
(fetch (POSITION YCOORD) of CENTERPT))
(IDIFFERENCE (fetch (POSITION XCOORD) of MAJRADPT)
(fetch (POSITION XCOORD) of CENTERPT])
(SK.COMPUTE.ELLIPSE.MINOR.RADIUS.PT
[LAMBDA (CENTER MAJORRADPT MINORPT ORIENTATION) (* rrb "19-Jul-85 14:23")
(* computes the point that is on the minor radius of an ellipse about CENTER with major radius and axis determined
by MAJORRADPT and minor radius determines by MINORPT.)
(PROG ((SINOR (SIN ORIENTATION))
(COSOR (COS ORIENTATION))
(SEMIMINORRADIUS (DISTANCEBETWEEN CENTER MINORPT))
(SEMIMAJORRADIUS (DISTANCEBETWEEN CENTER MAJORRADPT)))
(RETURN (CREATEPOSITION (DIFFERENCE (fetch (POSITION XCOORD) of CENTER)
(FTIMES SINOR SEMIMINORRADIUS))
(PLUS (fetch (POSITION YCOORD) of CENTER)
(FTIMES COSOR SEMIMINORRADIUS])
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD LOCALELLIPSE ((ELLIPSECENTER MINORRADIUSPOSITION MAJORRADIUSPOSITION)
SEMIMINORRADIUS SEMIMAJORRADIUS LOCALELLIPSEBRUSH))
(TYPERECORD ELLIPSE (ELLIPSECENTERLATLON SEMIMINORLATLON SEMIMAJORLATLON ORIENTATION BRUSH DASHING
ELLIPSEINITSCALE))
]
)
(READVARS ELLIPSEICON)
({(READBITMAP)(20 12
"@COL@@@@"
"AOOOH@@@"
"CN@GL@@@"
"G@@@N@@@"
"N@@@G@@@"
"L@@@C@@@"
"L@@@C@@@"
"N@@@G@@@"
"G@@@N@@@"
"CN@GL@@@"
"AOOOH@@@"
"@COL@@@@")})
(RPAQ ELLIPSE.CENTER (CURSORCREATE (READBITMAP) 8 8))
(16 16
"@GN@"
"AOOH"
"CLCL"
"G@@N"
"FDBF"
"NJEG"
"LEJC"
"LBDC"
"LBDC"
"LEJC"
"NJEG"
"FDBF"
"G@@N"
"CLCL"
"AOOH"
"@GN@")(RPAQ ELLIPSE.SEMI.MAJOR (CURSORCREATE (READBITMAP) 15 8))
(16 16
"@@AL"
"@@@L"
"@@@N"
"@@@F"
"@@BG"
"@@CC"
"@@CK"
"OOOO"
"OOOO"
"@@CK"
"@@CC"
"@@BG"
"@@@F"
"@@@N"
"@@@L"
"@@AL")(RPAQ ELLIPSE.SEMI.MINOR (CURSORCREATE (READBITMAP) 8 15))
(16 16
"@OO@"
"COOL"
"OIIO"
"NCLG"
"HGNA"
"@OO@"
"@AH@"
"@AH@"
"@AH@"
"@AH@"
"@AH@"
"@AH@"
"@AH@"
"@AH@"
"@AH@"
"@AH@")(DEFINEQ
(KNOTS.INSIDEFN
[LAMBDA (GCURVE WREG) (* rrb " 5-AUG-83 14:19")
(* determines if the global curve GCURVE is inside of
WREG.)
(* consider a curve inside only if one of its control
points is inside.)
(for PT in (fetch LATLONKNOTS of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GCURVE))
when (INSIDEP WREG PT) do (RETURN T])
(OPENCURVE.INPUTFN
[LAMBDA (W) (* rrb " 4-Sep-85 15:48")
(* reads a spline {series of points} from the user.)
(PROG ((SKCONTEXT (WINDOWPROP W (QUOTE SKETCHCONTEXT)))
KNOTS)
(RETURN (SK.CURVE.CREATE (SETQ KNOTS (for PT in (READ.LIST.OF.POINTS W T)
collect (SK.MAP.INPUT.PT.TO.GLOBAL PT W)))
NIL
(fetch (SKETCHCONTEXT SKETCHBRUSH) of SKCONTEXT)
(fetch (SKETCHCONTEXT SKETCHDASHING) of SKCONTEXT)
(SK.INPUT.SCALE W)
(SK.ARROWHEAD.CREATE W KNOTS])
(SK.CURVE.CREATE
[LAMBDA (GKNOTS CLOSED BRUSH DASHING INITSCALE ARROWHEADS)
(* rrb " 5-May-85 17:42")
(* creates a sketch element representing a curve.)
(AND GKNOTS
(KNOT.SET.SCALE.FIELD (create GLOBALPART
INDIVIDUALGLOBALPART ←(COND
(CLOSED (create CLOSEDCURVE
LATLONKNOTS ← GKNOTS
BRUSH ← BRUSH
DASHING ← DASHING
CLOSEDCURVEINITSCALE ← INITSCALE))
(T (create OPENCURVE
LATLONKNOTS ← GKNOTS
BRUSH ← BRUSH
DASHING ← DASHING
OPENCURVEINITSCALE ← INITSCALE
CURVEARROWHEADS ← ARROWHEADS])
(MAXXEXTENT
[LAMBDA (PTS) (* rrb " 1-APR-83 17:24")
(* returns the maximum width between any two points on
pts)
(COND
((NULL PTS)
0)
(T (PROG ((XMIN (fetch (POSITION XCOORD) of (CAR PTS)))
XMAX)
(SETQ XMAX XMIN)
[for PT in (CDR PTS)
do (COND
((GREATERP (SETQ PT (fetch (POSITION XCOORD) of PT))
XMAX)
(SETQ XMAX PT)))
(COND
((GREATERP XMIN PT)
(SETQ XMIN PT]
(RETURN (DIFFERENCE XMAX XMIN])
(MAXYEXTENT
[LAMBDA (PTS) (* rrb " 1-APR-83 17:24")
(* returns the maximum height between any two points on
pts)
(COND
((NULL PTS)
0)
(T (PROG ((YMIN (fetch (POSITION YCOORD) of (CAR PTS)))
YMAX)
(SETQ YMAX YMIN)
[for PT in (CDR PTS)
do (COND
((GREATERP (SETQ PT (fetch (POSITION YCOORD) of PT))
YMAX)
(SETQ YMAX PT)))
(COND
((GREATERP YMIN PT)
(SETQ YMIN PT]
(RETURN (DIFFERENCE YMAX YMIN])
(KNOT.SET.SCALE.FIELD
[LAMBDA (GKNOTELT) (* rrb "31-Jan-85 18:22")
(* updates the scale field after a change in the knots
of a knotted element.)
(PROG [(PTS (fetch (KNOTELT LATLONKNOTS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GKNOTELT]
(replace (GLOBALPART MINSCALE) of GKNOTELT with 0.0)
(* show it as long as it is two points wide or high.)
(replace (GLOBALPART MAXSCALE) of GKNOTELT with (FQUOTIENT (MAX 8 (MAXXEXTENT PTS)
(MAXYEXTENT PTS))
2.0))
(RETURN GKNOTELT])
(OPENCURVE.DRAWFN
[LAMBDA (CURVEELT WINDOW REGION) (* rrb "26-Apr-85 09:24")
(* draws a curve figure element.)
(PROG ((GCURVE (fetch (SCREENELT INDIVIDUALGLOBALPART) of CURVEELT))
(LCURVE (fetch (SCREENELT LOCALPART) of CURVEELT))
BRUSH)
(AND REGION (NOT (REGIONSINTERSECTP REGION (SK.ITEM.REGION CURVEELT)))
(RETURN))
(DRAWCURVE (fetch (LOCALCURVE KNOTS) of LCURVE)
NIL
(SETQ BRUSH (fetch (LOCALCURVE LOCALCURVEBRUSH) of LCURVE))
(fetch (OPENCURVE DASHING) of GCURVE)
WINDOW)
(DRAWARROWHEADS (fetch (OPENCURVE CURVEARROWHEADS) of GCURVE)
(fetch (LOCALCURVE ARROWHEADPTS) of LCURVE)
WINDOW BRUSH])
(OPENCURVE.EXPANDFN
[LAMBDA (GELT SCALE) (* rrb " 2-Jun-85 12:00")
(* returns a local record which has the LATLONKNOTS
field of the global element GELT translated into window
coordinats. Used for open curves)
(PROG ((INDGELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))
TMP)
[COND
((fetch (OPENCURVE OPENCURVEINITSCALE) of INDGELT))
(T (* old format didn't have an initial scale, default it
to 1.0)
(replace (GLOBALPART INDIVIDUALGLOBALPART) of GELT
with (SETQ INDGELT (create OPENCURVE using INDGELT OPENCURVEINITSCALE ← 1.0]
(RETURN (create SCREENELT
LOCALPART ←(create LOCALCURVE
KNOTS ←(SETQ TMP (for LATLONPT
in (fetch (OPENCURVE LATLONKNOTS)
of INDGELT)
collect (
SK.SCALE.POSITION.INTO.VIEWER LATLONPT SCALE)))
ARROWHEADPTS ←(SK.EXPAND.ARROWHEADS INDGELT TMP SCALE)
LOCALCURVEBRUSH ←(SCALE.BRUSH
(COND
([NOT (NUMBERP (SETQ TMP (fetch (OPENCURVE BRUSH)
of INDGELT]
(* new format, old format had brush width only.)
TMP)
(T [replace (OPENCURVE BRUSH) of INDGELT
with (SETQ TMP
(create BRUSH
BRUSHSIZE ← TMP
BRUSHSHAPE ←(QUOTE ROUND]
TMP))
(fetch (OPENCURVE OPENCURVEINITSCALE) of INDGELT)
SCALE))
GLOBALPART ← GELT])
(OPENCURVE.READCHANGEFN
[LAMBDA (SKW) (* rrb "12-Jul-85 13:34")
(* changefn for curves)
(PROG (ASPECT HOW)
(SETQ HOW (SELECTQ [SETQ ASPECT (MENU (create MENU
CENTERFLG ← T
TITLE ← "Which aspect?"
ITEMS ←(APPEND
(COND
[(SKETCHINCOLORP)
(QUOTE ((Color (QUOTE BRUSHCOLOR)
"Changes the color of the curve."]
(T NIL))
(QUOTE ((Arrowheads (QUOTE ARROW)
"allows changing of arrow head charactistics.")
(Shape (QUOTE SHAPE)
"changes the shape of the brush")
(Size (QUOTE SIZE)
"changes the size of the brush")
(Dashing (QUOTE DASHING)
"changes the dashing of the line."]
(SIZE (READSIZECHANGE "Change size how?"))
(SHAPE (READBRUSHSHAPE))
(ARROW (READ.ARROW.CHANGE))
(DASHING (READ.DASHING.CHANGE))
(BRUSHCOLOR (READ.COLOR.CHANGE "Change curve color how?"))
NIL))
(RETURN (AND HOW (LIST ASPECT HOW])
(OPENCURVE.TRANSFORMFN
[LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "26-Sep-85 12:11")
(* returns a copy of the global OPENCURVE element that has had each of its control points transformed by
transformfn. TRANSFORMDATA is arbitrary data that is passed to tranformfn.)
(PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)))
(RETURN (KNOT.SET.SCALE.FIELD (create GLOBALPART using GELT INDIVIDUALGLOBALPART ←
(create OPENCURVE
using INDVPART LATLONKNOTS ←
(SK.TRANSFORM.POINT.LIST
(fetch (OPENCURVE
LATLONKNOTS)
of INDVPART)
TRANSFORMFN TRANSFORMDATA)
BRUSH ←
(SK.TRANSFORM.BRUSH
(fetch (OPENCURVE BRUSH)
of INDVPART)
SCALEFACTOR)
CURVEARROWHEADS ←
(SK.TRANSFORM.ARROWHEADS
(fetch (OPENCURVE
CURVEARROWHEADS)
of INDVPART)
SCALEFACTOR])
(OPENCURVE.TRANSLATEPTSFN
[LAMBDA (KNOTELT SELPTS GDELTA WINDOW) (* rrb " 5-May-85 17:49")
(* returns a curve element which has the knots that are
members of SELPTS translated by the global amount
GDELTA.)
(PROG ((GKNOTELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of KNOTELT)))
(RETURN (SK.CURVE.CREATE (for PT in (fetch (LOCALCURVE KNOTS) of (fetch (SCREENELT
LOCALPART)
of KNOTELT))
as LATLONPT in (fetch LATLONKNOTS of GKNOTELT)
collect (COND
((MEMBER PT SELPTS)
(PTPLUS LATLONPT GDELTA))
(T LATLONPT)))
NIL
(fetch (OPENCURVE BRUSH) of GKNOTELT)
(fetch (OPENCURVE DASHING) of GKNOTELT)
(fetch (OPENCURVE OPENCURVEINITSCALE) of GKNOTELT)
(fetch (OPENCURVE CURVEARROWHEADS) of GKNOTELT])
(CLOSEDCURVE.DRAWFN
[LAMBDA (CURVEELT WINDOW REGION) (* rrb "26-Apr-85 11:39")
(* draws a curve figure element.)
(PROG ((GCURVE (fetch (SCREENELT INDIVIDUALGLOBALPART) of CURVEELT)))
(* make sure this curve might be in the REGION of
interest.)
(AND REGION (NOT (REGIONSINTERSECTP REGION (SK.ITEM.REGION CURVEELT)))
(RETURN))
(DRAWCURVE (fetch (LOCALKNOTS HOTSPOTS) of (fetch (SCREENELT LOCALPART) of CURVEELT))
T
(fetch (LOCALKNOTS LOCALKNOTSBRUSH) of (fetch (SCREENELT LOCALPART)
of CURVEELT))
(fetch (CLOSEDCURVE DASHING) of GCURVE)
WINDOW])
(CLOSEDCURVE.EXPANDFN
[LAMBDA (GELT SCALE) (* rrb "27-Apr-85 21:23")
(* returns a local record which has the LATLONKNOTS
field of the global element GELT translated into window
coordinats. Used for curves and wires.)
(PROG ((INDVKNOTELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))
BRSH)
[COND
((fetch (CLOSEDCURVE CLOSEDCURVEINITSCALE) of INDVKNOTELT))
(T (* old format didn't have an initial scale, default it
to 1.0)
(replace (GLOBALPART INDIVIDUALGLOBALPART) of GELT
with (SETQ INDVKNOTELT (create CLOSEDCURVE using INDVKNOTELT CLOSEDCURVEINITSCALE ←
1.0]
(RETURN (create SCREENELT
LOCALPART ←(create LOCALKNOTS
HOTSPOTS ←(for LATLONPT in (fetch LATLONKNOTS
of INDVKNOTELT)
collect (SK.SCALE.POSITION.INTO.VIEWER
LATLONPT SCALE))
LOCALKNOTSBRUSH ←(SCALE.BRUSH
(COND
([NOT (NUMBERP (SETQ BRSH (fetch (CLOSEDCURVE BRUSH)
of INDVKNOTELT]
(* new format, old format had brush width only.)
BRSH)
(T [replace (CLOSEDCURVE BRUSH) of INDVKNOTELT
with (SETQ BRSH
(create BRUSH
BRUSHSIZE ← BRSH
BRUSHSHAPE ←(QUOTE ROUND]
BRSH))
(fetch (CLOSEDCURVE CLOSEDCURVEINITSCALE)
of INDVKNOTELT)
SCALE))
GLOBALPART ← GELT])
(CLOSEDCURVE.REGIONFN
[LAMBDA (KNOTSCRELT) (* rrb "30-May-85 12:20")
(* returns the region occuppied by a list of knots
which represent a curve.)
(* uses the heuristic that the region containing the curve is not more than 20% larger than the knots.
This was determined empirically on several curves.)
(INCREASEREGION (EXPANDREGION (REGION.CONTAINING.PTS (fetch (SCREENELT HOTSPOTS) of KNOTSCRELT))
1.4)
(IQUOTIENT [ADD1 (SK.BRUSH.SIZE (fetch (LOCALKNOTS LOCALKNOTSBRUSH)
of (fetch (SCREENELT LOCALPART) of KNOTSCRELT]
2])
(READ.LIST.OF.POINTS
[LAMBDA (W ALLOWDUPS?) (* rrb "11-Jul-85 14:27")
(* reads a spline {series of points} from the user.)
(PROG (PT PTS)
(STATUSPRINT W "
" "Enter the points the curve goes through using the left button.
Click outside the window to stop.")
LP (COND
((SETQ PT (GETSKWPOSITION W POINTREADINGCURSOR))
(* add the point to the list and mark it.)
[COND
([OR ALLOWDUPS? (NOT (EQUAL (fetch (INPUTPT INPUT.POSITION)
of (CAR (LAST PTS)))
(fetch (INPUTPT INPUT.POSITION) of PT]
(SHOWSKETCHPOINT (fetch (INPUTPT INPUT.POSITION) of PT)
W PTS)
(SETQ PTS (NCONC1 PTS PT]
(GO LP))
(T (* erase point markers.)
(for PTTAIL on PTS do (SHOWSKETCHPOINT (fetch (INPUTPT INPUT.POSITION)
of (CAR PTTAIL))
W
(CDR PTTAIL)))
(CLRPROMPT) (* return points)
(RETURN PTS])
(CLOSEDCURVE.INPUTFN
[LAMBDA (W) (* rrb " 4-Sep-85 15:49")
(* reads a spline {series of points} from the user.)
(SK.CURVE.CREATE (for PT in (READ.LIST.OF.POINTS W T) collect (SK.MAP.INPUT.PT.TO.GLOBAL PT W))
T
(fetch (SKETCHCONTEXT SKETCHBRUSH) of (WINDOWPROP W (QUOTE SKETCHCONTEXT)))
(fetch (SKETCHCONTEXT SKETCHDASHING) of (WINDOWPROP W (QUOTE SKETCHCONTEXT)))
(SK.INPUT.SCALE W])
(CLOSEDCURVE.TRANSFORMFN
[LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "26-Apr-85 16:09")
(* returns a copy of the global CLOSEDCURVE element that has had each of its control points transformed by
transformfn. TRANSFORMDATA is arbitrary data that is passed to tranformfn.)
(PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)))
(RETURN (KNOT.SET.SCALE.FIELD (create GLOBALPART using GELT INDIVIDUALGLOBALPART ←(create
CLOSEDCURVE
using
INDVPART
LATLONKNOTS ←(
SK.TRANSFORM.POINT.LIST
(
fetch (CLOSEDCURVE LATLONKNOTS) of INDVPART)
TRANSFORMFN
TRANSFORMDATA)
BRUSH
←(
SK.TRANSFORM.BRUSH
(
fetch (CLOSEDCURVE BRUSH) of INDVPART)
SCALEFACTOR])
(CLOSEDCURVE.TRANSLATEPTSFN
[LAMBDA (KNOTELT SELPTS GDELTA WINDOW) (* rrb " 5-May-85 18:35")
(* returns a closed curve element which has the knots
that are members of SELPTS translated by the global
amount GDELTA.)
(PROG ((GKNOTELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of KNOTELT)))
(RETURN (SK.CURVE.CREATE (for PT in (fetch (LOCALCURVE KNOTS) of (fetch (SCREENELT
LOCALPART)
of KNOTELT))
as LATLONPT in (fetch LATLONKNOTS of GKNOTELT)
collect (COND
((MEMBER PT SELPTS)
(PTPLUS LATLONPT GDELTA))
(T LATLONPT)))
T
(fetch (CLOSEDCURVE BRUSH) of GKNOTELT)
(fetch (CLOSEDCURVE DASHING) of GKNOTELT)
(fetch (CLOSEDCURVE CLOSEDCURVEINITSCALE) of GKNOTELT)
NIL])
(INVISIBLEPARTP
[LAMBDA (WINDOW POINT) (* rrb "30-NOV-82 17:25")
(* determines if POINT is in the visible part of a
window.)
(INSIDE? (DSPCLIPPINGREGION NIL WINDOW)
(fetch (POSITION XCOORD) of POINT)
(fetch (POSITION YCOORD) of POINT])
(SHOWSKETCHPOINT
[LAMBDA (NEWPT W PTS) (* rrb "12-May-85 18:50")
(* puts down the marker for a new point unless it is
already a member of points.)
(OR (MEMBER NEWPT PTS)
(MARKPOINT NEWPT W SPOTMARKER])
(SHOWSKETCHXY
[LAMBDA (X Y WINDOW) (* rrb " 2-Oct-85 09:58")
(* puts down a marker for a point at position X,Y)
(BITBLT SPOTMARKER NIL NIL WINDOW (IDIFFERENCE X (LRSH (fetch (BITMAP BITMAPWIDTH) of SPOTMARKER)
1))
(IDIFFERENCE Y (LRSH (fetch (BITMAP BITMAPHEIGHT) of SPOTMARKER)
1))
NIL NIL (QUOTE INPUT)
(QUOTE INVERT])
(KNOTS.REGIONFN
[LAMBDA (KNOTSCRELT) (* rrb "29-May-85 21:17")
(* returns the region occuppied by a list of knots)
(* increase by half the brush size plus 2 This has the nice property of insuring that the region always has both
height and width.)
(INCREASEREGION (REGION.CONTAINING.PTS (fetch (SCREENELT HOTSPOTS) of KNOTSCRELT))
(IPLUS 3 (QUOTIENT (fetch (BRUSH BRUSHSIZE) of (fetch (LOCALWIRE
LOCALOPENWIREBRUSH)
of (fetch (SCREENELT LOCALPART)
of KNOTSCRELT)))
2])
(CURVE.REGIONFN
[LAMBDA (OPENCURVESCRELT) (* rrb "30-May-85 12:20")
(* returns the region occuppied by a list of knots
which represent a curve.)
(* uses the heuristic that the region containing the curve is not more than 20% larger than the knots.
This was determined empirically on several curves.)
(INCREASEREGION (EXPANDREGION (REGION.CONTAINING.PTS (fetch (SCREENELT HOTSPOTS) of
OPENCURVESCRELT))
1.4)
(IQUOTIENT [ADD1 (SK.BRUSH.SIZE (fetch (LOCALCURVE LOCALCURVEBRUSH)
of (fetch (SCREENELT LOCALPART) of
OPENCURVESCRELT]
2])
(KNOTS.TRANSLATEFN
[LAMBDA (SKELT DELTAPOS) (* rrb "28-Apr-85 18:45")
(* replaces the knots field of the global part of a
screen element with knots that have been translated
DELTAPOS.)
(PROG [(GKNOTELT (APPEND (fetch (GLOBALPART INDIVIDUALGLOBALPART) of SKELT]
(replace (KNOTELT LATLONKNOTS) of GKNOTELT with (for PT in (fetch (KNOTELT LATLONKNOTS)
of GKNOTELT)
collect (PTPLUS PT DELTAPOS)))
(RETURN (create GLOBALPART
COMMONGLOBALPART ←(APPEND (fetch (GLOBALPART COMMONGLOBALPART)
of SKELT))
INDIVIDUALGLOBALPART ← GKNOTELT])
(REGION.CONTAINING.PTS
[LAMBDA (PTLST) (* rrb " 7-Sep-84 11:26")
(* returns the region that contains all of the points
on PTLST.)
(AND PTLST (PROG ((XMIN (fetch (POSITION XCOORD) of (CAR PTLST)))
(XMAX (fetch (POSITION XCOORD) of (CAR PTLST)))
(YMIN (fetch (POSITION YCOORD) of (CAR PTLST)))
(YMAX (fetch (POSITION YCOORD) of (CAR PTLST)))
TMP)
[for PT in (CDR PTLST)
do (COND
((GREATERP (SETQ TMP (fetch (POSITION XCOORD) of PT))
XMAX)
(SETQ XMAX TMP))
((GREATERP XMIN TMP)
(SETQ XMIN TMP)))
(COND
((GREATERP (SETQ TMP (fetch (POSITION YCOORD) of PT))
YMAX)
(SETQ YMAX TMP))
((GREATERP YMIN TMP)
(SETQ YMIN TMP]
(RETURN (CREATEREGION XMIN YMIN (DIFFERENCE XMAX XMIN)
(DIFFERENCE YMAX YMIN])
)
(DEFINEQ
(CHANGE.ELTS.BRUSH.SIZE
[LAMBDA (HOWTOCHANGE ELTSWITHBRUSH SKW) (* rrb "10-Jan-85 14:00")
(* * function that prompts for how the line thickness should change and changes it for all elements in ELTSWITHBRUSH
that have a brush size or thickness.)
(* knows about the various types of sketch elements
types and shouldn't.)
(AND HOWTOCHANGE (for LINEDELT in ELTSWITHBRUSH collect (SK.CHANGE.BRUSH.SIZE LINEDELT
HOWTOCHANGE SKW])
(CHANGE.ELTS.BRUSH
[LAMBDA (CURVELTS SKW HOW) (* rrb " 4-Jan-85 14:55")
(* changefn for curves Actually makes the change.)
(SELECTQ (CAR HOW)
(SIZE (CHANGE.ELTS.BRUSH.SIZE (CADR HOW)
CURVELTS SKW))
(SHAPE (CHANGE.ELTS.BRUSH.SHAPE (CADR HOW)
CURVELTS SKW))
NIL])
(CHANGE.ELTS.BRUSH.SHAPE
[LAMBDA (NEWSHAPE CURVELTS SKW) (* rrb "10-Jan-85 16:49")
(* changes the brush shape of a list of curve elements.
Knows about the various sketch element types and
shouldn't need to.)
(AND NEWSHAPE (for CURVELT in CURVELTS collect (SK.CHANGE.BRUSH.SHAPE CURVELT NEWSHAPE SKW])
(SK.CHANGE.BRUSH.SHAPE
[LAMBDA (ELTWITHBRUSH HOW SKW) (* rrb " 9-Aug-85 10:00")
(* changes the brush shape in the element
ELTWITHBRUSH.)
(PROG (GCURVELT BRUSH TYPE NEWELT)
(RETURN (COND
((MEMB (SETQ TYPE (fetch (GLOBALPART GTYPE) of ELTWITHBRUSH))
(QUOTE (CLOSEDCURVE OPENCURVE ELLIPSE CIRCLE ARC CLOSEDWIRE WIRE)))
(* only works for things of curve type.)
(SETQ GCURVELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHBRUSH))
(SETQ BRUSH (SELECTQ TYPE
(CIRCLE (fetch (CIRCLE BRUSH) of GCURVELT))
(ARC (fetch (ARC ARCBRUSH) of GCURVELT))
(ELLIPSE (fetch (ELLIPSE BRUSH) of GCURVELT))
(WIRE (fetch (WIRE BRUSH) of GCURVELT))
(CLOSEDWIRE (fetch (CLOSEDWIRE BRUSH) of GCURVELT))
(fetch (OPENCURVE BRUSH) of GCURVELT)))
(COND
((NEQ HOW (fetch (BRUSH BRUSHSHAPE) of BRUSH))
(* new brush shape)
(SETQ NEWELT (SELECTQ TYPE
(CLOSEDCURVE (create CLOSEDCURVE
using GCURVELT BRUSH ←(create BRUSH
using BRUSH
BRUSHSHAPE ←
HOW)))
(OPENCURVE (create OPENCURVE
using GCURVELT BRUSH ←(create BRUSH
using BRUSH
BRUSHSHAPE ←
HOW)))
(CIRCLE (create CIRCLE
using GCURVELT BRUSH ←(create BRUSH
using BRUSH
BRUSHSHAPE ←
HOW)))
(ARC (create ARC
using GCURVELT ARCBRUSH ←(create BRUSH
using BRUSH
BRUSHSHAPE ←
HOW)))
(ELLIPSE (create ELLIPSE
using GCURVELT BRUSH ←(create BRUSH
using BRUSH
BRUSHSHAPE ←
HOW)))
(WIRE (create WIRE
using GCURVELT BRUSH ←(create BRUSH
using BRUSH
BRUSHSHAPE ←
HOW)))
(CLOSEDWIRE (create CLOSEDWIRE
using GCURVELT BRUSH ←(create BRUSH
using BRUSH
BRUSHSHAPE ←
HOW)))
(SHOULDNT)))
(create GLOBALPART
COMMONGLOBALPART ←(fetch (GLOBALPART COMMONGLOBALPART)
of ELTWITHBRUSH)
INDIVIDUALGLOBALPART ← NEWELT])
(SK.CHANGE.BRUSH.COLOR
[LAMBDA (ELTWITHLINE COLOR SKW) (* rrb " 9-Aug-85 10:00")
(* changes the brush color of ELTWITHLINE if it has a
brush)
(* knows about the various types of sketch elements
types and shouldn't.)
(PROG ((GLINELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHLINE))
TYPE BRUSH NEWBRUSH NEWELT)
(COND
[(MEMB (SETQ TYPE (fetch (GLOBALPART GTYPE) of ELTWITHLINE))
(QUOTE (WIRE BOX CLOSEDWIRE CLOSEDCURVE OPENCURVE CIRCLE ELLIPSE TEXTBOX ARC)))
(* only works for things of wire type.)
(* the brush is stored in the different place for all
element types.)
(SETQ BRUSH (SELECTQ TYPE
(CIRCLE (fetch (CIRCLE BRUSH) of GLINELT))
(ELLIPSE (fetch (ELLIPSE BRUSH) of GLINELT))
(TEXTBOX (fetch (TEXTBOX TEXTBOXBRUSH) of GLINELT))
(CLOSEDCURVE (fetch (CLOSEDCURVE BRUSH) of GLINELT))
(BOX (fetch (BOX BRUSH) of GLINELT))
(ARC (fetch (ARC ARCBRUSH) of GLINELT))
(fetch (OPENCURVE BRUSH) of GLINELT)))
(COND
((NOT (EQUAL COLOR (fetch (BRUSH BRUSHCOLOR) of BRUSH)))
(SETQ NEWBRUSH (create BRUSH using BRUSH BRUSHCOLOR ← COLOR))
(SETQ NEWELT (SELECTQ TYPE
(WIRE (create WIRE using GLINELT BRUSH ← NEWBRUSH))
(BOX (create BOX using GLINELT BRUSH ← NEWBRUSH))
(ARC (create ARC using GLINELT ARCBRUSH ← NEWBRUSH))
(TEXTBOX (create TEXTBOX
using GLINELT TEXTBOXBRUSH ← NEWBRUSH TEXTCOLOR ←
COLOR))
(CLOSEDWIRE (create CLOSEDWIRE using GLINELT BRUSH ← NEWBRUSH)
)
(CLOSEDCURVE (create CLOSEDCURVE using GLINELT BRUSH ←
NEWBRUSH))
(OPENCURVE (create OPENCURVE using GLINELT BRUSH ← NEWBRUSH))
(CIRCLE (create CIRCLE using GLINELT BRUSH ← NEWBRUSH))
(ELLIPSE (create ELLIPSE using GLINELT BRUSH ← NEWBRUSH))
(SHOULDNT)))
(RETURN (create GLOBALPART
COMMONGLOBALPART ←(fetch (GLOBALPART COMMONGLOBALPART)
of ELTWITHLINE)
INDIVIDUALGLOBALPART ← NEWELT]
((EQ TYPE (QUOTE TEXT)) (* change the color of text too.)
(COND
((NOT (EQUAL COLOR (fetch (TEXT TEXTCOLOR) of GLINELT)))
(RETURN (create GLOBALPART
COMMONGLOBALPART ←(fetch (GLOBALPART COMMONGLOBALPART)
of ELTWITHLINE)
INDIVIDUALGLOBALPART ←(create TEXT using GLINELT TEXTCOLOR ← COLOR])
(SK.CHANGE.BRUSH.SIZE
[LAMBDA (ELTWITHLINE HOW SKW) (* rrb "27-Sep-85 18:56")
(* changes the line size of ELTWITHLINE if it has a
brush size or thickness.)
(* knows about the various types of sketch elements
types and shouldn't.)
(PROG (SIZE GLINELT TYPE BRUSH NEWBRUSH NEWELT)
(COND
((MEMB (SETQ TYPE (fetch (GLOBALPART GTYPE) of ELTWITHLINE))
(QUOTE (WIRE BOX CLOSEDWIRE CLOSEDCURVE OPENCURVE CIRCLE ELLIPSE TEXTBOX ARC)))
(SETQ GLINELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHLINE))
(SETQ BRUSH (SELECTQ TYPE
(CIRCLE (fetch (CIRCLE BRUSH) of GLINELT))
(ELLIPSE (fetch (ELLIPSE BRUSH) of GLINELT))
(TEXTBOX (fetch (TEXTBOX TEXTBOXBRUSH) of GLINELT))
(CLOSEDCURVE (fetch (CLOSEDCURVE BRUSH) of GLINELT))
(BOX (fetch (BOX BRUSH) of GLINELT))
(ARC (fetch (ARC ARCBRUSH) of GLINELT))
(fetch (OPENCURVE BRUSH) of GLINELT)))
(* the change to the brush size must take into account
the current scale and the scale at which the brush was
entered.)
(COND
((GEQ [SETQ SIZE (COND
((NUMBERP HOW)
HOW)
(T (SELECTQ HOW
(SMALLER (FQUOTIENT (fetch (BRUSH BRUSHSIZE) of BRUSH)
2.0))
(FTIMES (fetch (BRUSH BRUSHSIZE) of BRUSH)
2.0]
0) (* don't let the brush size go negative.)
(SETQ NEWBRUSH (create BRUSH using BRUSH BRUSHSIZE ← SIZE))
(SETQ NEWELT (SELECTQ TYPE
(WIRE (create WIRE using GLINELT BRUSH ← NEWBRUSH))
(BOX (create BOX using GLINELT BRUSH ← NEWBRUSH))
(ARC (create ARC using GLINELT ARCBRUSH ← NEWBRUSH))
(TEXTBOX (* since this may change the location of characters in
the box, clear the selection.
Probably should happen somewhere else.)
(SKED.CLEAR.SELECTION SKW)
(create TEXTBOX using GLINELT TEXTBOXBRUSH ←
NEWBRUSH))
(CLOSEDWIRE (create CLOSEDWIRE using GLINELT BRUSH ← NEWBRUSH)
)
(CLOSEDCURVE (create CLOSEDCURVE using GLINELT BRUSH ←
NEWBRUSH))
(OPENCURVE (create OPENCURVE using GLINELT BRUSH ← NEWBRUSH))
(CIRCLE (create CIRCLE using GLINELT BRUSH ← NEWBRUSH))
(ELLIPSE (create ELLIPSE using GLINELT BRUSH ← NEWBRUSH))
(SHOULDNT)))
(RETURN (create GLOBALPART
COMMONGLOBALPART ←(fetch (GLOBALPART COMMONGLOBALPART)
of ELTWITHLINE)
INDIVIDUALGLOBALPART ← NEWELT])
(SK.CHANGE.ANGLE
[LAMBDA (ELTWITHARC HOW SKW) (* rrb "31-May-85 17:17")
(* changes the arc size of ELTWITHARC if it is an arc
element)
(PROG (GARCLT ARMANGLE RADIUS CENTERPT RADIUSPT CENTERX CENTERY)
(COND
((EQ (fetch (GLOBALPART GTYPE) of ELTWITHARC)
(QUOTE ARC)) (* only works for things of arc type.)
(SETQ GARCLT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHARC))
(SETQ CENTERPT (fetch (ARC ARCCENTERPT) of GARCLT))
(SETQ CENTERX (fetch (POSITION XCOORD) of CENTERPT))
(SETQ CENTERY (fetch (POSITION YCOORD) of CENTERPT))
(SETQ RADIUSPT (fetch (ARC ARCRADIUSPT) of GARCLT))
[SETQ ARMANGLE (COND
((fetch (ARC ARCDIRECTION) of GARCLT) (* clockwise direction)
(DIFFERENCE (SK.COMPUTE.SLOPE.OF.LINE CENTERPT RADIUSPT)
HOW))
(T (* positive direction)
(PLUS (SK.COMPUTE.SLOPE.OF.LINE CENTERPT RADIUSPT)
HOW]
(SETQ RADIUS (DISTANCEBETWEEN CENTERPT RADIUSPT))
(* calculate a position on the circle the right number
of degrees out.)
(RETURN (create GLOBALPART
COMMONGLOBALPART ←(fetch (GLOBALPART COMMONGLOBALPART) of ELTWITHARC)
INDIVIDUALGLOBALPART ←(create ARC
using
GARCLT ARCANGLEPT ←(create
POSITION
XCOORD ←[FIXR (PLUS CENTERX
(TIMES RADIUS
(COS ARMANGLE]
YCOORD ←(FIXR (PLUS CENTERY
(TIMES RADIUS
(SIN ARMANGLE])
(SK.CHANGE.ARC.DIRECTION
[LAMBDA (ELTWITHARC HOW SKW) (* rrb "31-May-85 16:57")
(* changes the direction around the circle that the arc
element goes.)
(PROG (GARCLT NOWDIRECTION)
(COND
((EQ (fetch (GLOBALPART GTYPE) of ELTWITHARC)
(QUOTE ARC)) (* only works for things of arc type.)
(SETQ GARCLT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHARC))
(SETQ NOWDIRECTION (fetch (ARC ARCDIRECTION) of GARCLT))
(COND
((OR (AND (EQ HOW (QUOTE CLOCKWISE))
(NULL NOWDIRECTION))
(AND (EQ HOW (QUOTE COUNTERCLOCKWISE))
NOWDIRECTION)) (* spec calls for one direction and it is currently
going the other.)
(RETURN (create GLOBALPART
COMMONGLOBALPART ←(fetch (GLOBALPART COMMONGLOBALPART)
of ELTWITHARC)
INDIVIDUALGLOBALPART ←(create ARC using GARCLT ARCDIRECTION ←(NOT
NOWDIRECTION])
(SK.SET.DEFAULT.BRUSH.SIZE
[LAMBDA (NEWBRUSHSIZE SKW) (* rrb "12-Jan-85 10:13")
(* sets the default brush size to NEWBRUSHSIZE)
(AND (NUMBERP NEWBRUSHSIZE)
(replace (SKETCHCONTEXT SKETCHBRUSH) of (WINDOWPROP SKW (QUOTE SKETCHCONTEXT))
with (create BRUSH using (fetch (SKETCHCONTEXT SKETCHBRUSH) of (WINDOWPROP SKW
(QUOTE
SKETCHCONTEXT)))
BRUSHSIZE ← NEWBRUSHSIZE])
(READSIZECHANGE
[LAMBDA (MENUTITLE ALLOWZEROFLG) (* rrb " 3-Oct-85 14:40")
(* interacts to get whether a line size should be
increased or decreased.)
(PROG [(NEWVALUE (MENU (create MENU
TITLE ← MENUTITLE
ITEMS ←(QUOTE (("smaller line" (QUOTE SMALLER)
"decreases the line thickness by 1.")
("LARGER LINE" (QUOTE LARGER)
"increases the line thickness by 1.")
("Set line size" (QUOTE SETSIZE)
"sets the line thickness to an entered value.")))
CENTERFLG ← T]
(RETURN (COND
((EQ NEWVALUE (QUOTE SETSIZE))
(SETQ NEWVALUE (RNUMBER "Enter the new line thickness." NIL NIL NIL T T)
)
(COND
((AND (NULL ALLOWZEROFLG)
(EQ NEWVALUE 0))
NIL)
(T NEWVALUE)))
(T NEWVALUE])
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(TYPERECORD KNOTELT (LATLONKNOTS BRUSH DASHING KNOTINITSCALE))
(RECORD LOCALCURVE (KNOTS ARROWHEADPTS LOCALCURVEBRUSH))
(TYPERECORD OPENCURVE (LATLONKNOTS BRUSH DASHING CURVEARROWHEADS OPENCURVEINITSCALE))
(TYPERECORD CLOSEDCURVE (LATLONKNOTS BRUSH DASHING CLOSEDCURVEINITSCALE))
(RECORD LOCALKNOTS (HOTSPOTS LOCALKNOTSBRUSH))
]
)
(READVARS OPENCURVEICON CLOSEDCURVEICON)
({(READBITMAP)(20 12
"@@@@@@@@"
"@L@@@@@@"
"@L@@F@@@"
"AL@@O@@@"
"AH@@G@@@"
"CH@@C@@@"
"CH@@C@@@"
"CH@@G@@@"
"AN@@N@@@"
"@OCLN@@@"
"@COOL@@@"
"@@NCH@@@")} {(READBITMAP)(20 12
"@@C@@@@@"
"ALGO@@@@"
"CNLOL@@@"
"GCLAN@@@"
"FAAHF@@@"
"L@CLC@@@"
"N@CFC@@@"
"F@FFG@@@"
"C@FGF@@@"
"CLFCL@@@"
"AON@H@@@"
"@GL@@@@@")})
(RPAQ CURVE.KNOT (CURSORCREATE (READBITMAP) 8 8))
(16 16
"@GN@"
"AOOH"
"CLCL"
"G@@N"
"FDBF"
"NJEG"
"LEJC"
"LBDC"
"LBDC"
"LEJC"
"NJEG"
"FDBF"
"G@@N"
"CLCL"
"AOOH"
"@GN@")(DEFINEQ
(KNOTS.EXPANDFN
[LAMBDA (GELT SCALE) (* rrb "27-Apr-85 21:03")
(* returns a local record which has the LATLONKNOTS
field of the global element GELT translated into window
coordinats. Used for closed wires.)
(PROG ((INDVKNOTELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))
BRSH)
[COND
((fetch (CLOSEDWIRE CLOSEDWIREINITSCALE) of INDVKNOTELT))
(T (* old format didn't have an initial scale, default it
to 1.0)
(replace (GLOBALPART INDIVIDUALGLOBALPART) of GELT
with (SETQ INDVKNOTELT (create CLOSEDWIRE using INDVKNOTELT CLOSEDWIREINITSCALE ←
1.0]
(RETURN (create SCREENELT
LOCALPART ←(create LOCALKNOTS
HOTSPOTS ←(for LATLONPT in (fetch LATLONKNOTS
of INDVKNOTELT)
collect (SK.SCALE.POSITION.INTO.VIEWER
LATLONPT SCALE))
LOCALKNOTSBRUSH ←(SCALE.BRUSH
(COND
([NOT (NUMBERP (SETQ BRSH (fetch (CLOSEDWIRE BRUSH)
of INDVKNOTELT]
(* new format, old format had brush width only.)
BRSH)
(T [replace (CLOSEDWIRE BRUSH) of INDVKNOTELT
with (SETQ BRSH
(create BRUSH
BRUSHSIZE ← BRSH
BRUSHSHAPE ←(QUOTE ROUND]
BRSH))
(fetch (CLOSEDWIRE CLOSEDWIREINITSCALE) of INDVKNOTELT)
SCALE))
GLOBALPART ← GELT])
(OPEN.WIRE.DRAWFN
[LAMBDA (OPENWIREELT WIN REG OPERATION) (* rrb "27-Apr-85 21:19")
(* draws an open wire element.)
(WB.DRAWLINE OPENWIREELT WIN REG OPERATION NIL (fetch (WIRE OPENWIREDASHING)
of (fetch (SCREENELT INDIVIDUALGLOBALPART)
of OPENWIREELT))
(fetch (LOCALWIRE LOCALOPENWIREBRUSH) of (fetch (SCREENELT LOCALPART) of OPENWIREELT]
)
(OPEN.KNOTS.EXPANDFN
[LAMBDA (GELT SCALE) (* rrb " 2-Jun-85 12:01")
(* returns a local record which has the LATLONKNOTS
field of the global element GELT translated into window
coordinats. Used for wires.)
(PROG ((INDGELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))
TMP)
[COND
((fetch (WIRE OPENWIREINITSCALE) of INDGELT))
(T (* old format didn't have an initial scale, default it
to 1.0)
(replace (GLOBALPART INDIVIDUALGLOBALPART) of GELT
with (SETQ INDGELT (create WIRE using INDGELT OPENWIREINITSCALE ← 1.0]
(RETURN (create SCREENELT
LOCALPART ←(create LOCALCURVE
KNOTS ←(SETQ TMP (for LATLONPT
in (fetch (WIRE LATLONKNOTS)
of INDGELT)
collect (
SK.SCALE.POSITION.INTO.VIEWER LATLONPT SCALE)))
ARROWHEADPTS ←(SK.EXPAND.ARROWHEADS INDGELT TMP SCALE)
LOCALCURVEBRUSH ←(SCALE.BRUSH
(COND
([NOT (NUMBERP (SETQ TMP (fetch (WIRE BRUSH)
of INDGELT]
(* new format, old format had brush width only.)
TMP)
(T [replace (WIRE BRUSH) of INDGELT
with (SETQ TMP
(create BRUSH
BRUSHSIZE ← TMP
BRUSHSHAPE ←(QUOTE ROUND]
TMP))
(fetch (WIRE OPENWIREINITSCALE) of INDGELT)
SCALE))
GLOBALPART ← GELT])
(OPENWIRE.READCHANGEFN
[LAMBDA (SKW WIREELTS) (* rrb "12-Jul-85 10:08")
(* * change function for line elements.)
(PROG (ASPECT HOW)
(SETQ HOW (SELECTQ [SETQ ASPECT (MENU (create MENU
CENTERFLG ← T
TITLE ← "Which aspect?"
ITEMS ←(APPEND
(COND
[(SKETCHINCOLORP)
(QUOTE (("Brush color" (QUOTE
BRUSHCOLOR)
"changes the color of the outline"]
(T NIL))
(QUOTE ((Arrowheads (QUOTE ARROW)
"allows changing of arrow head characteristics.")
(Size (QUOTE SIZE)
"changes the size of the brush")
(Dashing (QUOTE DASHING)
"changes the dashing of the line."]
(SIZE (READSIZECHANGE "Change size how?"))
(ARROW (READ.ARROW.CHANGE))
(DASHING (READ.DASHING.CHANGE))
(BRUSHCOLOR (READ.COLOR.CHANGE "Change line color how?"))
NIL))
(RETURN (AND HOW (LIST ASPECT HOW])
(OPENWIRE.TRANSFORMFN
[LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "26-Sep-85 12:10")
(* returns a copy of the global WIRE element that has had each of its control points transformed by transformfn.
TRANSFORMDATA is arbitrary data that is passed to tranformfn.)
(PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)))
(RETURN (KNOT.SET.SCALE.FIELD (create GLOBALPART using GELT INDIVIDUALGLOBALPART ←
(create WIRE
using INDVPART LATLONKNOTS ←
(SK.TRANSFORM.POINT.LIST
(fetch (WIRE LATLONKNOTS)
of INDVPART)
TRANSFORMFN TRANSFORMDATA)
BRUSH ←
(SK.TRANSFORM.BRUSH
(fetch (WIRE BRUSH)
of INDVPART)
SCALEFACTOR)
WIREARROWHEADS ←
(SK.TRANSFORM.ARROWHEADS
(fetch (WIRE
WIREARROWHEADS)
of INDVPART)
SCALEFACTOR])
(OPENWIRE.TRANSLATEPTSFN
[LAMBDA (KNOTELT SELPTS GDELTA WINDOW) (* rrb "26-Sep-85 17:45")
(* returns an open wire element which has the knots
that are members of SELPTS translated by the global
amount GDELTA.)
(PROG ((GKNOTELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of KNOTELT)))
(RETURN (SK.WIRE.CREATE (for PT in (fetch (LOCALWIRE KNOTS) of (fetch (SCREENELT LOCALPART)
of KNOTELT))
as LATLONPT in (fetch (WIRE LATLONKNOTS) of GKNOTELT)
collect (COND
((MEMBER PT SELPTS)
(PTPLUS LATLONPT GDELTA))
(T LATLONPT)))
(fetch (WIRE BRUSH) of GKNOTELT)
(fetch (WIRE OPENWIREDASHING) of GKNOTELT)
NIL
(fetch (WIRE OPENWIREINITSCALE) of GKNOTELT)
(fetch (WIRE WIREARROWHEADS) of GKNOTELT])
(SK.EXPAND.ARROWHEADS
[LAMBDA (GELT LOCALKNOTS SCALE) (* rrb "11-Sep-85 14:17")
(* returns a list of local from the list of local knots
and the individual part of the global element.)
(PROG (ARROWSPEC TYPE SPEC)
(OR (SETQ ARROWSPEC (SELECTQ (SETQ TYPE (fetch (INDIVIDUALGLOBALPART GTYPE) of GELT))
(WIRE (fetch (WIRE WIREARROWHEADS) of GELT))
(ARC (fetch (ARC ARCARROWHEADS) of GELT))
(OPENCURVE (fetch (OPENCURVE CURVEARROWHEADS) of GELT))
NIL))
(RETURN NIL))
(* new format that keeps arrow specs as (FIRST LAST T). This works for transformations while the old format doesn't.
old format that kept arrow specs as (LEFT RIGHT). It was changed 24/4/85 and happens upon reading in of a sketch.)
(RETURN (LIST (AND (SETQ SPEC (CAR ARROWSPEC))
(SELECTQ TYPE
(WIRE (WIRE.ARROWHEAD.POINTS LOCALKNOTS T (fetch (ARROWHEAD
ARROWANGLE)
of SPEC)
(QUOTIENT (fetch (ARROWHEAD
ARROWLENGTH)
of SPEC)
SCALE)))
((ARC OPENCURVE)
(CURVE.ARROWHEAD.POINTS LOCALKNOTS T (fetch (ARROWHEAD
ARROWANGLE)
of SPEC)
(QUOTIENT (fetch (ARROWHEAD
ARROWLENGTH)
of SPEC)
SCALE)))
(RETURN NIL)))
(AND (SETQ SPEC (CADR ARROWSPEC))
(SELECTQ TYPE
(WIRE (WIRE.ARROWHEAD.POINTS LOCALKNOTS NIL
(fetch (ARROWHEAD ARROWANGLE)
of SPEC)
(QUOTIENT (fetch (ARROWHEAD
ARROWLENGTH)
of SPEC)
SCALE)))
((ARC OPENCURVE)
(CURVE.ARROWHEAD.POINTS LOCALKNOTS NIL (fetch (ARROWHEAD
ARROWANGLE)
of SPEC)
(QUOTIENT (fetch (ARROWHEAD
ARROWLENGTH)
of SPEC)
SCALE)))
(RETURN NIL])
(WIRE.INPUTFN
[LAMBDA (W GPTLIST CLOSEDFLG BRUSH DEFSCALE DASHING FILLING)
(* rrb "26-Sep-85 17:49")
(* creates a wire {a series of straight lines through a list of points} from a list of points passed in or a list
that is read from the user via mouse.)
(PROG ((SKCONTEXT (WINDOWPROP W (QUOTE SKETCHCONTEXT)))
KNOTS)
(RETURN (SK.WIRE.CREATE [SETQ KNOTS (OR GPTLIST (for PT in (READ.LIST.OF.POINTS W)
collect (SK.MAP.INPUT.PT.TO.GLOBAL
PT W]
(COND
((NUMBERP BRUSH) (* called with a number from the sketch stream drawline
operation. Make it a round brush.)
(create BRUSH
BRUSHSIZE ← BRUSH
BRUSHSHAPE ← (QUOTE ROUND)))
(T (fetch (SKETCHCONTEXT SKETCHBRUSH) of SKCONTEXT)))
(OR (DASHINGP DASHING)
(fetch (SKETCHCONTEXT SKETCHDASHING) of SKCONTEXT))
CLOSEDFLG
(OR (NUMBERP DEFSCALE)
(SK.INPUT.SCALE W))
(SK.ARROWHEAD.CREATE W KNOTS)
FILLING])
(CLOSEDWIRE.REGIONFN
[LAMBDA (KNOTSCRELT) (* rrb " 2-Jun-85 17:15")
(* returns the region occuppied by a closed wire)
(* increase by half the brush size plus 2 This has the nice property of insuring that the region always has both
height and width.)
(INCREASEREGION (REGION.CONTAINING.PTS (fetch (SCREENELT HOTSPOTS) of KNOTSCRELT))
(IPLUS 3 (QUOTIENT (fetch (BRUSH BRUSHSIZE) of (fetch (LOCALCLOSEDWIRE
LOCALCLOSEDWIREBRUSH)
of (fetch (SCREENELT LOCALPART)
of KNOTSCRELT)))
2])
(SK.WIRE.CREATE
[LAMBDA (KNOTS BRUSH DASHING CLOSED SCALE ARROWHEADS FILLING)
(* rrb "26-Sep-85 17:50")
(* creates a wire sketch element.)
(AND KNOTS
(KNOT.SET.SCALE.FIELD (create GLOBALPART
INDIVIDUALGLOBALPART ←
(COND
(CLOSED (create CLOSEDWIRE
LATLONKNOTS ← KNOTS
BRUSH ← BRUSH
CLOSEDWIREDASHING ← DASHING
CLOSEDWIREINITSCALE ← SCALE
CLOSEDWIREFILLING ← FILLING))
(T (create WIRE
LATLONKNOTS ← KNOTS
BRUSH ← BRUSH
WIREARROWHEADS ← ARROWHEADS
OPENWIREDASHING ← DASHING
OPENWIREINITSCALE ← SCALE])
(WIRE.ADD.POINT.TO.END
[LAMBDA (WIREELT PT SKW) (* rrb "11-Jul-85 11:26")
(* adds a point onto the end of a wire element.)
(PROG ((NEWPOS (SK.MAP.INPUT.PT.TO.GLOBAL PT SKW))
KNOTS GWIREELT)
(SETQ GWIREELT (fetch (SCREENELT GLOBALPART) of WIREELT))
(SETQ KNOTS (fetch LATLONKNOTS of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GWIREELT)))
(RETURN (COND
((EQUAL NEWPOS (CAR (LAST KNOTS))) (* don't add duplicate points)
WIREELT)
(T (* add point at the end.)
(SK.UPDATE.ELEMENT GWIREELT (WIRE.INPUTFN SKW (APPEND KNOTS (CONS NEWPOS))
NIL)
SKW])
(READ.ARROW.CHANGE
[LAMBDA NIL
(DECLARE (GLOBALVARS SK.ARROW.END.MENU SK.ARROW.EDIT.MENU))
(* rrb "26-Jun-85 09:46")
(* gets a description of how to change the arrow heads
of a wire or curve.)
(PROG (WHICHEND ANGLECHANGE LENGTHCHANGE TYPECHANGE)
(RETURN (LIST (OR (READ.ARROWHEAD.END)
(RETURN))
(OR [MENU (COND
((type? MENU SK.ARROW.EDIT.MENU)
SK.ARROW.EDIT.MENU)
(T (SETQ SK.ARROW.EDIT.MENU (create MENU
TITLE ← "specify change"
ITEMS ←(QUOTE
((Add% Arrow (QUOTE ADD)
"Adds an arrow head.")
("Remove Arrow"
(QUOTE DELETE)
"Removes the arrow head.")
(Wider (QUOTE WIDER)
"Makes the angle of the head wider.")
(Narrower (QUOTE NARROWER)
"Makes the angle of the head smaller.")
(Larger (QUOTE LARGER)
"Makes the arrow head larger.")
(Smaller (QUOTE SMALLER)
"Makes the arrow head smaller.")
(V% shape (QUOTE OPEN)
"Makes the head be the side lines only.")
(Triangle (QUOTE CLOSED)
"Makes the head be two sides and a base.")))
CENTERFLG ← T]
(RETURN])
(CHANGE.ELTS.ARROWHEADS
[LAMBDA (CHANGESPEC ELTSWITHARROWS SKW) (* rrb "10-Jan-85 16:58")
(* * function that changes the arrow characteristics for all elements in ELTSWITHARROWS that can have arrows.)
(AND CHANGESPEC (for ARROWELT in ELTSWITHARROWS collect (SK.CHANGE.ARROWHEADS ARROWELT CHANGESPEC
SKW])
)
(DEFINEQ
(CLOSED.WIRE.INPUTFN
[LAMBDA (W PTLIST) (* rrb "13-Dec-84 10:10")
(* creates a closed wire {a series of straight lines through a list of points} from a list of points passed in or a
list that is read from the user via mouse.)
(WIRE.INPUTFN W PTLIST T])
(CLOSED.WIRE.DRAWFN
[LAMBDA (CLOSEDWIREELT WIN REG OPERATION) (* rrb "27-Sep-85 18:52")
(* draws a closed wire element.)
(PROG ((GINDVELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of CLOSEDWIREELT))
(LOCALPART (fetch (SCREENELT LOCALPART) of CLOSEDWIREELT))
VARX)
(AND (SETQ VARX (fetch (SKFILLING FILLING.TEXTURE) of (fetch (CLOSEDWIRE CLOSEDWIREFILLING)
of GINDVELT)))
(FILLPOLYGON (fetch (LOCALCLOSEDWIRE KNOTS) of LOCALPART)
VARX WIN))
(OR (EQ (fetch (BRUSH BRUSHSIZE) of (SETQ VARX (fetch (LOCALCLOSEDWIRE LOCALCLOSEDWIREBRUSH)
of LOCALPART)))
0)
(WB.DRAWLINE CLOSEDWIREELT WIN REG OPERATION T (fetch (CLOSEDWIRE CLOSEDWIREDASHING)
of GINDVELT)
VARX])
(CLOSEDWIRE.READCHANGEFN
[LAMBDA (SKW SCRNELTS) (* rrb " 8-Aug-85 21:12")
(* the users has selected SCRNELT to be changed this
function reads a specification of how the closed wire
elements should change.)
(PROG (ASPECT HOW)
(SETQ HOW (SELECTQ [SETQ ASPECT (MENU (create MENU
CENTERFLG ← T
TITLE ← "Which aspect?"
ITEMS ←(APPEND
(COND
[(SKETCHINCOLORP)
(QUOTE (("Brush color" (QUOTE
BRUSHCOLOR)
"changes the color of the outline")
("Filling color" (QUOTE
FILLINGCOLOR)
"changes the color of the filling"]
(T NIL))
[COND
(FILLPOLYGONFLG
(QUOTE ((Filling (QUOTE FILLING)
"allows changing of the filling texture of the box."]
(QUOTE ((Shape (QUOTE SHAPE)
"changes the shape of the brush")
(Size (QUOTE SIZE)
"changes the size of the brush")
(Dashing (QUOTE DASHING)
"changes the dashing of the line."]
(SIZE (READSIZECHANGE "Change size how?" T))
(FILLING (READ.FILLING.CHANGE))
(DASHING (READ.DASHING.CHANGE))
(SHAPE (READBRUSHSHAPE))
(BRUSHCOLOR (READ.COLOR.CHANGE "Change outline color how?"))
(FILLINGCOLOR (READ.COLOR.CHANGE "Change filling color how?" T))
NIL))
(RETURN (AND HOW (LIST ASPECT HOW])
(CLOSEDWIRE.TRANSFORMFN
[LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "26-Apr-85 16:41")
(* returns a copy of the global CLOSEDWIRE element that has had each of its control points transformed by
transformfn. TRANSFORMDATA is arbitrary data that is passed to tranformfn.)
(PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)))
(RETURN (KNOT.SET.SCALE.FIELD (create GLOBALPART using GELT INDIVIDUALGLOBALPART ←(create
CLOSEDWIRE
using
INDVPART
LATLONKNOTS ←(
SK.TRANSFORM.POINT.LIST
(
fetch (CLOSEDWIRE LATLONKNOTS) of INDVPART)
TRANSFORMFN
TRANSFORMDATA)
BRUSH
←(
SK.TRANSFORM.BRUSH
(
fetch (CLOSEDWIRE BRUSH) of INDVPART)
SCALEFACTOR])
(CLOSEDWIRE.TRANSLATEPTSFN
[LAMBDA (KNOTELT SELPTS GDELTA WINDOW) (* rrb "27-Sep-85 18:58")
(* returns a closed wire element which has the knots
that are members of SELPTS translated by the global
amount GDELTA.)
(PROG ((GKNOTELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of KNOTELT)))
(RETURN (SK.WIRE.CREATE (for PT in (fetch (LOCALCLOSEDWIRE KNOTS)
of (fetch (SCREENELT LOCALPART) of KNOTELT))
as LATLONPT in (fetch (CLOSEDWIRE LATLONKNOTS) of GKNOTELT)
collect (COND
((MEMBER PT SELPTS)
(PTPLUS LATLONPT GDELTA))
(T LATLONPT)))
(fetch (CLOSEDWIRE BRUSH) of GKNOTELT)
(fetch (CLOSEDWIRE CLOSEDWIREDASHING) of GKNOTELT)
T
(fetch (CLOSEDWIRE CLOSEDWIREINITSCALE) of GKNOTELT)
NIL
(fetch (CLOSEDWIRE CLOSEDWIREFILLING) of GKNOTELT])
)
(DEFINEQ
(CHANGED.ARROW
[LAMBDA (ARROW HOWTOCHANGE SCALE DEFARROW) (* rrb " 5-May-85 17:39")
(* * returns an arrow that has been changed according to the spec HOWTOCHANGE.)
(COND
((EQ HOWTOCHANGE (QUOTE ADD)) (* if there already is one, leave it alone.)
(OR ARROW (SK.CREATE.ARROWHEAD DEFARROW SCALE)))
((OR (EQ HOWTOCHANGE (QUOTE DELETE))
(NULL ARROW))
NIL)
(T (SELECTQ HOWTOCHANGE
[WIDER (create ARROWHEAD using ARROW ARROWANGLE ←(PLUS SK.ARROWHEAD.ANGLE.INCREMENT
(fetch (ARROWHEAD ARROWANGLE)
of ARROW]
(NARROWER (create ARROWHEAD using ARROW ARROWANGLE ←(DIFFERENCE
(fetch (ARROWHEAD ARROWANGLE) of ARROW)
SK.ARROWHEAD.ANGLE.INCREMENT)))
[LARGER (create ARROWHEAD using ARROW ARROWLENGTH ←(PLUS (TIMES
SK.ARROWHEAD.LENGTH.INCREMENT
SCALE)
(fetch (ARROWHEAD
ARROWLENGTH)
of ARROW]
(SMALLER (create ARROWHEAD using ARROW ARROWLENGTH ←(MAX
(DIFFERENCE (fetch (ARROWHEAD ARROWLENGTH)
of ARROW)
(TIMES SK.ARROWHEAD.LENGTH.INCREMENT
SCALE))
SCALE)))
(OPEN (create ARROWHEAD using ARROW ARROWTYPE ←(QUOTE LINE)))
(CLOSED (create ARROWHEAD using ARROW ARROWTYPE ←(QUOTE CLOSEDLINE)))
ARROW])
(SK.CHANGE.ARROWHEAD
[LAMBDA (ARROWELT HOW SKW) (* rrb "11-Jan-85 16:46")
(* changes the arrow heads of an element and returns
the new element if any actually occurred.)
(SK.CHANGE.ARROWHEAD1 ARROWELT (CAR HOW)
(CADR HOW)
(WINDOW.SCALE SKW)
(fetch (SKETCHCONTEXT SKETCHARROWHEAD) of (WINDOWPROP SKW (QUOTE
SKETCHCONTEXT])
(SK.CHANGE.ARROWHEAD1
[LAMBDA (GARROWELT WHICHEND HOWTOCHANGE SCALE DEFAULTARROWHEAD)
(* rrb " 2-Jun-85 11:54")
(PROG (INDGARROWELT NEWARROWS NOWARROWS CHANGEDFLG TYPE KNOTS)
(RETURN (COND
((MEMB (SETQ TYPE (fetch (GLOBALPART GTYPE) of GARROWELT))
(QUOTE (WIRE OPENCURVE ARC))) (* only works for things of wire type.)
(SETQ INDGARROWELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GARROWELT))
[SETQ NOWARROWS (OR (SELECTQ TYPE
(OPENCURVE (fetch (OPENCURVE CURVEARROWHEADS)
of INDGARROWELT))
(ARC (fetch (ARC ARCARROWHEADS) of INDGARROWELT))
(fetch (WIRE WIREARROWHEADS) of INDGARROWELT))
(QUOTE (NIL NIL T]
(SETQ KNOTS (SELECTQ TYPE
(ARC (* calculate the knots for the left most test)
(LIST (fetch (ARC ARCRADIUSPT) of INDGARROWELT)
(fetch (ARC ARCANGLEPT) of INDGARROWELT)))
(fetch LATLONKNOTS of INDGARROWELT)))
(* the brush is stored in the same place for all
element types.)
(SETQ NEWARROWS (bind NEWARROW for ARROW in NOWARROWS as END
in (QUOTE (FIRST LAST))
collect (SETQ NEWARROW (COND
((SK.ARROWHEAD.END.TEST WHICHEND END KNOTS)
(* change the spec)
(CHANGED.ARROW ARROW HOWTOCHANGE SCALE
DEFAULTARROWHEAD))
(T ARROW)))
(COND
((NOT (EQUAL NEWARROW ARROW))
(* keep track of whether or not any arrow was changed.)
(SETQ CHANGEDFLG T)))
NEWARROW))
(AND CHANGEDFLG (create GLOBALPART
COMMONGLOBALPART ←(fetch (GLOBALPART COMMONGLOBALPART)
of GARROWELT)
INDIVIDUALGLOBALPART ←(SELECTQ TYPE
(WIRE (create WIRE
using
INDGARROWELT
WIREARROWHEADS ←
NEWARROWS))
(ARC (create ARC
using
INDGARROWELT
ARCARROWHEADS ←
NEWARROWS))
(OPENCURVE (create
OPENCURVE
using
INDGARROWELT
CURVEARROWHEADS ←
NEWARROWS))
(SHOULDNT])
(SK.CREATE.ARROWHEAD
[LAMBDA (DEFAULTARROWHEAD SCALE) (* rrb " 5-May-85 17:39")
(* creates a new arrowhead which is the default
DEFAULTARROWHEAD scaled to SCALE.)
(create ARROWHEAD using DEFAULTARROWHEAD ARROWLENGTH ←(TIMES (fetch (ARROWHEAD ARROWLENGTH)
of DEFAULTARROWHEAD)
SCALE])
(SK.ARROWHEAD.CREATE
[LAMBDA (SKW KNOTS) (* rrb "30-May-85 11:21")
(* creates the arrowhead specs that go with a global
element from the current context.)
(PROG ((SKCONTEXT (WINDOWPROP SKW (QUOTE SKETCHCONTEXT)))
ARROWHEADWHERE)
(SETQ ARROWHEADWHERE (fetch (SKETCHCONTEXT SKETCHUSEARROWHEAD) of SKCONTEXT))
(RETURN (COND
([NOT (MEMB ARROWHEADWHERE (QUOTE (NIL NEITHER]
(* compute the arrowheads)
(* T is indicator of new format.)
(NCONC1 [for END in (QUOTE (FIRST LAST)) collect
(COND
((SK.ARROWHEAD.END.TEST
ARROWHEADWHERE END
KNOTS)
(* change the spec)
(SK.CREATE.ARROWHEAD
(fetch (SKETCHCONTEXT
SKETCHARROWHEAD)
of SKCONTEXT)
(WINDOW.SCALE SKW]
T])
(SK.ARROWHEAD.END.TEST
[LAMBDA (WHICHENDS END KNOTS) (* rrb " 5-May-85 17:36")
(* predicate which determines it END which is one of FIRST or LAST matches with WHICHENDS which is one of
(FIRST LAST BOTH RIGHT LEFT) on the series of points KNOTS.)
(OR (EQ WHICHENDS END)
(SELECTQ WHICHENDS
(BOTH T)
[LEFT (* determine if the specified end is END)
(COND
((LEFT.MOST.IS.BEGINP KNOTS)
(EQ END (QUOTE FIRST)))
((EQ END (QUOTE LAST]
[RIGHT (COND
((LEFT.MOST.IS.BEGINP KNOTS)
(EQ END (QUOTE LAST)))
((EQ END (QUOTE FIRST]
NIL])
(READ.ARROWHEAD.END
[LAMBDA NIL (* rrb " 2-Jan-85 11:13")
(* reads a specification of which end of a line or
curve to put an arrowhead on.)
(MENU (COND
((type? MENU SK.ARROW.END.MENU)
SK.ARROW.END.MENU)
(T (SETQ SK.ARROW.END.MENU (create MENU
TITLE ← "Which end?"
ITEMS ←(QUOTE ((Left% % % % % (QUOTE LEFT)
"changes will affect the left (or upper) end of the line.")
(% % % % Right (QUOTE RIGHT)
"changes will affect the right (or lower) end of the line.")
(Both (QUOTE BOTH)
"changes will affect both ends of the line.")
(First (QUOTE FIRST)
"changes will affect the end whose point was placed first.")
(Last (QUOTE LAST)
"changes will affect the end placed last.")))
CENTERFLG ← T])
(ARROW.HEAD.POSITIONS
[LAMBDA (TAIL.POSITION HEAD.POSITION HEAD.ANGLE HEAD.LENGTH)
(* edited: "16-MAR-83 11:56")
(PROG (X0 Y0 X1 Y1 DX DY COS.THETA LL SIN.THETA COS.RHO SIN.RHO XP1 YP1 XP2 YP2)
(SETQ X0 (fetch (POSITION XCOORD) of TAIL.POSITION))
(SETQ Y0 (fetch (POSITION YCOORD) of TAIL.POSITION))
(SETQ X1 (fetch (POSITION XCOORD) of HEAD.POSITION))
(SETQ Y1 (fetch (POSITION YCOORD) of HEAD.POSITION))
(SETQ DX (IDIFFERENCE X1 X0))
(SETQ DY (IDIFFERENCE Y1 Y0))
[SETQ LL (SQRT (PLUS (TIMES DX DX)
(TIMES DY DY]
(SETQ COS.RHO (QUOTIENT DX LL))
(SETQ SIN.RHO (QUOTIENT DY LL))
(SETQ COS.THETA (COS HEAD.ANGLE))
(SETQ SIN.THETA (SIN HEAD.ANGLE))
[SETQ XP1 (TIMES HEAD.LENGTH (DIFFERENCE (TIMES COS.RHO COS.THETA)
(TIMES SIN.RHO SIN.THETA]
[SETQ YP1 (TIMES HEAD.LENGTH (PLUS (TIMES SIN.RHO COS.THETA)
(TIMES SIN.THETA COS.RHO]
[SETQ XP2 (TIMES HEAD.LENGTH (PLUS (TIMES COS.RHO COS.THETA)
(TIMES SIN.RHO SIN.THETA]
[SETQ YP2 (TIMES HEAD.LENGTH (DIFFERENCE (TIMES SIN.RHO COS.THETA)
(TIMES SIN.THETA COS.RHO]
(RETURN (CONS (create POSITION
XCOORD ←(IDIFFERENCE X1 (FIX XP1))
YCOORD ←(IDIFFERENCE Y1 (FIX YP1)))
(create POSITION
XCOORD ←(IDIFFERENCE X1 (FIX XP2))
YCOORD ←(IDIFFERENCE Y1 (FIX YP2])
(ARROWHEAD.POINTS.LIST
[LAMBDA (HEAD.POSITION HEAD.ANGLE HEAD.LENGTH DX DY) (* rrb " 2-Jun-85 11:37")
(* * returns a list of end points for an arrowhead ending on HEAD.POSITION with a slope of DX DY with an angle of
HEAD.ANGLE and a length of HEAD.LENGTH The result is a list of (HEADPT ONESIDEENDPT OTHERSIDEENDPT) of points)
(PROG (X1 Y1 COS.THETA LL SIN.THETA COS.RHO SIN.RHO XP1 YP1 XP2 YP2)
(SETQ X1 (fetch (POSITION XCOORD) of HEAD.POSITION))
(SETQ Y1 (fetch (POSITION YCOORD) of HEAD.POSITION))
[SETQ LL (SQRT (PLUS (TIMES DX DX)
(TIMES DY DY]
(SETQ COS.RHO (QUOTIENT DX LL))
(SETQ SIN.RHO (QUOTIENT DY LL))
(SETQ COS.THETA (COS HEAD.ANGLE))
(SETQ SIN.THETA (SIN HEAD.ANGLE))
[SETQ XP1 (TIMES HEAD.LENGTH (DIFFERENCE (TIMES COS.RHO COS.THETA)
(TIMES SIN.RHO SIN.THETA]
[SETQ YP1 (TIMES HEAD.LENGTH (PLUS (TIMES SIN.RHO COS.THETA)
(TIMES SIN.THETA COS.RHO]
[SETQ XP2 (TIMES HEAD.LENGTH (PLUS (TIMES COS.RHO COS.THETA)
(TIMES SIN.RHO SIN.THETA]
[SETQ YP2 (TIMES HEAD.LENGTH (DIFFERENCE (TIMES SIN.RHO COS.THETA)
(TIMES SIN.THETA COS.RHO]
(RETURN (LIST HEAD.POSITION (create POSITION
XCOORD ←(FIXR (DIFFERENCE X1 XP1))
YCOORD ←(FIXR (DIFFERENCE Y1 YP1)))
(create POSITION
XCOORD ←(FIXR (DIFFERENCE X1 XP2))
YCOORD ←(FIXR (DIFFERENCE Y1 YP2])
(CURVE.ARROWHEAD.POINTS
[LAMBDA (LOCALKNOTS BEGFLG HEAD.ANGLE HEAD.LENGTH) (* rrb " 2-Jun-85 11:36")
(* returns a list of arrowhead points for a curve.
If BEGFLG is T, it is to go on the first end.)
(PROG [(SLOPE (\CURVESLOPE LOCALKNOTS (NOT BEGFLG]
(RETURN (ARROWHEAD.POINTS.LIST [COND
(BEGFLG (CAR LOCALKNOTS))
(T (CAR (LAST LOCALKNOTS]
HEAD.ANGLE HEAD.LENGTH (COND
(BEGFLG (MINUS (CAR SLOPE)))
(T (CAR SLOPE)))
(COND
(BEGFLG (MINUS (CDR SLOPE)))
(T (CDR SLOPE])
(LEFT.MOST.IS.BEGINP
[LAMBDA (KNOTLST) (* rrb "30-Nov-84 16:55")
(* * returns T if the beginning of the curve thru KNOTLST is to the left of its end.)
(COND
((NULL (CDR (LISTP KNOTLST)))
(ERROR KNOTLST "should have at least two elements."))
(T (PROG ((FIRST (CAR KNOTLST))
(LAST (CAR (LAST KNOTLST)))
FIRSTX LASTX)
(RETURN (OR (GREATERP (SETQ LASTX (fetch (POSITION XCOORD) of LAST))
(SETQ FIRSTX (fetch (POSITION XCOORD) of FIRST)))
(AND (EQP LASTX FIRSTX)
(GREATERP (fetch (POSITION YCOORD) of FIRST)
(fetch (POSITION YCOORD) of LAST])
(WIRE.ARROWHEAD.POINTS
[LAMBDA (LOCALKNOTS FIRSTFLG HEAD.ANGLE HEAD.LENGTH) (* rrb "11-Sep-85 13:59")
(* returns a list of arrowhead points for a wire.
If FIRSTFLG is T, it is to go on the first end.)
(PROG (HEADPT TAILPT)
(COND
(FIRSTFLG (SETQ HEADPT (CAR LOCALKNOTS))
(SETQ TAILPT (CADR LOCALKNOTS)))
((CDR LOCALKNOTS)
(for KNOTTAIL on LOCALKNOTS when (NULL (CDDR KNOTTAIL))
do (SETQ TAILPT (CAR KNOTTAIL))
(SETQ HEADPT (CADR KNOTTAIL))
(RETURN)))
(T (* only one point, don't put on an arrowhead.)
(RETURN)))
(RETURN (ARROWHEAD.POINTS.LIST HEADPT HEAD.ANGLE HEAD.LENGTH
(COND
(TAILPT (DIFFERENCE (fetch (POSITION XCOORD) of HEADPT)
(fetch (POSITION XCOORD) of TAILPT)))
(T 1))
(COND
(TAILPT (DIFFERENCE (fetch (POSITION YCOORD) of HEADPT)
(fetch (POSITION YCOORD) of TAILPT)))
(T 0])
(DRAWARROWHEADS
[LAMBDA (ARROWSPECS ARROWPTS WINDOW SIZE OPERATION) (* rrb "11-Sep-85 14:20")
(* * draws the arrowhead from the specs in ARROWSPECS and the points in ARROWPTS)
(* PTS may be NIL in the case where an arrowhead was
added to a closed knot element that only has one
point.)
(for SPEC in ARROWSPECS as PTS in ARROWPTS when (AND SPEC PTS)
do (DRAWCURVE (LIST (CAR PTS)
(CADR PTS))
NIL SIZE NIL WINDOW)
(DRAWCURVE (LIST (CAR PTS)
(CADDR PTS))
NIL SIZE NIL WINDOW)
(AND (EQ (fetch (ARROWHEAD ARROWTYPE) of SPEC)
(QUOTE CLOSEDLINE))
(DRAWCURVE (LIST (CADR PTS)
(CADDR PTS))
NIL SIZE NIL WINDOW])
(SK.SET.ARROWHEAD.LENGTH
[LAMBDA (W) (* rrb "20-Jun-85 11:07")
(* sets the size of the default arrowhead.)
(PROG [NEWSIZE (NOWARROWHEAD (fetch (SKETCHCONTEXT SKETCHARROWHEAD) of (WINDOWPROP W
(QUOTE
SKETCHCONTEXT]
(SETQ NEWSIZE (RNUMBER (CONCAT
"New arrowhead size in screen pts.
Current arrowhead size is "
(MKSTRING (fetch (ARROWHEAD ARROWLENGTH) of NOWARROWHEAD)))
NIL NIL NIL T))
(RETURN (COND
((OR (NULL NEWSIZE)
(IGEQ 0 NEWSIZE))
NIL)
(T (replace (SKETCHCONTEXT SKETCHARROWHEAD) of (WINDOWPROP W (QUOTE SKETCHCONTEXT)
)
with (create ARROWHEAD using NOWARROWHEAD ARROWLENGTH ← NEWSIZE])
(SK.SET.ARROWHEAD.ANGLE
[LAMBDA (W) (* rrb "20-Jun-85 11:07")
(* sets the angle of the default arrowhead.)
(PROG [NEWSIZE (NOWARROWHEAD (fetch (SKETCHCONTEXT SKETCHARROWHEAD) of (WINDOWPROP W
(QUOTE
SKETCHCONTEXT]
(SETQ NEWSIZE (RNUMBER (CONCAT "New head angle in degrees.
Current arrowhead angle is " (MKSTRING (fetch (ARROWHEAD ARROWANGLE) of NOWARROWHEAD)))
NIL NIL NIL T))
(RETURN (COND
((OR (NULL NEWSIZE)
(IGEQ 0 NEWSIZE))
NIL)
(T (replace (SKETCHCONTEXT SKETCHARROWHEAD) of (WINDOWPROP W (QUOTE SKETCHCONTEXT)
)
with (create ARROWHEAD using NOWARROWHEAD ARROWANGLE ← NEWSIZE])
(SK.SET.ARROWHEAD.TYPE
[LAMBDA (W) (* rrb "12-Dec-84 07:46")
(* Sets the type of the default arrowhead)
(PROG ([NEWSHAPE (MENU (create MENU
ITEMS ←(QUOTE ((V% shape (QUOTE LINE)
"arrowhead consists of two line segments.")
(Triangle (QUOTE CLOSEDLINE)
"arrowhead consists of a triangle."]
SKETCHCONTEXT)
(RETURN (AND NEWSHAPE (replace (SKETCHCONTEXT SKETCHARROWHEAD)
of (SETQ SKETCHCONTEXT (WINDOWPROP W (QUOTE SKETCHCONTEXT)))
with (create ARROWHEAD using (fetch (SKETCHCONTEXT SKETCHARROWHEAD)
of SKETCHCONTEXT)
ARROWTYPE ← NEWSHAPE])
(SK.SET.LINE.ARROWHEAD
[LAMBDA (W NEWVALUE) (* rrb " 6-May-85 18:16")
(* sets whether or not the default line has an
arrowhead.)
(PROG [(ARROWHEADEND (COND
((MEMB NEWVALUE (QUOTE (FIRST LAST BOTH NEITHER LEFT RIGHT)))
NEWVALUE)
(T (MENU (create MENU
TITLE ← "Which end?"
ITEMS ←(QUOTE ((First (QUOTE FIRST)
"An arrowhead will be at the first point of any new lines or curves.")
(Last (QUOTE LAST)
"An arrowhead will be at the last point of any new lines or curves.")
(Both (QUOTE BOTH)
"Arrowheads will be both ends of any new lines or curves.")
(Neither (QUOTE NEITHER)
"New lines will not have any arrowheads.")
(Left% % % % % (QUOTE LEFT)
"An arrowhead will be at the leftmost end of any new lines or curves.")
(% % % % Right (QUOTE RIGHT)
"An arrowhead will be at the rightmost end of any new lines or curves.")))
CENTERFLG ← T]
(RETURN (AND ARROWHEADEND (replace (SKETCHCONTEXT SKETCHUSEARROWHEAD)
of (WINDOWPROP W (QUOTE SKETCHCONTEXT)) with ARROWHEADEND])
(SK.UPDATE.ARROWHEAD.FORMAT
[LAMBDA (GELT) (* rrb "25-Apr-85 10:28")
(* makes sure that the element GELT is in new format.)
(* the fields of this are first arrowhead, last
arrowhead and new format indicator.
The old format had left arrowhead and right arrowhead.)
(PROG ((INDGARROWELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))
NOWARROWS)
(SELECTQ (fetch (INDIVIDUALGLOBALPART GTYPE) of INDGARROWELT)
[OPENCURVE (AND (SETQ NOWARROWS (fetch (OPENCURVE CURVEARROWHEADS) of INDGARROWELT)
)
(NULL (CDDR NOWARROWS))
(replace (OPENCURVE CURVEARROWHEADS) of INDGARROWELT
with (COND
((LEFT.MOST.IS.BEGINP (fetch LATLONKNOTS of INDGARROWELT)
)
(LIST (CAR NOWARROWS)
(CADR NOWARROWS)
T))
(T (LIST (CADR NOWARROWS)
(CAR NOWARROWS)
T]
[WIRE (AND (SETQ NOWARROWS (fetch (WIRE WIREARROWHEADS) of INDGARROWELT))
(NULL (CDDR NOWARROWS))
(replace (WIRE WIREARROWHEADS) of INDGARROWELT
with (COND
((LEFT.MOST.IS.BEGINP (fetch LATLONKNOTS of INDGARROWELT))
(LIST (CAR NOWARROWS)
(CADR NOWARROWS)
T))
(T (LIST (CADR NOWARROWS)
(CAR NOWARROWS)
T]
NIL)
(RETURN GELT])
(SK.SET.LINE.LENGTH.MODE
[LAMBDA (W VAL?) (* rrb " 6-May-85 18:13")
(* sets whether the lines drawn with the middle button connect e.g the next segment begins where the last one left
off or whether it takes two clicks to get a single segment line.)
(PROG [(LINEMODE (COND
((MEMBER VAL? (QUOTE (YES NO)))
VAL?)
(T (MENU (create MENU
TITLE ← "Connect middle button lines?"
ITEMS ←(QUOTE ((Yes (QUOTE YES)
"The lines drawn with the middle button will pick up where the last one left off.")
(No (QUOTE NO)
"Sets the default so that two middle clicks make a line.")))
CENTERFLG ← T]
(RETURN (AND LINEMODE (replace (SKETCHCONTEXT SKETCHLINEMODE) of (WINDOWPROP W
(QUOTE
SKETCHCONTEXT))
with (EQ LINEMODE (QUOTE NO])
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD LOCALWIRE (KNOTS ARROWHEADPTS LOCALOPENWIREBRUSH))
(TYPERECORD WIRE (LATLONKNOTS BRUSH WIREARROWHEADS OPENWIREDASHING OPENWIREINITSCALE))
(TYPERECORD CLOSEDWIRE (LATLONKNOTS BRUSH CLOSEDWIREDASHING CLOSEDWIREINITSCALE CLOSEDWIREFILLING))
(RECORD LOCALCLOSEDWIRE (KNOTS LOCALCLOSEDWIREBRUSH))
(RECORD ARROWHEAD (ARROWTYPE ARROWANGLE ARROWLENGTH))
]
)
(READVARS WIREICON CLOSEDWIREICON)
({(READBITMAP)(20 12
"@D@@@@@@"
"@L@@@@@@"
"AH@@@@@@"
"C@GOL@@@"
"F@OOL@@@"
"L@L@L@@@"
"LAH@L@@@"
"FAHAH@@@"
"CC@C@@@@"
"AK@C@@@@"
"@N@F@@@@"
"@F@L@@@@")} {(READBITMAP)(20 12
"@G@GN@@@"
"@OHON@@@"
"AMMLN@@@"
"CHOIL@@@"
"G@GCH@@@"
"N@@G@@@@"
"G@@N@@@@"
"CH@GH@@@"
"AL@AN@@@"
"@O@@F@@@"
"@GOON@@@"
"@COON@@@")})
(RPAQ? SK.ARROWHEAD.ANGLE.INCREMENT 10)
(RPAQ? SK.ARROWHEAD.LENGTH.INCREMENT 2)
(RPAQ SK.DEFAULT.ARROWHEAD (LIST (QUOTE LINE)
30.0 12))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS SK.DEFAULT.ARROWHEAD)
)
(RPAQ? SK.ARROW.END.MENU )
(RPAQ? SK.ARROW.EDIT.MENU )
(* stuff to support the text element type.)
(DEFINEQ
(TEXT.CHANGEFN
[LAMBDA (SCRNELTS SKW HOW) (* rrb "10-Jan-85 16:58")
(* the users has selected SCRNELT to be changed)
(for ELTWITHTEXT inside SCRNELTS collect (SK.CHANGE.TEXT ELTWITHTEXT HOW SKW])
(TEXT.READCHANGEFN
[LAMBDA (SKW SCRNELTS INTEXTBOXFLG) (* rrb " 9-Aug-85 17:01")
(* the users has selected SCRNELT to be changed this
function reads a specification of how the text elements
should change.)
(PROG ((COMMAND (MENU (create MENU
TITLE ← "Change text how?"
ITEMS ←[APPEND (COND
[(SKETCHINCOLORP)
(QUOTE (("Color" (QUOTE BRUSHCOLOR)
"changes the color of the text"]
(T NIL))
[COND
((SCREENELEMENTP SCRNELTS)
NIL)
(T (QUOTE (("look same" (QUOTE SAME)
"makes the font characteristics the same as those of the first selected piece of text."]
[COND
((AND (NULL INTEXTBOXFLG)
(SKETCH.ELEMENT.TYPEP (QUOTE TEXTBOX)))
(QUOTE (("box the text" (QUOTE BOX)
"makes the selected text into boxed text."]
(QUOTE (("different font" (QUOTE NEWFONT)
"prompts for a new font family.")
("smaller font" (QUOTE SMALLER)
"Make the text smaller")
("LARGER FONT" (QUOTE LARGER)
"Make the text font larger.")
("set font size" (QUOTE SETSIZE)
"makes all fonts a prompted for size")
("set family & size" (QUOTE FAMILY&SIZE)
"allows changing both the family and the size")
("BOLD" (QUOTE BOLD)
"makes the text bold.")
("unbold" (QUOTE UNBOLD)
"removes the bold look of text.")
("italic" (QUOTE ITALIC)
"makes the text italic.")
("unitalic" (QUOTE UNITALIC)
"removes the italic look of text.")
("center justify" (QUOTE CENTER)
"centers the text about its location")
("left justify " (QUOTE LEFT)
"left justifies the text to its location")
(" right justify" (QUOTE RIGHT)
"right justifies the text to its location.")
("top justify" (QUOTE TOP)
"makes the location be the top of the text.")
("bottom justify" (QUOTE BOTTOM)
"makes the location be the bottom of the text.")
("middle justify" (QUOTE MIDDLE)
"makes the control point specify the mid-height of the text.")
("baseline justify" (QUOTE BASELINE)
"makes the control popint specify the baseline of the text."]
CENTERFLG ← T)))
NEWSIZE FIRSTTEXTELT VAL)
(OR COMMAND (RETURN))
(SKED.CLEAR.SELECTION SKW)
[SETQ VAL (SELECTQ COMMAND
(SETSIZE (* read the new font size once)
(\SK.READ.FONT.SIZE1 SCRNELTS SKW))
[FAMILY&SIZE (* gets both a font size and a family)
(AND (SETQ VAL (SK.READFONTFAMILY SKW "New font family?"))
(SETQ NEWSIZE (\SK.READ.FONT.SIZE1 SCRNELTS SKW VAL]
(SAME (* set the text characteristics from the first
selection.)
(AND (SETQ FIRSTTEXTELT (for SCRNELT inside SCRNELTS
when (MEMB (fetch (SCREENELT GTYPE)
of SCRNELT)
(QUOTE (TEXTBOX TEXT)))
do (RETURN SCRNELT)))
(fetch (SCREENELT INDIVIDUALGLOBALPART) of FIRSTTEXTELT)))
(NEWFONT (* get a new font family)
(SK.READFONTFAMILY SKW "New font family?"))
(BRUSHCOLOR (READ.COLOR.CHANGE "Change text color how?"))
(RETURN (LIST (QUOTE TEXT)
COMMAND]
(RETURN (AND VAL (LIST COMMAND VAL])
(\SK.READ.FONT.SIZE1
[LAMBDA (SELECTEDELTS SKETCHW NEWFAMILY) (* rrb " 4-Oct-85 16:37")
(* reads a font size from the user.
If NEWFONT is NIL, use the one of the first selected
element.)
(PROG (FIRSTTEXTELT NEWSIZE NOWFONT NEWFONT)
(OR (SETQ FIRSTTEXTELT (for SCRNELT inside SELECTEDELTS
when (MEMB (fetch (SCREENELT GTYPE) of SCRNELT)
(QUOTE (TEXTBOX TEXT)))
do (RETURN SCRNELT)))
(RETURN))
(SETQ FIRSTTEXTELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of FIRSTTEXTELT))
(SETQ NOWFONT (fetch (TEXT FONT) of FIRSTTEXTELT))
(STATUSPRINT SKETCHW "Size of " (COND
((SCREENELEMENTP SELECTEDELTS)
"text")
(T "first selected text"))
" is "
(FONTPROP NOWFONT (QUOTE SIZE)))
(SETQ NEWSIZE (SK.READFONTSIZE NIL [OR NEWFAMILY (SETQ NEWFAMILY
(FONTPROP NOWFONT (QUOTE FAMILY]
SKETCHW))
(RETURN (COND
((NULL NEWSIZE)
(CLOSE.PROMPT.WINDOW SKETCHW)
NIL)
((NULL (SETQ NEWFONT (FONTCREATE NEWFAMILY NEWSIZE (FONTPROP
NOWFONT
(QUOTE FACE))
NIL NIL T)))
(STATUSPRINT SKETCHW NEWFAMILY NEWSIZE " not found.")
NIL)
(T (CLOSE.PROMPT.WINDOW SKETCHW)
(FONTNAMELIST NEWFONT])
(SK.TEXT.ELT.WITH.SAME.FIELDS
[LAMBDA (NEWONE ORGONE) (* rrb "18-Jul-85 14:16")
(* returns an element of the type of ORGONE whose text
fields are the same as NEWONE.)
(SELECTQ (fetch (INDIVIDUALGLOBALPART GTYPE) of ORGONE)
(TEXT (create TEXT
LOCATIONLATLON ←(fetch (TEXT LOCATIONLATLON) of ORGONE)
LISTOFCHARACTERS ←(fetch (TEXT LISTOFCHARACTERS) of ORGONE)
INITIALSCALE ←(fetch (TEXT INITIALSCALE) of NEWONE)
TEXTSTYLE ←(fetch (TEXT TEXTSTYLE) of NEWONE)
FONT ←(fetch (TEXT FONT) of NEWONE)
LISTOFREGIONS ←(fetch (TEXT LISTOFREGIONS) of NEWONE)
TEXTCOLOR ←(fetch (TEXT TEXTCOLOR) of NEWONE)))
(TEXTBOX (create TEXTBOX
TEXTBOXREGION ←(fetch (TEXTBOX TEXTBOXREGION) of ORGONE)
LISTOFCHARACTERS ←(fetch (TEXT LISTOFCHARACTERS) of ORGONE)
INITIALSCALE ←(fetch (TEXT INITIALSCALE) of NEWONE)
TEXTSTYLE ←(fetch (TEXT TEXTSTYLE) of NEWONE)
FONT ←(fetch (TEXT FONT) of NEWONE)
LISTOFREGIONS ←(fetch (TEXT LISTOFREGIONS) of NEWONE)
TEXTCOLOR ←(fetch (TEXT TEXTCOLOR) of NEWONE)
TEXTBOXBRUSH ←(fetch (TEXTBOX TEXTBOXBRUSH) of ORGONE)))
NIL])
(SK.READFONTFAMILY
[LAMBDA (SKW TITLE) (* rrb "14-Jun-85 18:38")
(* reads a font family name.)
(PROG ([KNOWNFAMILIES (UNION (for X in \FONTSONFILE collect (CAR X))
(for X in \FONTSINCORE WHEN (NOT (EQ (CHARCODE D)
(NTHCHARCODE (CAR X)
-1)))
collect (* don't include things like helveticad)
(CAR X]
FAMILY) (* offers a menu of possible choices.)
(COND
((AND KNOWNFAMILIES (NEQ (SETQ FAMILY (MENU (create MENU
ITEMS ←(APPEND
(QUOTE (("other" (QUOTE OTHER)
"prompts for a family not on the menu.")))
KNOWNFAMILIES)
TITLE ←(OR TITLE "Choose font")
CENTERFLG ← T)))
(QUOTE OTHER)))
(RETURN FAMILY))
(T (* grab the tty.)
(TTY.PROCESS (THIS.PROCESS))
(RETURN (CAR (ERSETQ (MKATOM (U-CASE (PROMPTFORWORD "New family: " NIL NIL
(GETPROMPTWINDOW SKW])
(CLOSE.PROMPT.WINDOW
[LAMBDA (WINDOW) (* rrb "28-Oct-84 14:14")
(* gets rid of the prompt window.)
(PROG (PRMPTWIN)
(RETURN (COND
((SETQ PRMPTWIN (GETPROMPTWINDOW WINDOW NIL NIL T))
(DETACHWINDOW PRMPTWIN)
(CLOSEW PRMPTWIN])
(TEXT.DRAWFN
[LAMBDA (TEXTELT WINDOW) (* rrb " 9-Aug-85 09:38")
(* shows a text element)
(TEXT.DRAWFN1 (fetch (LOCALTEXT LOCALLISTOFCHARACTERS) of (fetch (SCREENELT LOCALPART)
of TEXTELT))
(fetch (LOCALTEXT LINEREGIONS) of (fetch (SCREENELT LOCALPART) of TEXTELT))
(fetch (LOCALTEXT LOCALFONT) of (fetch (SCREENELT LOCALPART) of TEXTELT))
(fetch (TEXT TEXTCOLOR) of (fetch (SCREENELT INDIVIDUALGLOBALPART) of TEXTELT))
WINDOW])
(TEXT.DRAWFN1
[LAMBDA (STRS REGIONS FONT COLOR SKWINDOW) (* rrb " 2-Oct-85 10:05")
(* draws the image of a list of string in their local regions on a sketch window. It is broken out as a subfunction
so that it can be called by the update function also.)
(COND
((AND COLOR (SKETCHINCOLORP))
(DSPCOLOR COLOR SKWINDOW)))
(PROG (DESCENT)
(COND
((NULL FONT) (* text is too small or too large to be at this scale.)
(RETURN))
((FONTP FONT) (* font was found.)
(DSPFONT FONT SKWINDOW) (* refetch font from window, in case it is an
interpress stream so descent will be right.)
(SETQ DESCENT (FONTPROP (SETQ FONT (DSPFONT NIL SKWINDOW))
(QUOTE DESCENT)))
(RESETFORM (SETTERMTABLE SKETCH.TERMTABLE)
(for REGION in REGIONS as CHARS in STRS
do (MOVETO (fetch (REGION LEFT) of REGION)
(PLUS (fetch (REGION BOTTOM) of REGION)
DESCENT)
SKWINDOW)
(PRIN3 CHARS SKWINDOW))) (* return font to default so that messages come out
ok.)
(DSPFONT (DEFAULTFONT (QUOTE DISPLAY))
SKWINDOW))
(T (* if no font, just gray in regions)
(COND
((EQ (IMAGESTREAMTYPE SKWINDOW)
(QUOTE DISPLAY))
(for REGION in REGIONS do (BITBLT NIL NIL NIL SKWINDOW (fetch LEFT of REGION)
(fetch BOTTOM of REGION)
(fetch WIDTH of REGION)
(IQUOTIENT (ADD1 (fetch HEIGHT of REGION))
2)
(QUOTE TEXTURE)
NIL INDICATE.TEXT.SHADE)))
(T (* hardcopy can't support bitblt, draw a line instead.)
(bind MIDHGHT for REGION in REGIONS
do (DRAWLINE (fetch LEFT of REGION)
(SETQ MIDHGHT (PLUS (fetch BOTTOM of REGION)
(IQUOTIENT (ADD1 (fetch HEIGHT of REGION))
2)))
(fetch RIGHT of REGION)
MIDHGHT
(fetch HEIGHT of REGION)
NIL SKWINDOW])
(TEXT.INSIDEFN
[LAMBDA (GTEXT WREG) (* rrb " 5-AUG-83 16:54")
(* determines if the global text element is inside of
WREG.)
(for GREG in (fetch (TEXT LISTOFREGIONS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GTEXT))
when (REGIONSINTERSECTP GREG WREG) do (RETURN T])
(TEXT.EXPANDFN
[LAMBDA (GTEXTPART SCALE STREAM) (* rrb " 3-Oct-85 09:33")
(* creates a local text screen element from a global
text element.)
(PROG ((GTEXT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXTPART))
(CANONICALTESTSTR "AWIaiw")
TEXTPOS LOCALFONT GFONT GFONTDESC STYLE CANONICALWIDTH IMAGESTREAM LINEREGIONS)
[COND
((NLISTP (SETQ STYLE (fetch (TEXT TEXTSTYLE) of GTEXT)))
(* old format had horizontal positioning only, now has
vertical too. Fill in old default.)
(replace (TEXT TEXTSTYLE) of GTEXT with (SETQ STYLE (QUOTE (CENTER CENTER]
[SETQ GFONTDESC (FONTCREATE (SETQ GFONT (fetch (TEXT FONT) of GTEXT]
[SETQ IMAGESTREAM (COND
((STREAMP STREAM))
(T (WINDOWPROP STREAM (QUOTE DSP]
[COND
((EQUAL (TIMES SCALE (DSPSCALE NIL STREAM))
(fetch (TEXT INITIALSCALE) of GTEXT))
(* special case scales being the same so there is not a large delay when first character is typed and to avoid font
look up problems when hardcopying at scale 1)
(SETQ LOCALFONT (FONTCREATE GFONTDESC NIL NIL NIL STREAM)))
(T
(* use a canonical string to determine the font size so that all strings of a given font at a given scale look the
same. If font is determined by the width of the particular string, two different string will appear in different
fonts. In particular, the string may change fonts as the user is typing into it.)
(* don't use the face information when determining
string width because in some cases HELVETICA 10, the
bold is smaller than the regular.)
[SETQ CANONICALWIDTH (FIXR (QUOTIENT (TIMES (STRINGWIDTH
CANONICALTESTSTR
(LIST (CAR GFONT)
(CADR GFONT)))
(fetch (TEXT INITIALSCALE)
of GTEXT))
(TIMES SCALE (DSPSCALE NIL STREAM]
(* calculate the local font.)
(SETQ LOCALFONT (SK.PICK.FONT CANONICALWIDTH CANONICALTESTSTR IMAGESTREAM
(CAR GFONT)))
(COND
((FONTP LOCALFONT)
(SETQ LOCALFONT (FONTCOPY LOCALFONT (QUOTE FACE)
(CADDR GFONT]
(SETQ LINEREGIONS (SK.TEXT.LINE.REGIONS (fetch (TEXT LISTOFCHARACTERS)
of GTEXT)
(SETQ TEXTPOS (
SK.SCALE.POSITION.INTO.VIEWER
(fetch (TEXT LOCATIONLATLON)
of GTEXT)
SCALE))
(fetch (TEXT LISTOFREGIONS) of GTEXT)
LOCALFONT GFONTDESC STYLE SCALE IMAGESTREAM))
(RETURN (create SCREENELT
LOCALPART ←(create LOCALTEXT
DISPLAYPOSITION ← TEXTPOS
LINEREGIONS ← LINEREGIONS
LOCALFONT ← LOCALFONT
LOCALLISTOFCHARACTERS ←(fetch (TEXT
LISTOFCHARACTERS)
of GTEXT))
GLOBALPART ← GTEXTPART])
(SK.TEXT.LINE.REGIONS
[LAMBDA (LISTOFTEXT TEXTPOS GREGIONS LOCALFONT GLOBALFONT STYLE SCALE IMAGESTREAM)
(* rrb "14-Jan-85 16:20")
(* calculates the list of regions that each line of text in LISTOFTEXT will occupy. Used by both TEXT.EXPANDFN and
TEXTBOX.EXPANDFN. Captures those things which are common to the two elements.)
(COND
[(FONTP LOCALFONT)
(LTEXT.LINE.REGIONS LISTOFTEXT TEXTPOS (COND
((IMAGESTREAMTYPEP IMAGESTREAM (QUOTE HARDCOPY))
(* actually make the font be the font of the stream so
that the stream can be passed to STRINGWIDTH to get
hardcopy characteristics.)
(DSPFONT LOCALFONT IMAGESTREAM)
IMAGESTREAM)
(T LOCALFONT))
STYLE
(FIXR (TIMES (QUOTIENT (fetch (REGION HEIGHT) of (CAR GREGIONS))
SCALE)
(LENGTH LISTOFTEXT]
(T (for GREG in GREGIONS collect (CREATEREGION (FIXR (QUOTIENT (fetch (REGION LEFT)
of GREG)
SCALE))
(FIXR (QUOTIENT (fetch (REGION BOTTOM)
of GREG)
SCALE))
(FIXR (QUOTIENT (fetch (REGION WIDTH)
of GREG)
SCALE))
1])
(SK.PICK.FONT
[LAMBDA (WID STRING STREAM FAMILY) (* rrb "19-Jun-85 09:58")
(* returns the font in FAMILY that text should be
printed in to have the text STRING fit into a region
WID points wide)
(PROG (LASTFONT LASTSIZE DEVICE)
[SETQ DEVICE (COND
((NLISTP (SETQ DEVICE (IMAGESTREAMTYPE STREAM)))
DEVICE)
((MEMB (QUOTE HARDCOPY)
DEVICE)
(SETQ DEVICE (HARDCOPYSTREAMTYPE STREAM)))
(T (* don't know what is happening here but just use
display.)
(QUOTE DISPLAY]
(RETURN (for FONT in (SK.DECREASING.FONT.LIST FAMILY DEVICE)
when (NOT (GREATERP [SETQ LASTSIZE (STRINGWIDTH STRING (FONTCOPY (SETQ LASTFONT
FONT)
(QUOTE DEVICE)
(QUOTE DISPLAY]
WID))
do (* return a font for the proper device even though the
display fonts are used to pick a size.)
(RETURN (FONTCOPY FONT (QUOTE DEVICE)
DEVICE))
finally (RETURN (COND
((OR (NULL LASTFONT)
(GREATERP LASTSIZE (TIMES 1.5 WID)))
(QUOTE SHADE))
(T (* use the smallest if it isn't too large.)
(FONTCOPY LASTFONT (QUOTE DEVICE)
DEVICE])
(SK.NEXTSIZEFONT
[LAMBDA (WHICHDIR NOWFONT) (* rrb "19-Jun-85 14:10")
(* returns the next sized font either SMALLER or LARGER
that on of size FONT.)
(PROG [(NOWSIZE (FONTPROP NOWFONT (QUOTE HEIGHT)))
(DECREASEFONTLST (SK.DECREASING.FONT.LIST (CAR NOWFONT)
(QUOTE DISPLAY]
(RETURN (COND
[(EQ WHICHDIR (QUOTE LARGER))
(COND
((IGEQ NOWSIZE (FONTPROP (CAR DECREASEFONTLST)
(QUOTE HEIGHT)))
(* nothing larger)
NIL)
(T (for FONTTAIL on DECREASEFONTLST when [AND (CDR FONTTAIL)
(IGEQ NOWSIZE
(FONTPROP (CADR FONTTAIL)
(QUOTE HEIGHT]
do (RETURN (FONTNAMELIST (CAR FONTTAIL]
(T (for FONT in DECREASEFONTLST when (LESSP (FONTPROP FONT (QUOTE HEIGHT))
NOWSIZE)
do (RETURN (FONTNAMELIST FONT])
(SK.DECREASING.FONT.LIST
[LAMBDA (FAMILY DEVICETYPE) (* rrb "19-Jun-85 14:45")
(* returns a list of fonts of family FAMILY which work
on device DEVICETYPE)
[COND
((NULL FAMILY)
(SETQ FAMILY (QUOTE MODERN)))
((EQ FAMILY (QUOTE TIMESROMAND)) (* special check because larger timesroman fonts have a
D appended.)
(SETQ FAMILY (QUOTE TIMESROMAN] (* convert to families that exist on the known
devices.)
[COND
[(EQ DEVICETYPE (QUOTE PRESS))
(COND
((EQ FAMILY (QUOTE MODERN))
(SETQ FAMILY (QUOTE HELVETICA)))
((EQ FAMILY (QUOTE CLASSIC))
(SETQ FAMILY (QUOTE TIMESROMAN)))
((EQ FAMILY (QUOTE TERMINAL))
(SETQ FAMILY (QUOTE GACHA]
((EQ DEVICETYPE (QUOTE INTERPRESS))
(COND
((EQ FAMILY (QUOTE HELVETICA))
(SETQ FAMILY (QUOTE MODERN)))
((EQ FAMILY (QUOTE TIMESROMAN))
(SETQ FAMILY (QUOTE CLASSIC)))
((EQ FAMILY (QUOTE GACHA))
(SETQ FAMILY (QUOTE TERMINAL]
(for FONT in (SK.GUESS.FONTSAVAILABLE FAMILY DEVICETYPE) collect (FONTCOPY FONT (QUOTE DEVICE)
DEVICETYPE])
(SK.GUESS.FONTSAVAILABLE
[LAMBDA (FAMILY HDCPYTYPE) (* rrb " 9-Oct-85 16:10")
(* returns a list of all fonts of a FAMILY in
decreasing order.)
(PROG (FILEFONTS CACHE DISPLAYFONTSIZES)
(SETQ HDCPYTYPE (COND
((NULL HDCPYTYPE)
(PRINTERTYPE))
((NLISTP HDCPYTYPE)
HDCPYTYPE)
(T HDCPYTYPE))) (* cache the file fonts.)
[COND
[[SETQ FILEFONTS (ASSOC HDCPYTYPE (CDR (ASSOC FAMILY \FONTSONFILE]
(* note if a cache has been calculated.
Use it even if it is NIL)
(* \FONTSONFILE seems to group things such as
CLASSICTHIN under CLASSIC so make sure to remove
anything that has the wrong family.)
(SETQ FILEFONTS (SUBSET (CDR FILEFONTS)
(FUNCTION (LAMBDA (X)
(EQ (CAR X)
FAMILY]
(T (RESETFORM (CURSOR WAITINGCURSOR)
(SETQ FILEFONTS (FONTSAVAILABLE FAMILY (QUOTE *)
(QUOTE (MEDIUM REGULAR REGULAR))
NIL HDCPYTYPE T))
(* Since there is no way to determine the real sizes for PRESS fonts with size of 0 {meaning the widths scale},
guess that they are available in 10)
[COND
[(EQ HDCPYTYPE (QUOTE PRESS))
(* make sure to look for anything that has a display
font.)
(SETQ DISPLAYFONTSIZES (for FONT
in (FONTSAVAILABLE
FAMILY
(QUOTE *)
(QUOTE (MEDIUM REGULAR REGULAR)
)
NIL
(QUOTE DISPLAY))
collect (CADR FONT)))
(SETQ FILEFONTS
(for FONT in FILEFONTS
join (COND
[(EQ (CADR FONT)
0)
(for SIZE
in (UNION DISPLAYFONTSIZES
(QUOTE (36 30 24 18 14 12 10 8 6)
))
when (FONTCREATE (CAR FONT)
SIZE NIL NIL (QUOTE
DISPLAY)
T)
collect (CONS (CAR FONT)
(CONS SIZE (CDDR FONT]
(T (CONS FONT]
((EQ HDCPYTYPE (QUOTE DISPLAY))
(* patch around the bug in FONTSAVAILABLE.
Remove after J release.)
(SETQ FILEFONTS (SUBSET FILEFONTS
(FUNCTION (LAMBDA (FONT)
(EQUAL (CADDR FONT)
(QUOTE (MEDIUM REGULAR
REGULAR]
(* remove duplicates and sort)
[SETQ FILEFONTS (SORT (INTERSECTION FILEFONTS FILEFONTS)
(FUNCTION (LAMBDA (A B)
(GREATERP (CADR A)
(CADR B]
(COND
((NULL (SETQ CACHE (ASSOC FAMILY \FONTSONFILE)))
(SETQ \FONTSONFILE (CONS (LIST FAMILY (CONS HDCPYTYPE
FILEFONTS))
\FONTSONFILE)))
(T (NCONC1 CACHE (CONS HDCPYTYPE FILEFONTS]
(* reget the fonts in core since they may have changed
since last time.)
(RETURN (SORT (UNION (FONTSAVAILABLE FAMILY (QUOTE *)
NIL NIL HDCPYTYPE)
FILEFONTS)
(FUNCTION (LAMBDA (A B)
(COND
((EQ (CADR A)
(CADR B)) (* in case both TIMESROMAN and TIMESROMAND for example
make it in.)
(ALPHORDER (CADR A)
(CADR B)))
(T (GREATERP (CADR A)
(CADR B])
(TEXT.UPDATE.GLOBAL.REGIONS
[LAMBDA (GTEXTELT NEWGPOS OLDGPOS) (* rrb "12-Sep-84 11:36")
(* updates the list of regions occupied by the text in
the global coordinate space.)
(* this is used to determine the extent of a text
element in a region.)
(PROG ((XDIFF (DIFFERENCE (fetch (POSITION XCOORD) of NEWGPOS)
(fetch (POSITION XCOORD) of OLDGPOS)))
(YDIFF (DIFFERENCE (fetch (POSITION YCOORD) of NEWGPOS)
(fetch (POSITION YCOORD) of OLDGPOS)))
(INDTEXTGELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXTELT)))
(replace (TEXT LISTOFREGIONS) of INDTEXTGELT with (for GREG in (fetch (TEXT LISTOFREGIONS)
of INDTEXTGELT)
collect (REL.MOVE.REGION GREG XDIFF
YDIFF)))
(RETURN GTEXTELT])
(REL.MOVE.REGION
[LAMBDA (REGION DELTAX DELTAY) (* rrb "15-AUG-83 17:30")
(* moves a region by an amount DELTAX DELTAY)
(CREATEREGION (PLUS DELTAX (fetch (REGION LEFT) of REGION))
(PLUS DELTAY (fetch (REGION BOTTOM) of REGION))
(fetch (REGION WIDTH) of REGION)
(fetch (REGION HEIGHT) of REGION])
(LTEXT.LINE.REGIONS
[LAMBDA (LINES LPOSITION FONT STYLE TOTALHEIGHT) (* rrb " 4-Sep-85 17:16")
(* returns the regions occupied by the lines of text
LINES to format them in STYLE in font FONT at position
LPOSITION.)
(AND FONT (PROG ((FONT (FONTCREATE FONT))
(TEXTXPOS (fetch (POSITION XCOORD) of LPOSITION))
(TEXTYPOS (fetch (POSITION YCOORD) of LPOSITION))
HEIGHT HEIGHTOFLOCALTEXT LINEWIDTH)
(SETQ HEIGHT (FONTPROP FONT (QUOTE HEIGHT)))
(SETQ HEIGHTOFLOCALTEXT (TIMES HEIGHT (LENGTH LINES)))
(RETURN (for CHARS in LINES as Y
from [PLUS TEXTYPOS (SELECTQ (CADR STYLE)
[BASELINE
(* vertically center the baseline.
The baseline alignment should probably be independent
of the top -
bottom alignment eventually.)
(DIFFERENCE (DIFFERENCE (QUOTIENT
HEIGHTOFLOCALTEXT 2.0)
HEIGHT)
(MINUS (FONTPROP
FONT
(QUOTE DESCENT]
(CENTER (DIFFERENCE (QUOTIENT
HEIGHTOFLOCALTEXT 2.0)
HEIGHT))
(TOP (DIFFERENCE 1 HEIGHT))
(BOTTOM (DIFFERENCE HEIGHTOFLOCALTEXT
HEIGHT))
(ERROR "illegal vertical text style"
(CADR STYLE]
by (IMINUS HEIGHT)
collect [SETQ LINEWIDTH (DIFFERENCE (STRINGWIDTH CHARS FONT)
(COND
((EQ (NTHCHARCODE CHARS -1)
(CHARCODE CR))
(CHARWIDTH (CHARCODE CR)
FONT))
(T 0]
(CREATEREGION (SELECTQ (CAR STYLE)
(CENTER (DIFFERENCE TEXTXPOS
(QUOTIENT LINEWIDTH
2.0)))
(LEFT TEXTXPOS)
(DIFFERENCE TEXTXPOS LINEWIDTH))
Y LINEWIDTH HEIGHT])
(TEXT.INPUTFN
[LAMBDA (WINDOW) (* rrb "12-Dec-84 11:44")
(* reads text and a place to put it from the user and returns a TEXTELT that represents it. Can return NIL if the
user positions it outside of the window.)
(TEXT.POSITION.AND.CREATE (READ.TEXT "Text to be added: ")
(fetch (SKETCHCONTEXT SKETCHFONT) of (WINDOWPROP WINDOW (QUOTE
SKETCHCONTEXT)))
WINDOW "locate the text"])
(READ.TEXT
[LAMBDA (PRMPT) (* rrb " 9-AUG-83 12:42")
(PROG ([CLOSEWFLG (COND
((EQ (TTYDISPLAYSTREAM)
\DEFAULTTTYDISPLAYSTREAM)
T)
((AND (WFROMDS (TTYDISPLAYSTREAM))
(NOT (OPENWP (TTYDISPLAYSTREAM]
LST)
(AND PRMPT (PRIN1 PRMPT T))
(SETQ LST (CONS (READ T)
(READLINE)))
(AND CLOSEWFLG (CLOSEW (TTYDISPLAYSTREAM)))
(RETURN (APPLY (FUNCTION CONCAT)
(CONS (CAR LST)
(for WORD in (CDR LST) join (LIST (QUOTE % )
WORD])
(TEXT.POSITION.AND.CREATE
[LAMBDA (TEXT FONT WINDOW PROMPTMSG) (* rrb " 4-Sep-85 15:50")
(* gets a position for a piece of text from the user and returns a text element that represents it.
The text location is the center position of the text.)
(* later this should change the cursor to the image
being placed.)
(PROG [P1 LOCATION DISPLAYPOSITION (SCALE (SK.INPUT.SCALE WINDOW))
NEW.BITMAP DSP (WDTH (STRINGWIDTH TEXT FONT))
(HGHT (FONTHEIGHT FONT))
(TEXTALIGNMENT (fetch (SKETCHCONTEXT SKETCHTEXTALIGNMENT) of (WINDOWPROP WINDOW
(QUOTE
SKETCHCONTEXT]
(SETQ NEW.BITMAP (BITMAPCREATE WDTH HGHT))
(SETQ DSP (DSPCREATE NEW.BITMAP))
(DSPFONT FONT DSP)
(MOVETO 0 (FONTDESCENT FONT)
DSP)
(PRIN3 TEXT DSP)
[SETQ P1 (GET.BITMAP.POSITION WINDOW NEW.BITMAP (QUOTE PAINT)
PROMPTMSG
(IMINUS (SELECTQ (CAR TEXTALIGNMENT)
(CENTER (LRSH (ADD1 WDTH)
1))
(LEFT 0)
(SUB1 WDTH)))
(IMINUS (SELECTQ (CADR TEXTALIGNMENT)
(BASELINE (FONTPROP FONT (QUOTE DESCENT)))
(CENTER (LRSH (ADD1 HGHT)
1))
(TOP (SUB1 HGHT))
0]
(* scale range goes from 20 to 1.0 Use FONT as an
initial.)
(RETURN (AND P1 (CREATE.TEXT.ELEMENT (CONS TEXT)
(SK.MAP.INPUT.PT.TO.GLOBAL P1 WINDOW)
SCALE TEXTALIGNMENT FONT])
(CREATE.TEXT.ELEMENT
[LAMBDA (STRLST GPOSITION SCALE JUSTIFICATION FONT) (* rrb "12-May-85 16:22")
(* creates a text element for a sketch)
(TEXT.SET.SCALES (create GLOBALPART
INDIVIDUALGLOBALPART ←(TEXT.SET.GLOBAL.REGIONS (create TEXT
LOCATIONLATLON ←
GPOSITION
LISTOFCHARACTERS
← STRLST
INITIALSCALE ←
SCALE
TEXTSTYLE ←
JUSTIFICATION
FONT ← FONT])
(SK.TEXT.FROM.TEXTBOX
[LAMBDA (TEXTBOXELT SKW) (* rrb "25-Jan-85 11:53")
(* returns a textbox that replaces GTEXTBOXELT.)
(PROG ((INDTEXTBOXELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of TEXTBOXELT))
TEXTSTYLE BRUSH REGION)
(SETQ TEXTSTYLE (fetch (TEXTBOX TEXTSTYLE) of INDTEXTBOXELT))
(SETQ REGION (APPLY (FUNCTION UNIONREGIONS)
(fetch (TEXTBOX LISTOFREGIONS) of INDTEXTBOXELT)))
(RETURN (CREATE.TEXT.ELEMENT (ADD.EOLS (fetch (TEXTBOX LISTOFCHARACTERS) of INDTEXTBOXELT))
(MAP.GLOBAL.PT.ONTO.GRID
[create POSITION
XCOORD ←(SELECTQ (CAR TEXTSTYLE)
(LEFT (fetch (REGION LEFT)
of REGION))
(RIGHT (fetch (REGION RIGHT)
of REGION))
(PLUS (fetch (REGION LEFT)
of REGION)
(QUOTIENT
(fetch (REGION WIDTH)
of REGION)
2)))
YCOORD ←(SELECTQ (CADR TEXTSTYLE)
(TOP (fetch (REGION TOP)
of REGION))
(BOTTOM (fetch (REGION BOTTOM)
of REGION))
(PLUS (fetch (REGION BOTTOM)
of REGION)
(QUOTIENT
(fetch (REGION HEIGHT)
of REGION)
2]
SKW)
(fetch (TEXTBOX INITIALSCALE) of INDTEXTBOXELT)
TEXTSTYLE
(fetch (TEXTBOX FONT) of INDTEXTBOXELT])
(TEXT.SET.GLOBAL.REGIONS
[LAMBDA (GTEXTELT) (* rrb "29-Jan-85 14:50")
(* updates the list of regions occupied by the text in
the global coordinate space.)
(* this is used to determine the extent of a text
element in a region.)
(PROG ((SCALE (fetch (TEXT INITIALSCALE) of GTEXTELT)))
(replace (TEXT LISTOFREGIONS) of GTEXTELT
with (for LREG in [LTEXT.LINE.REGIONS (fetch (TEXT LISTOFCHARACTERS) of GTEXTELT)
(SK.SCALE.POSITION.INTO.VIEWER
(fetch (TEXT LOCATIONLATLON) of GTEXTELT)
SCALE)
(fetch (TEXT FONT) of GTEXTELT)
(fetch (TEXT TEXTSTYLE) of GTEXTELT)
(ITIMES (FONTHEIGHT (fetch (TEXT FONT)
of GTEXTELT))
(LENGTH (fetch (TEXT LISTOFCHARACTERS)
of GTEXTELT]
collect (UNSCALE.REGION LREG SCALE)))
(RETURN GTEXTELT])
(TEXT.REGIONFN
[LAMBDA (SCRTEXTELT) (* rrb " 2-Oct-84 16:36")
(* determines the local region covered by TEXTELT.)
(PROG [REG (LINEREGIONS (fetch (LOCALTEXT LINEREGIONS) of (fetch (SCREENELT LOCALPART)
of SCRTEXTELT]
(RETURN (COND
((NULL LINEREGIONS)
NIL)
(T (SETQ REG (CAR LINEREGIONS))
(for LINEREG in (CDR LINEREGIONS) do (SETQ REG (UNIONREGIONS REG LINEREG)))
REG])
(TEXT.TRANSLATEFN
[LAMBDA (GTEXT DELTAPOS WINDOW) (* rrb "28-Apr-85 18:45")
(* moves a text figure element to a new position.)
(PROG ((INDTEXTELT (COPY (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXT)))
NEWGPOS NEWTEXTELT) (* update the region positions.)
(TEXT.UPDATE.GLOBAL.REGIONS (SETQ NEWTEXTELT (create GLOBALPART
COMMONGLOBALPART ←(APPEND
(fetch (GLOBALPART COMMONGLOBALPART)
of GTEXT))
INDIVIDUALGLOBALPART ← INDTEXTELT))
(SETQ NEWGPOS (PTPLUS DELTAPOS (fetch (TEXT LOCATIONLATLON)
of INDTEXTELT)))
(fetch (TEXT LOCATIONLATLON) of INDTEXTELT))
(replace (TEXT LOCATIONLATLON) of INDTEXTELT with NEWGPOS)
(RETURN NEWTEXTELT])
(TEXT.TRANSFORMFN
[LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "26-Apr-85 16:13")
(* returns a copy of the global TEXT element that has had each of its control points transformed by transformfn.
TRANSFORMDATA is arbitrary data that is passed to tranformfn. SCALEFACTOR is the amount the transformation scales by
and is used to reset the size of the text.)
(PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)))
(RETURN (CREATE.TEXT.ELEMENT (fetch (TEXT LISTOFCHARACTERS) of INDVPART)
(SK.TRANSFORM.POINT (fetch (TEXT LOCATIONLATLON) of INDVPART)
TRANSFORMFN TRANSFORMDATA)
(FTIMES (fetch (TEXT INITIALSCALE) of INDVPART)
SCALEFACTOR)
(fetch (TEXT TEXTSTYLE) of INDVPART)
(fetch (TEXT FONT) of INDVPART])
(TEXT.TRANSLATEPTSFN
[LAMBDA (TEXTELT SELPTS GDELTA WINDOW) (* rrb " 5-May-85 18:05")
(* returns a text element that has its position
translated.)
(* shouldn't ever happen because a text element only
has one control pt and its translatefn should get
used.)
(fetch (SCREENELT GLOBALPART) of TEXTELT])
(TEXT.UPDATEFN
[LAMBDA (OLDLOCALELT NEWGELT SKETCHW) (* rrb " 9-Aug-85 09:13")
(* update function for text.
Tries to repaint only the lines of text that have
changed.)
(PROG ((NEWTEXTELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of NEWGELT))
(OLDTEXTELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of OLDLOCALELT))
LOCALTEXT NEWSCREENELT)
(COND
((AND (EQUAL (fetch (TEXT FONT) of NEWTEXTELT)
(fetch (TEXT FONT) of OLDTEXTELT))
(EQUAL (fetch (TEXT TEXTSTYLE) of NEWTEXTELT)
(fetch (TEXT TEXTSTYLE) of OLDTEXTELT))
(EQUAL (fetch (TEXT LOCATIONLATLON) of NEWTEXTELT)
(fetch (TEXT LOCATIONLATLON) of OLDTEXTELT))
(EQUAL (fetch (TEXT INITIALSCALE) of NEWTEXTELT)
(fetch (TEXT INITIALSCALE) of OLDTEXTELT))
(EQUAL (LENGTH (fetch (TEXT LISTOFCHARACTERS) of NEWTEXTELT))
(LENGTH (fetch (TEXT LISTOFCHARACTERS) of OLDTEXTELT)))
(EQUAL (fetch (TEXT TEXTCOLOR) of NEWTEXTELT)
(fetch (TEXT TEXTCOLOR) of OLDTEXTELT)))
(* if font, style or number of lines has changed, erase
and redraw.)
(SETQ LOCALTEXT (fetch (SCREENELT LOCALPART) of OLDLOCALELT))
(SETQ NEWSCREENELT (SK.ADD.ITEM NEWGELT SKETCHW))
(* update the screen display)
[PROG ((NEWSTRS (fetch (LOCALTEXT LOCALLISTOFCHARACTERS) of (fetch (SCREENELT LOCALPART)
of NEWSCREENELT)))
(OLDSTRS (fetch (LOCALTEXT LOCALLISTOFCHARACTERS) of LOCALTEXT))
(NEWLOCALREGIONS (fetch (LOCALTEXT LINEREGIONS) of (fetch (SCREENELT LOCALPART)
of NEWSCREENELT)))
(OLDLOCALREGIONS (fetch (LOCALTEXT LINEREGIONS) of LOCALTEXT)))
(COND
((NEQ (LENGTH NEWSTRS)
(LENGTH OLDSTRS))
(* creating the new element caused the line filling routines to change the number of lines so the partial redrawing
algorithms don't work and we have to redraw the whole element. Do this by erasing the old one then drawing the new
one.)
(SK.ERASE.ELT OLDLOCALELT SKETCHW)
(SK.DRAWFIGURE NEWSCREENELT SKETCHW NIL (WINDOW.SCALE SKETCHW))
(RETURN NEWSCREENELT)))
LP (COND
((OR NEWSTRS OLDSTRS) (* continue until both new and old are exhausted.)
[COND
([NOT (AND (EQUAL (CAR NEWSTRS)
(CAR OLDSTRS))
(EQUAL (CAR NEWLOCALREGIONS)
(CAR OLDLOCALREGIONS]
(* this line is the different, redraw it.)
(AND OLDLOCALREGIONS (DSPFILL (CAR OLDLOCALREGIONS)
BLACKSHADE
(QUOTE ERASE)
SKETCHW))
(AND NEWSTRS (TEXT.DRAWFN1 (LIST (CAR NEWSTRS))
(LIST (CAR NEWLOCALREGIONS))
(fetch (LOCALTEXT LOCALFONT) of LOCALTEXT)
(fetch (TEXT TEXTCOLOR) of OLDTEXTELT)
SKETCHW]
(SETQ NEWSTRS (CDR NEWSTRS))
(SETQ OLDSTRS (CDR OLDSTRS))
(SETQ NEWLOCALREGIONS (CDR NEWLOCALREGIONS))
(SETQ OLDLOCALREGIONS (CDR OLDLOCALREGIONS))
(GO LP]
(RETURN NEWSCREENELT])
(SK.CHANGE.TEXT
[LAMBDA (ELTWITHTEXT HOW SKW) (* rrb " 9-Aug-85 17:00")
(PROG ((COMMAND (CADR HOW))
NEWFONT NEWSIZE GINDTEXTELT NEWGTEXT FIRSTTEXTELT NOWFONT OLDFONT OLDFACE GTYPE NEWTHING
COMMAND)
(OR HOW (RETURN)) (* take down the caret before any change.)
(SKED.CLEAR.SELECTION SKW)
(COND
((MEMB (SETQ GTYPE (fetch (GLOBALPART GTYPE) of ELTWITHTEXT))
(QUOTE (TEXTBOX TEXT)))
(SETQ GINDTEXTELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHTEXT))
(SETQ NEWGTEXT
(SELECTQ (CAR HOW)
(TEXT (SELECTQ COMMAND
[(SMALLER LARGER) (* change the font)
(COND
[[SETQ NEWFONT
(SK.NEXTSIZEFONT COMMAND
(LIST (FONTPROP
(SETQ OLDFONT
(fetch (TEXT FONT)
of GINDTEXTELT))
(QUOTE FAMILY))
(FONTPROP OLDFONT
(QUOTE SIZE]
(* if there is an appropriate size font, use it.)
[SETQ NEWTHING (LIST (FONTPROP NEWFONT (QUOTE FAMILY))
(FONTPROP NEWFONT (QUOTE SIZE))
(FONTPROP OLDFONT (QUOTE FACE]
(COND
((EQ GTYPE (QUOTE TEXT))
(create TEXT using GINDTEXTELT FONT ← NEWTHING))
(T (create TEXTBOX using GINDTEXTELT FONT ← NEWTHING]
(T (* otherwise just scale the area some.)
(SETQ NEWTHING (FTIMES (fetch (TEXT INITIALSCALE)
of GINDTEXTELT)
(SELECTQ COMMAND
(LARGER 1.4)
.7142858)))
(COND
((EQ GTYPE (QUOTE TEXT))
(create TEXT using GINDTEXTELT INITIALSCALE ←
NEWTHING))
(T (create TEXTBOX using GINDTEXTELT INITIALSCALE ←
NEWTHING]
[(CENTER LEFT RIGHT)
(* change the horizontal justification)
[SETQ NEWTHING (LIST COMMAND (CADR (fetch (TEXT TEXTSTYLE)
of GINDTEXTELT]
(COND
((EQ GTYPE (QUOTE TEXT))
(create TEXT using GINDTEXTELT TEXTSTYLE ← NEWTHING))
(T (create TEXTBOX using GINDTEXTELT TEXTSTYLE ← NEWTHING]
[(TOP BOTTOM MIDDLE BASELINE)
(* change the vertical justification)
[SETQ NEWTHING (LIST (CAR (fetch (TEXT TEXTSTYLE)
of GINDTEXTELT))
(COND
((EQ COMMAND (QUOTE MIDDLE))
(QUOTE CENTER))
(T COMMAND]
(COND
((EQ GTYPE (QUOTE TEXT))
(create TEXT using GINDTEXTELT TEXTSTYLE ← NEWTHING))
(T (create TEXTBOX using GINDTEXTELT TEXTSTYLE ← NEWTHING]
[(BOLD UNBOLD ITALIC UNITALIC)
(* change the face)
(SETQ OLDFONT (fetch (TEXT FONT) of GINDTEXTELT))
(SETQ OLDFACE (FONTPROP OLDFONT (QUOTE FACE)))
[SETQ NEWTHING (LIST (FONTPROP OLDFONT (QUOTE FAMILY))
(FONTPROP OLDFONT (QUOTE SIZE))
(LIST (SELECTQ COMMAND
(BOLD (QUOTE BOLD))
(UNBOLD (QUOTE MEDIUM))
(CAR OLDFACE))
(SELECTQ COMMAND
(ITALIC (QUOTE ITALIC))
(UNITALIC (QUOTE
REGULAR))
(CADR OLDFACE))
(CADDR OLDFACE]
(COND
((EQ GTYPE (QUOTE TEXT))
(create TEXT using GINDTEXTELT FONT ← NEWTHING))
(T (create TEXTBOX using GINDTEXTELT FONT ← NEWTHING]
[BOX (* if it is a text element, BOX it)
(COND
((EQ GTYPE (QUOTE TEXT))
(RETURN (SK.TEXTBOX.FROM.TEXT ELTWITHTEXT SKW]
[UNBOX (* if it is a text box, unbox it.)
(COND
((EQ GTYPE (QUOTE TEXTBOX))
(RETURN (SK.TEXT.FROM.TEXTBOX ELTWITHTEXT SKW]
(SHOULDNT)))
(SETSIZE (SETQ NEWFONT COMMAND)
(COND
[(EQ (FONTPROP NEWFONT (QUOTE FAMILY))
(FONTPROP (fetch (TEXT FONT) of GINDTEXTELT)
(QUOTE FAMILY)))
(* if the families are the same, change them, otherwise
don't as it isn't known whether or not this family has
the right size.)
(COND
((EQ GTYPE (QUOTE TEXT))
(create TEXT using GINDTEXTELT FONT ← NEWFONT))
(T (create TEXTBOX using GINDTEXTELT FONT ← NEWFONT]
(T GINDTEXTELT)))
[NEWFONT (* set the font family)
[SETQ NEWFONT (LIST COMMAND (FONTPROP (SETQ OLDFONT
(fetch (TEXT FONT)
of GINDTEXTELT))
(QUOTE SIZE))
(FONTPROP OLDFONT (QUOTE FACE]
(OR (FONTCREATE NEWFONT NIL NIL NIL NIL T)
(STATUSPRINT SKW " Couldn't find " (CAR NEWFONT)
" in size "
(CADR NEWFONT))
(RETURN))
(COND
((EQ GTYPE (QUOTE TEXT))
(create TEXT using GINDTEXTELT FONT ← NEWFONT))
(T (create TEXTBOX using GINDTEXTELT FONT ← NEWFONT]
[FAMILY&SIZE (* set the font family and size)
[SETQ NEWFONT (LIST (CAR COMMAND)
(CADR COMMAND)
(FONTPROP (fetch (TEXT FONT) of GINDTEXTELT)
(QUOTE FACE]
(COND
((EQ GTYPE (QUOTE TEXT))
(create TEXT using GINDTEXTELT FONT ← NEWFONT))
(T (create TEXTBOX using GINDTEXTELT FONT ← NEWFONT]
(SAME (* set all of the font characteristics from the first
selected one.)
(SK.TEXT.ELT.WITH.SAME.FIELDS COMMAND GINDTEXTELT))
(SHOULDNT)))
(COND
((EQ GTYPE (QUOTE TEXT))
(TEXT.SET.GLOBAL.REGIONS NEWGTEXT))
(T (TEXTBOX.SET.GLOBAL.REGIONS NEWGTEXT)))
(RETURN (COND
((EQ GTYPE (QUOTE TEXT)) (* adjust the scales at which this appears because font
or scale may have changed.)
(TEXT.SET.SCALES (create GLOBALPART
COMMONGLOBALPART ←(fetch (GLOBALPART
COMMONGLOBALPART)
of ELTWITHTEXT)
INDIVIDUALGLOBALPART ← NEWGTEXT)))
(T (* scaling for text boxes depends on the box size which
can't change in this function.)
(create GLOBALPART
COMMONGLOBALPART ←(fetch (GLOBALPART COMMONGLOBALPART)
of ELTWITHTEXT)
INDIVIDUALGLOBALPART ← NEWGTEXT])
(TEXT.SET.SCALES
[LAMBDA (GTEXTELT) (* rrb "12-May-85 16:29")
(* sets the min and max scale properties of a global
text element. Called after something about the text
changes.)
(PROG [(COMMONPART (fetch (GLOBALPART COMMONGLOBALPART) of GTEXTELT))
(ORIGSCALE (fetch (TEXT INITIALSCALE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GTEXTELT]
(replace (COMMONGLOBALPART MINSCALE) of COMMONPART with (QUOTIENT ORIGSCALE 20.0))
(replace (COMMONGLOBALPART MAXSCALE) of COMMONPART
with (FTIMES (FONTHEIGHT (fetch (TEXT FONT) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GTEXTELT)))
ORIGSCALE))
(RETURN GTEXTELT])
(SK.FONT.LIST
[LAMBDA (FONTDESCRIPTOR) (* rrb " 2-Oct-85 14:41")
(* returns the font family, and size of a font
descriptor)
(LIST (FONTPROP FONTDESCRIPTOR (QUOTE FAMILY))
(FONTPROP FONTDESCRIPTOR (QUOTE SIZE))
(FONTPROP FONTDESCRIPTOR (QUOTE FACE])
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(TYPERECORD TEXT (LOCATIONLATLON LISTOFCHARACTERS INITIALSCALE TEXTSTYLE FONT LISTOFREGIONS
TEXTCOLOR))
(RECORD LOCALTEXT ((DISPLAYPOSITION)
LINEREGIONS LOCALFONT LOCALLISTOFCHARACTERS))
]
)
(DEFINEQ
(SK.SET.FONT
[LAMBDA (W NEWFONT) (* rrb " 2-Oct-85 14:55")
(* sets the entire default font. Used when a sketch stream is created. or any of the defaults are changed.
NEWFONT is a list of (FAMILY SIZE FACE))
(COND
(NEWFONT (COND
((FONTCREATE NEWFONT NIL NIL NIL NIL T)
(* clear the cache of looked up fonts. This provides the user a way of clearing the cache that shouldn't happen too
much and is documented.)
(AND (FASSOC (CAR NEWFONT)
\FONTSONFILE)
(SETQ \FONTSONFILE (for BUCKET in \FONTSONFILE
when (NEQ (CAR BUCKET)
(CAR NEWFONT))
collect BUCKET)))
(replace (SKETCHCONTEXT SKETCHFONT) of (WINDOWPROP W (QUOTE SKETCHCONTEXT))
with NEWFONT))
(T (STATUSPRINT W (CAR NEWFONT)
" "
(CADR NEWFONT)
" "
(SELECTQ (CAR (CADDR NEWFONT))
(BOLD (QUOTE BOLD))
"")
(SELECTQ (CADR (CADDR NEWFONT))
(ITALIC (QUOTE ITALIC))
"")
" not found"])
(SK.SET.TEXT.FONT
[LAMBDA (W) (* rrb " 4-Oct-85 16:21")
(* sets the size of the default arrowhead.)
(PROG [NEWFONT NOWFONT (SKCONTEXT (WINDOWPROP W (QUOTE SKETCHCONTEXT]
(SETQ NEWFONT (SK.READFONTFAMILY W (PACK* "now: " (CAR (SETQ NOWFONT
(fetch (SKETCHCONTEXT
SKETCHFONT)
of SKCONTEXT)))
" "
(CADR NOWFONT)
". New?")))
(COND
(NEWFONT (SK.SET.FONT W (LIST NEWFONT (CADR NOWFONT)
(CADDR NOWFONT])
(SK.SET.TEXT.SIZE
[LAMBDA (W) (* rrb " 2-Oct-85 14:36")
(* sets the size of the default font.)
(PROG (NEWSIZE (SKCONTEXT (WINDOWPROP W (QUOTE SKETCHCONTEXT)))
NOWFONT)
(SETQ NOWFONT (fetch (SKETCHCONTEXT SKETCHFONT) of SKCONTEXT))
(SETQ NEWSIZE (SK.READFONTSIZE NIL (FONTPROP NOWFONT (QUOTE FAMILY))
W))
(COND
(NEWSIZE (SK.SET.FONT W (LIST (CAR NOWFONT)
NEWSIZE
(CADDR NOWFONT])
(SK.SET.TEXT.HORIZ.ALIGN
[LAMBDA (SKW NEWALIGN) (* rrb " 1-Aug-85 11:50")
(* * reads a new value for the horizontal justification)
(PROG ([NEWJUST (COND
((MEMB NEWALIGN (QUOTE (CENTER LEFT RIGHT)))
NEWALIGN)
(T (MENU (create MENU
ITEMS ←(QUOTE ((" Center " (QUOTE CENTER)
"New text will be centered around its position")
("Left " (QUOTE LEFT)
"the left edge of the text will be at its position.")
(" Right" (QUOTE RIGHT)
"the right edge of the text will be at its position."]
SKCONTEXT)
(RETURN (AND NEWJUST (replace (SKETCHCONTEXT SKETCHTEXTALIGNMENT)
of (SETQ SKCONTEXT (WINDOWPROP SKW (QUOTE SKETCHCONTEXT)))
with (CONS NEWJUST (CDR (fetch (SKETCHCONTEXT SKETCHTEXTALIGNMENT)
of SKCONTEXT])
(SK.READFONTSIZE
[LAMBDA (TITLE FONTFAMILY SKW) (* rrb " 4-Sep-85 17:31")
(* * gets a legal known font size from the user.)
(* this should have MENUROWS ← 1 when title height bug
in menu package gets fixed.)
(PROG ((FONTSIZES (SK.COLLECT.FONT.SIZES FONTFAMILY))
NEWSIZE)
(COND
((NULL FONTSIZES)
(GO MORE)))
(SETQ NEWSIZE (MENU (create MENU
TITLE ←(COND
(TITLE)
(FONTFAMILY (CONCAT "new " FONTFAMILY " size?"))
(T "New font size?"))
ITEMS ←(CONS (QUOTE (More (QUOTE MORE)
"will look on font directories to find more sizes."))
FONTSIZES)
CENTERFLG ← T)))
(COND
((NEQ NEWSIZE (QUOTE MORE))
(RETURN NEWSIZE)))
MORE (* do longer search of files)
(SETQ NEWSIZE (SK.COLLECT.FONT.SIZES FONTFAMILY T))
(COND
((NULL NEWSIZE) (* could not find any fonts of that family)
(RETURN NIL))
((EQUAL NEWSIZE FONTSIZES) (* not new ones found)
(STATUSPRINT SKW "
No more font sizes found.")))
(RETURN (MENU (create MENU
TITLE ←(OR TITLE "New font size?")
ITEMS ← NEWSIZE
CENTERFLG ← T])
(SK.COLLECT.FONT.SIZES
[LAMBDA (FAMILY FILESTOOFLG) (* rrb " 2-Oct-85 10:43")
(* collects all of the sizes that are known.
If FAMILY is given, gets just those sizes.)
(PROG (INCORESIZES FILESIZES)
[COND
[FAMILY (for TYPEBUCKET in (CDR (FASSOC FAMILY \FONTSONFILE))
do (for FFONT in (CDR TYPEBUCKET) do (OR (MEMB (CADR FFONT)
INCORESIZES)
(SETQ INCORESIZES
(CONS (CADR FFONT)
INCORESIZES]
(T (* look at all fonts)
(for FAMILYBUCKET in \FONTSONFILE do (for TYPEBUCKET in (CDR FAMILYBUCKET)
do (for FFONT in (CDR TYPEBUCKET)
do (OR (MEMB (CADR FFONT)
INCORESIZES)
(SETQ INCORESIZES
(CONS (CADR FFONT)
INCORESIZES]
(RETURN (SORT (UNION INCORESIZES
(COND
[FILESTOOFLG (* wants those on files too, Flip the cursor to note
wait.)
(RESETFORM (CURSOR WAITINGCURSOR)
(bind SIZES for FONT
in (FONTSAVAILABLE (OR FAMILY
(QUOTE *))
(QUOTE *)
NIL NIL (QUOTE DISPLAY)
T)
do (OR (MEMB (FONTPROP FONT (QUOTE SIZE))
SIZES)
(SETQ SIZES
(CONS (FONTPROP FONT
(QUOTE SIZE))
SIZES)))
finally (RETURN SIZES]
(T (bind SIZES for FONT in (FONTSAVAILABLE (OR FAMILY (QUOTE *))
(QUOTE *)
NIL NIL (QUOTE DISPLAY)
FILESTOOFLG)
do (OR (MEMB (FONTPROP FONT (QUOTE SIZE))
SIZES)
(SETQ SIZES (CONS (FONTPROP FONT (QUOTE SIZE))
SIZES)))
finally (RETURN SIZES])
(SK.SET.TEXT.VERT.ALIGN
[LAMBDA (SKW NEWALIGN) (* rrb " 7-May-85 09:20")
(* * reads a new value for the vertical justification)
(PROG ([NEWJUST (COND
((MEMB NEWALIGN (QUOTE (TOP CENTER BASELINE BOTTOM)))
NEWALIGN)
(T (MENU (create MENU
TITLE ← "New vertical alignment?"
ITEMS ←(QUOTE (("Top" (QUOTE TOP)
"the top of new text's vertical extent will be at its position")
("Center" (QUOTE CENTER)
"New text's vertical extent will be centered around its position")
("Baseline" (QUOTE BASELINE)
"The baseline of new text will be at its position.")
("Bottom" (QUOTE BOTTOM)
"the bottom of new text's vertical extent will be at its position")))
CENTERFLG ← T]
SKCONTEXT)
(RETURN (AND NEWJUST (replace (SKETCHCONTEXT SKETCHTEXTALIGNMENT)
of (SETQ SKCONTEXT (WINDOWPROP SKW (QUOTE SKETCHCONTEXT)))
with (LIST (CAR (fetch (SKETCHCONTEXT SKETCHTEXTALIGNMENT)
of SKCONTEXT))
NEWJUST])
(SK.SET.TEXT.LOOKS
[LAMBDA (W) (* rrb "12-Jan-85 10:08")
(* * reads a new value for the looks of default text)
(SK.SET.DEFAULT.TEXT.FACE (MENU (create MENU
ITEMS ←(QUOTE ((regular (QUOTE (MEDIUM REGULAR REGULAR))
"new text will be neither bold nor italic.")
(bold (QUOTE (BOLD REGULAR REGULAR))
"new text will be bold.")
(italic (QUOTE (MEDIUM ITALIC REGULAR))
"new text will be italic.")
(bold/italic (QUOTE (BOLD ITALIC REGULAR))
"new text will be bold and italic.")))
TITLE ← "New default look"
CENTERFLG ← T))
W])
(SK.SET.DEFAULT.TEXT.FACE
[LAMBDA (NEWDEFAULTFACE SKW) (* rrb " 4-Oct-85 16:24")
(* changes the default text face to NEWDEFAULTFACE.)
(PROG [(NOWFONT (fetch (SKETCHCONTEXT SKETCHFONT) of (WINDOWPROP SKW (QUOTE
SKETCHCONTEXT]
(RETURN (AND NEWDEFAULTFACE (SK.SET.FONT SKW (LIST (CAR NOWFONT)
(CADR NOWFONT)
NEWDEFAULTFACE])
)
(DEFINEQ
(CREATE.SKETCH.TERMTABLE
[LAMBDA NIL (* rrb " 2-Oct-85 10:40")
(* returns a terminal table that has most characters
printing as REAL)
(* it is used by TEXT.DRAWFN1 to print strings in
sketch.)
(PROG ((TTBL (COPYTERMTABLE NIL)))
(for I from 128 to 255 do (AND (EQ (ECHOCHAR I NIL TTBL)
(QUOTE INDICATE))
(ECHOCHAR I (QUOTE REAL)
TTBL)))
(RETURN TTBL])
)
(RPAQQ INDICATE.TEXT.SHADE 23130)
(RPAQ? SK.DEFAULT.FONT )
(RPAQ? SK.DEFAULT.TEXT.ALIGNMENT (QUOTE (CENTER BASELINE)))
(RPAQ? \FONTSONFILE NIL)
(RPAQ SKETCH.TERMTABLE (CREATE.SKETCH.TERMTABLE))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS SKETCH.TERMTABLE SK.DEFAULT.TEXT.ALIGNMENT INDICATE.TEXT.SHADE \FONTSONFILE)
)
(* stuff for supporting the TEXTBOX sketch element.)
(DEFINEQ
(SK.BREAK.INTO.LINES
[LAMBDA (STRLST FONT WIDTH) (* rrb "14-Jun-85 18:04")
(* returns a list of lines {as strings} of the text stored on STRLST broken so that as many words as possible fit on
a line WIDTH wide.)
(COND
[(OR (FONTP FONT)
(WINDOWP FONT))
(PROG ((SPACEWIDTH (CHARWIDTH (CHARCODE % )
FONT))
(REMAINING WIDTH)
THISLINE NEWLST PREVCHARCR)
(for STR in STRLST
do (PROG ((BEGPTR 1)
(CHPTR 1)
(CHARSWID 0)
(LIMITPTR (ADD1 (NCHARS STR)))
CHCODE ENDPTR)
CHLP(COND
((EQ CHPTR LIMITPTR) (* ran out of characters.)
(COND
((EQ LIMITPTR 1) (* empty line, ignore it.)
(RETURN))
[(ILEQ CHARSWID REMAINING) (* this whole thing fits.)
(SETQ THISLINE (CONS [COND
((EQ BEGPTR 1)
(* save substring call.)
STR)
(T
(* put substring in.)
(SUBSTRING STR BEGPTR (SUB1 CHPTR]
(COND
(THISLINE
(* put a space in)
(CONS " " THISLINE]
(ENDPTR (* found a word or words that will fit, put them on
this line and finish this line.)
(SETQ NEWLST (CONS [CONS (COND
((EQ ENDPTR 0)
(* line began with a space and only it fit)
" ")
(T (SUBSTRING STR BEGPTR ENDPTR)))
(COND
(THISLINE
(* put a space in)
(CONS " " THISLINE]
NEWLST))
(SETQ THISLINE (CONS (OR (SUBSTRING STR (PLUS ENDPTR 2)
(SUB1 CHPTR))
"")))
(SETQ REMAINING WIDTH))
(T (* the remainder of this string goes on the next line.)
(AND THISLINE (SETQ NEWLST (CONS THISLINE NEWLST)))
[SETQ THISLINE (CONS (COND
((EQ BEGPTR 1)
(* save substring call.)
STR)
(T
(* put substring in.)
(SUBSTRING STR BEGPTR (SUB1 CHPTR]
(SETQ REMAINING WIDTH)))
(* decrement space remaining.)
(SETQ REMAINING (IDIFFERENCE REMAINING (IPLUS CHARSWID SPACEWIDTH)))
(RETURN) (* put the part of this line that didn't fit on the
next line.)
)
((EQ (CHARCODE % )
(SETQ CHCODE (NTHCHARCODE STR CHPTR)))
(* got to a space)
[COND
((ILEQ CHARSWID REMAINING) (* mark the end of something that we know fits.)
(* decrement space remaining.)
(SETQ REMAINING (DIFFERENCE REMAINING CHARSWID)))
(ENDPTR (* found a word or words that will fit, put them on
this line and finish this line.)
(SETQ NEWLST (CONS [CONS (OR (SUBSTRING STR BEGPTR ENDPTR)
"")
(COND
(THISLINE
(* put a space in)
(CONS " " THISLINE]
NEWLST))
(* reset the pointers to note this beginning.)
(SETQ THISLINE NIL)
(* ENDPTR is always just before a space, put the
beginning at the character following the space.)
(SETQ BEGPTR (PLUS ENDPTR 2))
(SETQ REMAINING (DIFFERENCE WIDTH CHARSWID)))
(T (* the rest of the current string goes on the next
line.)
(COND
(THISLINE (SETQ NEWLST (CONS THISLINE NEWLST))
(SETQ THISLINE NIL)))
(SETQ REMAINING (DIFFERENCE WIDTH CHARSWID]
(SETQ ENDPTR (SUB1 CHPTR))
(SETQ CHARSWID 0))
((EQ CHCODE (CHARCODE EOL)) (* CR, end a line.)
[COND
((GREATERP CHARSWID REMAINING)
(* the last word before the CR doesn't fit on this
line.)
(COND
(ENDPTR (* put some of it on the previous line)
(SETQ NEWLST (CONS [CONS (OR (SUBSTRING STR BEGPTR ENDPTR)
"")
(COND
(THISLINE
(* put a space in)
(CONS " " THISLINE]
NEWLST))
(SETQ THISLINE NIL)
(SETQ BEGPTR (PLUS ENDPTR 2)))
(T (* end the previous line and put this stuff on a new
one.)
(COND
(THISLINE (SETQ NEWLST (CONS THISLINE NEWLST))
(SETQ THISLINE NIL]
[SETQ THISLINE (CONS (COND
((AND (EQ (ADD1 CHPTR)
LIMITPTR)
(EQ BEGPTR 1))
(* last character of str, save substring call.
for efficiency)
STR)
(T (* put substring in.)
(SUBSTRING STR BEGPTR CHPTR)))
(COND
(THISLINE
(* put a space in)
(CONS " " THISLINE]
(SETQ NEWLST (CONS THISLINE NEWLST))
(SETQ THISLINE NIL)
(SETQ CHARSWID 0)
(SETQ REMAINING WIDTH)
(COND
((EQ (ADD1 CHPTR)
LIMITPTR)
(SETQ PREVCHARCR T)
(RETURN))
(T (SETQ BEGPTR (ADD1 CHPTR))
(SETQ ENDPTR)))
(SETQ CHPTR (ADD1 CHPTR))
(GO CHLP)))
(SETQ CHARSWID (PLUS CHARSWID (CHARWIDTH CHCODE FONT)))
(SETQ CHPTR (ADD1 CHPTR))
(SETQ PREVCHARCR NIL)
(GO CHLP)))
(RETURN (for LINE in [REVERSE (COND
(THISLINE (CONS THISLINE NEWLST))
(NEWLST (COND
(PREVCHARCR
(* if end of last line was a CR, put an empty line in
so cursor shows there.)
(CONS "" NEWLST))
(T NEWLST)))
(T (LIST ""]
collect (APPLY (FUNCTION CONCAT)
(REVERSE LINE]
(T (* if there isn't any font, it is probably SHADE.
Just leave the strings alone)
STRLST])
(SK.BRUSH.SIZE
[LAMBDA (SKBRUSH) (* rrb "30-Dec-84 13:38")
(* returns the size of a brush. This is used in places where the brush can be either an instance of the record BRUSH
or a thickness.)
(COND
((NUMBERP SKBRUSH))
(T (fetch (BRUSH BRUSHSIZE) of SKBRUSH])
(SK.TEXTBOX.CREATE
[LAMBDA (SKETCHREGION BRUSH SCALE WINDOW) (* rrb "12-Jul-85 17:18")
(* * creates a sketch element from a region)
(PROG [(CONTEXT (WINDOWPROP WINDOW (QUOTE SKETCHCONTEXT]
(RETURN (SK.TEXTBOX.CREATE1 SKETCHREGION BRUSH (LIST "")
SCALE
(fetch (SKETCHCONTEXT SKETCHTEXTBOXALIGNMENT) of CONTEXT)
(fetch (SKETCHCONTEXT SKETCHFONT) of CONTEXT)
(fetch (SKETCHCONTEXT SKETCHDASHING) of CONTEXT)
(fetch (SKETCHCONTEXT SKETCHFILLING) of CONTEXT])
(SK.TEXTBOX.CREATE1
[LAMBDA (SKETCHREGION BRUSH LSTOFSTRS INITSCALE STYLE INITFONT DASHING FILLING)
(* rrb " 5-May-85 18:42")
(BOX.SET.SCALES SKETCHREGION
(create GLOBALPART
INDIVIDUALGLOBALPART ←(TEXTBOX.SET.GLOBAL.REGIONS (create TEXTBOX
TEXTBOXREGION ←
SKETCHREGION
LISTOFCHARACTERS ←
LSTOFSTRS
INITIALSCALE ←
INITSCALE
TEXTSTYLE ←
STYLE
FONT ← INITFONT
TEXTBOXBRUSH ←
BRUSH
TEXTBOXDASHING
← DASHING
TEXTBOXFILLING
← FILLING])
(SK.TEXTBOX.POSITION.IN.BOX
[LAMBDA (REGION STYLE FONT BRUSHWIDTH) (* rrb "20-Feb-85 18:44")
(* returns the position that the text should be put at
to have it look right within box REGION, sytle STYLE in
font FONT)
(create POSITION
XCOORD ←(SELECTQ (CAR STYLE)
(LEFT (PLUS (fetch (REGION LEFT) of REGION)
BRUSHWIDTH))
(RIGHT (DIFFERENCE (fetch (REGION RIGHT) of REGION)
BRUSHWIDTH))
(CENTER (PLUS (fetch (REGION LEFT) of REGION)
(QUOTIENT (fetch (REGION WIDTH) of REGION)
2.0)))
(SHOULDNT))
YCOORD ←(SELECTQ (CADR STYLE)
(TOP (DIFFERENCE (fetch (REGION TOP) of REGION)
BRUSHWIDTH))
(BOTTOM (PLUS (fetch (REGION BOTTOM) of REGION)
BRUSHWIDTH))
(CENTER (PLUS (fetch (REGION BOTTOM) of REGION)
(QUOTIENT (fetch (REGION HEIGHT) of REGION)
2.0)))
(BASELINE (PLUS (fetch (REGION BOTTOM) of REGION)
(QUOTIENT (DIFFERENCE (fetch (REGION HEIGHT)
of REGION)
(FONTPROP FONT (QUOTE ASCENT)))
2.0)))
(SHOULDNT])
(TEXTBOX.CHANGEFN
[LAMBDA (SCRNELTS SKW HOW) (* rrb " 6-Jan-85 19:03")
(* the users has selected SCRNELT to be changed)
(SELECTQ (CAR HOW)
(TEXT (TEXT.CHANGEFN SCRNELTS SKW HOW))
(SIZE (CHANGE.ELTS.BRUSH.SIZE (CADR HOW)
SCRNELTS SKW))
NIL])
(TEXTBOX.DRAWFN
[LAMBDA (TEXTBOXELT WINDOW WINREG OPERATION) (* rrb " 9-Aug-85 17:53")
(* draws a text box element.)
(PROG ((INDVPART (fetch (SCREENELT INDIVIDUALGLOBALPART) of TEXTBOXELT))
(LOCALPART (fetch (SCREENELT LOCALPART) of TEXTBOXELT))
FILLING BRUSH)
(OR (NULL WINREG)
(REGIONSINTERSECTP WINREG (fetch (LOCALTEXTBOX LOCALTEXTBOXREGION) of LOCALPART))
(RETURN))
[COND
((TEXTUREP (SETQ FILLING (fetch (TEXTBOX TEXTBOXFILLING) of INDVPART)))
(* old format, update to new one which has a list of
(texture color))
(replace (TEXTBOX TEXTBOXFILLING) of INDVPART
with (SETQ FILLING (create SKFILLING
FILLING.TEXTURE ← FILLING
FILLING.COLOR ← NIL]
(SETQ BRUSH (fetch (LOCALTEXTBOX LOCALTEXTBOXBRUSH) of LOCALPART))
[COND
((OR (NULL FILLING)
(WINDOWP WINDOW)
(IMAGESTREAMTYPEP WINDOW (QUOTE DISPLAY)))
(* display supports writing over texture.)
(BOX.DRAWFN1 (fetch (LOCALTEXTBOX LOCALTEXTBOXREGION) of LOCALPART)
(fetch (BRUSH BRUSHSIZE) of BRUSH)
WINDOW WINREG OPERATION (fetch (TEXTBOX TEXTBOXDASHING) of INDVPART)
(fetch (SKFILLING FILLING.TEXTURE) of FILLING)
(fetch (BRUSH BRUSHCOLOR) of BRUSH)
(fetch (SKFILLING FILLING.COLOR) of FILLING)))
(T (* most devices can't operate in REPLACE mode so just
put texture where there won't be any text.)
(BOX.DRAWFN1 (fetch (LOCALTEXTBOX LOCALTEXTBOXREGION) of LOCALPART)
(fetch (BRUSH BRUSHSIZE) of (fetch (LOCALTEXTBOX LOCALTEXTBOXBRUSH)
of LOCALPART))
WINDOW WINREG OPERATION (fetch (TEXTBOX TEXTBOXDASHING) of INDVPART)
NIL
(fetch (BRUSH BRUSHCOLOR) of BRUSH))
(SK.TEXTURE.AROUND.REGIONS (fetch (LOCALTEXTBOX LOCALTEXTBOXREGION) of LOCALPART)
(fetch (LOCALTEXTBOX LINEREGIONS) of LOCALPART)
(fetch (SKFILLING FILLING.TEXTURE) of FILLING)
WINDOW
(fetch (SKFILLING FILLING.COLOR) of FILLING]
(COND
((AND (EQ (OR OPERATION (DSPOPERATION NIL WINDOW))
(QUOTE PAINT))
(fetch (TEXTBOX TEXTBOXFILLING) of INDVPART))
(* if in PAINT, change to replace mode so characters
will appear over text.)
(DSPOPERATION (QUOTE REPLACE)
WINDOW)
(DSPBACKCOLOR (PROG1 (DSPBACKCOLOR (fetch (SKFILLING FILLING.COLOR) of FILLING)
WINDOW)
(TEXT.DRAWFN1 (fetch (LOCALTEXTBOX LOCALLISTOFCHARACTERS)
of LOCALPART)
(fetch (LOCALTEXTBOX LINEREGIONS) of LOCALPART)
(fetch (LOCALTEXTBOX LOCALFONT) of LOCALPART)
(fetch (BRUSH BRUSHCOLOR) of BRUSH)
WINDOW))
WINDOW)
(DSPOPERATION (QUOTE PAINT)
WINDOW))
(T (TEXT.DRAWFN1 (fetch (LOCALTEXTBOX LOCALLISTOFCHARACTERS) of LOCALPART)
(fetch (LOCALTEXTBOX LINEREGIONS) of LOCALPART)
(fetch (LOCALTEXTBOX LOCALFONT) of LOCALPART)
(fetch (BRUSH BRUSHCOLOR) of BRUSH)
WINDOW])
(SK.TEXTURE.AROUND.REGIONS
[LAMBDA (BOXREGION INREGIONS TEXTURE STREAM COLOR) (* rrb "12-Jul-85 17:44")
(* puts texture inside of a box but not in a collection of interior regions. Assumes INREGIONS are in order from top
to bottom and abut in the Y direction.)
(PROG [BOXLEFT BOXRIGHT BOXTOP BOXBOTTOM X Y (MARGIN (TIMES 3 (DSPSCALE NIL STREAM]
(COND
((NULL INREGIONS)
(DSPFILL BOXREGION TEXTURE (QUOTE REPLACE)
STREAM)
(RETURN)))
(SETQ BOXLEFT (fetch (REGION LEFT) of BOXREGION))
(SETQ BOXBOTTOM (fetch (REGION BOTTOM) of BOXREGION))
(SETQ BOXTOP (fetch (REGION TOP) of BOXREGION))
(SETQ BOXRIGHT (fetch (REGION RIGHT) of BOXREGION))
(COND
([GREATERP BOXTOP (SETQ X (fetch (REGION TOP) of (CAR INREGIONS]
(* fill area above the first region)
(BLTSHADE TEXTURE STREAM BOXLEFT X (fetch (REGION WIDTH) of BOXREGION)
(DIFFERENCE BOXTOP X)
(QUOTE REPLACE)
NIL COLOR)))
[for LEAVEREGION in INREGIONS
do (COND
((GREATERP (SETQ X (DIFFERENCE (fetch (REGION LEFT) of LEAVEREGION)
MARGIN))
BOXLEFT) (* fill area to the left of this region)
(BLTSHADE TEXTURE STREAM BOXLEFT (fetch (REGION BOTTOM) of LEAVEREGION)
(DIFFERENCE X BOXLEFT)
(fetch (REGION HEIGHT) of LEAVEREGION)
(QUOTE REPLACE)
NIL COLOR)))
(COND
((GREATERP BOXRIGHT (SETQ X (PLUS (fetch (REGION RIGHT) of LEAVEREGION)
MARGIN)))
(* fill area to the right of this region)
(BLTSHADE TEXTURE STREAM (ADD1 X)
(fetch (REGION BOTTOM) of LEAVEREGION)
(DIFFERENCE BOXRIGHT X)
(fetch (REGION HEIGHT) of LEAVEREGION)
(QUOTE REPLACE)
NIL COLOR]
(COND
((GREATERP [SETQ X (fetch (REGION BOTTOM) of (CAR (LAST INREGIONS]
BOXBOTTOM) (* fill area below the last region)
(BLTSHADE TEXTURE STREAM BOXLEFT BOXBOTTOM (fetch (REGION WIDTH) of BOXREGION)
(DIFFERENCE X BOXBOTTOM)
(QUOTE REPLACE)
NIL COLOR])
(TEXTBOX.EXPANDFN
[LAMBDA (GTEXTBOXELT SCALE STREAM) (* rrb "13-Jun-85 10:49")
(* creates a local textbox screen element from a global
text box element)
(PROG ((GTEXTBOX (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXTBOXELT))
(CANONICALTESTSTR "AWIaiw")
LREG TEXTPOS LOCALFONT GFONT STYLE CANONICALWIDTH IMAGESTREAM LINEREGIONS BRUSHWIDTH
NEWLISTOFSTRS LOCALBRUSH) (* calculate the local brush)
(SETQ LOCALBRUSH (SCALE.BRUSH (COND
([NOT (NUMBERP (SETQ LOCALBRUSH (fetch (TEXTBOX
TEXTBOXBRUSH)
of GTEXTBOX]
(* new format, old format had brush width only.)
LOCALBRUSH)
(T [replace (TEXTBOX TEXTBOXBRUSH) of GTEXTBOX
with (SETQ LOCALBRUSH
(create BRUSH
BRUSHSIZE ← LOCALBRUSH
BRUSHSHAPE ←(QUOTE ROUND]
LOCALBRUSH))
(fetch (TEXTBOX INITIALSCALE) of GTEXTBOX)
SCALE)) (* calculate the local region for the text box.)
(SETQ LREG (SCALE.REGION (fetch (TEXTBOX TEXTBOXREGION) of GTEXTBOX)
SCALE))
(* use a canonical string to determine the font size so that all strings of a given font at a given scale look the
same. If font is determined by the width of the particular string, two different string will appear in different
fonts. In particular, the string may change fonts as the user is typing into it.)
(* don't use the face information when determining
string width because in some cases HELVETICA 10, the
bold is smaller than the regular.)
[SETQ CANONICALWIDTH (FIXR (QUOTIENT (TIMES [STRINGWIDTH
CANONICALTESTSTR
(LIST (FONTPROP (SETQ GFONT
(fetch (TEXTBOX FONT)
of GTEXTBOX))
(QUOTE FAMILY))
(FONTPROP GFONT (QUOTE SIZE]
(fetch (TEXTBOX INITIALSCALE) of GTEXTBOX))
(TIMES SCALE (DSPSCALE NIL STREAM]
(* calculate the local font.)
[SETQ LOCALFONT (SK.PICK.FONT CANONICALWIDTH CANONICALTESTSTR
[SETQ IMAGESTREAM (COND
((STREAMP STREAM))
(T (WINDOWPROP STREAM (QUOTE DSP]
(FONTPROP GFONT (QUOTE FAMILY]
[COND
((FONTP LOCALFONT)
(SETQ LOCALFONT (FONTCOPY LOCALFONT (QUOTE FACE)
(FONTPROP GFONT (QUOTE FACE]
(SETQ BRUSHWIDTH (ADD1 (QUOTIENT (fetch (BRUSH BRUSHSIZE) of LOCALBRUSH)
2)))
(* recalculate the line breaks for the particular stream given. This is necessary because the difference between
display and hardcopy must be taken into account.)
[SETQ NEWLISTOFSTRS (COND
[(FONTP LOCALFONT)
(SK.BREAK.INTO.LINES (fetch (TEXTBOX LISTOFCHARACTERS) of GTEXTBOX)
LOCALFONT
(COND
[(IMAGESTREAMTYPEP IMAGESTREAM (QUOTE HARDCOPY))
(* do the split on the basis of the hardcopy font)
(FIXR (TIMES (IDIFFERENCE (fetch (REGION WIDTH)
of LREG)
(ITIMES BRUSHWIDTH 2))
(PROGN
(* the scale should be a parameter of the hardcopy
font, maybe font widths scale.
but for now assume widths are in micas.)
MICASPERPT]
(T (IDIFFERENCE (fetch (REGION WIDTH) of LREG)
(ITIMES BRUSHWIDTH 2]
(T (* if not local font, leave line breaks alone.)
(fetch (TEXTBOX LISTOFCHARACTERS) of GTEXTBOX]
(SETQ STYLE (fetch (TEXTBOX TEXTSTYLE) of GTEXTBOX))
(SETQ LINEREGIONS (SK.TEXT.LINE.REGIONS (OR NEWLISTOFSTRS (QUOTE ("")))
(SK.TEXTBOX.POSITION.IN.BOX LREG STYLE GFONT
BRUSHWIDTH)
(fetch (TEXTBOX LISTOFREGIONS) of GTEXTBOX)
LOCALFONT GFONT STYLE SCALE IMAGESTREAM))
(RETURN (create SCREENELT
LOCALPART ←(create LOCALTEXTBOX
TEXTBOXLL ←(create POSITION
XCOORD ←(fetch (REGION LEFT)
of LREG)
YCOORD ←(fetch (REGION BOTTOM)
of LREG))
TEXTBOXUR ←(create POSITION
XCOORD ←(fetch (REGION PRIGHT)
of LREG)
YCOORD ←(fetch (REGION PTOP)
of LREG))
LINEREGIONS ← LINEREGIONS
LOCALFONT ← LOCALFONT
LOCALTEXTBOXREGION ← LREG
LOCALLISTOFCHARACTERS ← NEWLISTOFSTRS
LOCALTEXTBOXBRUSH ← LOCALBRUSH)
GLOBALPART ← GTEXTBOXELT])
(TEXTBOX.INPUTFN
[LAMBDA (W LREGION) (* rrb " 4-Sep-85 15:51")
(* creates a box element for a sketch window.
Prompts the user for one if none is given.)
(PROG (LOCALREG)
(COND
((REGIONP LREGION)
(SETQ LOCALREG LREGION))
[(NULL LREGION)
(COND
([SETQ LOCALREG (CAR (ERSETQ (GETWREGION W (FUNCTION SK.BOX.GETREGIONFN)
W]
(* WINDOWPROP will get exterior of window which should
really be reduced to the interior.)
(* make sure the last selected point wasn't outside.)
(OR (SUBREGIONP (DSPCLIPPINGREGION NIL W)
LOCALREG)
(RETURN)))
(T (RETURN]
(T (\ILLEGAL.ARG LREGION)))
(RETURN (SK.TEXTBOX.CREATE (UNSCALE.REGION.FROM.SKETCHW LOCALREG W)
(fetch (SKETCHCONTEXT SKETCHBRUSH) of (WINDOWPROP W
(QUOTE
SKETCHCONTEXT)))
(SK.INPUT.SCALE W)
W])
(TEXTBOX.INSIDEFN
[LAMBDA (GTEXTBOX WREG) (* rrb "30-Dec-84 17:23")
(* determines if the global TEXTBOX GTEXTBOX is inside
of WREG.)
(REGIONSINTERSECTP (fetch (TEXTBOX TEXTBOXREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GTEXTBOX))
WREG])
(TEXTBOX.REGIONFN
[LAMBDA (TEXTBOXSCRELT) (* rrb " 3-May-85 16:47")
(* returns the region occuppied by a box.)
(* is increased by the brush size This has the nice
property of insuring that the region always has both
height and width.)
(INCREASEREGION (fetch (LOCALTEXTBOX LOCALTEXTBOXREGION) of (fetch (SCREENELT LOCALPART)
of TEXTBOXSCRELT))
(SK.BRUSH.SIZE (fetch (TEXTBOX TEXTBOXBRUSH) of (fetch (SCREENELT
INDIVIDUALGLOBALPART)
of TEXTBOXSCRELT])
(TEXTBOX.SET.GLOBAL.REGIONS
[LAMBDA (GTEXTBOXELT) (* rrb " 3-Sep-85 17:05")
(* updates the list of characters and list of regions
occupied by the textbox in the global coordinate
space.)
(* this is used to determine the extent of a text
element in a region.)
(PROG [(SCALE (fetch (TEXTBOX INITIALSCALE) of GTEXTBOXELT))
(FONT (fetch (TEXTBOX FONT) of GTEXTBOXELT))
(LISTOFSTRS (fetch (TEXTBOX LISTOFCHARACTERS) of GTEXTBOXELT))
(TEXTSTYLE (fetch (TEXTBOX TEXTSTYLE) of GTEXTBOXELT))
(REGION (fetch (TEXTBOX TEXTBOXREGION) of GTEXTBOXELT))
(BRUSHWIDTH (ADD1 (SK.BRUSH.SIZE (fetch (TEXTBOX TEXTBOXBRUSH) of GTEXTBOXELT]
(replace (TEXTBOX LISTOFREGIONS) of GTEXTBOXELT
with (for LREG in (LTEXT.LINE.REGIONS LISTOFSTRS (SK.TEXTBOX.POSITION.IN.BOX REGION
TEXTSTYLE
FONT
BRUSHWIDTH)
FONT TEXTSTYLE (ITIMES (FONTHEIGHT FONT)
(LENGTH LISTOFSTRS)))
collect LREG))
(RETURN GTEXTBOXELT])
(TEXTBOX.TRANSLATEFN
[LAMBDA (SKELT DELTAPOS) (* rrb "28-Apr-85 18:46")
(* * returns a textbox element which has been translated by DELTAPOS)
(PROG ((GTEXTBOXELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of SKELT))
OLDREG NEWREG)
(SETQ NEWREG (REL.MOVE.REGION (SETQ OLDREG (fetch (TEXTBOX TEXTBOXREGION) of GTEXTBOXELT))
(fetch (POSITION XCOORD) of DELTAPOS)
(fetch (POSITION YCOORD) of DELTAPOS)))
(RETURN (TEXT.UPDATE.GLOBAL.REGIONS (create GLOBALPART
COMMONGLOBALPART ←(APPEND (fetch (GLOBALPART
COMMONGLOBALPART)
of SKELT))
INDIVIDUALGLOBALPART ←(create TEXTBOX
using GTEXTBOXELT
TEXTBOXREGION ←
NEWREG))
(create POSITION
XCOORD ←(fetch (REGION LEFT) of NEWREG)
YCOORD ←(fetch (REGION BOTTOM) of NEWREG))
(create POSITION
XCOORD ←(fetch (REGION LEFT) of OLDREG)
YCOORD ←(fetch (REGION BOTTOM) of OLDREG])
(TEXTBOX.TRANSLATEPTSFN
[LAMBDA (TEXTBOXELT SELPTS GDELTA WINDOW) (* rrb "31-May-85 10:41")
(* returns a closed wire element which has the knots
that are members of SELPTS translated by the global
amount GDELTA.)
(PROG ((GTEXTBOXELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of TEXTBOXELT))
OLDGLOBALREGION LLX LLY URX URY)
(SETQ OLDGLOBALREGION (fetch (TEXTBOX TEXTBOXREGION) of GTEXTBOXELT))
[COND
[(MEMBER (fetch (LOCALTEXTBOX TEXTBOXLL) of (fetch (SCREENELT LOCALPART) of TEXTBOXELT))
SELPTS) (* lower left point is moving.)
(SETQ LLX (PLUS (fetch (REGION LEFT) of OLDGLOBALREGION)
(fetch (POSITION XCOORD) of GDELTA)))
(SETQ LLY (PLUS (fetch (REGION BOTTOM) of OLDGLOBALREGION)
(fetch (POSITION YCOORD) of GDELTA]
(T (SETQ LLX (fetch (REGION LEFT) of OLDGLOBALREGION))
(SETQ LLY (fetch (REGION BOTTOM) of OLDGLOBALREGION]
[COND
[(MEMBER (fetch (LOCALTEXTBOX TEXTBOXUR) of (fetch (SCREENELT LOCALPART) of TEXTBOXELT))
SELPTS) (* upper right point)
(SETQ URX (PLUS (fetch (REGION PRIGHT) of OLDGLOBALREGION)
(fetch (POSITION XCOORD) of GDELTA)))
(SETQ URY (PLUS (fetch (REGION PTOP) of OLDGLOBALREGION)
(fetch (POSITION YCOORD) of GDELTA]
(T (SETQ URX (fetch (REGION PRIGHT) of OLDGLOBALREGION))
(SETQ URY (fetch (REGION PTOP) of OLDGLOBALREGION]
(RETURN (SK.TEXTBOX.CREATE1 (CREATEREGION (MIN LLX URX)
(MIN LLY URY)
(ABS (DIFFERENCE LLX URX))
(ABS (DIFFERENCE LLY URY)))
(fetch (TEXTBOX TEXTBOXBRUSH) of GTEXTBOXELT)
(fetch (TEXTBOX LISTOFCHARACTERS) of GTEXTBOXELT)
(fetch (TEXTBOX INITIALSCALE) of GTEXTBOXELT)
(fetch (TEXTBOX TEXTSTYLE) of GTEXTBOXELT)
(fetch (TEXTBOX FONT) of GTEXTBOXELT)
(fetch (TEXTBOX TEXTBOXDASHING) of GTEXTBOXELT)
(fetch (TEXTBOX TEXTBOXFILLING) of GTEXTBOXELT])
(TEXTBOX.TRANSFORMFN
[LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "12-Jul-85 17:29")
(* returns a copy of the global TEXTBOX element that has had each of its control points transformed by transformfn.
TRANSFORMDATA is arbitrary data that is passed to tranformfn. SCALEFACTOR is how much the transformation scales the
figure and is used to determine the size of the font.)
(PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)))
(* transform the font by changing the scale according to how much the width of the box around the first line of text
changes from the transformation.)
(RETURN (SK.TEXTBOX.CREATE1 (SK.TRANSFORM.REGION (fetch (TEXTBOX TEXTBOXREGION)
of INDVPART)
TRANSFORMFN TRANSFORMDATA)
(fetch (TEXTBOX TEXTBOXBRUSH) of INDVPART)
(fetch (TEXTBOX LISTOFCHARACTERS) of INDVPART)
(FTIMES (fetch (TEXTBOX INITIALSCALE) of INDVPART)
SCALEFACTOR)
(fetch (TEXTBOX TEXTSTYLE) of INDVPART)
(fetch (TEXTBOX FONT) of INDVPART)
(fetch (TEXTBOX TEXTBOXDASHING) of INDVPART)
(fetch (TEXTBOX TEXTBOXFILLING) of INDVPART])
(TEXTBOX.UPDATEFN
[LAMBDA (OLDLOCALELT NEWGELT SKETCHW) (* rrb "18-Jul-85 14:15")
(* update function for text inside of textboxes.
Tries to repaint only the lines of text that have
changed.)
(* takes advantage of the fact that all relevant text
fields are in the same place in TEXT and TEXTBOX
records.)
(* if the box size has changed, reprint the whole thing
anyway.)
(PROG ((NEWTB (fetch (GLOBALPART INDIVIDUALGLOBALPART) of NEWGELT))
(OLDTB (fetch (SCREENELT INDIVIDUALGLOBALPART) of OLDLOCALELT)))
(RETURN (COND
((AND (EQUAL (fetch (TEXTBOX TEXTBOXBRUSH) of NEWTB)
(fetch (TEXTBOX TEXTBOXBRUSH) of OLDTB))
(EQUAL (fetch (TEXTBOX TEXTBOXDASHING) of NEWTB)
(fetch (TEXTBOX TEXTBOXDASHING) of OLDTB))
(EQUAL (fetch (TEXTBOX TEXTBOXFILLING) of NEWTB)
(fetch (TEXTBOX TEXTBOXFILLING) of OLDTB))
(EQUAL (fetch (TEXTBOX TEXTCOLOR) of NEWTB)
(fetch (TEXTBOX TEXTCOLOR) of OLDTB)))
(DSPOPERATION (PROG1 (DSPOPERATION (QUOTE REPLACE)
SKETCHW)
(* change to replace mode to erase background.)
(SETQ NEWTB (TEXT.UPDATEFN OLDLOCALELT NEWGELT SKETCHW)))
SKETCHW)
NEWTB])
(TEXTBOX.READCHANGEFN
[LAMBDA (SKW SCRNELTS) (* rrb " 9-Aug-85 17:58")
(* reads how the user wants to change a textbox.)
(PROG ((COMMAND (MENU (create MENU
TITLE ← "Change which part?"
ITEMS ←[APPEND (COND
[(SKETCHINCOLORP)
(QUOTE (("Outline color" (QUOTE BRUSHCOLOR)
"changes the color of the outline")
("Filling color" (QUOTE FILLINGCOLOR)
"changes the color of the filling"]
(T NIL))
(QUOTE (("The text" (QUOTE TEXT)
"allows changing the properties of the text.")
("Box thickness" (QUOTE SIZE)
"changes the size of the brush")
(Dashing (QUOTE DASHING)
"changes the dashing of the box.")
(Filling (QUOTE FILLING)
"allows changing of the filling texture of the box.")
("Unbox the text" (QUOTE (TEXT UNBOX))
"takes the text out of any selected text boxes."]
CENTERFLG ← T)))
HOW)
(RETURN (SELECTQ COMMAND
(TEXT (TEXT.READCHANGEFN SKW SCRNELTS T))
(COND
((LISTP COMMAND)
COMMAND)
((SETQ HOW (SELECTQ COMMAND
(FILLING (READ.FILLING.CHANGE))
(SIZE (READSIZECHANGE "Change size how?" T))
(DASHING (READ.DASHING.CHANGE))
(BRUSHCOLOR (READ.COLOR.CHANGE
"Change outline color how?"))
(FILLINGCOLOR (READ.COLOR.CHANGE
"Change filling color how?"
T))
COMMAND))
(LIST COMMAND HOW])
(SK.TEXTBOX.TEXT.POSITION
[LAMBDA (GTEXTBOXELT) (* returns the position of the text in a text box
element.)
(create POSITION
XCOORD ←(fetch (REGION LEFT) of (SETQ GTEXTBOXELT (fetch (TEXTBOX TEXTBOXREGION)
of GTEXTBOXELT)))
YCOORD ←(fetch (REGION TOP) of GTEXTBOXELT])
(SK.TEXTBOX.FROM.TEXT
[LAMBDA (TEXTELT SKW) (* rrb " 4-Sep-85 16:49")
(* returns a textbox that replaces GTEXTELT.)
(PROG ((INDTEXTELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of TEXTELT))
BRUSH)
(RETURN (SK.TEXTBOX.CREATE1
(MAP.GLOBAL.REGION.ONTO.GRID
(INCREASEREGION (APPLY (FUNCTION UNIONREGIONS)
(fetch (TEXT LISTOFREGIONS) of INDTEXTELT))
(IQUOTIENT [ADD1 (SK.BRUSH.SIZE
(SETQ BRUSH
(fetch (BRUSH BRUSHSIZE)
of (fetch (SKETCHCONTEXT SKETCHBRUSH)
of (WINDOWPROP SKW (QUOTE
SKETCHCONTEXT]
2))
SKW)
BRUSH
(fetch (TEXT LISTOFCHARACTERS) of INDTEXTELT)
(fetch (TEXT INITIALSCALE) of INDTEXTELT)
(fetch (TEXT TEXTSTYLE) of INDTEXTELT)
(fetch (TEXT FONT) of INDTEXTELT])
(ADD.EOLS
[LAMBDA (STRLST) (* rrb "24-Jan-85 17:55")
(* adds an eol to every string in STRLST that doesn't
end in one.)
(for STR in STRLST collect (COND
((EQ (CHARCODE EOL)
(NTHCHARCODE STR -1))
STR)
(T (CONCAT STR "
"])
)
[DECLARE: EVAL@COMPILE
(RECORD LOCALTEXTBOX ((TEXTBOXLL TEXTBOXUR)
LINEREGIONS LOCALFONT LOCALLISTOFCHARACTERS LOCALTEXTBOXREGION
LOCALTEXTBOXBRUSH))
(TYPERECORD TEXTBOX (TEXTBOXREGION LISTOFCHARACTERS INITIALSCALE TEXTSTYLE FONT LISTOFREGIONS
TEXTCOLOR TEXTBOXBRUSH TEXTBOXDASHING TEXTBOXFILLING))
]
(* stuff to handle default alignment for text boxes)
(DEFINEQ
(SK.SET.TEXTBOX.VERT.ALIGN
[LAMBDA (SKW) (* rrb " 7-Jan-85 16:24")
(* * reads a new value for the vertical justification default for text boxes)
(PROG ((NEWJUST (MENU (create MENU
TITLE ← "New vertical alignment?"
ITEMS ←(QUOTE (("Top" (QUOTE TOP)
"the top of new text's vertical extent will be at its position")
("Center" (QUOTE CENTER)
"New text's vertical extent will be centered around its position")
("Baseline" (QUOTE BASELINE)
"The baseline of new text will be at its position.")
("Bottom" (QUOTE BOTTOM)
"the bottom of new text's vertical extent will be at its position")))
CENTERFLG ← T)))
SKCONTEXT)
(RETURN (AND NEWJUST (replace (SKETCHCONTEXT SKETCHTEXTBOXALIGNMENT)
of (SETQ SKCONTEXT (WINDOWPROP SKW (QUOTE SKETCHCONTEXT)))
with (LIST (CAR (fetch (SKETCHCONTEXT SKETCHTEXTBOXALIGNMENT)
of SKCONTEXT))
NEWJUST])
(SK.SET.TEXTBOX.HORIZ.ALIGN
[LAMBDA (SKW NEWALIGN) (* rrb " 7-Jan-85 16:24")
(* * reads a new value for the horizontal justification default for text boxes)
(PROG ([NEWJUST (OR NEWALIGN (MENU (create MENU
ITEMS ←(QUOTE ((" Center " (QUOTE CENTER)
"New text will be centered around its position")
("Left " (QUOTE LEFT)
"the left edge of the text will be at its position.")
(" Right" (QUOTE RIGHT)
"the right edge of the text will be at its position."]
SKCONTEXT)
(RETURN (AND NEWJUST (replace (SKETCHCONTEXT SKETCHTEXTBOXALIGNMENT)
of (SETQ SKCONTEXT (WINDOWPROP SKW (QUOTE SKETCHCONTEXT)))
with (CONS NEWJUST (CDR (fetch (SKETCHCONTEXT
SKETCHTEXTBOXALIGNMENT)
of SKCONTEXT])
)
(RPAQ TEXTBOXICON (READBITMAP))
(36 12
"OOOOOOOOO@@@"
"OOOOOOOOO@@@"
"L@@@@@@@C@@@"
"ML@@@N@@C@@@"
"LIMELIBEC@@@"
"LIDHHOEBC@@@"
"LILHHIEBC@@@"
"LIADHIEEC@@@"
"LIMDHNBEC@@@"
"L@@@@@@@C@@@"
"OOOOOOOOO@@@"
"OOOOOOOOO@@@")
(RPAQ? SK.DEFAULT.TEXTBOX.ALIGNMENT (QUOTE (CENTER CENTER)))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS SK.DEFAULT.TEXTBOX.ALIGNMENT)
)
(* functions to implement the box sketch element.)
(DEFINEQ
(SK.BOX.DRAWFN
[LAMBDA (BOXELT WIN WINREG OPERATION) (* rrb "19-Jul-85 16:34")
(* draws a box from its sketch element.)
(PROG ((INDVBOXELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of BOXELT))
(LOCALBOXELT (fetch (SCREENELT LOCALPART) of BOXELT))
FILLING BRUSH)
[COND
((TEXTUREP (SETQ FILLING (fetch (BOX BOXFILLING) of INDVBOXELT)))
(* old format, update to new one which has a list of
(texture color))
(replace (BOX BOXFILLING) of INDVBOXELT
with (SETQ FILLING (create SKFILLING
FILLING.TEXTURE ← FILLING
FILLING.COLOR ← NIL]
(RETURN (BOX.DRAWFN1 (fetch (LOCALBOX LOCALREGION) of LOCALBOXELT)
(fetch (BRUSH BRUSHSIZE) of (SETQ BRUSH (fetch (LOCALBOX LOCALBOXBRUSH)
of LOCALBOXELT)))
WIN WINREG OPERATION (fetch (BOX BOXDASHING) of INDVBOXELT)
(fetch (SKFILLING FILLING.TEXTURE) of FILLING)
(fetch (BRUSH BRUSHCOLOR) of BRUSH)
(fetch (SKFILLING FILLING.COLOR) of FILLING])
(BOX.DRAWFN1
[LAMBDA (REG SIZE WIN WINREG OPERATION DASHING TEXTURE OUTLINECOLOR FILLINGCOLOR)
(* rrb " 8-Aug-85 21:19")
(* draws a box. Used by both box and text box
elements.)
(COND
((OR (NULL WINREG)
(REGIONSINTERSECTP WINREG REG))
(COND
(FILLINGCOLOR (* call the filling routine that does color.)
(FILLPOLYGON (KNOTS.OF.REGION REG SIZE)
(create SKFILLING
FILLING.TEXTURE ← TEXTURE
FILLING.COLOR ← FILLINGCOLOR)
WIN))
(TEXTURE (DSPFILL REG TEXTURE OPERATION WIN)))
(SK.DRAWAREABOX (fetch (REGION LEFT) of REG)
(fetch (REGION BOTTOM) of REG)
(fetch (REGION WIDTH) of REG)
(fetch (REGION HEIGHT) of REG)
SIZE OPERATION WIN DASHING OUTLINECOLOR])
(KNOTS.OF.REGION
[LAMBDA (REGION BORDER) (* rrb "18-Jul-85 09:49")
(* returns the knots of the interior rectangle of a
region.)
(PROG (LFT BTM TP RGHT (HLFBORDER (FQUOTIENT BORDER 2.0)))
(SETQ LFT (PLUS (fetch (REGION LEFT) of REGION)
HLFBORDER))
(SETQ BTM (PLUS (fetch (REGION BOTTOM) of REGION)
HLFBORDER))
(SETQ TP (DIFFERENCE (fetch (REGION TOP) of REGION)
HLFBORDER))
(SETQ RGHT (DIFFERENCE (fetch (REGION RIGHT) of REGION)
HLFBORDER))
(RETURN (LIST (create POSITION
XCOORD ← LFT
YCOORD ← BTM)
(create POSITION
XCOORD ← LFT
YCOORD ← TP)
(create POSITION
XCOORD ← RGHT
YCOORD ← TP)
(create POSITION
XCOORD ← RGHT
YCOORD ← BTM])
(SK.DRAWAREABOX
[LAMBDA (LEFT BOTTOM WIDTH HEIGHT BORDER OP W DASHING COLOR)
(* rrb "12-Jul-85 17:53")
(* draws lines along the region. Copied from the function DRAWAREABOX in GRAPHER and changed to be the same as
drawing lines between the corner points.)
(PROG (BIG/HALF SM/HALF TOP HORIZLEFT HORIZRIGHT RIGHT)
(SETQ BIG/HALF (IQUOTIENT BORDER 2))
(SETQ SM/HALF (IQUOTIENT (SUB1 BORDER)
2))
(SETQ TOP (IPLUS BOTTOM HEIGHT))
(SETQ RIGHT (PLUS LEFT WIDTH)) (* draw left edge)
(DRAWLINE LEFT (DIFFERENCE BOTTOM SM/HALF)
LEFT
(PLUS TOP BIG/HALF)
BORDER OP W COLOR DASHING) (* draw top)
(DRAWLINE (SETQ HORIZLEFT (IPLUS LEFT BIG/HALF 1))
TOP
(SETQ HORIZRIGHT (SUB1 (IDIFFERENCE RIGHT SM/HALF)))
TOP BORDER OP W COLOR DASHING) (* draw right edge)
(DRAWLINE RIGHT (DIFFERENCE BOTTOM SM/HALF)
RIGHT
(PLUS TOP BIG/HALF)
BORDER OP W COLOR DASHING) (* draw bottom)
(DRAWLINE HORIZLEFT BOTTOM HORIZRIGHT BOTTOM BORDER OP W COLOR DASHING])
(SK.BOX.EXPANDFN
[LAMBDA (GBOX SCALE) (* rrb "31-May-85 10:22")
(* returns a local record which has the region field of
the global element GELT translated into window
coordinats.)
(* for now only allow to move the left-bottom or
right-top corner.)
(PROG ((INDGELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GBOX))
LREG)
[COND
((fetch (BOX BOXINITSCALE) of INDGELT))
(T (* old format didn't have an initial scale, default it
to 1.0)
(replace (GLOBALPART INDIVIDUALGLOBALPART) of GBOX
with (SETQ INDGELT (create BOX using INDGELT BOXINITSCALE ← 1.0]
(SETQ LREG (SCALE.REGION (fetch (BOX GLOBALREGION) of INDGELT)
SCALE))
(RETURN (create SCREENELT
LOCALPART ←(create LOCALBOX
BOXLL ←(create POSITION
XCOORD ←(fetch (REGION LEFT)
of LREG)
YCOORD ←(fetch (REGION BOTTOM)
of LREG))
BOXUR ←(create POSITION
XCOORD ←(fetch (REGION PRIGHT)
of LREG)
YCOORD ←(fetch (REGION PTOP)
of LREG))
LOCALREGION ← LREG
LOCALBOXBRUSH ←(SCALE.BRUSH
(COND
([NOT (NUMBERP (SETQ LREG (fetch (BOX BRUSH)
of INDGELT]
(* new format, old format had brush width only.)
LREG)
(T [replace (BOX BRUSH) of INDGELT
with (SETQ LREG
(create BRUSH
BRUSHSIZE ← LREG
BRUSHSHAPE ←(QUOTE ROUND]
LREG))
(fetch (BOX BOXINITSCALE) of INDGELT)
SCALE))
GLOBALPART ← GBOX])
(SK.BOX.GETREGIONFN
[LAMBDA (FIXPT MOVINGPT W) (* rrb "11-Jul-85 14:38")
(* getregion fn that generates an error if a point is
clicked outside of window. Also puts things on the
window grid.)
(SKETCHW.UPDATE.LOCATORS W)
(COND
[MOVINGPT (* this test the fixed pt every time which is
unnecessary but does allow us to catch button down.)
(COND
((INSIDEP (WINDOWPROP W (QUOTE REGION))
FIXPT)
(MAP.SCREEN.POSITION.ONTO.GRID MOVINGPT W (LASTMOUSESTATE RIGHT)))
(T (ERROR!]
(T (MAP.SCREEN.POSITION.ONTO.GRID FIXPT W (LASTMOUSESTATE RIGHT])
(BOX.SET.SCALES
[LAMBDA (GREG GBOXELT) (* rrb " 7-Feb-85 12:30")
(* updates the scale field after a change in the region
of a box element.)
(* removed the part of the scale that was limiting it to defaults. If it has to go back in, please leave a note as
to why.)
(PROG (WIDTH HEIGHT)
(replace (GLOBALPART MINSCALE) of GBOXELT with (FQUOTIENT (MIN (SETQ WIDTH
(fetch (REGION WIDTH)
of GREG))
(SETQ HEIGHT
(fetch (REGION HEIGHT)
of GREG)))
1000.0))
(replace (GLOBALPART MAXSCALE) of GBOXELT with (FQUOTIENT (MAX WIDTH HEIGHT)
2.0))
(RETURN GBOXELT])
(SK.BOX.INPUTFN
[LAMBDA (W LREGION) (* rrb " 4-Sep-85 15:50")
(* creates a box element for a sketch window.
Prompts the user for one if none is given.)
(PROG (LOCALREG SKCONTEXT)
(COND
((REGIONP LREGION)
(SETQ LOCALREG LREGION))
[(NULL LREGION)
(COND
([SETQ LOCALREG (CAR (ERSETQ (GETWREGION W (FUNCTION SK.BOX.GETREGIONFN)
W]
(* WINDOWPROP will get exterior of window which should
really be reduced to the interior.)
(* make sure the last selected point wasn't outside.)
(OR (SUBREGIONP (DSPCLIPPINGREGION NIL W)
LOCALREG)
(RETURN)))
(T (RETURN]
(T (\ILLEGAL.ARG LREGION)))
(RETURN (SK.BOX.CREATE (UNSCALE.REGION.FROM.SKETCHW LOCALREG W)
[fetch (SKETCHCONTEXT SKETCHBRUSH) of (SETQ SKCONTEXT
(WINDOWPROP W (QUOTE
SKETCHCONTEXT]
(fetch (SKETCHCONTEXT SKETCHDASHING) of SKCONTEXT)
(SK.INPUT.SCALE W)
(fetch (SKETCHCONTEXT SKETCHFILLING) of SKCONTEXT])
(SK.BOX.CREATE
[LAMBDA (SKETCHREGION BRUSH DASHING INITSCALE FILLING) (* rrb "26-Apr-85 10:52")
(* * creates a sketch element from a region)
(BOX.SET.SCALES SKETCHREGION
(create GLOBALPART
INDIVIDUALGLOBALPART ←(create BOX
GLOBALREGION ← SKETCHREGION
BRUSH ← BRUSH
BOXDASHING ← DASHING
BOXINITSCALE ← INITSCALE
BOXFILLING ← FILLING])
(SK.BOX.INSIDEFN
[LAMBDA (GBOX WREG) (* rrb " 5-AUG-83 16:04")
(* determines if the global BOX GBOX is inside of
WREG.)
(REGIONSINTERSECTP (fetch (BOX GLOBALREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GBOX))
WREG])
(SK.BOX.REGIONFN
[LAMBDA (BOXSCRLET) (* rrb " 3-Oct-85 17:12")
(* returns the region occuppied by a box.)
(INCREASEREGION (fetch (LOCALBOX LOCALREGION) of (fetch (SCREENELT LOCALPART)
of BOXSCRLET))
(fetch (BRUSH BRUSHSIZE) of (fetch (LOCALBOX LOCALBOXBRUSH)
of (fetch (SCREENELT LOCALPART)
of BOXSCRLET])
(SK.BOX.READCHANGEFN
[LAMBDA (SKW SCRNELTS) (* rrb "18-Jul-85 10:42")
(* the users has selected SCRNELT to be changed this
function reads a specification of how the box elements
should change.)
(PROG (ASPECT HOW)
(SETQ HOW (SELECTQ [SETQ ASPECT (MENU (create MENU
CENTERFLG ← T
TITLE ← "Which aspect?"
ITEMS ←(APPEND
(COND
[(SKETCHINCOLORP)
(QUOTE (("Brush color" (QUOTE
BRUSHCOLOR)
"changes the color of the outline")
("Filling color" (QUOTE
FILLINGCOLOR)
"changes the color of the filling"]
(T NIL))
(QUOTE ((Filling (QUOTE FILLING)
"allows changing of the filling texture of the box.")
(Size (QUOTE SIZE)
"changes the size of the brush")
(Dashing (QUOTE DASHING)
"changes the dashing of the line."]
(SIZE (READSIZECHANGE "Change size how?" T))
(FILLING (READ.FILLING.CHANGE))
(DASHING (READ.DASHING.CHANGE))
(BRUSHCOLOR (READ.COLOR.CHANGE "Change outline color how?"))
(FILLINGCOLOR (READ.COLOR.CHANGE "Change filling color how?" T))
NIL))
(RETURN (AND HOW (LIST ASPECT HOW])
(SK.CHANGE.FILLING
[LAMBDA (ELTWITHFILLING HOW SKW) (* rrb " 9-Aug-85 14:57")
(* changes the texture in the element ELTWITHFILLING.)
(PROG (GFILLEDELT TEXTURE FILLING TYPE NEWELT)
(AND (EQ HOW (QUOTE NONE))
(SETQ HOW NIL))
(RETURN (COND
((MEMB (SETQ TYPE (fetch (GLOBALPART GTYPE) of ELTWITHFILLING))
(QUOTE (BOX TEXTBOX CLOSEDWIRE CIRCLE)))
(* only works for things that have a filling, for now
just boxes and polygons)
(SETQ GFILLEDELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHFILLING))
[SETQ TEXTURE (fetch (SKFILLING FILLING.TEXTURE)
of (SETQ FILLING (SELECTQ TYPE
(BOX (fetch (BOX BOXFILLING)
of GFILLEDELT))
(TEXTBOX (fetch (TEXTBOX
TEXTBOXFILLING)
of GFILLEDELT))
(CLOSEDWIRE (fetch (CLOSEDWIRE
CLOSEDWIREFILLING)
of GFILLEDELT))
(CIRCLE (fetch (CIRCLE CIRCLEFILLING)
of GFILLEDELT))
(SHOULDNT]
(COND
((NOT (EQUAL HOW TEXTURE)) (* new filling)
(SETQ NEWELT (create SKFILLING using FILLING FILLING.TEXTURE ← HOW))
(SETQ NEWELT (SELECTQ TYPE
(BOX (create BOX using GFILLEDELT BOXFILLING ← NEWELT)
)
(TEXTBOX (create TEXTBOX using GFILLEDELT
TEXTBOXFILLING ←
NEWELT))
(CLOSEDWIRE (create CLOSEDWIRE
using GFILLEDELT CLOSEDWIREFILLING ←
NEWELT))
(CIRCLE (create CIRCLE using GFILLEDELT CIRCLEFILLING
← NEWELT))
(SHOULDNT)))
(create GLOBALPART
COMMONGLOBALPART ←(fetch (GLOBALPART COMMONGLOBALPART)
of ELTWITHFILLING)
INDIVIDUALGLOBALPART ← NEWELT])
(SK.CHANGE.FILLING.COLOR
[LAMBDA (ELTWITHFILLING HOW SKW) (* rrb "18-Jul-85 10:26")
(* changes the texture in the element ELTWITHFILLING.)
(PROG (GFILLEDELT COLOR FILLING TYPE NEWELT)
(AND (EQ HOW (QUOTE NONE))
(SETQ HOW NIL))
(RETURN (COND
((MEMB (SETQ TYPE (fetch (GLOBALPART GTYPE) of ELTWITHFILLING))
(QUOTE (BOX TEXTBOX CLOSEDWIRE)))
(* only works for things that have a filling, for now
just boxes and polygons)
(SETQ GFILLEDELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHFILLING))
[SETQ COLOR (fetch (SKFILLING FILLING.COLOR)
of (SETQ FILLING (SELECTQ TYPE
(BOX (fetch (BOX BOXFILLING)
of GFILLEDELT))
(TEXTBOX (fetch (TEXTBOX
TEXTBOXFILLING)
of GFILLEDELT))
(CLOSEDWIRE (fetch (CLOSEDWIRE
CLOSEDWIREFILLING)
of GFILLEDELT))
(SHOULDNT]
(COND
((NOT (EQUAL HOW COLOR)) (* new filling)
(SETQ NEWELT (create SKFILLING using FILLING FILLING.COLOR ← HOW))
(SETQ NEWELT (SELECTQ TYPE
(BOX (create BOX using GFILLEDELT BOXFILLING ← NEWELT)
)
(TEXTBOX (create TEXTBOX using GFILLEDELT
TEXTBOXFILLING ←
NEWELT))
(CLOSEDWIRE (create CLOSEDWIRE
using GFILLEDELT CLOSEDWIREFILLING ←
NEWELT))
(SHOULDNT)))
(create GLOBALPART
COMMONGLOBALPART ←(fetch (GLOBALPART COMMONGLOBALPART)
of ELTWITHFILLING)
INDIVIDUALGLOBALPART ← NEWELT])
(SK.BOX.TRANSLATEFN
[LAMBDA (SKELT DELTAPOS) (* rrb "28-Apr-85 18:46")
(* * returns a curve element which has the box translated by DELTAPOS)
(PROG ((GBOXELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of SKELT)))
(RETURN (create GLOBALPART
COMMONGLOBALPART ←(APPEND (fetch (GLOBALPART COMMONGLOBALPART)
of SKELT))
INDIVIDUALGLOBALPART ←(create BOX using GBOXELT GLOBALREGION ←(
REL.MOVE.REGION
(fetch (BOX GLOBALREGION)
of GBOXELT)
(fetch (POSITION XCOORD)
of DELTAPOS)
(fetch (POSITION YCOORD)
of DELTAPOS])
(SK.BOX.TRANSFORMFN
[LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "12-Jul-85 17:16")
(* returns a copy of the global BOX element that has had each of its control points transformed by transformfn.
TRANSFORMDATA is arbitrary data that is passed to tranformfn.)
(PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)))
(RETURN (SK.BOX.CREATE (SK.TRANSFORM.REGION (fetch (BOX GLOBALREGION) of INDVPART)
TRANSFORMFN TRANSFORMDATA)
(SK.TRANSFORM.BRUSH (fetch (BOX BRUSH) of INDVPART)
SCALEFACTOR)
(fetch (BOX BOXDASHING) of INDVPART)
(fetch (BOX BOXINITSCALE) of INDVPART)
(fetch (BOX BOXFILLING) of INDVPART])
(SK.BOX.TRANSLATEPTSFN
[LAMBDA (BOXELT SELPTS GDELTA WINDOW) (* rrb "12-Jul-85 17:55")
(* returns a closed wire element which has the knots
that are members of SELPTS translated by the global
amount GDELTA.)
(PROG ((GBOXELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of BOXELT))
OLDGLOBALREGION LLX LLY URX URY)
(SETQ OLDGLOBALREGION (fetch (BOX GLOBALREGION) of GBOXELT))
[COND
[(MEMBER (fetch (LOCALBOX BOXLL) of (fetch (SCREENELT LOCALPART) of BOXELT))
SELPTS) (* lower left point is moving.)
(SETQ LLX (PLUS (fetch (REGION LEFT) of OLDGLOBALREGION)
(fetch (POSITION XCOORD) of GDELTA)))
(SETQ LLY (PLUS (fetch (REGION BOTTOM) of OLDGLOBALREGION)
(fetch (POSITION YCOORD) of GDELTA]
(T (SETQ LLX (fetch (REGION LEFT) of OLDGLOBALREGION))
(SETQ LLY (fetch (REGION BOTTOM) of OLDGLOBALREGION]
[COND
[(MEMBER (fetch (LOCALBOX BOXUR) of (fetch (SCREENELT LOCALPART) of BOXELT))
SELPTS) (* upper right point)
(SETQ URX (PLUS (fetch (REGION PRIGHT) of OLDGLOBALREGION)
(fetch (POSITION XCOORD) of GDELTA)))
(SETQ URY (PLUS (fetch (REGION PTOP) of OLDGLOBALREGION)
(fetch (POSITION YCOORD) of GDELTA]
(T (SETQ URX (fetch (REGION PRIGHT) of OLDGLOBALREGION))
(SETQ URY (fetch (REGION PTOP) of OLDGLOBALREGION]
(RETURN (SK.BOX.CREATE (CREATEREGION (MIN LLX URX)
(MIN LLY URY)
(ABS (DIFFERENCE LLX URX))
(ABS (DIFFERENCE LLY URY)))
(fetch (BOX BRUSH) of GBOXELT)
(fetch (BOX BOXDASHING) of GBOXELT)
(fetch (BOX BOXINITSCALE) of GBOXELT)
(fetch (BOX BOXFILLING) of GBOXELT])
(UNSCALE.REGION.FROM.SKETCHW
[LAMBDA (LREG WINDOW) (* rrb "25-Oct-84 12:53")
(* returns the global region that corresponds to a
local region.)
(UNSCALE.REGION.TO.GRID LREG (SKETCHW.SCALE WINDOW)
(AND (WINDOWPROP WINDOW (QUOTE USEGRID))
(SK.GRIDFACTOR WINDOW])
(UNSCALE.REGION.TO.GRID
[LAMBDA (REGION SCALE GRIDSIZE) (* rrb "25-Oct-84 12:53")
(* scales a region from a window region to the larger
coordinate space.)
(PROG [(LFT (TIMES SCALE (fetch (REGION LEFT) of REGION)))
(BTM (TIMES SCALE (fetch (REGION BOTTOM) of REGION)))
(WDTH (TIMES SCALE (fetch (REGION WIDTH) of REGION)))
(HGHT (TIMES SCALE (fetch (REGION HEIGHT) of REGION]
[COND
(GRIDSIZE (* move X and Y to nearest point on the grid)
(SETQ LFT (NEAREST.ON.GRID LFT GRIDSIZE))
(SETQ BTM (NEAREST.ON.GRID BTM GRIDSIZE))
(SETQ WDTH (NEAREST.ON.GRID WDTH GRIDSIZE))
(SETQ HGHT (NEAREST.ON.GRID HGHT GRIDSIZE]
(RETURN (CREATEREGION LFT BTM WDTH HGHT])
(INCREASEREGION
[LAMBDA (REGION BYAMOUNT) (* rrb " 9-Sep-84 19:58")
(* * increases a region by a fixed amount in all directions.)
(CREATEREGION (DIFFERENCE (fetch (REGION LEFT) of REGION)
BYAMOUNT)
(DIFFERENCE (fetch (REGION BOTTOM) of REGION)
BYAMOUNT)
(PLUS (fetch (REGION WIDTH) of REGION)
(TIMES BYAMOUNT 2))
(PLUS (fetch (REGION HEIGHT) of REGION)
(TIMES BYAMOUNT 2])
(INSUREREGIONSIZE
[LAMBDA (REGION MINSIZE) (* rrb " 5-Dec-84 11:27")
(* * makes sure the height and width of REGION are at least MINSIZE.)
(PROG (X)
(COND
((GREATERP MINSIZE (SETQ X (fetch (REGION WIDTH) of REGION)))
(replace (REGION LEFT) of REGION with (DIFFERENCE (fetch (REGION LEFT) of REGION)
(QUOTIENT (DIFFERENCE MINSIZE X)
2)))
(replace (REGION WIDTH) of REGION with MINSIZE)))
(COND
((GREATERP MINSIZE (SETQ X (fetch (REGION HEIGHT) of REGION)))
(replace (REGION BOTTOM) of REGION with (DIFFERENCE (fetch (REGION BOTTOM)
of REGION)
(QUOTIENT (DIFFERENCE MINSIZE X)
2)))
(replace (REGION HEIGHT) of REGION with MINSIZE)))
(RETURN REGION])
(EXPANDREGION
[LAMBDA (REGION BYFACTOR) (* rrb "30-Nov-84 10:43")
(* * expands a region by a factor.)
(PROG ((WIDTH (fetch (REGION WIDTH) of REGION))
(HEIGHT (fetch (REGION HEIGHT) of REGION))
NEWWIDTH NEWHEIGHT)
(SETQ NEWWIDTH (TIMES WIDTH BYFACTOR))
(SETQ NEWHEIGHT (TIMES HEIGHT BYFACTOR))
(RETURN (CREATEREGION (DIFFERENCE (fetch (REGION LEFT) of REGION)
(QUOTIENT (IDIFFERENCE NEWWIDTH WIDTH)
2))
(DIFFERENCE (fetch (REGION BOTTOM) of REGION)
(QUOTIENT (IDIFFERENCE NEWHEIGHT HEIGHT)
2))
NEWWIDTH NEWHEIGHT])
(REGION.FROM.COORDINATES
[LAMBDA (X1 Y1 X2 Y2) (* rrb "11-Sep-84 16:27")
(* * returns the region for which { X1 Y1 } and { X2 Y2} are the corners.)
(CREATEREGION (MIN X1 X2)
(MIN Y1 Y2)
(ADD1 (ABS (IDIFFERENCE X2 X1)))
(ADD1 (ABS (IDIFFERENCE Y2 Y1])
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(TYPERECORD BOX (GLOBALREGION BRUSH BOXDASHING BOXINITSCALE BOXFILLING))
(RECORD LOCALBOX ((BOXLL BOXUR)
LOCALREGION LOCALBOXBRUSH))
]
)
(READVARS BOXICON)
({(READBITMAP)(20 12
"@@@@@@@@"
"GOOON@@@"
"GOOON@@@"
"F@@@F@@@"
"F@@@F@@@"
"F@@@F@@@"
"F@@@F@@@"
"F@@@F@@@"
"F@@@F@@@"
"GOOON@@@"
"GOOON@@@"
"@@@@@@@@")})
(* fns for the arc sketch element type)
(DEFINEQ
(ARC.DRAWFN
[LAMBDA (ARCELT WINDOW REGION) (* rrb "30-May-85 10:34")
(* draws a arc from a arc element.)
(PROG ((GARC (fetch (SCREENELT INDIVIDUALGLOBALPART) of ARCELT))
(LARC (fetch (SCREENELT LOCALPART) of ARCELT))
BRUSH)
(AND REGION (NOT (REGIONSINTERSECTP REGION (SK.ITEM.REGION ARCELT)))
(RETURN)) (* draw the curve from the knots)
(DRAWCURVE (fetch (LOCALARC LOCALARCKNOTS) of LARC)
NIL
(SETQ BRUSH (fetch (LOCALARC LOCALARCBRUSH) of LARC))
(fetch (ARC ARCDASHING) of GARC)
WINDOW)
(DRAWARROWHEADS (fetch (ARC ARCARROWHEADS) of GARC)
(fetch (LOCALARC LOCALARCARROWHEADPTS) of LARC)
WINDOW BRUSH])
(ARC.EXPANDFN
[LAMBDA (GARC SCALE) (* rrb " 2-Jun-85 13:22")
(* returns a screen elt that has a arc screen element
calculated from the global part.)
(PROG ((INDGARC (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GARC))
CENTER RADIUSPT ANGLEPT LOCALKNOTS)
(SETQ CENTER (SK.SCALE.POSITION.INTO.VIEWER (fetch (ARC ARCCENTERPT) of INDGARC)
SCALE))
(SETQ RADIUSPT (SK.SCALE.POSITION.INTO.VIEWER (fetch (ARC ARCRADIUSPT) of INDGARC)
SCALE))
(SETQ ANGLEPT (SK.SCALE.POSITION.INTO.VIEWER (fetch (ARC ARCANGLEPT) of INDGARC)
SCALE))
(SETQ LOCALKNOTS (SK.COMPUTE.ARC.PTS CENTER RADIUSPT ANGLEPT (fetch (ARC ARCDIRECTION)
of INDGARC)))
(RETURN (create SCREENELT
LOCALPART ←(create LOCALARC
LOCALARCCENTERPT ← CENTER
LOCALARCRADIUSPT ← RADIUSPT
LOCALARCANGLEPT ← ANGLEPT
LOCALARCARROWHEADPTS ←(SK.EXPAND.ARROWHEADS INDGARC
LOCALKNOTS
SCALE)
LOCALARCBRUSH ←(SCALE.BRUSH (fetch (ARC ARCBRUSH)
of INDGARC)
(fetch (ARC ARCINITSCALE)
of INDGARC)
SCALE)
LOCALARCKNOTS ← LOCALKNOTS)
GLOBALPART ← GARC])
(ARC.INPUTFN
[LAMBDA (WINDOW) (* rrb " 4-Sep-85 15:48")
(* reads three points from the user and returns the arc
figure element that it represents.)
(PROG (CENTER RADPT ANGLEPT SKCONTEXT)
(STATUSPRINT WINDOW "
" "Indicate center of the arc")
(COND
((SETQ CENTER (GETSKWPOSITION WINDOW ELLIPSE.CENTER))
(MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of CENTER)
NIL WINDOW))
(T (CLOSEPROMPTWINDOW WINDOW)
(RETURN NIL)))
(STATUSPRINT WINDOW "
" "Indicate end of the arc")
(COND
((SETQ RADPT (GETSKWPOSITION WINDOW ARC.RADIUS.CURSOR))
(MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of RADPT)
NIL WINDOW))
(T (* erase center pt on way out)
(MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of CENTER)
NIL WINDOW)
(CLOSEPROMPTWINDOW WINDOW)
(RETURN NIL)))
(STATUSPRINT WINDOW "
" "Indicate the angle of the arc")
(SETQ ANGLEPT (GETSKWPOSITION WINDOW ARC.ANGLE.CURSOR))
(CLOSEPROMPTWINDOW WINDOW) (* erase the point marks.)
(MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of RADPT)
NIL WINDOW)
(MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of CENTER)
NIL WINDOW)
(OR ANGLEPT (RETURN NIL))
(* the list of knots passed to SK.ARROWHEAD.CREATE is only used to determine right and left so don't bother to
create a good one. Actually this introduces a bug when the angle point is not on the same side of the radius point
as the end of the arc is. should fix.)
(RETURN (ARC.CREATE (SK.MAP.INPUT.PT.TO.GLOBAL CENTER WINDOW)
(SK.MAP.INPUT.PT.TO.GLOBAL RADPT WINDOW)
(SK.MAP.INPUT.PT.TO.GLOBAL ANGLEPT WINDOW)
[fetch (SKETCHCONTEXT SKETCHBRUSH) of (SETQ SKCONTEXT
(WINDOWPROP WINDOW
(QUOTE
SKETCHCONTEXT]
(fetch (SKETCHCONTEXT SKETCHDASHING) of SKCONTEXT)
(SK.INPUT.SCALE WINDOW)
(SK.ARROWHEAD.CREATE WINDOW (LIST RADPT ANGLEPT))
(fetch (SKETCHCONTEXT SKETCHARCDIRECTION) of SKCONTEXT])
(ARC.CREATE
[LAMBDA (CENTERPT RADPT ANGLEPT BRUSH DASHING INITSCALE ARROWHEADS DIRECTION)
(* rrb "19-Jul-85 14:35")
(* creates a global arc element.)
(SET.ARC.SCALES (create GLOBALPART
INDIVIDUALGLOBALPART ←(create ARC
ARCCENTERPT ← CENTERPT
ARCRADIUSPT ← RADPT
ARCBRUSH ← BRUSH
ARCDASHING ← DASHING
ARCINITSCALE ← INITSCALE
ARCARROWHEADS ← ARROWHEADS
ARCANGLEPT ←(SK.COMPUTE.ARC.ANGLE.PT
CENTERPT
RADPT
ANGLEPT)
ARCDIRECTION ← DIRECTION])
(ARC.MOVEFN
[LAMBDA (ARCELT SELPOS NEWPOS WINDOW) (* rrb "30-May-85 13:21")
(* returns a global arc element which has the part
SELPOS moved to NEWPOS.)
(PROG ((LOCALEL (fetch (SCREENELT LOCALPART) of ARCELT))
(GLOBALEL (fetch (SCREENELT INDIVIDUALGLOBALPART) of ARCELT))
CENTERPT ANGLEPT RADPT PTSCALE)
(SETQ CENTERPT (fetch (ARC ARCCENTERPT) of GLOBALEL))
(SETQ ANGLEPT (fetch (ARC ARCANGLEPT) of GLOBALEL))
(SETQ RADPT (fetch (ARC ARCRADIUSPT) of GLOBALEL))
(* find the point that has moved and change it.)
[COND
((EQUAL SELPOS (fetch (LOCALARC LOCALARCCENTERPT) of LOCALEL))
(SETQ CENTERPT (SK.MAP.FROM.WINDOW.TO.GLOBAL.GRID NEWPOS WINDOW)))
((EQUAL SELPOS (fetch (LOCALARC LOCALARCRADIUSPT) of LOCALEL))
(SETQ RADPT (SK.MAP.FROM.WINDOW.TO.GLOBAL.GRID NEWPOS WINDOW)))
((EQUAL SELPOS (fetch (LOCALARC LOCALARCANGLEPT) of LOCALEL))
(SETQ ANGLEPT (SK.MAP.FROM.WINDOW.TO.GLOBAL.GRID NEWPOS WINDOW]
(* return a new global elt because the orientation
changes but is needed to erase the one that is already
on the screen.)
(RETURN (SK.CREATE.ARC.USING CENTERPT RADPT ANGLEPT GLOBALEL])
(ARC.TRANSLATEPTS
[LAMBDA (ARCELT SELPTS GLOBALDELTA WINDOW) (* rrb "30-May-85 13:05")
(* returns a new global arc element which has the
points on SELPTS moved by a global distance.)
(PROG ((LOCALEL (fetch (SCREENELT LOCALPART) of ARCELT))
(GLOBALEL (fetch (SCREENELT INDIVIDUALGLOBALPART) of ARCELT))
CENTERPT ANGLEPT RADPT PTSCALE)
(SETQ CENTERPT (fetch (ARC ARCCENTERPT) of GLOBALEL))
(SETQ ANGLEPT (fetch (ARC ARCANGLEPT) of GLOBALEL))
(SETQ RADPT (fetch (ARC ARCRADIUSPT) of GLOBALEL))
(* find the point that has moved and change it.)
[COND
((MEMBER (fetch (LOCALARC LOCALARCCENTERPT) of LOCALEL)
SELPTS)
(SETQ CENTERPT (PTPLUS CENTERPT GLOBALDELTA)))
((MEMBER (fetch (LOCALARC LOCALARCRADIUSPT) of LOCALEL)
SELPTS)
(SETQ RADPT (PTPLUS RADPT GLOBALDELTA)))
((MEMBER (fetch (LOCALARC LOCALARCANGLEPT) of LOCALEL)
SELPTS)
(SETQ ANGLEPT (PTPLUS ANGLEPT GLOBALDELTA]
(RETURN (SK.CREATE.ARC.USING CENTERPT RADPT ANGLEPT GLOBALEL])
(ARC.INSIDEFN
[LAMBDA (GARC WREG) (* rrb "30-May-85 13:20")
(* determines if the global arc GARC is inside of
WREG.)
(* consider an arc inside only if one of its control
points is inside.)
(PROG ((INDGARC (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GARC)))
(RETURN (OR (INSIDEP WREG (fetch (ARC ARCCENTERPT) of INDGARC))
(INSIDEP WREG (fetch (ARC ARCRADIUSPT) of INDGARC))
(INSIDEP WREG (fetch (ARC ARCANGLEPT) of INDGARC])
(ARC.REGIONFN
[LAMBDA (ARCSCRELT) (* rrb "30-May-85 12:23")
(* returns the region occuppied by an arc.)
(* uses the heuristic that the region containing the curve is not more than 10% larger than the knots.
This was determined empirically on several curves.)
(INCREASEREGION (EXPANDREGION (REGION.CONTAINING.PTS (fetch (LOCALARC LOCALARCKNOTS)
of (fetch (SCREENELT LOCALPART)
of ARCSCRELT)))
1.1)
(IQUOTIENT [ADD1 (SK.BRUSH.SIZE (fetch (LOCALARC LOCALARCBRUSH)
of (fetch (SCREENELT LOCALPART) of ARCSCRELT]
2])
(ARC.TRANSLATE
[LAMBDA (ARCSKELT DELTAPOS) (* rrb "30-May-85 13:10")
(* returns a global arc element which has the arc
translated by DELTAPOS.)
(PROG ((GLOBALEL (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ARCSKELT)))
(RETURN (SK.CREATE.ARC.USING (PTPLUS (fetch (ARC ARCCENTERPT) of GLOBALEL)
DELTAPOS)
(PTPLUS (fetch (ARC ARCRADIUSPT) of GLOBALEL)
DELTAPOS)
(PTPLUS (fetch (ARC ARCANGLEPT) of GLOBALEL)
DELTAPOS)
GLOBALEL])
(ARC.TRANSFORMFN
[LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "26-Sep-85 12:11")
(* returns a copy of the global element that has had each of its control points transformed by transformfn.
TRANSFORMDATA is arbitrary data that is passed to tranformfn.)
(PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))
NEWGELT)
(SETQ NEWGELT (SK.CREATE.ARC.USING (SK.TRANSFORM.POINT (fetch (ARC ARCCENTERPT)
of INDVPART)
TRANSFORMFN TRANSFORMDATA)
(SK.TRANSFORM.POINT (fetch (ARC ARCRADIUSPT)
of INDVPART)
TRANSFORMFN TRANSFORMDATA)
(SK.TRANSFORM.POINT (fetch (ARC ARCANGLEPT)
of INDVPART)
TRANSFORMFN TRANSFORMDATA)
INDVPART)) (* update the brush too.)
(replace (ARC ARCBRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of NEWGELT)
with (SK.TRANSFORM.BRUSH (fetch (ARC ARCBRUSH) of INDVPART)
SCALEFACTOR))
(replace (ARC ARCARROWHEADS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of NEWGELT)
with (SK.TRANSFORM.ARROWHEADS (fetch (ARC ARCARROWHEADS) of INDVPART)
SCALEFACTOR))
[AND (EQ TRANSFORMFN (QUOTE SK.APPLY.AFFINE.TRANSFORM))
(COND
([COND
[(GREATERP 0.0 (fetch (AFFINETRANSFORMATION Ax) of TRANSFORMDATA))
(* x coord is reflected, switch direction unless Y is
reflected also.)
(NOT (GREATERP 0.0 (fetch (AFFINETRANSFORMATION Ey) of TRANSFORMDATA]
(T (GREATERP 0.0 (fetch (AFFINETRANSFORMATION Ey)
TRANSFORMDATA]
(* change the direction if the transformation
reflects.)
(replace (ARC ARCDIRECTION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of NEWGELT)
with (NOT (fetch (ARC ARCDIRECTION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART]
(RETURN NEWGELT])
(ARC.READCHANGEFN
[LAMBDA (SKW) (* rrb "12-Jul-85 14:42")
(* changefn for arcs)
(PROG (ASPECT HOW)
(SETQ HOW (SELECTQ [SETQ ASPECT (MENU (create MENU
CENTERFLG ← T
TITLE ← "Which aspect?"
ITEMS ←(APPEND
[COND
((SKETCHINCOLORP)
(QUOTE ((Color (QUOTE BRUSHCOLOR)
"changes the color of the outline"]
(QUOTE ((Arrowheads (QUOTE ARROW)
"allows changing of arrow head charactistics.")
(Size (QUOTE SIZE)
"changes the size of the brush")
(Angle (QUOTE ANGLE)
"changes the amount of angle in the arc.")
(Dashing (QUOTE DASHING)
"changes the dashing of the line.")
(Direction (QUOTE DIRECTION)
"changes which way around the circle the arc is drawn."]
(SIZE (READSIZECHANGE "Change size how?"))
(ANGLE (READANGLE))
(ARROW (READ.ARROW.CHANGE))
(DASHING (READ.DASHING.CHANGE))
(DIRECTION (READARCDIRECTION))
(BRUSHCOLOR (READ.COLOR.CHANGE "Change color how?"))
NIL))
(RETURN (AND HOW (LIST ASPECT HOW])
)
(DEFINEQ
(SK.COMPUTE.ARC.ANGLE.PT
[LAMBDA (CENTERPT RADPT ANGLEPT) (* rrb "19-Jul-85 14:40")
(* computes the intersection of the line CENTERPT
ANGLEPT with the circle with center CENTERPT that goes
through RADPT.)
(PROG ((RADIUS (DISTANCEBETWEEN CENTERPT RADPT))
(BETA (SK.COMPUTE.SLOPE.OF.LINE CENTERPT ANGLEPT)))
(RETURN (create POSITION
XCOORD ←(PLUS (fetch (POSITION XCOORD) of CENTERPT)
(TIMES RADIUS (COS BETA)))
YCOORD ←(PLUS (fetch (POSITION YCOORD) of CENTERPT)
(TIMES RADIUS (SIN BETA])
(SK.COMPUTE.ARC.PTS
[LAMBDA (CENTERPT RADIUSPT ARCPT DIRECTION) (* DECLARATIONS: FLOATING)
(* rrb "19-Jun-85 11:33")
(* computes a list of knots that a spline goes through
to make an arc)
(PROG ((RADIUS (DISTANCEBETWEEN CENTERPT RADIUSPT))
(ALPHA (SK.COMPUTE.SLOPE.OF.LINE CENTERPT RADIUSPT))
(BETA (SK.COMPUTE.SLOPE.OF.LINE CENTERPT ARCPT))
(CENTERX (fetch (POSITION XCOORD) of CENTERPT))
(CENTERY (fetch (POSITION YCOORD) of CENTERPT))
PTLST ANGLEINCR DEGREESARC)
[COND
[DIRECTION (* if non-NIL go in a counterclockwise direction.)
(COND
((GREATERP BETA ALPHA)
(SETQ BETA (DIFFERENCE BETA 360.0]
(T (COND
((GREATERP ALPHA BETA) (* angle crosses angle change point, correct.)
(SETQ BETA (PLUS BETA 360.0]
(* calculate an increment close to 10.0 that is exact but always have at least 5 knots and don't have more than a
knot every 5 pts)
[SETQ ANGLEINCR (FQUOTIENT (SETQ DEGREESARC (DIFFERENCE BETA ALPHA))
(IMIN (IMAX (ABS (FIX (FQUOTIENT DEGREESARC 10.0)))
5)
(PROGN (* don't have more than a knot every 5 pts)
(IMAX (ABS (FIX (QUOTIENT (TIMES RADIUS 6.3
(QUOTIENT
DEGREESARC
360.0))
4)))
3]
(* go from initial point to just past the last point. The just past (PLUS BETA (QUOTIENT ANGLEINCR 5.0)) picks up
the case where the floating pt rounding error accumulates to be greater than the last point when it is very close to
it.)
[SETQ PTLST (for ANGLE from ALPHA to (PLUS BETA (QUOTIENT ANGLEINCR 5.0)) by ANGLEINCR
collect (create POSITION
XCOORD ←[FIXR (PLUS CENTERX (TIMES RADIUS (COS ANGLE]
YCOORD ←(FIXR (PLUS CENTERY (TIMES RADIUS (SIN ANGLE]
(* add first and last points exactly. (CONS RADIUSPT (NCONC1 PTLST (create POSITION XCOORD ←
(FIXR (PLUS CENTERX (TIMES RADIUS (COS BETA)))) YCOORD ← (FIXR (PLUS CENTERY (TIMES RADIUS (SIN BETA))))))))
(RETURN PTLST])
(SK.SET.ARC.DIRECTION
[LAMBDA (SKW NEWDIR) (* rrb "31-May-85 17:29")
(* * reads a value of arc direction and makes it the default)
(PROG [(LOCALNEWDIR (OR NEWDIR (READARCDIRECTION "Which way should new arcs go?"]
(RETURN (AND LOCALNEWDIR (replace (SKETCHCONTEXT SKETCHARCDIRECTION)
of (WINDOWPROP SKW (QUOTE SKETCHCONTEXT))
with (EQ LOCALNEWDIR (QUOTE CLOCKWISE])
(SK.SET.ARC.DIRECTION.CW
[LAMBDA (SKW) (* sets the default to clockwise)
(SK.SET.ARC.DIRECTION SKW (QUOTE CLOCKWISE])
(SK.SET.ARC.DIRECTION.CCW
[LAMBDA (SKW) (* sets the default direction of arcs to
counterclockwise)
(SK.SET.ARC.DIRECTION SKW (QUOTE COUNTERCLOCKWISE])
(SK.COMPUTE.SLOPE.OF.LINE
[LAMBDA (PT1 PT2) (* rrb "31-May-85 12:26")
(* computes the angle of a line)
(SK.COMPUTE.SLOPE (DIFFERENCE (fetch (POSITION XCOORD) of PT2)
(fetch (POSITION XCOORD) of PT1))
(DIFFERENCE (fetch (POSITION YCOORD) of PT2)
(fetch (POSITION YCOORD) of PT1])
(SK.CREATE.ARC.USING
[LAMBDA (CENTERPT RADPT ANGLEPT INDVARCELT) (* rrb "19-Jul-85 14:42")
(* creates an arc global element that is like another
one but has different positions.)
(SET.ARC.SCALES (create GLOBALPART
INDIVIDUALGLOBALPART ←(create ARC
using INDVARCELT ARCCENTERPT ← CENTERPT
ARCRADIUSPT ← RADPT ARCANGLEPT ←(
SK.COMPUTE.ARC.ANGLE.PT CENTERPT RADPT
ANGLEPT])
(SET.ARC.SCALES
[LAMBDA (GARCELT) (* rrb "30-May-85 11:33")
(* updates the scale fields of an arc.
Called upon creation and when a point is moved.)
(PROG [(RAD (DISTANCEBETWEEN (fetch (ARC ARCCENTERPT) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GARCELT))
(fetch (ARC ARCRADIUSPT) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GARCELT]
(replace (GLOBALPART MAXSCALE) of GARCELT with RAD)
(replace (GLOBALPART MINSCALE) of GARCELT with (QUOTIENT RAD 3000.0))
(RETURN GARCELT])
)
(RPAQ? SK.NUMBER.OF.POINTS.IN.ARC 8)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS SK.NUMBER.OF.POINTS.IN.ARC)
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(TYPERECORD ARC (ARCCENTERPT ARCRADIUSPT ARCBRUSH ARCDASHING ARCINITSCALE ARCARROWHEADS ARCANGLEPT
ARCDIRECTION))
(RECORD LOCALARC ((LOCALARCCENTERPT LOCALARCRADIUSPT LOCALARCANGLEPT)
LOCALARCARROWHEADPTS LOCALARCBRUSH LOCALARCKNOTS))
]
)
(RPAQ ARC.RADIUS.CURSOR (CURSORCREATE (READBITMAP) 15 8))
(16 16
"@@AL"
"@@@L"
"@@@N"
"@@@F"
"@@BG"
"@@CC"
"@@CK"
"OOOO"
"OOOO"
"@@CH"
"@@C@"
"@@B@"
"@@@@"
"@@@@"
"@@@@"
"@@@@")(RPAQ ARC.ANGLE.CURSOR (CURSORCREATE (READBITMAP) 8 15))
(16 16
"@AO@"
"@AOL"
"@AIO"
"@CLG"
"@GNA"
"@OO@"
"@AH@"
"@AH@"
"@AH@"
"@AH@"
"@AH@"
"@AH@"
"@AH@"
"@AH@"
"@AH@"
"@AH@")(READVARS ARCICON)
({(READBITMAP)(20 12
"@AOH@@@@"
"@COL@@@@"
"@G@N@@@@"
"@F@F@@@@"
"@N@G@@@@"
"@L@C@@@@"
"@@@C@@@@"
"@@@G@@@@"
"@@@F@@@@"
"@@@N@@@@"
"@@@L@@@@"
"@@@@@@@@")})
(INIT.SKETCH.ELEMENTS)
(PUTPROPS SKETCHELEMENTS COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (7713 16518 (INIT.SKETCH.ELEMENTS 7723 . 14659) (CREATE.SKETCH.ELEMENT.TYPE 14661 .
15916) (SKETCH.ELEMENT.TYPEP 15918 . 16251) (SKETCH.ELEMENT.NAMEP 16253 . 16516)) (16555 17083 (
SKETCHINCOLORP 16565 . 16815) (READ.COLOR.CHANGE 16817 . 17081)) (17504 19087 (\POSSIBLECOLOR 17514 .
18062) (RGBP 18064 . 18699) (HLSP 18701 . 19085)) (19088 20392 (SKFILLINGP 19098 . 19612) (
SK.INSURE.FILLING 19614 . 20390)) (20393 34419 (CIRCLE.EXPANDFN 20403 . 22571) (CIRCLE.DRAWFN 22573 .
24942) (CIRCLE.INPUTFN 24944 . 26544) (CIRCLE.INSIDEFN 26546 . 27687) (CIRCLE.REGIONFN 27689 . 28699)
(CIRCLE.TRANSLATE 28701 . 29560) (CIRCLE.TRANSFORMFN 29562 . 30631) (CIRCLE.TRANSLATEPTS 30633 . 31930
) (SK.CIRCLE.CREATE 31932 . 32499) (SET.CIRCLE.SCALE 32501 . 33246) (SK.BRUSH.READCHANGE 33248 . 34417
)) (42883 60258 (ELLIPSE.EXPANDFN 42893 . 45178) (ELLIPSE.DRAWFN 45180 . 47672) (ELLIPSE.INPUTFN 47674
. 49769) (ELLIPSE.INSIDEFN 49771 . 50558) (ELLIPSE.CREATE 50560 . 51548) (ELLIPSE.REGIONFN 51550 .
53459) (ELLIPSE.TRANSLATEFN 53461 . 54612) (ELLIPSE.TRANSFORMFN 54614 . 55647) (ELLIPSE.TRANSLATEPTS
55649 . 57276) (MARK.SPOT 57278 . 58354) (DISTANCEBETWEEN 58356 . 58853) (SQUARE 58855 . 58901) (
COMPUTE.ELLIPSE.ORIENTATION 58903 . 59470) (SK.COMPUTE.ELLIPSE.MINOR.RADIUS.PT 59472 . 60256)) (61285
83844 (KNOTS.INSIDEFN 61295 . 61878) (OPENCURVE.INPUTFN 61880 . 62574) (SK.CURVE.CREATE 62576 . 63332)
(MAXXEXTENT 63334 . 64043) (MAXYEXTENT 64045 . 64754) (KNOT.SET.SCALE.FIELD 64756 . 65559) (
OPENCURVE.DRAWFN 65561 . 66439) (OPENCURVE.EXPANDFN 66441 . 68257) (OPENCURVE.READCHANGEFN 68259 .
69563) (OPENCURVE.TRANSFORMFN 69565 . 70685) (OPENCURVE.TRANSLATEPTSFN 70687 . 71726) (
CLOSEDCURVE.DRAWFN 71728 . 72604) (CLOSEDCURVE.EXPANDFN 72606 . 74411) (CLOSEDCURVE.REGIONFN 74413 .
75175) (READ.LIST.OF.POINTS 75177 . 76462) (CLOSEDCURVE.INPUTFN 76464 . 77061) (
CLOSEDCURVE.TRANSFORMFN 77063 . 78082) (CLOSEDCURVE.TRANSLATEPTSFN 78084 . 79088) (INVISIBLEPARTP
79090 . 79501) (SHOWSKETCHPOINT 79503 . 79850) (SHOWSKETCHXY 79852 . 80363) (KNOTS.REGIONFN 80365 .
81083) (CURVE.REGIONFN 81085 . 81877) (KNOTS.TRANSLATEFN 81879 . 82689) (REGION.CONTAINING.PTS 82691
. 83842)) (83845 98784 (CHANGE.ELTS.BRUSH.SIZE 83855 . 84449) (CHANGE.ELTS.BRUSH 84451 . 84883) (
CHANGE.ELTS.BRUSH.SHAPE 84885 . 85344) (SK.CHANGE.BRUSH.SHAPE 85346 . 88043) (SK.CHANGE.BRUSH.COLOR
88045 . 91012) (SK.CHANGE.BRUSH.SIZE 91014 . 94057) (SK.CHANGE.ANGLE 94059 . 95998) (
SK.CHANGE.ARC.DIRECTION 96000 . 97188) (SK.SET.DEFAULT.BRUSH.SIZE 97190 . 97765) (READSIZECHANGE 97767
. 98782)) (99706 114890 (KNOTS.EXPANDFN 99716 . 101494) (OPEN.WIRE.DRAWFN 101496 . 101996) (
OPEN.KNOTS.EXPANDFN 101998 . 103777) (OPENWIRE.READCHANGEFN 103779 . 104956) (OPENWIRE.TRANSFORMFN
104958 . 106033) (OPENWIRE.TRANSLATEPTSFN 106035 . 107060) (SK.EXPAND.ARROWHEADS 107062 . 109291) (
WIRE.INPUTFN 109293 . 110507) (CLOSEDWIRE.REGIONFN 110509 . 111236) (SK.WIRE.CREATE 111238 . 112026) (
WIRE.ADD.POINT.TO.END 112028 . 112889) (READ.ARROW.CHANGE 112891 . 114503) (CHANGE.ELTS.ARROWHEADS
114505 . 114888)) (114891 120035 (CLOSED.WIRE.INPUTFN 114901 . 115236) (CLOSED.WIRE.DRAWFN 115238 .
116174) (CLOSEDWIRE.READCHANGEFN 116176 . 117943) (CLOSEDWIRE.TRANSFORMFN 117945 . 118959) (
CLOSEDWIRE.TRANSLATEPTSFN 118961 . 120033)) (120036 142164 (CHANGED.ARROW 120046 . 121579) (
SK.CHANGE.ARROWHEAD 121581 . 122092) (SK.CHANGE.ARROWHEAD1 122094 . 124773) (SK.CREATE.ARROWHEAD
124775 . 125221) (SK.ARROWHEAD.CREATE 125223 . 126448) (SK.ARROWHEAD.END.TEST 126450 . 127192) (
READ.ARROWHEAD.END 127194 . 128305) (ARROW.HEAD.POSITIONS 128307 . 130068) (ARROWHEAD.POINTS.LIST
130070 . 131777) (CURVE.ARROWHEAD.POINTS 131779 . 132484) (LEFT.MOST.IS.BEGINP 132486 . 133270) (
WIRE.ARROWHEAD.POINTS 133272 . 134501) (DRAWARROWHEADS 134503 . 135398) (SK.SET.ARROWHEAD.LENGTH
135400 . 136325) (SK.SET.ARROWHEAD.ANGLE 136327 . 137230) (SK.SET.ARROWHEAD.TYPE 137232 . 138065) (
SK.SET.LINE.ARROWHEAD 138067 . 139485) (SK.UPDATE.ARROWHEAD.FORMAT 139487 . 141168) (
SK.SET.LINE.LENGTH.MODE 141170 . 142162)) (143284 194448 (TEXT.CHANGEFN 143294 . 143616) (
TEXT.READCHANGEFN 143618 . 147688) (\SK.READ.FONT.SIZE1 147690 . 149219) (SK.TEXT.ELT.WITH.SAME.FIELDS
149221 . 150656) (SK.READFONTFAMILY 150658 . 151965) (CLOSE.PROMPT.WINDOW 151967 . 152372) (
TEXT.DRAWFN 152374 . 153007) (TEXT.DRAWFN1 153009 . 155462) (TEXT.INSIDEFN 155464 . 155922) (
TEXT.EXPANDFN 155924 . 159289) (SK.TEXT.LINE.REGIONS 159291 . 160728) (SK.PICK.FONT 160730 . 162326) (
SK.NEXTSIZEFONT 162328 . 163477) (SK.DECREASING.FONT.LIST 163479 . 164922) (SK.GUESS.FONTSAVAILABLE
164924 . 168972) (TEXT.UPDATE.GLOBAL.REGIONS 168974 . 170051) (REL.MOVE.REGION 170053 . 170511) (
LTEXT.LINE.REGIONS 170513 . 172708) (TEXT.INPUTFN 172710 . 173226) (READ.TEXT 173228 . 173917) (
TEXT.POSITION.AND.CREATE 173919 . 175711) (CREATE.TEXT.ELEMENT 175713 . 176301) (SK.TEXT.FROM.TEXTBOX
176303 . 177956) (TEXT.SET.GLOBAL.REGIONS 177958 . 179131) (TEXT.REGIONFN 179133 . 179739) (
TEXT.TRANSLATEFN 179741 . 180706) (TEXT.TRANSFORMFN 180708 . 181635) (TEXT.TRANSLATEPTSFN 181637 .
182159) (TEXT.UPDATEFN 182161 . 185802) (SK.CHANGE.TEXT 185804 . 193108) (TEXT.SET.SCALES 193110 .
194028) (SK.FONT.LIST 194030 . 194446)) (194709 204519 (SK.SET.FONT 194719 . 195921) (SK.SET.TEXT.FONT
195923 . 196609) (SK.SET.TEXT.SIZE 196611 . 197228) (SK.SET.TEXT.HORIZ.ALIGN 197230 . 198239) (
SK.READFONTSIZE 198241 . 199779) (SK.COLLECT.FONT.SIZES 199781 . 201975) (SK.SET.TEXT.VERT.ALIGN
201977 . 203222) (SK.SET.TEXT.LOOKS 203224 . 203991) (SK.SET.DEFAULT.TEXT.FACE 203993 . 204517)) (
204520 205204 (CREATE.SKETCH.TERMTABLE 204530 . 205202)) (205611 242282 (SK.BREAK.INTO.LINES 205621 .
213057) (SK.BRUSH.SIZE 213059 . 213425) (SK.TEXTBOX.CREATE 213427 . 214045) (SK.TEXTBOX.CREATE1 214047
. 214838) (SK.TEXTBOX.POSITION.IN.BOX 214840 . 216229) (TEXTBOX.CHANGEFN 216231 . 216628) (
TEXTBOX.DRAWFN 216630 . 220327) (SK.TEXTURE.AROUND.REGIONS 220329 . 222886) (TEXTBOX.EXPANDFN 222888
. 228153) (TEXTBOX.INPUTFN 228155 . 229406) (TEXTBOX.INSIDEFN 229408 . 229826) (TEXTBOX.REGIONFN
229828 . 230577) (TEXTBOX.SET.GLOBAL.REGIONS 230579 . 231912) (TEXTBOX.TRANSLATEFN 231914 . 233126) (
TEXTBOX.TRANSLATEPTSFN 233128 . 235604) (TEXTBOX.TRANSFORMFN 235606 . 236934) (TEXTBOX.UPDATEFN 236936
. 238604) (TEXTBOX.READCHANGEFN 238606 . 240419) (SK.TEXTBOX.TEXT.POSITION 240421 . 240808) (
SK.TEXTBOX.FROM.TEXT 240810 . 241861) (ADD.EOLS 241863 . 242280)) (242673 244815 (
SK.SET.TEXTBOX.VERT.ALIGN 242683 . 243829) (SK.SET.TEXTBOX.HORIZ.ALIGN 243831 . 244813)) (245241
269870 (SK.BOX.DRAWFN 245251 . 246554) (BOX.DRAWFN1 246556 . 247543) (KNOTS.OF.REGION 247545 . 248519)
(SK.DRAWAREABOX 248521 . 249855) (SK.BOX.EXPANDFN 249857 . 251977) (SK.BOX.GETREGIONFN 251979 .
252797) (BOX.SET.SCALES 252799 . 253693) (SK.BOX.INPUTFN 253695 . 255070) (SK.BOX.CREATE 255072 .
255510) (SK.BOX.INSIDEFN 255512 . 255914) (SK.BOX.REGIONFN 255916 . 256421) (SK.BOX.READCHANGEFN
256423 . 257987) (SK.CHANGE.FILLING 257989 . 260116) (SK.CHANGE.FILLING.COLOR 260118 . 262068) (
SK.BOX.TRANSLATEFN 262070 . 262847) (SK.BOX.TRANSFORMFN 262849 . 263645) (SK.BOX.TRANSLATEPTSFN 263647
. 265830) (UNSCALE.REGION.FROM.SKETCHW 265832 . 266260) (UNSCALE.REGION.TO.GRID 266262 . 267242) (
INCREASEREGION 267244 . 267776) (INSUREREGIONSIZE 267778 . 268749) (EXPANDREGION 268751 . 269500) (
REGION.FROM.COORDINATES 269502 . 269868)) (270291 284742 (ARC.DRAWFN 270301 . 271226) (ARC.EXPANDFN
271228 . 272698) (ARC.INPUTFN 272700 . 275204) (ARC.CREATE 275206 . 275923) (ARC.MOVEFN 275925 .
277510) (ARC.TRANSLATEPTS 277512 . 278862) (ARC.INSIDEFN 278864 . 279586) (ARC.REGIONFN 279588 .
280352) (ARC.TRANSLATE 280354 . 281039) (ARC.TRANSFORMFN 281041 . 283292) (ARC.READCHANGEFN 283294 .
284740)) (284743 290734 (SK.COMPUTE.ARC.ANGLE.PT 284753 . 285481) (SK.COMPUTE.ARC.PTS 285483 . 288014)
(SK.SET.ARC.DIRECTION 288016 . 288526) (SK.SET.ARC.DIRECTION.CW 288528 . 288712) (
SK.SET.ARC.DIRECTION.CCW 288714 . 288948) (SK.COMPUTE.SLOPE.OF.LINE 288950 . 289428) (
SK.CREATE.ARC.USING 289430 . 289992) (SET.ARC.SCALES 289994 . 290732)))))
STOP