(FILECREATED "11-Dec-85 12:04:27" {PHYLUM}<PAPERWORKS>SKETCHELEMENTS.;85 392253
changes to: (FNS SK.UPDATE.WIRE.ELT.AFTER.CHANGE \SK.PUT.JUSTIFICATION SKETCH.CREATE.CIRCLE
\SK.GET.JUSTIFICATION PUTSKETCHELEMENTPROP \SK.GET.1STCONTROLPT
\SK.GET.2NDCONTROLPT \SK.GET.3RDCONTROLPT \SK.PUT.DIRECTION \SK.PUT.FONT
\SK.GET.FILLING \SK.GET.DIRECTION \SK.GET.FONT \SK.GET.ARROWHEADS
OPEN.WIRE.DRAWFN OPEN.KNOTS.EXPANDFN SK.BOX.REGIONFN \SK.GET.BRUSH
\SK.GET.DASHING \SKELT.PUT.DATA INIT.SKETCH.ELEMENTS CIRCLE.EXPANDFN
CIRCLE.DRAWFN ELLIPSE.EXPANDFN ELLIPSE.DRAWFN OPENCURVE.DRAWFN
OPENCURVE.EXPANDFN CLOSEDCURVE.DRAWFN CLOSEDCURVE.EXPANDFN WIRE.EXPANDFN
TEXTBOX.DRAWFN TEXTBOX.EXPANDFN SK.BOX.DRAWFN SK.BOX.EXPANDFN ARC.DRAWFN
ARC.EXPANDFN GETSKETCHELEMENTPROP \SK.PUT.ARROWHEADS \SK.PUT.DASHING
SK.UPDATE.ELLIPSE.AFTER.CHANGE SK.UPDATE.ARC.AFTER.CHANGE
SK.UPDATE.CIRCLE.AFTER.CHANGE \SK.PUT.BRUSH SKETCH.UPDATE \SKELT.GET.DATA
SKETCH.UPDATE1)
(VARS SKETCHELEMENTSCOMS)
(RECORDS LOCALCURVE LOCALWIRE LOCALCIRCLE LOCALELLIPSE LOCALCLOSEDCURVE LOCALBOX
LOCALARC LOCALTEXTBOX)
previous date: " 5-Dec-85 18:32:42" {PHYLUM}<PAPERWORKS>SKETCHELEMENTS.;80)
(* 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 \CURSOR.IN.MIDDLE.MENU)
(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 SK.CREATE.DEFAULT.FILLING SKFILLINGP SK.INSURE.FILLING SK.INSURE.COLOR))
(COMS (FNS SKETCH.CREATE.CIRCLE CIRCLE.EXPANDFN CIRCLE.DRAWFN CIRCLE.INPUTFN
SK.UPDATE.CIRCLE.AFTER.CHANGE SK.READ.CIRCLE.POINT SK.SHOW.CIRCLE CIRCLE.INSIDEFN
CIRCLE.REGIONFN CIRCLE.GLOBALREGIONFN CIRCLE.TRANSLATE CIRCLE.TRANSFORMFN
CIRCLE.TRANSLATEPTS SK.CIRCLE.CREATE SET.CIRCLE.SCALE SK.BRUSH.READCHANGE)
(FNS BRUSHP SK.INSURE.BRUSH SK.INSURE.DASHING)
(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 SKETCH.CREATE.ELLIPSE ELLIPSE.EXPANDFN ELLIPSE.DRAWFN ELLIPSE.INPUTFN
SK.READ.ELLIPSE.MAJOR.PT SK.SHOW.ELLIPSE.MAJOR.RADIUS SK.READ.ELLIPSE.MINOR.PT
SK.SHOW.ELLIPSE.MINOR.RADIUS ELLIPSE.INSIDEFN ELLIPSE.CREATE
SK.UPDATE.ELLIPSE.AFTER.CHANGE ELLIPSE.REGIONFN ELLIPSE.GLOBALREGIONFN
ELLIPSE.TRANSLATEFN ELLIPSE.TRANSFORMFN ELLIPSE.TRANSLATEPTS MARK.SPOT
DISTANCEBETWEEN SK.DISTANCE.TO 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 SKETCH.CREATE.OPEN.CURVE OPENCURVE.INPUTFN SK.CURVE.CREATE MAXXEXTENT MAXYEXTENT
KNOT.SET.SCALE.FIELD OPENCURVE.DRAWFN OPENCURVE.EXPANDFN OPENCURVE.READCHANGEFN
OPENCURVE.TRANSFORMFN OPENCURVE.TRANSLATEPTSFN SKETCH.CREATE.CLOSED.CURVE
CLOSEDCURVE.DRAWFN CLOSEDCURVE.EXPANDFN CLOSEDCURVE.REGIONFN
CLOSEDCURVE.GLOBALREGIONFN READ.LIST.OF.POINTS CLOSEDCURVE.INPUTFN
CLOSEDCURVE.READCHANGEFN CLOSEDCURVE.TRANSFORMFN CLOSEDCURVE.TRANSLATEPTSFN
INVISIBLEPARTP SHOWSKETCHPOINT SHOWSKETCHXY KNOTS.REGIONFN OPENWIRE.GLOBALREGIONFN
CURVE.REGIONFN OPENCURVE.GLOBALREGIONFN 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)
(FNS SK.CHANGE.ELEMENT.KNOTS)
(FNS SK.INSURE.POINT.LIST SK.INSURE.POSITION)
(DECLARE: DONTCOPY (RECORDS KNOTELT LOCALCURVE OPENCURVE CLOSEDCURVE LOCALCLOSEDCURVE
LOCALCLOSEDWIRE))
(UGLYVARS OPENCURVEICON CLOSEDCURVEICON)
(CURSORS CURVE.KNOT))
(COMS (FNS SKETCH.CREATE.WIRE CLOSEDWIRE.EXPANDFN KNOTS.INSIDEFN OPEN.WIRE.DRAWFN
WIRE.EXPANDFN SK.UPDATE.WIRE.ELT.AFTER.CHANGE OPENWIRE.READCHANGEFN
OPENWIRE.TRANSFORMFN OPENWIRE.TRANSLATEPTSFN SK.EXPAND.ARROWHEADS WIRE.INPUTFN
SK.READ.WIRE.POINTS SK.READ.POINTS.WITH.FEEDBACK OPENWIRE.FEEDBACKFN
CLOSEDWIRE.FEEDBACKFN CLOSEDWIRE.REGIONFN CLOSEDWIRE.GLOBALREGIONFN SK.WIRE.CREATE
WIRE.ADD.POINT.TO.END READ.ARROW.CHANGE CHANGE.ELTS.ARROWHEADS)
(FNS SKETCH.CREATE.CLOSED.WIRE 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)
(FNS SK.INSURE.ARROWHEADS SK.ARROWHEADP)
(DECLARE: DONTCOPY (RECORDS LOCALWIRE WIRE CLOSEDWIRE LOCALCLOSEDWIRE ARROWHEAD))
(UGLYVARS WIREICON CLOSEDWIREICON)
(INITVARS (SK.ARROWHEAD.ANGLE.INCREMENT 5)
(SK.ARROWHEAD.LENGTH.INCREMENT 2))
(ADDVARS (SK.ARROWHEAD.TYPES LINE CLOSEDLINE CURVE SOLID))
(INITVARS (SK.DEFAULT.ARROW.LENGTH 8)
(SK.DEFAULT.ARROW.TYPE (QUOTE CURVE))
(SK.DEFAULT.ARROW.ANGLE 18.0))
(GLOBALVARS SK.DEFAULT.ARROW.LENGTH SK.DEFAULT.ARROW.TYPE SK.DEFAULT.ARROW.ANGLE
SK.ARROWHEAD.TYPES)
(INITVARS (SK.ARROW.END.MENU)
(SK.ARROW.EDIT.MENU)))
(COMS (* stuff to support the text element type.)
(FNS SKETCH.CREATE.TEXT 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.UPDATE.TEXT.AFTER.CHANGE
SK.TEXT.FROM.TEXTBOX TEXT.SET.GLOBAL.REGIONS TEXT.REGIONFN TEXT.GLOBALREGIONFN
TEXT.TRANSLATEFN TEXT.TRANSFORMFN TEXT.TRANSLATEPTSFN TEXT.UPDATEFN SK.CHANGE.TEXT
TEXT.SET.SCALES SK.FONT.LIST BREAK.AT.CARRIAGE.RETURNS)
(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)
(FNS SK.FONT.LIST SK.INSURE.FONT SK.INSURE.STYLE SK.INSURE.TEXT)
(VARS INDICATE.TEXT.SHADE)
[INITVARS (SK.DEFAULT.FONT)
(SK.DEFAULT.TEXT.ALIGNMENT (QUOTE (CENTER BASELINE]
(INITVARS \FONTSONFILE)
(ADDVARS (SK.HORIZONTAL.STYLES LEFT RIGHT CENTER)
(SK.VERTICAL.STYLES TOP CENTER BASELINE BOTTOM))
(VARS (SKETCH.TERMTABLE (CREATE.SKETCH.TERMTABLE)))
(GLOBALVARS SKETCH.TERMTABLE SK.DEFAULT.TEXT.ALIGNMENT INDICATE.TEXT.SHADE \FONTSONFILE
SK.HORIZONTAL.STYLES SK.VERTICAL.STYLES))
(COMS (* stuff for supporting the TEXTBOX sketch element.)
(FNS SKETCH.CREATE.TEXTBOX SK.BREAK.INTO.LINES SK.BRUSH.SIZE SK.TEXTBOX.CREATE
SK.TEXTBOX.CREATE1 SK.UPDATE.TEXTBOX.AFTER.CHANGE SK.TEXTBOX.POSITION.IN.BOX
TEXTBOX.CHANGEFN TEXTBOX.DRAWFN SK.TEXTURE.AROUND.REGIONS TEXTBOX.EXPANDFN
TEXTBOX.INPUTFN TEXTBOX.INSIDEFN TEXTBOX.REGIONFN TEXTBOX.GLOBALREGIONFN
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 SKETCH.CREATE.BOX 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.GLOBALREGIONFN 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 SKETCH.CREATE.ARC ARC.DRAWFN ARC.EXPANDFN ARC.INPUTFN SK.INVERT.CIRCLE
SK.READ.ARC.ANGLE.POINT SK.SHOW.ARC ARC.CREATE SK.UPDATE.ARC.AFTER.CHANGE
ARC.MOVEFN ARC.TRANSLATEPTS ARC.INSIDEFN ARC.REGIONFN ARC.GLOBALREGIONFN
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)
(FNS SK.INSURE.DIRECTION)
(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 CW.ARC.ANGLE.CURSOR CW.ARC.RADIUS.CURSOR)
(UGLYVARS ARCICON))
[COMS (* property getting and setting stuff)
(FNS GETSKETCHELEMENTPROP \SK.GET.BRUSH \SK.GET.FILLING \SK.GET.ARROWHEADS \SK.GET.FONT
\SK.GET.JUSTIFICATION \SK.GET.DIRECTION \SK.GET.DASHING PUTSKETCHELEMENTPROP
\SK.PUT.FONT \SK.PUT.JUSTIFICATION \SK.PUT.DIRECTION \SK.PUT.DASHING \SK.PUT.BRUSH
\SK.PUT.ARROWHEADS \SKELT.PUT.FILLING SK.COPY.ELEMENT.PROPERTY.LIST SKETCH.UPDATE
SKETCH.UPDATE1 \SKELT.GET.SCALE \SKELT.PUT.SCALE \SKELT.PUT.DATA
SK.REPLACE.TEXT.IN.ELEMENT \SKELT.GET.DATA \SK.GET.1STCONTROLPT
\SK.PUT.1STCONTROLPT \SK.GET.2NDCONTROLPT \SK.PUT.2NDCONTROLPT
\SK.GET.3RDCONTROLPT \SK.PUT.3RDCONTROLPT)
(FNS LOWERLEFTCORNER UPPERRIGHTCORNER)
(* stuff for compatibility with unadvertised interface. Remove after L release.)
(P (MOVD? (QUOTE GETSKETCHELEMENTPROP)
(QUOTE GETSKELEMENTPROP))
(MOVD? (QUOTE PUTSKETCHELEMENTPROP)
(QUOTE PUTSKELEMENTPROP))
(MOVD? (QUOTE SKETCH.CREATE.IMAGE.OBJECT)
(QUOTE SKETCH.IMAGE.OBJECT.ELEMENT]
(P (INIT.SKETCH.ELEMENTS))))
(* contains the functions need to implement the sketch basic element types)
(DEFINEQ
(INIT.SKETCH.ELEMENTS
[LAMBDA NIL (* rrb " 7-Dec-85 20:20")
(* 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)
(FUNCTION CIRCLE.GLOBALREGIONFN]
[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)
(FUNCTION ELLIPSE.GLOBALREGIONFN]
[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)
(FUNCTION ARC.GLOBALREGIONFN]
[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)
(FUNCTION OPENCURVE.GLOBALREGIONFN]
[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 CLOSEDCURVE.READCHANGEFN)
(FUNCTION CLOSEDCURVE.TRANSFORMFN)
(FUNCTION CLOSEDCURVE.TRANSLATEPTSFN)
(FUNCTION CLOSEDCURVE.GLOBALREGIONFN]
[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 WIRE.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)
(FUNCTION OPENWIRE.GLOBALREGIONFN]
[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 CLOSEDWIRE.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)
(FUNCTION CLOSEDWIRE.GLOBALREGIONFN]
[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)
(FUNCTION TEXT.GLOBALREGIONFN]
[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)
(FUNCTION SK.BOX.GLOBALREGIONFN]
(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)
(FUNCTION TEXTBOX.GLOBALREGIONFN])
(CREATE.SKETCH.ELEMENT.TYPE
[LAMBDA (SKETCHTYPE LABEL DOCSTR DRAWFN EXPANDFN OBSOLETE CHANGEFN INPUTFN INSIDEFN REGIONFN
TRANSLATEFN UPDATEFN READCHANGEFN TRANSFORMFN TRANSLATEPTSFN GLOBALREGIONFN)
(* rrb "18-Oct-85 17:18")
(* 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
GLOBALREGIONFN ← GLOBALREGIONFN))
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])
(\CURSOR.IN.MIDDLE.MENU
[LAMBDA (MENU) (* rrb " 6-Nov-85 09:46")
(* brings up the menu so that the cursor is in the
middle.)
(MENU MENU (create POSITION
XCOORD ←(DIFFERENCE LASTMOUSEX (QUOTIENT (fetch (MENU IMAGEWIDTH)
of MENU)
2))
YCOORD ←(DIFFERENCE LASTMOUSEY (QUOTIENT (fetch (MENU IMAGEHEIGHT)
of MENU)
2])
)
(* 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 CURRENTCOLOR) (* rrb "29-Oct-85 12:30")
(* reads a color from the user and returns it)
(READCOLOR1 MSG ALLOWNONEFLG CURRENTCOLOR])
)
(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 "31-Oct-85 10:51")
(* return T if X is a hue lightness saturation
triple.)
(AND (NUMBERP (CAR (LISTP X)))
(IGREATERP (CAR X)
-1)
(IGREATERP 361 (CAR X))
[FLOATP (CAR (LISTP (CDR X]
[FLOATP (CAR (LISTP (CDDR X]
X])
)
(DEFINEQ
(SK.CREATE.DEFAULT.FILLING
[LAMBDA NIL (* rrb "16-Oct-85 15:43")
(create SKFILLING
FILLING.TEXTURE ← SK.DEFAULT.TEXTURE
FILLING.COLOR ← SK.DEFAULT.BACKCOLOR])
(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 "16-Oct-85 15:47")
(* converts several possible legal filling
specifications into a sketch filling)
(COND
((SKFILLINGP FILLING))
(T (PROG [(DEFAULTFILLING (COND
[(WINDOWP SKW)
(fetch (SKETCHCONTEXT SKETCHFILLING)
of (WINDOWPROP SKW (QUOTE SKETCHCONTEXT]
(T (SK.CREATE.DEFAULT.FILLING]
(RETURN (COND
((NULL FILLING)
DEFAULTFILLING)
((TEXTUREP FILLING)
(create SKFILLING using DEFAULTFILLING FILLING.TEXTURE ← FILLING))
((\POSSIBLECOLOR FILLING) (* note that small numbers can be either a texture or
a color. This algorithm will make them be a texture.)
(create SKFILLING using DEFAULTFILLING FILLING.COLOR ← FILLING))
(T (* should be a check here for a color too.)
(\ILLEGAL.ARG FILLING])
(SK.INSURE.COLOR
[LAMBDA (COLOR) (* rrb "16-Oct-85 18:05")
(* checks the validity of a color argument.)
(COND
((NULL COLOR)
NIL)
((\POSSIBLECOLOR COLOR))
(T (\ILLEGAL.ARG COLOR])
)
(DEFINEQ
(SKETCH.CREATE.CIRCLE
[LAMBDA (CENTERPT RADIUSPT BRUSH DASHING FILLING SCALE) (* rrb "11-Dec-85 10:43")
(* creates a sketch circle element.)
(SK.CIRCLE.CREATE (SK.INSURE.POSITION CENTERPT)
(COND
[(NUMBERP RADIUSPT)
(create POSITION
XCOORD ←(PLUS (fetch (POSITION XCOORD) of CENTERPT)
RADIUSPT)
YCOORD ←(PLUS (fetch (POSITION YCOORD) of CENTERPT]
(T (SK.INSURE.POSITION RADIUSPT)))
(SK.INSURE.BRUSH BRUSH)
(SK.INSURE.DASHING DASHING)
(OR (NUMBERP SCALE)
1.0)
(SK.INSURE.FILLING FILLING])
(CIRCLE.EXPANDFN
[LAMBDA (GCIRCLE SCALE) (* rrb " 7-Dec-85 20:45")
(* 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)
LOCALCIRCLEFILLING ←(APPEND
(fetch (CIRCLE CIRCLEFILLING) of
INDGCIRCLE))
LOCALCIRCLEDASHING ←(fetch (CIRCLE DASHING)
of INDGCIRCLE))
GLOBALPART ← GCIRCLE])
(CIRCLE.DRAWFN
[LAMBDA (CIRCLEELT WINDOW REGION) (* rrb " 7-Dec-85 20:38")
(* 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 (LOCALCIRCLE LOCALCIRCLEDASHING) of LCIRCLE))
(SETQ FILLING (fetch (LOCALCIRCLE LOCALCIRCLEFILLING) of LCIRCLE))
(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)
(COND
((EQ (DSPOPERATION NIL WINDOW)
(QUOTE ERASE)) (* use black in case the window moved because of
texture to window alignment bug.)
BLACKSHADE)
(T (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 "15-Nov-85 14:25")
(* 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 (SK.READ.CIRCLE.POINT WINDOW (fetch (INPUTPT INPUT.POSITION)
of CENTERPT)
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])
(SK.UPDATE.CIRCLE.AFTER.CHANGE
[LAMBDA (GCIRELT) (* rrb " 7-Dec-85 19:50")
(* updates the dependent fields of a circle element
when a field changes.)
(replace (CIRCLE CIRCLEREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GCIRELT)
with NIL])
(SK.READ.CIRCLE.POINT
[LAMBDA (WINDOW CENTERPT CURSOR) (* rrb "15-Nov-85 14:23")
(* reads a point from the user prompting them with a
circle that follows the cursor)
(COND
(SKETCH.VERBOSE.FEEDBACK (SK.READ.POINT.WITH.FEEDBACK WINDOW CURSOR (FUNCTION
SK.SHOW.CIRCLE)
CENTERPT))
(T (GETSKWPOSITION WINDOW CURSOR])
(SK.SHOW.CIRCLE
[LAMBDA (X Y WINDOW CENTERPT) (* rrb "15-Nov-85 14:18")
(* xors a circle to X Y from CENTERPT in a window.
Used as the feedback function for reading the radius
point for circles.)
(* Mark the point too.)
(SHOWSKETCHXY X Y WINDOW)
(PROG ((CENTERX (fetch (POSITION XCOORD) of CENTERPT))
(CENTERY (fetch (POSITION YCOORD) of CENTERPT)))
(DRAWCIRCLE CENTERX CENTERY (SK.DISTANCE.TO CENTERX CENTERY X Y)
1 NIL WINDOW])
(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.GLOBALREGIONFN
[LAMBDA (GCIRELT) (* rrb "18-Oct-85 16:32")
(* returns the global region occupied by a global
circle element.)
(OR (fetch (CIRCLE CIRCLEREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GCIRELT))
(PROG ((INDVCIRCLE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GCIRELT))
RADIUS CENTER REGION)
(* make the radius be too large by the amount of the brush to catch round off, i.e. it should be half the brush
size.)
[SETQ RADIUS (PLUS (DISTANCEBETWEEN (SETQ CENTER (fetch (CIRCLE
CENTERLATLON)
of INDVCIRCLE))
(fetch (CIRCLE RADIUSLATLON)
of INDVCIRCLE))
(fetch (BRUSH BRUSHSIZE) of (fetch (CIRCLE BRUSH)
of INDVCIRCLE]
(SETQ REGION (CREATEREGION (DIFFERENCE (fetch (POSITION XCOORD)
of CENTER)
RADIUS)
(DIFFERENCE (fetch (POSITION YCOORD)
of CENTER)
RADIUS)
(SETQ RADIUS (TIMES RADIUS 2))
RADIUS))
(replace (CIRCLE CIRCLEREGION) of INDVCIRCLE with REGION)
(RETURN REGION])
(CIRCLE.TRANSLATE
[LAMBDA (CIRCLESKELT DELTAPOS) (* rrb "18-Oct-85 11:00")
(* 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)
CIRCLEREGION ← NIL])
(CIRCLE.TRANSFORMFN
[LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "18-Oct-85 11:04")
(* 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)
CIRCLEREGION ← NIL])
(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 "18-Oct-85 11:01")
(* creates a sketch element)
(* region is a cache that will be filled if needed.)
(SET.CIRCLE.SCALE (create GLOBALPART
INDIVIDUALGLOBALPART ←(create CIRCLE
CENTERLATLON ← CENTERPT
RADIUSLATLON ← RADIUSPT
BRUSH ← BRUSH
DASHING ← DASHING
CIRCLEINITSCALE ← INITSCALE
CIRCLEFILLING ← FILLING
CIRCLEREGION ← NIL])
(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 SCRNELTS) (* rrb " 6-Nov-85 09:49")
(* changefn for curves)
(PROG (ASPECT HOW)
(SETQ HOW (SELECTQ [SETQ ASPECT
(\CURSOR.IN.MIDDLE.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
(fetch (BRUSH BRUSHCOLOR)
of (GETSKETCHELEMENTPROP (fetch
(SCREENELT
GLOBALPART)
of
(CAR SCRNELTS))
(QUOTE BRUSH]
NIL))
(RETURN (AND HOW (LIST ASPECT HOW])
)
(DEFINEQ
(BRUSHP
[LAMBDA (BR) (* rrb "31-Oct-85 09:46")
(* checks if BR is a legal brush)
(AND (LISTP BR)
(MEMB (CAR BR)
(QUOTE (ROUND SQUARE VERTICAL HORIZONTAL DIAGONAL)))
[NUMBERP (CAR (LISTP (CDR BR]
[OR (NULL (CDDR BR))
(AND [OR [NULL (CAR (LISTP (CDDR BR]
(\POSSIBLECOLOR (CAR (LISTP (CDDR BR]
(NULL (CDDDR BR]
BR])
(SK.INSURE.BRUSH
[LAMBDA (BRUSH) (* rrb "16-Oct-85 15:37")
(* coerces BRUSH into a brush.
Errors if it won't go.)
(COND
((BRUSHP BRUSH))
((NUMBERP BRUSH)
(create BRUSH
BRUSHSIZE ← BRUSH))
((NULL BRUSH)
SK.DEFAULT.BRUSH)
(T (\ILLEGAL.ARG BRUSH])
(SK.INSURE.DASHING
[LAMBDA (DASHING) (* rrb "16-Oct-85 17:04")
(* checks the validity of a dashing argument.
NIL is ok and means no dashing.)
(AND DASHING (OR (DASHINGP DASHING)
(\ILLEGAL.ARG DASHING])
)
[DECLARE: EVAL@COMPILE
(RECORD BRUSH (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR))
]
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD LOCALCIRCLE ((CENTERPOSITION RADIUSPOSITION)
LOCALHOTREGION RADIUS LOCALCIRCLEBRUSH LOCALCIRCLEFILLING LOCALCIRCLEDASHING))
(TYPERECORD CIRCLE (CENTERLATLON RADIUSLATLON BRUSH DASHING CIRCLEINITSCALE CIRCLEFILLING
CIRCLEREGION))
]
)
(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 \CURSOR.IN.MIDDLE.MENU)
(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 SK.CREATE.DEFAULT.FILLING SKFILLINGP SK.INSURE.FILLING SK.INSURE.COLOR))
(COMS (FNS SKETCH.CREATE.CIRCLE CIRCLE.EXPANDFN CIRCLE.DRAWFN CIRCLE.INPUTFN
SK.UPDATE.CIRCLE.AFTER.CHANGE SK.READ.CIRCLE.POINT SK.SHOW.CIRCLE CIRCLE.INSIDEFN
CIRCLE.REGIONFN CIRCLE.GLOBALREGIONFN CIRCLE.TRANSLATE CIRCLE.TRANSFORMFN
CIRCLE.TRANSLATEPTS SK.CIRCLE.CREATE SET.CIRCLE.SCALE SK.BRUSH.READCHANGE)
(FNS BRUSHP SK.INSURE.BRUSH SK.INSURE.DASHING)
(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 SKETCH.CREATE.ELLIPSE ELLIPSE.EXPANDFN ELLIPSE.DRAWFN ELLIPSE.INPUTFN
SK.READ.ELLIPSE.MAJOR.PT SK.SHOW.ELLIPSE.MAJOR.RADIUS SK.READ.ELLIPSE.MINOR.PT
SK.SHOW.ELLIPSE.MINOR.RADIUS ELLIPSE.INSIDEFN ELLIPSE.CREATE
SK.UPDATE.ELLIPSE.AFTER.CHANGE ELLIPSE.REGIONFN ELLIPSE.GLOBALREGIONFN
ELLIPSE.TRANSLATEFN ELLIPSE.TRANSFORMFN ELLIPSE.TRANSLATEPTS MARK.SPOT
DISTANCEBETWEEN SK.DISTANCE.TO 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 SKETCH.CREATE.OPEN.CURVE OPENCURVE.INPUTFN SK.CURVE.CREATE MAXXEXTENT MAXYEXTENT
KNOT.SET.SCALE.FIELD OPENCURVE.DRAWFN OPENCURVE.EXPANDFN OPENCURVE.READCHANGEFN
OPENCURVE.TRANSFORMFN OPENCURVE.TRANSLATEPTSFN SKETCH.CREATE.CLOSED.CURVE
CLOSEDCURVE.DRAWFN CLOSEDCURVE.EXPANDFN CLOSEDCURVE.REGIONFN
CLOSEDCURVE.GLOBALREGIONFN READ.LIST.OF.POINTS CLOSEDCURVE.INPUTFN
CLOSEDCURVE.READCHANGEFN CLOSEDCURVE.TRANSFORMFN CLOSEDCURVE.TRANSLATEPTSFN
INVISIBLEPARTP SHOWSKETCHPOINT SHOWSKETCHXY KNOTS.REGIONFN OPENWIRE.GLOBALREGIONFN
CURVE.REGIONFN OPENCURVE.GLOBALREGIONFN 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)
(FNS SK.CHANGE.ELEMENT.KNOTS)
(FNS SK.INSURE.POINT.LIST SK.INSURE.POSITION)
(DECLARE: DONTCOPY (RECORDS KNOTELT LOCALCURVE OPENCURVE CLOSEDCURVE LOCALCLOSEDCURVE
LOCALCLOSEDWIRE))
(UGLYVARS OPENCURVEICON CLOSEDCURVEICON)
(CURSORS CURVE.KNOT))
(COMS (FNS SKETCH.CREATE.WIRE CLOSEDWIRE.EXPANDFN KNOTS.INSIDEFN OPEN.WIRE.DRAWFN
WIRE.EXPANDFN SK.UPDATE.WIRE.ELT.AFTER.CHANGE OPENWIRE.READCHANGEFN
OPENWIRE.TRANSFORMFN OPENWIRE.TRANSLATEPTSFN SK.EXPAND.ARROWHEADS WIRE.INPUTFN
SK.READ.WIRE.POINTS SK.READ.POINTS.WITH.FEEDBACK OPENWIRE.FEEDBACKFN
CLOSEDWIRE.FEEDBACKFN CLOSEDWIRE.REGIONFN CLOSEDWIRE.GLOBALREGIONFN SK.WIRE.CREATE
WIRE.ADD.POINT.TO.END READ.ARROW.CHANGE CHANGE.ELTS.ARROWHEADS)
(FNS SKETCH.CREATE.CLOSED.WIRE 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)
(FNS SK.INSURE.ARROWHEADS SK.ARROWHEADP)
(DECLARE: DONTCOPY (RECORDS LOCALWIRE WIRE CLOSEDWIRE LOCALCLOSEDWIRE ARROWHEAD))
(UGLYVARS WIREICON CLOSEDWIREICON)
(INITVARS (SK.ARROWHEAD.ANGLE.INCREMENT 5)
(SK.ARROWHEAD.LENGTH.INCREMENT 2))
(ADDVARS (SK.ARROWHEAD.TYPES LINE CLOSEDLINE CURVE SOLID))
(INITVARS (SK.DEFAULT.ARROW.LENGTH 8)
(SK.DEFAULT.ARROW.TYPE (QUOTE CURVE))
(SK.DEFAULT.ARROW.ANGLE 18.0))
(GLOBALVARS SK.DEFAULT.ARROW.LENGTH SK.DEFAULT.ARROW.TYPE SK.DEFAULT.ARROW.ANGLE
SK.ARROWHEAD.TYPES)
(INITVARS (SK.ARROW.END.MENU)
(SK.ARROW.EDIT.MENU)))
(COMS (* stuff to support the text element type.)
(FNS SKETCH.CREATE.TEXT 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.UPDATE.TEXT.AFTER.CHANGE
SK.TEXT.FROM.TEXTBOX TEXT.SET.GLOBAL.REGIONS TEXT.REGIONFN TEXT.GLOBALREGIONFN
TEXT.TRANSLATEFN TEXT.TRANSFORMFN TEXT.TRANSLATEPTSFN TEXT.UPDATEFN SK.CHANGE.TEXT
TEXT.SET.SCALES SK.FONT.LIST BREAK.AT.CARRIAGE.RETURNS)
(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)
(FNS SK.FONT.LIST SK.INSURE.FONT SK.INSURE.STYLE SK.INSURE.TEXT)
(VARS INDICATE.TEXT.SHADE)
[INITVARS (SK.DEFAULT.FONT)
(SK.DEFAULT.TEXT.ALIGNMENT (QUOTE (CENTER BASELINE]
(INITVARS \FONTSONFILE)
(ADDVARS (SK.HORIZONTAL.STYLES LEFT RIGHT CENTER)
(SK.VERTICAL.STYLES TOP CENTER BASELINE BOTTOM))
(VARS (SKETCH.TERMTABLE (CREATE.SKETCH.TERMTABLE)))
(GLOBALVARS SKETCH.TERMTABLE SK.DEFAULT.TEXT.ALIGNMENT INDICATE.TEXT.SHADE \FONTSONFILE
SK.HORIZONTAL.STYLES SK.VERTICAL.STYLES))
(COMS (* stuff for supporting the TEXTBOX sketch element.)
(FNS SKETCH.CREATE.TEXTBOX SK.BREAK.INTO.LINES SK.BRUSH.SIZE SK.TEXTBOX.CREATE
SK.TEXTBOX.CREATE1 SK.UPDATE.TEXTBOX.AFTER.CHANGE SK.TEXTBOX.POSITION.IN.BOX
TEXTBOX.CHANGEFN TEXTBOX.DRAWFN SK.TEXTURE.AROUND.REGIONS TEXTBOX.EXPANDFN
TEXTBOX.INPUTFN TEXTBOX.INSIDEFN TEXTBOX.REGIONFN TEXTBOX.GLOBALREGIONFN
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 SKETCH.CREATE.BOX 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.GLOBALREGIONFN 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 SKETCH.CREATE.ARC ARC.DRAWFN ARC.EXPANDFN ARC.INPUTFN SK.INVERT.CIRCLE
SK.READ.ARC.ANGLE.POINT SK.SHOW.ARC ARC.CREATE SK.UPDATE.ARC.AFTER.CHANGE
ARC.MOVEFN ARC.TRANSLATEPTS ARC.INSIDEFN ARC.REGIONFN ARC.GLOBALREGIONFN
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)
(FNS SK.INSURE.DIRECTION)
(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 CW.ARC.ANGLE.CURSOR CW.ARC.RADIUS.CURSOR)
(UGLYVARS ARCICON))
[COMS (* property getting and setting stuff)
(FNS GETSKETCHELEMENTPROP \SK.GET.BRUSH \SK.GET.FILLING \SK.GET.ARROWHEADS \SK.GET.FONT
\SK.GET.JUSTIFICATION \SK.GET.DIRECTION \SK.GET.DASHING PUTSKETCHELEMENTPROP
\SK.PUT.FONT \SK.PUT.JUSTIFICATION \SK.PUT.DIRECTION \SK.PUT.DASHING \SK.PUT.BRUSH
\SK.PUT.ARROWHEADS \SKELT.PUT.FILLING SK.COPY.ELEMENT.PROPERTY.LIST SKETCH.UPDATE
SKETCH.UPDATE1 \SKELT.GET.SCALE \SKELT.PUT.SCALE \SKELT.PUT.DATA
SK.REPLACE.TEXT.IN.ELEMENT \SKELT.GET.DATA \SK.GET.1STCONTROLPT
\SK.PUT.1STCONTROLPT \SK.GET.2NDCONTROLPT \SK.PUT.2NDCONTROLPT
\SK.GET.3RDCONTROLPT \SK.PUT.3RDCONTROLPT)
(FNS LOWERLEFTCORNER UPPERRIGHTCORNER)
(* stuff for compatibility with unadvertised interface. Remove after L release.)
(P (MOVD? (QUOTE GETSKETCHELEMENTPROP)
(QUOTE GETSKELEMENTPROP))
(MOVD? (QUOTE PUTSKETCHELEMENTPROP)
(QUOTE PUTSKELEMENTPROP))
(MOVD? (QUOTE SKETCH.CREATE.IMAGE.OBJECT)
(QUOTE SKETCH.IMAGE.OBJECT.ELEMENT]
(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
(SKETCH.CREATE.ELLIPSE
[LAMBDA (CENTERPT ORIENTATIONPT OTHERRADIUSPT BRUSH DASHING WILLBEFILLING SCALE)
(* rrb "16-Oct-85 17:05")
(* creates a sketch ellipse element.)
(ELLIPSE.CREATE (SK.INSURE.POSITION CENTERPT)
(SK.INSURE.POSITION ORIENTATIONPT)
(SK.INSURE.POSITION OTHERRADIUSPT)
(SK.INSURE.BRUSH BRUSH)
(SK.INSURE.DASHING DASHING)
(OR (NUMBERP SCALE)
1.0])
(ELLIPSE.EXPANDFN
[LAMBDA (GELLIPSE SCALE) (* rrb " 7-Dec-85 20:40")
(* 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
ELLIPSEREGION ← NIL]
(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)
LOCALELLIPSEDASHING ←(fetch (ELLIPSE DASHING)
of INDGELLIPSE))
GLOBALPART ← GELLIPSE])
(ELLIPSE.DRAWFN
[LAMBDA (ELLIPSEELT WINDOW REGION) (* rrb " 7-Dec-85 20:40")
(* 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 (LOCALELLIPSE LOCALELLIPSEDASHING) of LELLIPSE))
(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 "14-Nov-85 17:01")
(* 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 (SK.READ.ELLIPSE.MAJOR.PT WINDOW (fetch (INPUTPT INPUT.POSITION)
of CENTER)))
(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 (SK.READ.ELLIPSE.MINOR.PT WINDOW (fetch (INPUTPT INPUT.POSITION)
of CENTER)
(fetch (INPUTPT INPUT.POSITION)
of MAJRAD)))
(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])
(SK.READ.ELLIPSE.MAJOR.PT
[LAMBDA (SKW CENTERPT) (* rrb "14-Nov-85 16:46")
(* reads a position from the user that will be the
major radius point of an ellipse.)
(COND
(SKETCH.VERBOSE.FEEDBACK (SK.READ.POINT.WITH.FEEDBACK WINDOW ELLIPSE.SEMI.MAJOR
(FUNCTION
SK.SHOW.ELLIPSE.MAJOR.RADIUS)
CENTERPT))
(T (GETSKWPOSITION WINDOW ELLIPSE.SEMI.MAJOR])
(SK.SHOW.ELLIPSE.MAJOR.RADIUS
[LAMBDA (X Y WINDOW CENTERPT) (* rrb "14-Nov-85 16:46")
(* xors a line from X Y to a point the opposite side of CENTERPT in a window. Used as the feedback function for
reading the major radius point for ellipses.)
(* Mark the point too.)
(SHOWSKETCHXY X Y WINDOW)
(DRAWLINE X Y (PLUS X (TIMES 2 (DIFFERENCE (fetch (POSITION XCOORD) of CENTERPT)
X)))
(PLUS Y (TIMES 2 (DIFFERENCE (fetch (POSITION YCOORD) of CENTERPT)
Y)))
1
(QUOTE INVERT)
WINDOW])
(SK.READ.ELLIPSE.MINOR.PT
[LAMBDA (SKW CENTERPT MAJORPT) (* rrb "14-Nov-85 17:01")
(* reads a position from the user that will be the
major radius point of an ellipse.)
(COND
[SKETCH.VERBOSE.FEEDBACK (SK.READ.POINT.WITH.FEEDBACK WINDOW ELLIPSE.SEMI.MINOR
(FUNCTION
SK.SHOW.ELLIPSE.MINOR.RADIUS)
(LIST CENTERPT (DISTANCEBETWEEN
CENTERPT MAJORPT)
(COMPUTE.ELLIPSE.ORIENTATION
CENTERPT MAJORPT]
(T (GETSKWPOSITION WINDOW ELLIPSE.SEMI.MINOR])
(SK.SHOW.ELLIPSE.MINOR.RADIUS
[LAMBDA (X Y WINDOW ELLIPSEARGS) (* rrb "15-Nov-85 14:17")
(* xors a line from X Y to a point the opposite side of CENTERPT in a window. Used as the feedback function for
reading the major radius point for ellipses.)
(* Mark the point too.)
(SHOWSKETCHXY X Y WINDOW)
(PROG ((CENTERX (CAR ELLIPSEARGS))
CENTERY)
(SETQ CENTERY (fetch (POSITION YCOORD) of CENTERX))
(SETQ CENTERX (fetch (POSITION XCOORD) of CENTERX))
(DRAWELLIPSE CENTERX CENTERY (SK.DISTANCE.TO CENTERX CENTERY X Y)
(CADR ELLIPSEARGS)
(CADDR ELLIPSEARGS)
1 NIL 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])
(SK.UPDATE.ELLIPSE.AFTER.CHANGE
[LAMBDA (GELLIPSEELT) (* rrb " 7-Dec-85 19:54")
(* updates the dependent fields of an ellipse element
when a field changes.)
(replace (ELLIPSE ELLIPSEREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of
GELLIPSEELT)
with NIL])
(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.GLOBALREGIONFN
[LAMBDA (GELELT) (* rrb "20-Nov-85 16:09")
(* returns the global region occupied by a global
ellipse element.)
(OR (fetch (ELLIPSE ELLIPSEREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELELT))
(PROG ((INDVELLIPSE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELELT))
CENTERPT HALFBOXSIZE MAXRAD REGION)
(SETQ CENTERPT (fetch (ELLIPSE ELLIPSECENTERLATLON) of INDVELLIPSE))
[SETQ MAXRAD (MAX (DISTANCEBETWEEN CENTERPT (fetch (ELLIPSE SEMIMAJORLATLON)
of INDVELLIPSE))
(DISTANCEBETWEEN CENTERPT (fetch (ELLIPSE SEMIMINORLATLON)
of INDVELLIPSE]
[SETQ HALFBOXSIZE (PLUS MAXRAD (fetch (BRUSH BRUSHSIZE)
of (fetch (ELLIPSE BRUSH) of
INDVELLIPSE]
(* use a square about the center as wide as the
largest radius. This gets too much but is easy to
calculate.)
(SETQ REGION (CREATEREGION (DIFFERENCE (fetch (POSITION XCOORD)
of CENTERPT)
HALFBOXSIZE)
(DIFFERENCE (fetch (POSITION YCOORD)
of CENTERPT)
HALFBOXSIZE)
(ITIMES HALFBOXSIZE 2)
(ITIMES HALFBOXSIZE 2)))
(replace (ELLIPSE ELLIPSEREGION) of INDVELLIPSE with REGION)
(RETURN REGION])
(ELLIPSE.TRANSLATEFN
[LAMBDA (SKELT DELTAPOS) (* rrb "18-Oct-85 17:08")
(* 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)
ELLIPSEREGION ← NIL])
(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])
(SK.DISTANCE.TO
[LAMBDA (X1 Y1 X2 Y2) (* rrb "15-Nov-85 14:17")
(* returns the distance between two points)
(SQRT (PLUS (SQUARE (DIFFERENCE X1 X2))
(SQUARE (DIFFERENCE Y1 Y2])
(SQUARE
[LAMBDA (X)
(TIMES X X])
(COMPUTE.ELLIPSE.ORIENTATION
[LAMBDA (CENTERPT MAJRADPT) (* rrb "19-Oct-85 12:44")
(* computes the orientation of an ellipse from its
center point and its major radius point.)
(PROG [(DELTAX (IDIFFERENCE (fetch (POSITION XCOORD) of MAJRADPT)
(fetch (POSITION XCOORD) of CENTERPT]
(RETURN (COND
((ZEROP DELTAX)
90.0)
(T (ARCTAN2 (IDIFFERENCE (fetch (POSITION YCOORD) of MAJRADPT)
(fetch (POSITION YCOORD) of CENTERPT))
DELTAX])
(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)
LOCALHOTREGION SEMIMINORRADIUS SEMIMAJORRADIUS LOCALELLIPSEBRUSH
LOCALELLIPSEDASHING LOCALELLIPSEFILLING))
(TYPERECORD ELLIPSE (ELLIPSECENTERLATLON SEMIMINORLATLON SEMIMAJORLATLON ORIENTATION BRUSH DASHING
ELLIPSEINITSCALE ELLIPSEFILLING ELLIPSEREGION))
]
)
(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
(SKETCH.CREATE.OPEN.CURVE
[LAMBDA (POINTS BRUSH DASHING ARROWHEADS SCALE) (* rrb "16-Oct-85 17:14")
(* creates a sketch open curve element.)
(SK.CURVE.CREATE (SK.INSURE.POINT.LIST POINTS)
NIL
(SK.INSURE.BRUSH BRUSH)
(SK.INSURE.DASHING DASHING)
(OR (NUMBERP SCALE)
1.0)
(SK.INSURE.ARROWHEADS ARROWHEADS])
(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 " 7-Dec-85 20:42")
(* 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 (LOCALCURVE LOCALCURVEDASHING) of LCURVE)
WINDOW)
(DRAWARROWHEADS (fetch (OPENCURVE CURVEARROWHEADS) of GCURVE)
(fetch (LOCALCURVE ARROWHEADPTS) of LCURVE)
WINDOW BRUSH])
(OPENCURVE.EXPANDFN
[LAMBDA (GELT SCALE) (* rrb " 7-Dec-85 20:42")
(* 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
OPENCURVEREGION ← NIL]
(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)
LOCALCURVEDASHING ←(fetch (OPENCURVE DASHING)
of INDGELT))
GLOBALPART ← GELT])
(OPENCURVE.READCHANGEFN
[LAMBDA (SKW SCRNELTS) (* rrb "20-Nov-85 10:42")
(* changefn for curves)
(PROG (ASPECT HOW)
(SETQ HOW (SELECTQ [SETQ ASPECT
(\CURSOR.IN.MIDDLE.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.")
("Add point"
(QUOTE ADDPOINT)
"adds a point to the curve."]
(SIZE (READSIZECHANGE "Change size how?"))
(SHAPE (READBRUSHSHAPE))
(ARROW (READ.ARROW.CHANGE))
(DASHING (READ.DASHING.CHANGE))
[BRUSHCOLOR (READ.COLOR.CHANGE
"Change curve color how?" NIL
(fetch (BRUSH BRUSHCOLOR)
of (GETSKETCHELEMENTPROP (fetch
(SCREENELT
GLOBALPART)
of
(CAR SCRNELTS))
(QUOTE BRUSH]
(ADDPOINT (READ.POINT.TO.ADD (CAR SCRNELTS)
SKW))
NIL))
(RETURN (AND HOW (LIST ASPECT HOW])
(OPENCURVE.TRANSFORMFN
[LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "18-Oct-85 17:02")
(* 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)
OPENCURVEREGION ←
NIL])
(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])
(SKETCH.CREATE.CLOSED.CURVE
[LAMBDA (POINTS BRUSH DASHING WILLBEFILLING SCALE) (* rrb "16-Oct-85 17:15")
(* creates a sketch closed curve element.)
(SK.CURVE.CREATE (SK.INSURE.POINT.LIST POINTS)
T
(SK.INSURE.BRUSH BRUSH)
(SK.INSURE.DASHING DASHING)
(OR (NUMBERP SCALE)
1.0])
(CLOSEDCURVE.DRAWFN
[LAMBDA (CURVEELT WINDOW REGION) (* rrb " 7-Dec-85 20:45")
(* draws a curve figure element.)
(PROG ((LCURVE (fetch (SCREENELT LOCALPART) 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 (LOCALCLOSEDCURVE LOCALCLOSEDCURVEKNOTS) of LCURVE)
T
(fetch (LOCALCLOSEDCURVE LOCALCLOSEDCURVEBRUSH) of LCURVE)
(fetch (LOCALCLOSEDCURVE LOCALCLOSEDCURVEDASHING) of LCURVE)
WINDOW])
(CLOSEDCURVE.EXPANDFN
[LAMBDA (GELT SCALE) (* rrb " 7-Dec-85 20:45")
(* 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
CLOSEDCURVEREGION ← NIL]
(RETURN (create SCREENELT
LOCALPART ←(create LOCALCLOSEDCURVE
LOCALCLOSEDCURVEKNOTS ←(for LATLONPT
in (fetch
LATLONKNOTS
of
INDVKNOTELT)
collect
(
SK.SCALE.POSITION.INTO.VIEWER
LATLONPT SCALE))
LOCALCLOSEDCURVEBRUSH ←(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)
LOCALCLOSEDCURVEFILLING ←(APPEND
(fetch (CLOSEDCURVE CLOSEDCURVEFILLING)
of INDVKNOTELT))
LOCALCLOSEDCURVEDASHING ←(fetch (CLOSEDCURVE
DASHING)
of INDVKNOTELT))
GLOBALPART ← GELT])
(CLOSEDCURVE.REGIONFN
[LAMBDA (KNOTSCRELT) (* rrb " 2-Dec-85 20:40")
(* 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 (LOCALCLOSEDCURVE
LOCALCLOSEDCURVEBRUSH)
of (fetch (SCREENELT LOCALPART)
of KNOTSCRELT]
2])
(CLOSEDCURVE.GLOBALREGIONFN
[LAMBDA (GCLOSEDCURVEELT) (* rrb "18-Oct-85 16:37")
(* returns the global region occupied by a global
closed curve element.)
(OR (fetch (CLOSEDCURVE CLOSEDCURVEREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GCLOSEDCURVEELT))
(PROG ((INDVCLOSEDCURVE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GCLOSEDCURVEELT))
REGION)
(* uses the heuristic that the region containing the curve is not more than 40% larger than the knots.
This was determined empirically on several curves.)
[SETQ REGION (INCREASEREGION (EXPANDREGION (REGION.CONTAINING.PTS
(fetch (CLOSEDCURVE
LATLONKNOTS)
of INDVCLOSEDCURVE))
1.4)
(SK.BRUSH.SIZE (fetch (CLOSEDCURVE BRUSH)
of INDVCLOSEDCURVE]
(replace (CLOSEDCURVE CLOSEDCURVEREGION) of INDVCLOSEDCURVE with REGION)
(RETURN REGION])
(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.READCHANGEFN
[LAMBDA (SKW SCRNELTS) (* rrb "20-Nov-85 11:09")
(* changefn for curves)
(PROG (ASPECT HOW)
(SETQ HOW (SELECTQ [SETQ ASPECT
(\CURSOR.IN.MIDDLE.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.")
("Add point"
(QUOTE ADDPOINT)
"adds a point to the curve."]
(SIZE (READSIZECHANGE "Change size how?"))
(SHAPE (READBRUSHSHAPE))
(DASHING (READ.DASHING.CHANGE))
[BRUSHCOLOR (READ.COLOR.CHANGE
"Change brush color how?" NIL
(fetch (BRUSH BRUSHCOLOR)
of (GETSKETCHELEMENTPROP (fetch
(SCREENELT
GLOBALPART)
of
(CAR SCRNELTS))
(QUOTE BRUSH]
(ADDPOINT (READ.POINT.TO.ADD (CAR SCRNELTS)
SKW))
NIL))
(RETURN (AND HOW (LIST ASPECT HOW])
(CLOSEDCURVE.TRANSFORMFN
[LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "18-Oct-85 16:52")
(* 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)
CLOSEDCURVEREGION ←
NIL])
(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])
(OPENWIRE.GLOBALREGIONFN
[LAMBDA (GOPENWIREELT) (* rrb "23-Oct-85 11:30")
(* returns the global region occupied by a global open
curve element.)
(OR (fetch (WIRE OPENWIREREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GOPENWIREELT))
(PROG ((INDVOPENWIRE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GOPENWIREELT))
REGION)
[SETQ REGION (INCREASEREGION (REGION.CONTAINING.PTS (fetch (WIRE
LATLONKNOTS)
of INDVOPENWIRE))
(SK.BRUSH.SIZE (fetch (WIRE BRUSH)
of INDVOPENWIRE]
(replace (WIRE OPENWIREREGION) of INDVOPENWIRE with REGION)
(RETURN REGION])
(CURVE.REGIONFN
[LAMBDA (OPENCURVESCRELT) (* rrb "18-Oct-85 16:36")
(* 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 40% 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])
(OPENCURVE.GLOBALREGIONFN
[LAMBDA (GOPENCURVEELT) (* rrb "18-Oct-85 16:36")
(* returns the global region occupied by a global open
curve element.)
(OR (fetch (OPENCURVE OPENCURVEREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GOPENCURVEELT))
(PROG ((INDVOPENCURVE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GOPENCURVEELT))
REGION)
(* uses the heuristic that the region containing the curve is not more than 40% larger than the knots.
This was determined empirically on several curves.)
[SETQ REGION (INCREASEREGION (EXPANDREGION (REGION.CONTAINING.PTS
(fetch (OPENCURVE LATLONKNOTS)
of INDVOPENCURVE))
1.4)
(SK.BRUSH.SIZE (fetch (OPENCURVE BRUSH)
of INDVOPENCURVE]
(replace (OPENCURVE OPENCURVEREGION) of INDVOPENCURVE with REGION)
(RETURN REGION])
(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 "18-Oct-85 16:45")
(* 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
OPENWIREREGION ← NIL))
(BOX (create BOX using GLINELT BRUSH ← NEWBRUSH))
(ARC (create ARC
using GLINELT ARCBRUSH ← NEWBRUSH ARCREGION ←
NIL))
(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
CLOSEDWIREREGION ← NIL))
(CLOSEDCURVE (create CLOSEDCURVE
using GLINELT BRUSH ← NEWBRUSH
CLOSEDCURVEREGION ← NIL))
(OPENCURVE (create OPENCURVE
using GLINELT BRUSH ← NEWBRUSH
OPENCURVEREGION ← NIL))
(CIRCLE (create CIRCLE
using GLINELT BRUSH ← NEWBRUSH
CIRCLEREGION ← NIL))
(ELLIPSE (create ELLIPSE
using GLINELT BRUSH ← NEWBRUSH
ELLIPSEREGION ← NIL))
(SHOULDNT)))
(RETURN (create GLOBALPART
COMMONGLOBALPART ←(fetch (GLOBALPART COMMONGLOBALPART)
of ELTWITHLINE)
INDIVIDUALGLOBALPART ← NEWELT])
(SK.CHANGE.ANGLE
[LAMBDA (ELTWITHARC HOW SKW) (* rrb "18-Oct-85 17:05")
(* 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]
ARCREGION ← NIL])
(SK.CHANGE.ARC.DIRECTION
[LAMBDA (ELTWITHARC HOW SKW) (* rrb "18-Oct-85 17:06")
(* 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)
ARCREGION ← NIL])
(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 " 6-Nov-85 09:50")
(* interacts to get whether a line size should be
increased or decreased.)
(PROG [(NEWVALUE (\CURSOR.IN.MIDDLE.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])
)
(DEFINEQ
(SK.CHANGE.ELEMENT.KNOTS
[LAMBDA (ELTWITHKNOTS NEWKNOTS) (* rrb "20-Nov-85 11:01")
(* changes the knots in the element ELTWITHKNOTS)
(PROG ((GCURVELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHKNOTS))
NEWELT)
(SETQ NEWELT (SELECTQ (fetch (INDIVIDUALGLOBALPART GTYPE) of GCURVELT)
(CLOSEDCURVE (create CLOSEDCURVE using GCURVELT LATLONKNOTS
← NEWKNOTS))
(OPENCURVE (create OPENCURVE using GCURVELT LATLONKNOTS ←
NEWKNOTS))
(WIRE (create WIRE using GCURVELT LATLONKNOTS ← NEWKNOTS))
(CLOSEDWIRE (create CLOSEDWIRE using GCURVELT LATLONKNOTS ←
NEWKNOTS))
(RETURN)))
(RETURN (KNOT.SET.SCALE.FIELD (create GLOBALPART
COMMONGLOBALPART ←(fetch (GLOBALPART
COMMONGLOBALPART)
of ELTWITHKNOTS)
INDIVIDUALGLOBALPART ← NEWELT])
)
(DEFINEQ
(SK.INSURE.POINT.LIST
[LAMBDA (POINTLST) (* rrb "16-Oct-85 17:01")
(* makes sure POINTLST is a list of positions.)
(COND
((LISTP POINTLST)
(AND (EVERY POINTLST (FUNCTION SK.INSURE.POSITION))
POINTLST))
(T (\ILLEGAL.ARG POINTLST])
(SK.INSURE.POSITION
[LAMBDA (POSITION) (* rrb "16-Oct-85 17:02")
(OR (POSITIONP POSITION)
(\ILLEGAL.ARG POSITION])
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(TYPERECORD KNOTELT (LATLONKNOTS BRUSH DASHING KNOTINITSCALE))
(RECORD LOCALCURVE (KNOTS LOCALHOTREGION ARROWHEADPTS LOCALCURVEBRUSH LOCALCURVEDASHING))
(TYPERECORD OPENCURVE (LATLONKNOTS BRUSH DASHING CURVEARROWHEADS OPENCURVEINITSCALE OPENCURVEREGION)
)
(TYPERECORD CLOSEDCURVE (LATLONKNOTS BRUSH DASHING CLOSEDCURVEINITSCALE CLOSEDCURVEFILLING
CLOSEDCURVEREGION))
(RECORD LOCALCLOSEDCURVE (LOCALCLOSEDCURVEKNOTS LOCALCLOSEDCURVEHOTREGION LOCALCLOSEDCURVEBRUSH
LOCALCLOSEDCURVEFILLING LOCALCLOSEDCURVEDASHING))
(RECORD LOCALCLOSEDWIRE (KNOTS LOCALHOTREGION LOCALCLOSEDWIREBRUSH LOCALCLOSEDWIREFILLING))
]
)
(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
(SKETCH.CREATE.WIRE
[LAMBDA (POINTS BRUSH DASHING ARROWHEADS SCALE) (* rrb "16-Oct-85 17:05")
(* creates a sketch wire element.)
(SK.WIRE.CREATE (SK.INSURE.POINT.LIST POINTS)
(SK.INSURE.BRUSH BRUSH)
(SK.INSURE.DASHING DASHING)
NIL
(OR (NUMBERP SCALE)
1.0)
(SK.INSURE.ARROWHEADS ARROWHEADS)
NIL])
(CLOSEDWIRE.EXPANDFN
[LAMBDA (GELT SCALE) (* rrb " 2-Dec-85 20:42")
(* 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
CLOSEDWIREREGION ← NIL]
(RETURN (create SCREENELT
LOCALPART ←(create LOCALCLOSEDWIRE
KNOTS ←(for LATLONPT
in (fetch LATLONKNOTS
of INDVKNOTELT)
collect (
SK.SCALE.POSITION.INTO.VIEWER
LATLONPT SCALE))
LOCALCLOSEDWIREBRUSH ←(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)
LOCALCLOSEDWIREFILLING ←(APPEND
(fetch (CLOSEDWIRE CLOSEDWIREFILLING)
of INDVKNOTELT)))
GLOBALPART ← GELT])
(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])
(OPEN.WIRE.DRAWFN
[LAMBDA (OPENWIREELT WIN REG OPERATION) (* rrb " 7-Dec-85 20:11")
(* draws an open wire element.)
(WB.DRAWLINE OPENWIREELT WIN REG OPERATION NIL (fetch (LOCALWIRE LOCALWIREDASHING)
of (fetch (SCREENELT LOCALPART)
of OPENWIREELT))
(fetch (LOCALWIRE LOCALOPENWIREBRUSH) of (fetch (SCREENELT LOCALPART)
of OPENWIREELT])
(WIRE.EXPANDFN
[LAMBDA (GELT SCALE) (* rrb " 7-Dec-85 20:34")
(* 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
OPENWIREREGION ← NIL]
(RETURN (create SCREENELT
LOCALPART ←(create LOCALWIRE
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)
LOCALOPENWIREBRUSH ←(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)
LOCALWIREDASHING ←(fetch (WIRE OPENWIREDASHING)
of INDGELT))
GLOBALPART ← GELT])
(SK.UPDATE.WIRE.ELT.AFTER.CHANGE
[LAMBDA (GWIRELT) (* rrb "11-Dec-85 11:27")
(* updates the dependent fields of a wire element
after one of the fields changes.)
(* clear the region cache)
(replace (OPENCURVE OPENCURVEREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GWIRELT)
with NIL)
(KNOT.SET.SCALE.FIELD GWIRELT])
(OPENWIRE.READCHANGEFN
[LAMBDA (SKW WIREELTS) (* rrb " 6-Nov-85 09:50")
(* * change function for line elements.)
(PROG (ASPECT HOW)
(SETQ HOW (SELECTQ [SETQ ASPECT
(\CURSOR.IN.MIDDLE.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
(fetch (BRUSH BRUSHCOLOR)
of (GETSKETCHELEMENTPROP (fetch
(SCREENELT
GLOBALPART)
of
(CAR WIREELTS))
(QUOTE BRUSH]
NIL))
(RETURN (AND HOW (LIST ASPECT HOW])
(OPENWIRE.TRANSFORMFN
[LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "18-Oct-85 16:50")
(* 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)
OPENWIREREGION ←
NIL])
(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 " 1-Nov-85 10:09")
(* 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)
(fetch (ARROWHEAD ARROWTYPE) of SPEC)))
((ARC OPENCURVE)
(CURVE.ARROWHEAD.POINTS
LOCALKNOTS T (fetch (ARROWHEAD ARROWANGLE)
of SPEC)
(QUOTIENT (fetch (ARROWHEAD ARROWLENGTH)
of SPEC)
SCALE)
(fetch (ARROWHEAD ARROWTYPE) of SPEC)))
(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)
(fetch (ARROWHEAD ARROWTYPE) of SPEC)))
((ARC OPENCURVE)
(CURVE.ARROWHEAD.POINTS
LOCALKNOTS NIL (fetch (ARROWHEAD ARROWANGLE)
of SPEC)
(QUOTIENT (fetch (ARROWHEAD ARROWLENGTH)
of SPEC)
SCALE)
(fetch (ARROWHEAD ARROWTYPE) of SPEC)))
(RETURN NIL])
(WIRE.INPUTFN
[LAMBDA (W GPTLIST CLOSEDFLG BRUSH DEFSCALE DASHING FILLING)
(* rrb "15-Nov-85 11:39")
(* 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 (SK.READ.WIRE.POINTS
W CLOSEDFLG)
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])
(SK.READ.WIRE.POINTS
[LAMBDA (SKW CLOSEDFLG) (* rrb "15-Nov-85 11:27")
(* reads a list of points for an open wire.)
(COND
(SKETCH.VERBOSE.FEEDBACK (SK.READ.POINTS.WITH.FEEDBACK SKW NIL CLOSEDFLG))
(T (READ.LIST.OF.POINTS SKW])
(SK.READ.POINTS.WITH.FEEDBACK
[LAMBDA (W ALLOWDUPS? CLOSEDFLG) (* rrb "15-Nov-85 11:36")
(* reads a {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 (SK.READ.POINT.WITH.FEEDBACK W POINTREADINGCURSOR
(COND
(CLOSEDFLG (FUNCTION
CLOSEDWIRE.FEEDBACKFN))
(T (FUNCTION OPENWIRE.FEEDBACKFN)))
PTS))
(* 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) (* draw the line so it will remain displayed while the
user adds other points. This will not close it.)
(AND PTS (DRAWBETWEEN (fetch (INPUTPT INPUT.POSITION)
of (CAR (LAST PTS)))
(fetch (INPUTPT INPUT.POSITION) of PT)
1
(QUOTE INVERT)
W))
(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))
(* erase line)
(AND (CDR PTTAIL)
(DRAWBETWEEN (fetch (INPUTPT INPUT.POSITION) of (CAR PTTAIL))
(fetch (INPUTPT INPUT.POSITION) of (CADR PTTAIL))
1
(QUOTE INVERT)
W)))
(CLRPROMPT) (* return points)
(RETURN PTS])
(OPENWIRE.FEEDBACKFN
[LAMBDA (X Y WINDOW PREVPTS) (* rrb "15-Nov-85 11:32")
(* provides the rubberbanding feedback for the user
inputting a point for an open wire.)
(SHOWSKETCHXY X Y WINDOW)
(AND PREVPTS (PROG (LASTPT)
(RETURN (DRAWLINE [fetch (POSITION XCOORD)
of (SETQ LASTPT (fetch (INPUTPT
INPUT.POSITION)
of (CAR (LAST
PREVPTS]
(fetch (POSITION YCOORD) of LASTPT)
X Y 1 (QUOTE INVERT)
WINDOW])
(CLOSEDWIRE.FEEDBACKFN
[LAMBDA (X Y WINDOW PREVPTS) (* rrb "15-Nov-85 11:31")
(* provides the rubberbanding feedback for the user
inputting a point for an open wire.)
(SHOWSKETCHXY X Y WINDOW) (* draw from the first pt to the new pt)
(PROG (ENDPT)
(AND PREVPTS (DRAWLINE [fetch (POSITION XCOORD) of (SETQ ENDPT
(fetch (INPUTPT
INPUT.POSITION)
of (CAR PREVPTS]
(fetch (POSITION YCOORD) of ENDPT)
X Y 1 (QUOTE INVERT)
WINDOW)) (* draw from the last pt to the new pt)
(AND (CDR PREVPTS)
(DRAWLINE [fetch (POSITION XCOORD) of (SETQ ENDPT
(fetch (INPUTPT INPUT.POSITION)
of (CAR (LAST PREVPTS]
(fetch (POSITION YCOORD) of ENDPT)
X Y 1 (QUOTE INVERT)
WINDOW])
(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])
(CLOSEDWIRE.GLOBALREGIONFN
[LAMBDA (GCLOSEDWIREELT) (* rrb "23-Oct-85 11:30")
(* returns the global region occupied by a global
closed curve element.)
(OR (fetch (CLOSEDWIRE CLOSEDWIREREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GCLOSEDWIREELT))
(PROG ((INDVCLOSEDWIRE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GCLOSEDWIREELT))
REGION)
[SETQ REGION (INCREASEREGION (REGION.CONTAINING.PTS (fetch (CLOSEDWIRE
LATLONKNOTS)
of INDVCLOSEDWIRE))
(SK.BRUSH.SIZE (fetch (CLOSEDWIRE BRUSH)
of INDVCLOSEDWIRE]
(replace (CLOSEDWIRE CLOSEDWIREREGION) of INDVCLOSEDWIRE with REGION)
(RETURN REGION])
(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 "20-Nov-85 11:49")
(* 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 [\CURSOR.IN.MIDDLE.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.")
("Solid triangle"
(QUOTE SOLID)
"makes a solid triangular arrowhead.")
("Curved V" (QUOTE
OPENCURVE)
"Makes the arrowhead have curved side lines.")))
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
(SKETCH.CREATE.CLOSED.WIRE
[LAMBDA (POINTS BRUSH DASHING FILLING SCALE) (* rrb "16-Oct-85 17:12")
(* creates a sketch closed wire element.)
(SK.WIRE.CREATE (SK.INSURE.POINT.LIST POINTS)
(SK.INSURE.BRUSH BRUSH)
(SK.INSURE.DASHING DASHING)
T
(OR (NUMBERP SCALE)
1.0)
NIL
(SK.INSURE.FILLING FILLING])
(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 " 4-Dec-85 11:51")
(* draws a closed wire element.)
(PROG ((GINDVELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of CLOSEDWIREELT))
(LOCALPART (fetch (SCREENELT LOCALPART) of CLOSEDWIREELT))
VARX)
(SETQ VARX (fetch (LOCALCLOSEDWIRE LOCALCLOSEDWIREFILLING) of LOCALPART))
(COND
((AND SKETCHINCOLORFLG (OR (fetch (SKFILLING FILLING.TEXTURE) of VARX)
(fetch (SKFILLING FILLING.COLOR) of VARX)))
(FILLPOLYGON (fetch (LOCALCLOSEDWIRE KNOTS) of LOCALPART)
VARX WIN))
((fetch (SKFILLING FILLING.TEXTURE) of VARX)
(FILLPOLYGON (fetch (LOCALCLOSEDWIRE KNOTS) of LOCALPART)
(COND
((EQ (DSPOPERATION NIL WIN)
(QUOTE ERASE))
(* use WHITE because fillpolygon doesn't know about ERASE mode. (* use black in case the window moved because of
texture to window alignment bug.))
WHITESHADE)
(T (fetch (SKFILLING FILLING.TEXTURE) of VARX)))
WIN))
((fetch (SKFILLING FILLING.COLOR) of VARX)
(FILLPOLYGON (fetch (LOCALCLOSEDWIRE KNOTS) of LOCALPART)
(TEXTUREOFCOLOR (fetch (SKFILLING FILLING.COLOR) of 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 "20-Nov-85 11:10")
(* 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
(\CURSOR.IN.MIDDLE.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.")
("Add point" (QUOTE ADDPOINT)
"adds a point to the curve."]
(SIZE (READSIZECHANGE "Change size how?" T))
(FILLING (READ.FILLING.CHANGE))
(DASHING (READ.DASHING.CHANGE))
(SHAPE (READBRUSHSHAPE))
[BRUSHCOLOR (READ.COLOR.CHANGE
"Change outline color how?" NIL
(fetch (BRUSH BRUSHCOLOR)
of (GETSKETCHELEMENTPROP (fetch
(SCREENELT
GLOBALPART)
of
(CAR SCRNELTS))
(QUOTE BRUSH]
(ADDPOINT (READ.POINT.TO.ADD (CAR SCRNELTS)
SKW))
[FILLINGCOLOR (READ.COLOR.CHANGE
"Change filling color how?" T
(fetch (SKFILLING FILLING.COLOR)
of (GETSKETCHELEMENTPROP
(fetch (SCREENELT GLOBALPART)
of (CAR SCRNELTS))
(QUOTE FILLING]
NIL))
(RETURN (AND HOW (LIST ASPECT HOW])
(CLOSEDWIRE.TRANSFORMFN
[LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "18-Oct-85 16:46")
(* 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)
CLOSEDWIREREGION ←
NIL])
(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 "20-Nov-85 11:37")
(* * 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)))
(SOLID (create ARROWHEAD using ARROW ARROWTYPE ←(QUOTE SOLID)))
(OPENCURVE (create ARROWHEAD using ARROW ARROWTYPE ←(QUOTE CURVE)))
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 " 6-Nov-85 09:46")
(* reads a specification of which end of a line or
curve to put an arrowhead on.)
(\CURSOR.IN.MIDDLE.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 HEAD.TYPE)
(* rrb "20-Nov-85 11:43")
(* * 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 If HEAD.TYPE is LINE or CLOSEDLINE, the result is a list of
(HEADPT ONESIDEENDPT OTHERSIDEENDPT) If HEAD.TYPE is CURVE, the result is (HEADPT (SIDE1PT1 SIDE1PT2)
(SIDE2PT1 SIDE2PT2)))
(PROG (X1 Y1 COS.THETA LL SIN.THETA COS.RHO SIN.RHO XP1 YP1 XP2 YP2 ENDPT1 ENDPT2)
(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]
[SETQ ENDPT1 (create POSITION
XCOORD ←(FIXR (DIFFERENCE X1 XP1))
YCOORD ←(FIXR (DIFFERENCE Y1 YP1]
[SETQ ENDPT2 (create POSITION
XCOORD ←(FIXR (DIFFERENCE X1 XP2))
YCOORD ←(FIXR (DIFFERENCE Y1 YP2]
(RETURN (SELECTQ HEAD.TYPE
((LINE CLOSEDLINE SOLID)
(LIST HEAD.POSITION ENDPT1 ENDPT2))
(CURVE (* redo calculations with half the angle and half the
length for a midpoint in the curve.)
(SETQ HEAD.ANGLE (QUOTIENT HEAD.ANGLE 1.5))
(SETQ HEAD.LENGTH (QUOTIENT HEAD.LENGTH 2.0))
(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]
(LIST HEAD.POSITION (LIST (create POSITION
XCOORD ←(FIXR
(DIFFERENCE
X1 XP1))
YCOORD ←(FIXR
(DIFFERENCE
Y1 YP1)))
ENDPT1)
(LIST (create POSITION
XCOORD ←(FIXR (DIFFERENCE
X1 XP2))
YCOORD ←(FIXR (DIFFERENCE
Y1 YP2)))
ENDPT2)))
NIL])
(CURVE.ARROWHEAD.POINTS
[LAMBDA (LOCALKNOTS BEGFLG HEAD.ANGLE HEAD.LENGTH HEAD.TYPE)
(* rrb " 1-Nov-85 09:56")
(* 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)))
HEAD.TYPE])
(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 HEAD.TYPE)
(* rrb " 1-Nov-85 10:08")
(* 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))
HEAD.TYPE])
(DRAWARROWHEADS
[LAMBDA (ARROWSPECS ARROWPTS WINDOW SIZE OPERATION) (* rrb "20-Nov-85 16:33")
(* * 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.)
(bind ARROWTYPE for SPEC in ARROWSPECS as PTS in ARROWPTS when (AND SPEC PTS)
do (SELECTQ (SETQ ARROWTYPE (fetch (ARROWHEAD ARROWTYPE) of SPEC))
(CURVE (* curve type. ARROWPTS format is
(headPt (side1pt1 side1pt2)
(side2pt1 side2pt2)))
(DRAWCURVE (CONS (CAR PTS)
(CADR PTS))
NIL SIZE NIL WINDOW)
(DRAWCURVE (CONS (CAR PTS)
(CADDR PTS))
NIL SIZE NIL WINDOW))
(SOLID (* solid triangle)
(FILLPOLYGON PTS BLACKSHADE WINDOW))
((LINE CLOSEDLINE) (* straight line form of arrow.)
(DRAWCURVE (LIST (CAR PTS)
(CADR PTS))
NIL SIZE NIL WINDOW)
(DRAWCURVE (LIST (CAR PTS)
(CADDR PTS))
NIL SIZE NIL WINDOW)
(AND (EQ ARROWTYPE (QUOTE CLOSEDLINE))
(DRAWCURVE (LIST (CADR PTS)
(CADDR PTS))
NIL SIZE NIL WINDOW)))
NIL])
(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 "20-Nov-85 11:46")
(* Sets the type of the default arrowhead)
(PROG ([NEWSHAPE (\CURSOR.IN.MIDDLE.MENU (create MENU
ITEMS ←(QUOTE ((V% shape (QUOTE LINE)
"arrowhead consists of two line segments.")
(Triangle (QUOTE
CLOSEDLINE)
"arrowhead consists of a triangle.")
("Solid triangle"
(QUOTE SOLID)
"makes a solid triangular arrowhead.")
("Curved V"
(QUOTE CURVE)
"Makes the head have curved side lines."]
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-Nov-85 09:50")
(* sets whether or not the default line has an
arrowhead.)
(PROG [(ARROWHEADEND (COND
((MEMB NEWVALUE (QUOTE (FIRST LAST BOTH NEITHER LEFT RIGHT)))
NEWVALUE)
(T (\CURSOR.IN.MIDDLE.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-Nov-85 09:51")
(* 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 (\CURSOR.IN.MIDDLE.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])
)
(DEFINEQ
(SK.INSURE.ARROWHEADS
[LAMBDA (ARROWHEADSPECS) (* rrb " 1-Nov-85 09:29")
(* makes sure ARROWHEADSPECS is a legal list of two
arrowhead specifications.)
(COND
((NULL ARROWHEADSPECS)
NIL)
((for SPEC in ARROWHEADSPECS
collect (COND
((NULL SPEC)
NIL)
((SK.ARROWHEADP SPEC))
((EQ SPEC T)
(create ARROWHEAD
ARROWTYPE ← SK.DEFAULT.ARROW.TYPE
ARROWANGLE ← SK.DEFAULT.ARROW.ANGLE
ARROWLENGTH ← SK.DEFAULT.ARROW.LENGTH))
(T (\ILLEGAL.ARG ARROWHEADSPECS])
(SK.ARROWHEADP
[LAMBDA (ARROWHEAD) (* rrb "16-Oct-85 16:24")
(* determines if ARROWHEAD is a legal arrowhead
specification.)
(AND (EQLENGTH ARROWHEAD 3)
(MEMB (fetch (ARROWHEAD ARROWTYPE) of ARROWHEAD)
SK.ARROWHEAD.TYPES)
(NUMBERP (fetch (ARROWHEAD ARROWANGLE) of ARROWHEAD))
(NUMBERP (fetch (ARROWHEAD ARROWLENGTH) of ARROWHEAD))
ARROWHEAD])
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD LOCALWIRE (KNOTS LOCALHOTREGION ARROWHEADPTS LOCALOPENWIREBRUSH LOCALWIREDASHING))
(TYPERECORD WIRE (LATLONKNOTS BRUSH WIREARROWHEADS OPENWIREDASHING OPENWIREINITSCALE OPENWIREREGION)
)
(TYPERECORD CLOSEDWIRE (LATLONKNOTS BRUSH CLOSEDWIREDASHING CLOSEDWIREINITSCALE CLOSEDWIREFILLING
CLOSEDWIREREGION))
(RECORD LOCALCLOSEDWIRE (KNOTS LOCALHOTREGION LOCALCLOSEDWIREBRUSH LOCALCLOSEDWIREFILLING))
(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 5)
(RPAQ? SK.ARROWHEAD.LENGTH.INCREMENT 2)
(ADDTOVAR SK.ARROWHEAD.TYPES LINE CLOSEDLINE CURVE SOLID)
(RPAQ? SK.DEFAULT.ARROW.LENGTH 8)
(RPAQ? SK.DEFAULT.ARROW.TYPE (QUOTE CURVE))
(RPAQ? SK.DEFAULT.ARROW.ANGLE 18.0)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS SK.DEFAULT.ARROW.LENGTH SK.DEFAULT.ARROW.TYPE SK.DEFAULT.ARROW.ANGLE SK.ARROWHEAD.TYPES)
)
(RPAQ? SK.ARROW.END.MENU )
(RPAQ? SK.ARROW.EDIT.MENU )
(* stuff to support the text element type.)
(DEFINEQ
(SKETCH.CREATE.TEXT
[LAMBDA (STRING POSITION FONT JUSTIFICATION COLOR SCALE) (* rrb " 4-Dec-85 20:51")
(* creates a text element.)
(CREATE.TEXT.ELEMENT (SK.INSURE.TEXT STRING)
(SK.INSURE.POSITION POSITION)
(OR (NUMBERP SCALE)
1.0)
(SK.INSURE.STYLE JUSTIFICATION SK.DEFAULT.TEXT.ALIGNMENT)
(SK.INSURE.FONT FONT)
(SK.INSURE.COLOR COLOR])
(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 " 6-Nov-85 09:51")
(* the users has selected SCRNELT to be changed this
function reads a specification of how the text
elements should change.)
(PROG ((COMMAND (\CURSOR.IN.MIDDLE.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?" NIL
(fetch (BRUSH BRUSHCOLOR)
of (GETSKETCHELEMENTPROP (fetch
(SCREENELT
GLOBALPART)
of
(CAR SCRNELTS))
(QUOTE BRUSH]
(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 "21-Nov-85 11:28")
(* reads a font family name.)
(PROG ([KNOWNFAMILIES (UNION (for X in \FONTSONFILE collect (CAR X))
(for X in \FONTSINCORE collect (CAR X]
FAMILY) (* offers a menu of possible choices.)
(COND
((AND KNOWNFAMILIES (NEQ (SETQ FAMILY
(\CURSOR.IN.MIDDLE.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 " 5-Dec-85 17:49")
(* 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 DEVICE)
[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
[(NLISTP (SETQ DEVICE (IMAGESTREAMTYPE STREAM]
((MEMB (QUOTE HARDCOPY)
DEVICE)
(SETQ DEVICE (HARDCOPYSTREAMTYPE STREAM)))
(T (* don't know what is happening here but just use
display.)
(SETQ DEVICE (QUOTE DISPLAY]
[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 DEVICE)))
(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 DEVICE
(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 ←(APPEND
(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 DEVICE FAMILY) (* rrb "22-Oct-85 15:30")
(* 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)
(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 "21-Nov-85 11:15")
(* returns a list of fonts of family FAMILY which work
on device DEVICETYPE)
[COND
((NULL FAMILY)
(SETQ FAMILY (QUOTE MODERN] (* 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 STREAMORFONT STYLE TOTALHEIGHT) (* rrb " 4-Dec-85 11:51")
(* returns the regions occupied by the lines of text
LINES to format them in STYLE in font FONT at position
LPOSITION.)
(AND STREAMORFONT (PROG ((FONT (FONTCREATE STREAMORFONT))
(TEXTXPOS (fetch (POSITION XCOORD) of LPOSITION))
(TEXTYPOS (fetch (POSITION YCOORD) of LPOSITION))
HEIGHT HEIGHTOFLOCALTEXT LINEWIDTH)
[SETQ HEIGHT (COND
((STREAMP STREAMORFONT)
(* use the line feed height because in hardcopy
streams this is more correct.)
(MINUS (DSPLINEFEED NIL STREAMORFONT)))
(T (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 STREAMORFONT)
(COND
((EQ (NTHCHARCODE CHARS -1)
(CHARCODE CR))
(CHARWIDTH (CHARCODE CR)
STREAMORFONT))
(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 "16-Oct-85 18:29")
(* 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
(fetch (BRUSH BRUSHCOLOR)
of (fetch (SKETCHCONTEXT SKETCHBRUSH)
of (WINDOWPROP WINDOW
(QUOTE
SKETCHCONTEXT])
(CREATE.TEXT.ELEMENT
[LAMBDA (STRLST GPOSITION SCALE JUSTIFICATION FONT COLOR)
(* rrb " 4-Dec-85 20:50")
(* creates a text element for a sketch)
(SK.UPDATE.TEXT.AFTER.CHANGE (create GLOBALPART
INDIVIDUALGLOBALPART ←(create TEXT
LOCATIONLATLON ←
GPOSITION
LISTOFCHARACTERS ←
STRLST
INITIALSCALE ← SCALE
TEXTSTYLE ←
JUSTIFICATION
FONT ← FONT
TEXTCOLOR ← COLOR])
(SK.UPDATE.TEXT.AFTER.CHANGE
[LAMBDA (GTEXTELT) (* rrb " 4-Dec-85 20:50")
(* updates the dependent fields in a text element that
has had its text field changed.)
(TEXT.SET.GLOBAL.REGIONS (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXTELT))
(TEXT.SET.SCALES GTEXTELT)
GTEXTELT])
(SK.TEXT.FROM.TEXTBOX
[LAMBDA (TEXTBOXELT SKW) (* rrb "16-Oct-85 18:30")
(* 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)
(fetch (TEXTBOX TEXTCOLOR) 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.GLOBALREGIONFN
[LAMBDA (GTEXTELT) (* rrb "18-Oct-85 16:43")
(* returns the global region occupied by a global text
element.)
(PROG [REG (LINEREGIONS (fetch (TEXT LISTOFREGIONS) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GTEXTELT]
(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 "16-Oct-85 18:30")
(* 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)
(fetch (TEXT TEXTCOLOR) 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 " 5-Dec-85 17:59")
(* 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])
(BREAK.AT.CARRIAGE.RETURNS
[LAMBDA (STRING) (* rrb "16-Oct-85 18:24")
(* returns a list of strings breaking string at
carriage returns.)
(PROG (STRLST (STR (OR (STRINGP STRING)
(MKSTRING STRING)))
(PREV 0)
(WHERE 0))
LP (COND
((SETQ WHERE (STRPOS "
" STR (ADD1 WHERE)))
[SETQ STRLST (NCONC1 STRLST (COND
((EQ WHERE (ADD1 PREV))
"")
(T (SUBSTRING STR (ADD1 PREV)
(SUB1 WHERE]
(SETQ PREV WHERE)
(GO LP)))
(RETURN (NCONC1 STRLST (OR (SUBSTRING STR (ADD1 PREV)
-1)
""])
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(TYPERECORD TEXT (LOCATIONLATLON LISTOFCHARACTERS INITIALSCALE TEXTSTYLE FONT LISTOFREGIONS
TEXTCOLOR))
(RECORD LOCALTEXT ((DISPLAYPOSITION)
LOCALHOTREGION 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 " 6-Nov-85 09:51")
(* * reads a new value for the horizontal justification)
(PROG ([NEWJUST (COND
((MEMB NEWALIGN (QUOTE (CENTER LEFT RIGHT)))
NEWALIGN)
(T (\CURSOR.IN.MIDDLE.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 " 6-Nov-85 09:51")
(* * 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 (\CURSOR.IN.MIDDLE.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 " 6-Nov-85 09:52")
(* * reads a new value for the vertical justification)
(PROG ([NEWJUST (COND
((MEMB NEWALIGN (QUOTE (TOP CENTER BASELINE BOTTOM)))
NEWALIGN)
(T (\CURSOR.IN.MIDDLE.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 " 6-Nov-85 09:52")
(* * reads a new value for the looks of default text)
(SK.SET.DEFAULT.TEXT.FACE (\CURSOR.IN.MIDDLE.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])
)
(DEFINEQ
(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])
(SK.INSURE.FONT
[LAMBDA (FONT) (* rrb "16-Oct-85 17:46")
(* checks the validity of a font argument for a sketch
element.)
(COND
[(NULL FONT)
(SK.FONT.LIST (OR (AND SK.DEFAULT.FONT (FONTCREATE SK.DEFAULT.FONT))
(DEFAULTFONT (QUOTE DISPLAY]
((FONTP FONT)
(SK.FONT.LIST FONT))
((FONTCREATE FONT)
(SK.FONT.LIST (FONTCREATE FONT)))
(T (\ILLEGAL.ARG FONT])
(SK.INSURE.STYLE
[LAMBDA (STYLE DEFAULT) (* rrb "16-Oct-85 17:51")
(* checks the validity of a STYLE argument for a
sketch element)
(COND
((NULL STYLE)
DEFAULT)
((AND (LISTP STYLE)
(MEMB (CAR STYLE)
SK.HORIZONTAL.STYLES)
(MEMB (CAR (LISTP (CDR STYLE)))
SK.VERTICAL.STYLES)
(NULL (CDDR STYLE)))
STYLE)
(T (\ILLEGAL.ARG STYLE])
(SK.INSURE.TEXT
[LAMBDA (TEXTTHING) (* rrb " 4-Nov-85 18:53")
(* puts something in the form necessary for a text
list of characters.)
(COND
((NLISTP TEXTTHING)
(BREAK.AT.CARRIAGE.RETURNS TEXTTHING))
(T (for X in TEXTTHING join (BREAK.AT.CARRIAGE.RETURNS X])
)
(RPAQQ INDICATE.TEXT.SHADE 23130)
(RPAQ? SK.DEFAULT.FONT )
(RPAQ? SK.DEFAULT.TEXT.ALIGNMENT (QUOTE (CENTER BASELINE)))
(RPAQ? \FONTSONFILE NIL)
(ADDTOVAR SK.HORIZONTAL.STYLES LEFT RIGHT CENTER)
(ADDTOVAR SK.VERTICAL.STYLES TOP CENTER BASELINE BOTTOM)
(RPAQ SKETCH.TERMTABLE (CREATE.SKETCH.TERMTABLE))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS SKETCH.TERMTABLE SK.DEFAULT.TEXT.ALIGNMENT INDICATE.TEXT.SHADE \FONTSONFILE
SK.HORIZONTAL.STYLES SK.VERTICAL.STYLES)
)
(* stuff for supporting the TEXTBOX sketch element.)
(DEFINEQ
(SKETCH.CREATE.TEXTBOX
[LAMBDA (STRING REGION FONT JUSTIFICATION BOXBRUSH BOXDASHING FILLING TEXTCOLOR SCALE)
(* rrb "16-Oct-85 18:25")
(* creates a sketch box element.)
(SK.TEXTBOX.CREATE1 (OR (REGIONP REGION)
(\ILLEGAL.ARG REGION))
(SK.INSURE.BRUSH BOXBRUSH)
[COND
((NLISTP STRING)
(BREAK.AT.CARRIAGE.RETURNS STRING))
(T (for X in STRING join (BREAK.AT.CARRIAGE.RETURNS X]
(OR (NUMBERP SCALE)
1.0)
(SK.INSURE.STYLE JUSTIFICATION SK.DEFAULT.TEXTBOX.ALIGNMENT)
(SK.INSURE.FONT FONT)
(SK.INSURE.DASHING BOXDASHING)
(SK.INSURE.FILLING FILLING)
(SK.INSURE.COLOR TEXTCOLOR])
(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 "16-Oct-85 17:59")
(* * 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)
(fetch (BRUSH BRUSHCOLOR) of (fetch (SKETCHCONTEXT
SKETCHBRUSH)
of CONTEXT])
(SK.TEXTBOX.CREATE1
[LAMBDA (SKETCHREGION BRUSH LSTOFSTRS INITSCALE STYLE INITFONT DASHING FILLING TEXTCOLOR)
(* rrb " 4-Dec-85 20:45")
(SK.UPDATE.TEXTBOX.AFTER.CHANGE (create GLOBALPART
INDIVIDUALGLOBALPART ←(create TEXTBOX
TEXTBOXREGION ←
SKETCHREGION
LISTOFCHARACTERS ←
LSTOFSTRS
INITIALSCALE ←
INITSCALE
TEXTSTYLE ← STYLE
FONT ← INITFONT
TEXTCOLOR ← TEXTCOLOR
TEXTBOXBRUSH ← BRUSH
TEXTBOXDASHING ←
DASHING
TEXTBOXFILLING ←
FILLING])
(SK.UPDATE.TEXTBOX.AFTER.CHANGE
[LAMBDA (GTEXTBOXELT) (* rrb " 4-Dec-85 21:51")
(* updates the dependent fields in a textbox element
that has had its text field changed.)
(PROG ((INDELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXTBOXELT)))
(TEXTBOX.SET.GLOBAL.REGIONS INDELT)
(BOX.SET.SCALES (fetch (TEXTBOX TEXTBOXREGION) of INDELT)
GTEXTBOXELT)
(RETURN GTEXTBOXELT])
(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 " 7-Dec-85 20:53")
(* draws a text box element.)
(PROG ((LOCALPART (fetch (SCREENELT LOCALPART) of TEXTBOXELT))
FILLING BRUSH)
(OR (NULL WINREG)
(REGIONSINTERSECTP WINREG (fetch (LOCALTEXTBOX LOCALTEXTBOXREGION)
of LOCALPART))
(RETURN))
(SETQ BRUSH (fetch (LOCALTEXTBOX LOCALTEXTBOXBRUSH) of LOCALPART))
(SETQ FILLING (fetch (LOCALTEXTBOX LOCALTEXTBOXFILLING) 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 (LOCALTEXTBOX LOCALTEXTBOXDASHING)
of LOCALPART)
(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 (LOCALTEXTBOX LOCALTEXTBOXDASHING)
of LOCALPART)
NIL
(fetch (BRUSH BRUSHCOLOR) of BRUSH))
(SK.TEXTURE.AROUND.REGIONS (fetch (LOCALTEXTBOX LOCALTEXTBOXREGION)
of LOCALPART)
(fetch (LOCALTEXTBOX LINEREGIONS) of LOCALPART)
(COND
((EQ (DSPOPERATION NIL WINDOW)
(QUOTE ERASE))
(* use black in case the window moved because of
texture to window alignment bug.)
BLACKSHADE)
(T (fetch (SKFILLING FILLING.TEXTURE) of FILLING))
)
WINDOW
(fetch (SKFILLING FILLING.COLOR) of FILLING]
(COND
((AND (EQ (OR OPERATION (DSPOPERATION NIL WINDOW))
(QUOTE PAINT))
(OR (fetch (SKFILLING FILLING.TEXTURE) of FILLING)
(fetch (SKFILLING FILLING.COLOR) of FILLING)))
(* 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 " 7-Dec-85 20:53")
(* 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 DEVICE) (* 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))
[COND
((TEXTUREP (fetch (TEXTBOX TEXTBOXFILLING) of GTEXTBOX))
(* old format, update to new one which has a list of
(texture color))
(replace (TEXTBOX TEXTBOXFILLING) of GTEXTBOX with (create
SKFILLING
FILLING.TEXTURE ←(fetch
(TEXTBOX TEXTBOXFILLING)
of
GTEXTBOX)
FILLING.COLOR ← NIL]
(* calculate the local region for the text box.)
(SETQ LREG (SCALE.REGION (fetch (TEXTBOX TEXTBOXREGION) of GTEXTBOX)
SCALE))
[COND
[(NLISTP (SETQ DEVICE (IMAGESTREAMTYPE STREAM]
((MEMB (QUOTE HARDCOPY)
DEVICE)
(SETQ DEVICE (HARDCOPYSTREAMTYPE STREAM)))
(T (* don't know what is happening here but just use
display.)
(SETQ DEVICE (QUOTE DISPLAY]
(* 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 IMAGESTREAM (COND
((STREAMP STREAM))
(T (WINDOWPROP STREAM (QUOTE DSP]
[SETQ LOCALFONT (SK.PICK.FONT CANONICALWIDTH CANONICALTESTSTR DEVICE
(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)
(COND
((IMAGESTREAMTYPEP IMAGESTREAM (QUOTE HARDCOPY))
IMAGESTREAM)
(T 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
LOCALTEXTBOXFILLING ←(APPEND
(fetch (TEXTBOX TEXTBOXFILLING)
of GTEXTBOX))
LOCALTEXTBOXDASHING ←(fetch (TEXTBOX
TEXTBOXDASHING)
of GTEXTBOX))
GLOBALPART ← GTEXTBOXELT])
(TEXTBOX.INPUTFN
[LAMBDA (W LREGION) (* rrb "20-Nov-85 15:47")
(* 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.)
(COND
((OR (NOT (SUBREGIONP (DSPCLIPPINGREGION NIL W)
LOCALREG))
(AND (EQ (fetch (REGION WIDTH) of LOCALREG)
0)
(EQ (fetch (REGION HEIGHT) of LOCALREG)
0)))
(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.GLOBALREGIONFN
[LAMBDA (GTEXTBOXELT) (* rrb "18-Oct-85 17:11")
(* returns the global region occupied by a global
textbox element.)
(fetch (TEXTBOX TEXTBOXREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXTBOXELT]
)
(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 "16-Oct-85 17:59")
(* 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)
(fetch (TEXTBOX TEXTCOLOR) of GTEXTBOXELT])
(TEXTBOX.TRANSFORMFN
[LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "16-Oct-85 17:59")
(* 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)
(fetch (TEXTBOX TEXTCOLOR) of INDVPART])
(TEXTBOX.UPDATEFN
[LAMBDA (OLDLOCALELT NEWGELT SKETCHW) (* rrb " 5-Dec-85 18:02")
(* 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))
(OLDLOCALTB (fetch (SCREENELT LOCALPART) of OLDLOCALELT)))
(RETURN (COND
((AND (EQUAL (fetch (TEXTBOX TEXTBOXBRUSH) of NEWTB)
(fetch (TEXTBOX TEXTBOXBRUSH) of OLDTB))
(EQUAL (fetch (TEXTBOX TEXTBOXDASHING) of NEWTB)
(fetch (LOCALTEXTBOX LOCALTEXTBOXDASHING) of OLDLOCALTB))
(EQUAL (fetch (TEXTBOX TEXTBOXFILLING) of NEWTB)
(fetch (LOCALTEXTBOX LOCALTEXTBOXFILLING) of OLDLOCALTB))
(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 " 6-Nov-85 09:52")
(* reads how the user wants to change a textbox.)
(PROG ((COMMAND (\CURSOR.IN.MIDDLE.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?" NIL
(fetch (BRUSH BRUSHCOLOR)
of (GETSKETCHELEMENTPROP
(fetch (SCREENELT GLOBALPART)
of (CAR SCRNELTS))
(QUOTE BRUSH]
[FILLINGCOLOR
(READ.COLOR.CHANGE
"Change filling color how?" T
(fetch (SKFILLING FILLING.COLOR)
of (GETSKETCHELEMENTPROP
(fetch (SCREENELT GLOBALPART)
of (CAR SCRNELTS))
(QUOTE FILLING]
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 "24-Oct-85 17:19")
(* returns a textbox that replaces GTEXTELT.)
(PROG ((INDTEXTELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of TEXTELT))
BRUSH CONTEXT)
(RETURN
(SK.TEXTBOX.CREATE1
(MAP.GLOBAL.REGION.ONTO.GRID
(INCREASEREGION (APPLY (FUNCTION UNIONREGIONS)
(fetch (TEXT LISTOFREGIONS) of INDTEXTELT))
(IQUOTIENT [ADD1
(SK.BRUSH.SIZE
(fetch (BRUSH BRUSHSIZE)
of (SETQ BRUSH
(fetch (SKETCHCONTEXT SKETCHBRUSH)
of (SETQ CONTEXT
(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)
(fetch (SKETCHCONTEXT SKETCHDASHING) of CONTEXT)
(fetch (SKETCHCONTEXT SKETCHFILLING) of CONTEXT)
(fetch (BRUSH BRUSHCOLOR) of BRUSH])
(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)
LOCALHOTREGION LINEREGIONS LOCALFONT LOCALLISTOFCHARACTERS LOCALTEXTBOXREGION
LOCALTEXTBOXBRUSH LOCALTEXTBOXFILLING LOCALTEXTBOXDASHING))
(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 " 6-Nov-85 09:52")
(* * reads a new value for the vertical justification default for text boxes)
(PROG ((NEWJUST (\CURSOR.IN.MIDDLE.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 " 6-Nov-85 09:52")
(* * reads a new value for the horizontal justification default for text boxes)
(PROG ([NEWJUST (OR NEWALIGN (\CURSOR.IN.MIDDLE.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
(SKETCH.CREATE.BOX
[LAMBDA (REGION BRUSH DASHING FILLING SCALE) (* rrb "16-Oct-85 17:31")
(* creates a sketch box element.)
(SK.BOX.CREATE (OR (REGIONP REGION)
(\ILLEGAL.ARG REGION))
(SK.INSURE.BRUSH BRUSH)
(SK.INSURE.DASHING DASHING)
(OR (NUMBERP SCALE)
1.0)
(SK.INSURE.FILLING FILLING])
(SK.BOX.DRAWFN
[LAMBDA (BOXELT WIN WINREG OPERATION) (* rrb " 7-Dec-85 20:51")
(* draws a box from its sketch element.)
(PROG ((LOCALBOXELT (fetch (SCREENELT LOCALPART) of BOXELT))
FILLING BRUSH)
(SETQ FILLING (fetch (LOCALBOX LOCALBOXFILLING) of LOCALBOXELT))
(RETURN (BOX.DRAWFN1 (fetch (LOCALBOX LOCALREGION) of LOCALBOXELT)
(fetch (BRUSH BRUSHSIZE) of (SETQ BRUSH
(fetch (LOCALBOX
LOCALBOXBRUSH)
of LOCALBOXELT)))
WIN WINREG OPERATION (fetch (LOCALBOX LOCALBOXDASHING)
of LOCALBOXELT)
(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 " 4-Dec-85 11:23")
(* draws a box. Used by both box and text box
elements.)
(COND
((OR (NULL WINREG)
(REGIONSINTERSECTP WINREG REG))
(COND
((AND SKETCHINCOLORFLG (OR FILLINGCOLOR TEXTURE))
(* 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 (COND
((EQ (OR OPERATION (DSPOPERATION NIL WIN))
(QUOTE ERASE)) (* use black in case the window moved because of
texture to window alignment bug.)
BLACKSHADE)
(T TEXTURE))
OPERATION WIN))
(FILLINGCOLOR (* if no texture, use the color.)
(DSPFILL REG (TEXTUREOFCOLOR FILLINGCOLOR)
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 " 7-Dec-85 20:51")
(* 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]
[COND
((TEXTUREP (fetch (BOX BOXFILLING) of INDGELT))
(* old format, update to new one which has a list of
(texture color))
(replace (BOX BOXFILLING) of INDGELT with (create SKFILLING
FILLING.TEXTURE ←(fetch
(BOX BOXFILLING)
of
INDGELT)
FILLING.COLOR ← NIL]
(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)
LOCALBOXFILLING ←(APPEND (fetch
(BOX BOXFILLING)
of INDGELT))
LOCALBOXDASHING ←(fetch (BOX BOXDASHING)
of INDGELT))
GLOBALPART ← GBOX])
(SK.BOX.GETREGIONFN
[LAMBDA (FIXPT MOVINGPT W) (* rrb "20-Nov-85 15:45")
(* 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.)
(PROG [(REG (WINDOWPROP W (QUOTE REGION]
(RETURN (COND
((INSIDEP REG FIXPT)
(COND
((INSIDEP REG MOVINGPT)
(MAP.SCREEN.POSITION.ONTO.GRID MOVINGPT W (LASTMOUSESTATE
RIGHT)))
(T (* if the cursor is outside, return the fixed point so
the feedback box disappears.)
FIXPT)))
(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 "20-Nov-85 15:48")
(* 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.)
(COND
((OR (NOT (SUBREGIONP (DSPCLIPPINGREGION NIL W)
LOCALREG))
(AND (EQ (fetch (REGION WIDTH) of LOCALREG)
0)
(EQ (fetch (REGION HEIGHT) of LOCALREG)
0)))
(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 " 7-Dec-85 19:41")
(* returns the region occupied 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.GLOBALREGIONFN
[LAMBDA (GBOXELT) (* rrb "18-Oct-85 17:10")
(* returns the global region occupied by a global box
element.)
(fetch (BOX GLOBALREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GBOXELT])
(SK.BOX.READCHANGEFN
[LAMBDA (SKW SCRNELTS) (* rrb " 6-Nov-85 09:52")
(* 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
(\CURSOR.IN.MIDDLE.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?" NIL
(fetch (BRUSH BRUSHCOLOR)
of (GETSKETCHELEMENTPROP (fetch
(SCREENELT
GLOBALPART)
of
(CAR SCRNELTS))
(QUOTE BRUSH]
[FILLINGCOLOR (READ.COLOR.CHANGE
"Change filling color how?" T
(fetch (SKFILLING FILLING.COLOR)
of (GETSKETCHELEMENTPROP
(fetch (SCREENELT GLOBALPART)
of (CAR SCRNELTS))
(QUOTE FILLING]
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 "29-Oct-85 16:50")
(* 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 CIRCLE)))
(* 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))
(CIRCLE (fetch (CIRCLE CIRCLEFILLING)
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))
(CIRCLE (create CIRCLE
using GFILLEDELT CIRCLEFILLING ←
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)
LOCALHOTREGION LOCALREGION LOCALBOXBRUSH LOCALBOXFILLING LOCALBOXDASHING))
]
)
(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
(SKETCH.CREATE.ARC
[LAMBDA (CENTERPT RADIUSPT ANGLEPT BRUSH DASHING ARROWHEADS DIRECTION SCALE)
(* rrb "19-Oct-85 12:45")
(* creates a sketch arc element.)
(ARC.CREATE (SK.INSURE.POSITION CENTERPT)
(SK.INSURE.POSITION RADIUSPT)
(SK.INSURE.POSITION ANGLEPT)
(SK.INSURE.BRUSH BRUSH)
(SK.INSURE.DASHING DASHING)
(OR (NUMBERP SCALE)
1.0)
(SK.INSURE.ARROWHEADS ARROWHEADS)
(SK.INSURE.DIRECTION DIRECTION])
(ARC.DRAWFN
[LAMBDA (ARCELT WINDOW REGION) (* rrb " 7-Dec-85 20:47")
(* 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 (LOCALARC LOCALARCDASHING) of LARC)
WINDOW)
(DRAWARROWHEADS (fetch (ARC ARCARROWHEADS) of GARC)
(fetch (LOCALARC LOCALARCARROWHEADPTS) of LARC)
WINDOW BRUSH])
(ARC.EXPANDFN
[LAMBDA (GARC SCALE) (* rrb " 7-Dec-85 20:47")
(* 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
LOCALARCDASHING ←(fetch (ARC ARCDASHING)
of INDGARC))
GLOBALPART ← GARC])
(ARC.INPUTFN
[LAMBDA (WINDOW) (* rrb "18-Nov-85 14:36")
(* reads three points from the user and returns the
arc figure element that it represents.)
(PROG [CENTER RADPT ANGLEPT DIRECTION (SKCONTEXT (WINDOWPROP WINDOW (QUOTE SKETCHCONTEXT]
(SETQ DIRECTION (fetch (SKETCHCONTEXT SKETCHARCDIRECTION) of 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 (SK.READ.CIRCLE.POINT WINDOW (fetch (INPUTPT INPUT.POSITION)
of CENTER)
(COND
(DIRECTION
(* use a cursor that shows the arc going in the
correct direction.)
CW.ARC.RADIUS.CURSOR)
(T ARC.RADIUS.CURSOR]
(T (* erase center pt on way out)
(MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of CENTER)
NIL WINDOW)
(CLOSEPROMPTWINDOW WINDOW)
(RETURN NIL)))
(COND
((NEQ SKETCH.VERBOSE.FEEDBACK (QUOTE ALWAYS))
(* if feedback in medium mode, put up circle)
(SK.INVERT.CIRCLE CENTER RADPT WINDOW))
(T (* if feedback is in very verbose mode, just put up
the radius pt.)
(MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of RADPT)
NIL WINDOW)))
(STATUSPRINT WINDOW "
" "Indicate the angle of the arc")
(SETQ ANGLEPT (SK.READ.ARC.ANGLE.POINT WINDOW (COND
(DIRECTION CW.ARC.ANGLE.CURSOR)
(T ARC.ANGLE.CURSOR))
(fetch (INPUTPT INPUT.POSITION)
of CENTER)
(fetch (INPUTPT INPUT.POSITION)
of RADPT)
DIRECTION))
(CLOSEPROMPTWINDOW WINDOW) (* erase the point marks.)
(COND
((NEQ SKETCH.VERBOSE.FEEDBACK (QUOTE ALWAYS))
(* if feedback in medium mode, put up circle)
(SK.INVERT.CIRCLE CENTER RADPT WINDOW))
(T (* if feedback is in very verbose mode, just put up
the radius pt.)
(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 SKCONTEXT)
(fetch (SKETCHCONTEXT SKETCHDASHING) of SKCONTEXT)
(SK.INPUT.SCALE WINDOW)
(SK.ARROWHEAD.CREATE WINDOW (LIST RADPT ANGLEPT))
DIRECTION])
(SK.INVERT.CIRCLE
[LAMBDA (CENTERIPT RADIUSIPT SKW) (* rrb "18-Nov-85 14:36")
(* draws a circle as feedback while the user in
inputting the angle point of an arc.)
(PROG ((PREVOP (DSPOPERATION (QUOTE INVERT)
SKW)))
(RETURN (PROG1 (SK.SHOW.CIRCLE (fetch (POSITION XCOORD)
of (fetch (INPUTPT INPUT.POSITION)
of RADIUSIPT))
(fetch (POSITION YCOORD)
of (fetch (INPUTPT INPUT.POSITION)
of RADIUSIPT))
SKW
(fetch (INPUTPT INPUT.POSITION) of CENTERIPT))
(DSPOPERATION PREVOP SKW])
(SK.READ.ARC.ANGLE.POINT
[LAMBDA (WINDOW CURSOR CENTERPT RADIUSPT DIRECTION) (* rrb "18-Nov-85 14:36")
(* reads a point from the user prompting them with an
arc that follows the cursor)
(COND
((EQ SKETCH.VERBOSE.FEEDBACK (QUOTE ALWAYS))
(SK.READ.POINT.WITH.FEEDBACK WINDOW CURSOR (FUNCTION SK.SHOW.ARC)
(LIST CENTERPT RADIUSPT DIRECTION)))
(T (GETSKWPOSITION WINDOW CURSOR])
(SK.SHOW.ARC
[LAMBDA (X Y WINDOW ARCARGS) (* rrb "15-Nov-85 14:32")
(* draws an arc as feedback for reading the angle
point of an arc.)
(* Mark the point too.)
(SHOWSKETCHXY X Y WINDOW)
(DRAWCURVE (SK.COMPUTE.ARC.PTS (CAR ARCARGS)
(CADR ARCARGS)
(create POSITION
XCOORD ← X
YCOORD ← Y)
(CADDR ARCARGS))
NIL 1 NIL WINDOW])
(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])
(SK.UPDATE.ARC.AFTER.CHANGE
[LAMBDA (GARCELT) (* rrb " 7-Dec-85 19:52")
(* updates the dependent fields of a arc element when
a field changes.)
(replace (ARC ARCREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GARCELT)
with NIL])
(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.GLOBALREGIONFN
[LAMBDA (GARCELT) (* rrb "18-Oct-85 16:31")
(* returns the global region occupied by a global arc
element.)
(OR (fetch (ARC ARCREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GARCELT))
(PROG ((INDVARC (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GARCELT))
REGION)
(* 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.)
[SETQ REGION (INCREASEREGION (EXPANDREGION (REGION.CONTAINING.PTS
(SK.COMPUTE.ARC.PTS
(fetch (ARC ARCCENTERPT)
of INDVARC)
(fetch (ARC ARCRADIUSPT)
of INDVARC)
(fetch (ARC ARCANGLEPT)
of INDVARC)
(fetch (ARC ARCDIRECTION)
of INDVARC)))
1.1)
(SK.BRUSH.SIZE (fetch (ARC ARCBRUSH)
of INDVARC]
(replace (ARC ARCREGION) of INDVARC with REGION)
(RETURN REGION])
(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 SCRNELTS) (* rrb " 6-Nov-85 09:53")
(* changefn for arcs)
(PROG (ASPECT HOW)
(SETQ HOW (SELECTQ [SETQ ASPECT
(\CURSOR.IN.MIDDLE.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
(fetch (BRUSH BRUSHCOLOR)
of (GETSKETCHELEMENTPROP (fetch
(SCREENELT
GLOBALPART)
of
(CAR SCRNELTS))
(QUOTE BRUSH]
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 "18-Oct-85 17:06")
(* 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)
ARCREGION ← NIL])
(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])
)
(DEFINEQ
(SK.INSURE.DIRECTION
[LAMBDA (DIR) (* rrb "16-Oct-85 16:11")
(* decodes a DIRECTION spec which indicates whether an
arc goes clockwise or counterclockwise.
T is CLOCKWISE. NIL is COUNTERCLOCKWISE.)
(SELECTQ DIR
((NIL COUNTERCLOCKWISE)
NIL)
((T CLOCKWISE)
T)
(\ILLEGAL.ARC DIR])
)
(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 ARCREGION))
(RECORD LOCALARC ((LOCALARCCENTERPT LOCALARCRADIUSPT LOCALARCANGLEPT)
LOCALHOTREGION LOCALARCARROWHEADPTS LOCALARCBRUSH LOCALARCKNOTS LOCALARCDASHING))
]
)
(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@")(RPAQ CW.ARC.ANGLE.CURSOR (CURSORCREATE (READBITMAP) 8 15))
(16 16
"@GH@"
"COH@"
"OIH@"
"LCL@"
"@GN@"
"@OO@"
"@AH@"
"@AH@"
"@AH@"
"@AH@"
"@AH@"
"@AH@"
"@AH@"
"@AH@"
"@AH@"
"@AH@")(RPAQ CW.ARC.RADIUS.CURSOR (CURSORCREATE (READBITMAP) 15 8))
(16 16
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@B@"
"@@C@"
"@@CH"
"OOOO"
"OOOO"
"@@CK"
"@@CC"
"@@BC"
"@@@F"
"@@@F"
"@@@L"
"@@AH")(READVARS ARCICON)
({(READBITMAP)(20 13
"@@@@@@@@"
"@AOH@@@@"
"@COL@@@@"
"@G@N@@@@"
"@F@F@@@@"
"@N@G@@@@"
"@L@C@@@@"
"@@@C@@@@"
"@@@G@@@@"
"@@@F@@@@"
"@@@N@@@@"
"@@@L@@@@"
"@@@@@@@@")})
(* property getting and setting stuff)
(DEFINEQ
(GETSKETCHELEMENTPROP
[LAMBDA (ELEMENT PROPERTY) (* rrb " 8-Dec-85 21:09")
(* gets the property from a sketch element.)
(* knows about and sets the system ones specially.
All others go to the elements property list.)
(SELECTQ PROPERTY
(TYPE (fetch (GLOBALPART GTYPE) of ELEMENT))
(SCALE (\SKELT.GET.SCALE ELEMENT))
(REGION (ERROR "Not implemented yet"))
((POSITION 1STCONTROLPT)
(\SK.GET.1STCONTROLPT ELEMENT))
(2NDCONTROLPT (\SK.GET.2NDCONTROLPT ELEMENT))
(3RDCONTROLPT (\SK.GET.3RDCONTROLPT ELEMENT))
(DATA (\SKELT.GET.DATA ELEMENT))
(BRUSH (\SK.GET.BRUSH ELEMENT))
(FILLING (\SK.GET.FILLING ELEMENT))
(DASHING (\SK.GET.DASHING ELEMENT))
(ARROWHEADS (\SK.GET.ARROWHEADS ELEMENT))
(FONT (\SK.GET.FONT ELEMENT))
(JUSTIFICATION (\SK.GET.JUSTIFICATION ELEMENT))
(DIRECTION (\SK.GET.DIRECTION ELEMENT))
(LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of ELEMENT)
PROPERTY])
(\SK.GET.BRUSH
[LAMBDA (GELT) (* rrb " 7-Dec-85 19:52")
(* gets the brush field from a global sketch element
instance.)
(SELECTQ (fetch (GLOBALPART GTYPE) of GELT)
((WIRE CLOSEDWIRE OPENCURVE CLOSEDCURVE BOX)
(fetch (WIRE BRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)))
((CIRCLE ARC)
(fetch (CIRCLE BRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)))
(ELLIPSE (fetch (ELLIPSE BRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)))
(TEXTBOX (fetch (TEXTBOX TEXTBOXBRUSH) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GELT)))
(LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT)
(QUOTE BRUSH])
(\SK.GET.FILLING
[LAMBDA (GELT) (* rrb " 7-Dec-85 18:58")
(* gets the filling field from a global sketch element
instance.)
(SELECTQ (fetch (GLOBALPART GTYPE) of GELT)
((CLOSEDWIRE CLOSEDCURVE BOX)
(fetch (CLOSEDWIRE CLOSEDWIREFILLING) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GELT)))
(CIRCLE (fetch (CIRCLE CIRCLEFILLING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)))
(ELLIPSE (fetch (ELLIPSE ELLIPSEFILLING) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GELT)))
(TEXTBOX (fetch (TEXTBOX TEXTBOXFILLING) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GELT)))
(LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT)
(QUOTE FILLING])
(\SK.GET.ARROWHEADS
[LAMBDA (GELT) (* rrb " 7-Dec-85 19:17")
(* gets the arrowhead field from a global sketch
element instance.)
(SELECTQ (fetch (GLOBALPART GTYPE) of GELT)
(WIRE (fetch (WIRE WIREARROWHEADS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)))
(OPENCURVE (fetch (OPENCURVE CURVEARROWHEADS) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GELT)))
(ARC (fetch (ARC ARCARROWHEADS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)))
(LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT)
(QUOTE ARROWHEADS])
(\SK.GET.FONT
[LAMBDA (GELT) (* rrb " 7-Dec-85 19:22")
(* gets the font field from a global sketch element
instance.)
(SELECTQ (fetch (GLOBALPART GTYPE) of GELT)
((TEXT TEXTBOX)
(fetch (TEXT FONT) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)))
(LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT)
(QUOTE FONT])
(\SK.GET.JUSTIFICATION
[LAMBDA (GELT) (* rrb " 9-Dec-85 11:31")
(* gets the justification field from a global sketch
element instance.)
(SELECTQ (fetch (GLOBALPART GTYPE) of GELT)
((TEXT TEXTBOX)
(fetch (TEXT TEXTSTYLE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)))
(LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of ELEMENT)
(QUOTE JUSTIFICATION])
(\SK.GET.DIRECTION
[LAMBDA (GELT) (* rrb " 7-Dec-85 19:21")
(* gets the direction field from a global sketch
element instance.)
(SELECTQ (fetch (GLOBALPART GTYPE) of GELT)
(ARC (fetch (ARC ARCDIRECTION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)))
(LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT)
(QUOTE DIRECTION])
(\SK.GET.DASHING
[LAMBDA (GELT) (* rrb " 7-Dec-85 20:05")
(* gets the dashing field from a global sketch element
instance.)
(SELECTQ (fetch (GLOBALPART GTYPE) of GELT)
((WIRE CIRCLE ARC)
(fetch (WIRE OPENWIREDASHING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)))
((CLOSEDWIRE OPENCURVE CLOSEDCURVE BOX)
(fetch (CLOSEDWIRE CLOSEDWIREDASHING) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GELT)))
(ELLIPSE (fetch (ELLIPSE DASHING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)))
(TEXTBOX (fetch (TEXTBOX TEXTBOXDASHING) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GELT)))
(LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT)
(QUOTE DASHING])
(PUTSKETCHELEMENTPROP
[LAMBDA (ELEMENT PROPERTY VALUE SKETCHTOUPDATE) (* rrb " 9-Dec-85 11:37")
(* puts the property from a sketch element.)
(* knows about and sets the system ones specially.
All others go to the elements property list.)
(* mostly not implemented yet.)
(PROG1 (GETSKETCHELEMENTPROP ELEMENT PROPERTY)
(AND (SELECTQ PROPERTY
(TYPE (ERROR "Can't change types"))
(SCALE (\SKELT.PUT.SCALE ELEMENT VALUE)
T)
(REGION (ERROR "Not implemented yet"))
((POSITION 1STCONTROLPT)
(\SK.PUT.1STCONTROLPT ELEMENT VALUE))
(2NDCONTROLPT (\SK.PUT.2NDCONTROLPT ELEMENT VALUE))
(3RDCONTROLPT (\SK.PUT.3RDCONTROLPT ELEMENT VALUE))
(DATA (\SKELT.PUT.DATA ELEMENT VALUE SKETCHTOUPDATE))
(BRUSH (\SK.ELT.PUT.BRUSH ELEMENT VALUE SKETCHTOUPDATE))
(FILLING (\SKELT.PUT.FILLING ELEMENT VALUE))
(DASHING (\SKELT.PUT.DASHING ELEMENT VALUE))
(ARROWHEADS (\SK.PUT.ARROWHEADS ELEMENT VALUE))
(FONT (\SK.PUT.FONT ELEMENT VALUE))
(JUSTIFICATION (\SK.PUT.JUSTIFICATION ELEMENT VALUE))
(DIRECTION (\SK.PUT.DIRECTION ELEMENT VALUE))
(PROG ((PLIST (fetch (GLOBALPART SKELEMENTPROPLIST) of ELEMENT)))
[COND
(PLIST (LISTPUT PLIST PROPERTY VALUE))
(T (replace (GLOBALPART SKELEMENTPROPLIST) of ELEMENT
with (LIST PROPERTY VALUE]
(* if it wasn't a system recognized property, return
NIL so it won't be redisplayed.)
(RETURN NIL)))
SKETCHTOUPDATE
(SKETCH.UPDATE SKETCHTOUPDATE ELEMENT])
(\SK.PUT.FONT
[LAMBDA (GELT NEWVALUE) (* rrb " 9-Dec-85 11:36")
(* sets the font field from a global sketch element
instance.)
(SELECTQ (fetch (GLOBALPART GTYPE) of GELT)
(TEXT (replace (TEXT FONT) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)
with (SK.INSURE.TEXT STRING))
(SK.UPDATE.TEXT.AFTER.CHANGE GELT))
(TEXTBOX (replace (TEXTBOX FONT) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)
with (SK.INSURE.TEXT STRING))
(SK.UPDATE.TEXTBOX.AFTER.CHANGE GELT))
(LISTPUT (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT)
(QUOTE FONT)
NEWVALUE])
(\SK.PUT.JUSTIFICATION
[LAMBDA (GELT NEWVALUE) (* rrb "11-Dec-85 11:27")
(* sets the justification field from a global sketch
element instance.)
(SELECTQ (fetch (GLOBALPART GTYPE) of GELT)
(TEXT (replace (TEXT TEXTSTYLE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)
with (SK.INSURE.STYLE NEWVALUE SK.DEFAULT.TEXT.ALIGNMENT))
(SK.UPDATE.TEXT.AFTER.CHANGE GELT))
(TEXTBOX (replace (TEXTBOX TEXTSTYLE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)
with (SK.INSURE.STYLE NEWVALUE SK.DEFAULT.TEXT.ALIGNMENT))
(SK.UPDATE.TEXTBOX.AFTER.CHANGE GELT))
(LISTPUT (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT)
(QUOTE JUSTIFICATION)
NEWVALUE])
(\SK.PUT.DIRECTION
[LAMBDA (GELT NEWVALUE) (* rrb " 9-Dec-85 11:37")
(* puts the direction field from a global sketch
element instance.)
(SELECTQ (fetch (GLOBALPART GTYPE) of GELT)
(ARC (replace (ARC ARCDIRECTION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)
with (SK.INSURE.DIRECTION NEWVALUE))
(SK.UPDATE.ARC.AFTER.CHANGE GELT))
(LISTPUT (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT)
(QUOTE DIRECTION)
NEWVALUE])
(\SK.PUT.DASHING
[LAMBDA (GELT NEWVALUE) (* rrb " 7-Dec-85 20:53")
(* sets the dashing field of a global sketch element.)
(OR (DASHINGP NEWVALUE)
(\ILLEGAL.ARG NEWVALUE))
(SELECTQ (fetch (GLOBALPART GTYPE) of GELT)
((WIRE CIRCLE ARC)
(replace (WIRE OPENWIREDASHING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)
with NEWVALUE))
((CLOSEDWIRE OPENCURVE CLOSEDCURVE BOX)
(replace (CLOSEDWIRE CLOSEDWIREDASHING) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GELT)
with NEWVALUE))
(ELLIPSE (replace (ELLIPSE DASHING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)
with NEWVALUE))
(TEXTBOX (replace (TEXTBOX TEXTBOXDASHING) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GELT)
with NEWVALUE))
(LISTPUT (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT)
(QUOTE DASHING)
NEWVALUE])
(\SK.PUT.BRUSH
[LAMBDA (GELT NEWVALUE SKETCHTOUPDATE) (* rrb " 7-Dec-85 19:59")
(* gets the brush field from a global sketch element
instance.)
(OR (BRUSHP NEWVALUE)
(\ILLEGAL.ARG NEWVALUE))
(SELECTQ (fetch (GLOBALPART GTYPE) of GELT)
((WIRE CLOSEDWIRE OPENCURVE CLOSEDCURVE)
(replace (WIRE BRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)
with NEWVALUE)
(SK.UPDATE.WIRE.ELT.AFTER.CHANGE GELT))
(BOX (replace (BOX BRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)
with NEWVALUE))
(CIRCLE (replace (CIRCLE BRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)
with NEWVALUE)
(SK.UPDATE.CIRCLE.AFTER.CHANGE GELT))
(ARC (replace (ARC ARCBRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)
with NEWVALUE)
(SK.UPDATE.ARC.AFTER.CHANGE GELT))
(ELLIPSE (replace (ELLIPSE BRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)
with NEWVALUE)
(SK.UPDATE.ELLIPSE.AFTER.CHANGE GELT))
(TEXTBOX (AND SKETCHTOUPDATE (SKETCH.CLEANUP SKETCHTOUPDATE))
(replace (TEXTBOX TEXTBOXBRUSH) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GELT)
with NEWVALUE)
(SK.UPDATE.TEXTBOX.AFTER.CHANGE GELT))
(LISTPUT (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT)
(QUOTE BRUSH)
NEWVALUE])
(\SK.PUT.ARROWHEADS
[LAMBDA (GELT NEWVALUE) (* rrb " 8-Dec-85 19:27")
(* sets the arrowhead field from a global sketch
element instance.)
(SELECTQ (fetch (GLOBALPART GTYPE) of GELT)
[WIRE (replace (WIRE WIREARROWHEADS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT with (SK.INSURE.ARROWHEADS
NEWVALUE]
[OPENCURVE (replace (OPENCURVE CURVEARROWHEADS) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GELT
with (
SK.INSURE.ARROWHEADS
NEWVALUE]
[ARC (replace (ARC ARCARROWHEADS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT with (SK.INSURE.ARROWHEADS
NEWVALUE]
(LISTPUT (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT)
(QUOTE ARROWHEADS)
NEWVALUE])
(\SKELT.PUT.FILLING
[LAMBDA (GELT FILLING) (* rrb " 2-Dec-85 18:31")
(* sets the filling field of a global sketch element
instance.)
(COND
((SKFILLINGP FILLING)
(SELECTQ (fetch (GLOBALPART GTYPE) of GELT)
(BOX (replace (BOX BOXFILLING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)
with FILLING))
(TEXTBOX (replace (TEXTBOX TEXTBOXFILLING) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GELT)
with FILLING))
(CLOSEDWIRE (replace (CLOSEDWIRE CLOSEDWIREFILLING) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GELT)
with FILLING))
(CIRCLE (replace (CIRCLE CIRCLEFILLING) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GELT)
with FILLING))
NIL))
(T (\ILLEGAL.ARG FILLING])
(SK.COPY.ELEMENT.PROPERTY.LIST
[LAMBDA (ELEMENT) (* rrb "25-Nov-85 17:43")
(* copies the property list of an element.)
(replace (GLOBALPART SKELEMENTPROPLIST) of ELEMENT with (APPEND (fetch (GLOBALPART
SKELEMENTPROPLIST)
of ELEMENT])
(SKETCH.UPDATE
[LAMBDA (SKETCH ELEMENTS) (* rrb " 6-Dec-85 14:40")
(* updates all or part of a sketch.)
(PROG ((SKSTRUC (INSURE.SKETCH SKETCH))
ALLVIEWERS)
(SETQ ALLVIEWERS (ALL.SKETCH.VIEWERS SKSTRUC))
(COND
((NULL ELEMENTS)
(for SKW in ALLVIEWERS do (SK.UPDATE.AFTER.SCALE.CHANGE SKW)))
((GLOBALELEMENTP ELEMENTS)
(SKETCH.UPDATE1 ELEMENTS ALLVIEWERS))
((LISTP ELEMENTS)
(for ELT in ELEMENTS do (SKETCH.UPDATE1 ELT ALLVIEWERS)))
(T (\ILLEGAL.ARG ELEMENTS])
(SKETCH.UPDATE1
[LAMBDA (GELT VIEWERS) (* rrb " 6-Dec-85 14:40")
(* updates the element GELT in the sketch viewers
VIEWERS.)
(for SKW in VIEWERS
do (COND
([EQ GELT (fetch (SCREENELT GLOBALPART) of (fetch (TEXTELTSELECTION SKTEXTELT)
of (WINDOWPROP SKW
(QUOTE
SELECTION]
(* if the element being updated is the current text
selection, clear the selection.)
(SKED.CLEAR.SELECTION SKW)))
(SK.UPDATE.ELEMENT1 GELT GELT SKW T])
(\SKELT.GET.SCALE
[LAMBDA (GELT) (* rrb "29-Oct-85 13:44")
(* gets the scale field from a global sketch element
instance.)
(SELECTQ (fetch (GLOBALPART GTYPE) of GELT)
((TEXT TEXTBOX SKIMAGEOBJ BITMAPELT)
(fetch (TEXT INITIALSCALE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)))
((WIRE OPENCURVE CIRCLE ARC)
(fetch (WIRE OPENWIREINITSCALE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)))
((CLOSEDWIRE CLOSEDCURVE BOX)
(fetch (CLOSEDWIRE CLOSEDWIREINITSCALE) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GELT)))
(ELLIPSE (fetch (ELLIPSE ELLIPSEINITSCALE) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GELT)))
NIL])
(\SKELT.PUT.SCALE
[LAMBDA (GELT NEWVALUE) (* rrb "16-Oct-85 21:24")
(* sets the scale field of a global sketch element
instance.)
(COND
((NUMBERP NEWVALUE)
(SELECTQ (fetch (GLOBALPART GTYPE) of GELT)
((TEXT TEXTBOX SKIMAGEOBJ BITMAPELT)
(replace (TEXT INITIALSCALE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)
with NEWVALUE))
((WIRE OPENCURVE CIRCLE ARC)
(replace (WIRE OPENWIREINITSCALE) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GELT)
with NEWVALUE))
((CLOSEDWIRE CLOSEDCURVE BOX)
(replace (CLOSEDWIRE CLOSEDWIREINITSCALE) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GELT)
with NEWVALUE))
(ELLIPSE (replace (ELLIPSE ELLIPSEINITSCALE) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GELT)
with NEWVALUE))
NIL))
(T (\ILLEGAL.ARG NEWVALUE])
(\SKELT.PUT.DATA
[LAMBDA (GELT NEWVALUE SKETCHTOUPDATE) (* rrb " 7-Dec-85 19:58")
(* changes the data of a sketch element.)
(* this is harder than it seems because all of the
dependent fields must be updated also -
lots of grubby details duplicated.)
(PROG ((INDVELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)))
(RETURN (SELECTQ (fetch (GLOBALPART GTYPE) of GELT)
(GROUP (COND
([OR (NLISTP NEWVALUE)
(NOT (EVERY NEWVALUE (FUNCTION GLOBALELEMENTP]
(\ILLEGAL.ARG NEWVALUE)))
(replace (GROUP LISTOFGLOBALELTS) of INDVELT
with NEWVALUE)
(SK.UPDATE.GROUP.AFTER.CHANGE GELT))
((TEXT TEXTBOX) (* before changing the text element, make sure any
interactive editing is closed off.)
(AND SKETCHTOUPDATE (SKETCH.CLEANUP SKETCHTOUPDATE))
(SK.REPLACE.TEXT.IN.ELEMENT GELT (SK.INSURE.TEXT NEWVALUE)))
(BITMAPELT (replace (BITMAPELT SKBITMAP) of INDVELT
with NEWVALUE))
(SKIMAGEOBJ (replace (SKIMAGEOBJ SKIMAGEOBJ) of INDVELT
with NEWVALUE)
(SK.UPDATE.IMAGEOBJECT.AFTER.CHANGE GELT))
((WIRE OPENCURVE CLOSEDWIRE CLOSEDCURVE)
(replace (WIRE LATLONKNOTS) of INDVELT with NEWVALUE)
(SK.UPDATE.WIRE.ELT.AFTER.CHANGE GELT))
NIL])
(SK.REPLACE.TEXT.IN.ELEMENT
[LAMBDA (GTEXTELT NEWSTRS) (* rrb " 5-Dec-85 11:46")
(* changes the characters in a text or textbox
element.)
(SELECTQ (fetch (GLOBALPART GTYPE) of GTEXTELT)
(TEXTBOX (replace (TEXTBOX LISTOFCHARACTERS) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GTEXTELT)
with NEWSTRS)
(SK.UPDATE.TEXTBOX.AFTER.CHANGE GTEXTELT))
(TEXT (replace (TEXT LISTOFCHARACTERS) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GTEXTELT)
with NEWSTRS)
(SK.UPDATE.TEXT.AFTER.CHANGE GTEXTELT))
(\ILLEGAL.ARG GTEXTELT))
GTEXTELT])
(\SKELT.GET.DATA
[LAMBDA (GELT) (* rrb " 6-Dec-85 14:52")
(* changes the data of a sketch element.)
(PROG ((INDVELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)))
(RETURN (SELECTQ (fetch (GLOBALPART GTYPE) of GELT)
(GROUP (fetch (GROUP LISTOFGLOBALELTS) of INDVELT))
((TEXT TEXTBOX)
(fetch (TEXT LISTOFCHARACTERS) of INDVELT))
(BITMAPELT (fetch (BITMAPELT SKBITMAP) of INDVELT))
(SKIMAGEOBJ (fetch (SKIMAGEOBJ SKIMAGEOBJ) of INDVELT))
((WIRE OPENCURVE CLOSEDWIRE CLOSEDCURVE)
(fetch (WIRE LATLONKNOTS) of INDVELT))
(LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT)
(QUOTE DATA])
(\SK.GET.1STCONTROLPT
[LAMBDA (GELT PROPERTY) (* rrb " 9-Dec-85 11:33")
(* gets the first control point field from a global
sketch element instance.)
(SELECTQ (fetch (GLOBALPART GTYPE) of GELT)
((TEXT CIRCLE ARC ELLIPSE)
(fetch (TEXT LOCATIONLATLON) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)))
[(TEXTBOX BOX)
(LOWERLEFTCORNER (fetch (BOX GLOBALREGION) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GELT]
[(BITMAPELT SKIMAGEOBJ)
(LOWERLEFTCORNER (fetch (SKIMAGEOBJ SKIMOBJ.GLOBALREGION)
of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT]
[(WIRE CLOSEDWIRE OPENCURVE CLOSEDCURVE)
(CAR (fetch (WIRE LATLONKNOTS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT]
(GROUP (fetch (GROUP GROUPCONTROLPOINT) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GELT)))
(LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT)
PROPERTY])
(\SK.PUT.1STCONTROLPT
[LAMBDA (GELT NEWPOSITION) (* rrb " 4-Nov-85 19:11")
(* changes the first control point field from a global
sketch element instance.)
(ERROR "Not implemented yet.") (* NEED GRUBBY DETAILS OF UPDATING ALL DEPENDENT
FIELDS. SHOULD PROBABLY BE MADE TO CALL THE
TRANSLATEPTSFN.)
(OR (POSITIONP NEWPOSITION)
(\ILLEGAL.ARG NEWPOSITION))
(PROG ((INDVELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))
X)
(RETURN (SELECTQ (CAR INDVELT)
((TEXT CIRCLE ARC ELLIPSE)
(replace (TEXT LOCATIONLATLON) of INDVELT with NEWPOSITION))
[(TEXTBOX BOX)
(replace (BOX GLOBALREGION) of INDVELT
with (create REGION
using (fetch (BOX GLOBALREGION) of INDVELT)
LEFT ←(fetch (POSITION XCOORD)
of NEWPOSITION)
BOTTOM ←(fetch (POSITION YCOORD)
of NEWPOSITION]
[(BITMAPELT SKIMAGEOBJ)
(replace (SKIMAGEOBJ SKIMOBJ.GLOBALREGION) of INDVELT
with (create REGION
using (fetch (SKIMAGEOBJ SKIMOBJ.GLOBALREGION)
of INDVELT)
LEFT ←(fetch (POSITION XCOORD)
of NEWPOSITION)
BOTTOM ←(fetch (POSITION YCOORD)
of NEWPOSITION]
[(WIRE CLOSEDWIRE OPENCURVE CLOSEDCURVE)
(COND
((SETQ X (fetch (WIRE LATLONKNOTS) of INDVELT))
(* there is at least one knot)
(RPLACA X NEWPOSITION))
(T (replace (WIRE LATLONKNOTS) of INDVELT
with (CONS NEWPOSITION]
(GROUP (replace (GROUP GROUPCONTROLPOINT) of INDVELT
with NEWPOSITION))
NIL])
(\SK.GET.2NDCONTROLPT
[LAMBDA (GELT) (* rrb " 9-Dec-85 11:32")
(* gets the second control point field from a global
sketch element instance.)
(SELECTQ (fetch (GLOBALPART GTYPE) of GELT)
((CIRCLE ARC ELLIPSE)
(fetch (CIRCLE RADIUSLATLON) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)))
[(TEXTBOX BOX)
(UPPERRIGHTCORNER (fetch (BOX GLOBALREGION) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GELT]
[(WIRE CLOSEDWIRE OPENCURVE CLOSEDCURVE)
(CADR (fetch (WIRE LATLONKNOTS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT]
(LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT)
(QUOTE 2NDCONTROLPT])
(\SK.PUT.2NDCONTROLPT
[LAMBDA (GELT NEWPOSITION) (* rrb " 4-Nov-85 19:10")
(* changes the second control point field from a
global sketch element instance.)
(ERROR "Not implemented yet.") (* NEED GRUBBY DETAILS OF UPDATING ALL DEPENDENT
FIELDS. SHOULD PROBABLY BE MADE TO CALL THE
TRANSLATEPTSFN.)
(OR (POSITIONP NEWPOSITION)
(\ILLEGAL.ARG NEWPOSITION))
(PROG ((INDVELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))
X)
(RETURN (SELECTQ (CAR INDVELT)
((CIRCLE ARC ELLIPSE)
(replace (CIRCLE RADIUSLATLON) of INDVELT with NEWPOSITION))
[(TEXTBOX BOX)
(SETQ X (fetch (BOX GLOBALREGION) of INDVELT))
(replace (BOX GLOBALREGION) of INDVELT
with (create REGION using X WIDTH ←(DIFFERENCE
(fetch (POSITION XCOORD)
of NEWPOSITION)
(fetch (REGION LEFT)
of X))
HEIGHT ←(DIFFERENCE
(fetch (POSITION YCOORD)
of NEWPOSITION)
(fetch (REGION BOTTOM)
of X]
[(WIRE CLOSEDWIRE OPENCURVE CLOSEDCURVE)
(COND
((NULL (SETQ X (fetch (WIRE LATLONKNOTS) of INDVELT)))
(* doesn't have a first knot, give it one at 0 . 0)
(replace (WIRE LATLONKNOTS) of INDVELT
with (LIST (QUOTE (0 . 0))
NEWPOSITION)))
((NULL (CDR X))
(replace (WIRE LATLONKNOTS) of INDVELT
with (LIST (CAR X)
NEWPOSITION)))
(T (* there is at least one knot)
(RPLACA (CDR X)
NEWPOSITION]
NIL])
(\SK.GET.3RDCONTROLPT
[LAMBDA (GELT) (* rrb " 9-Dec-85 11:32")
(* gets the third control point field from a global
sketch element instance.)
(SELECTQ (fetch (GLOBALPART GTYPE) of GELT)
(ELLIPSE (fetch (ELLIPSE SEMIMAJORLATLON) of (fetch (GLOBALPART
INDIVIDUALGLOBALPART)
of GELT)))
(ARC (fetch (ARC ARCANGLEPT) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT)))
[(WIRE CLOSEDWIRE OPENCURVE CLOSEDCURVE)
(CADDR (fetch (WIRE LATLONKNOTS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART)
of GELT]
(LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT)
(QUOTE 3RDCONTROLPT])
(\SK.PUT.3RDCONTROLPT
[LAMBDA (GELT NEWPOSITION) (* rrb " 4-Nov-85 19:11")
(* changes the third control point field from a global
sketch element instance.)
(ERROR "Not implemented yet.") (* NEED GRUBBY DETAILS OF UPDATING ALL DEPENDENT
FIELDS. SHOULD PROBABLY BE MADE TO CALL THE
TRANSLATEPTSFN.)
(OR (POSITIONP NEWPOSITION)
(\ILLEGAL.ARG NEWPOSITION))
(PROG ((INDVELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))
X)
(RETURN (SELECTQ (CAR INDVELT)
(ELLIPSE (replace (ELLIPSE SEMIMAJORLATLON) of INDVELT
with NEWPOSITION))
(ARC (replace (ARC ARCANGLEPT) of INDVELT with NEWPOSITION))
[(WIRE CLOSEDWIRE OPENCURVE CLOSEDCURVE)
(COND
((NULL (SETQ X (fetch (WIRE LATLONKNOTS) of INDVELT)))
(* doesn't have a first knot, give it one at 0 . 0)
(replace (WIRE LATLONKNOTS) of INDVELT
with (LIST (QUOTE (0 . 0))
(QUOTE (0 . 0))
NEWPOSITION)))
((NULL (CDR X))
(replace (WIRE LATLONKNOTS) of INDVELT
with (LIST (CAR X)
(QUOTE (0 . 0))
NEWPOSITION)))
((NULL (CDDR X))
(replace (WIRE LATLONKNOTS) of INDVELT
with (LIST (CAR X)
(CADR X)
NEWPOSITION)))
(T (* there is at least one knot)
(RPLACA (CDDR X)
NEWPOSITION]
NIL])
)
(DEFINEQ
(LOWERLEFTCORNER
[LAMBDA (REGION) (* returns a position which is the lower left corner
of a region.)
(CREATEPOSITION (FETCH (REGION LEFT) OF REGION)
(FETCH (REGION BOTTOM) OF REGION])
(UPPERRIGHTCORNER
[LAMBDA (REGION) (* rrb "16-Oct-85 21:10")
(* returns a position which is the lower left corner
of a region.)
(CREATEPOSITION (fetch (REGION RIGHT) of REGION)
(fetch (REGION TOP) of REGION])
)
(* stuff for compatibility with unadvertised interface. Remove after L release.)
(MOVD? (QUOTE GETSKETCHELEMENTPROP)
(QUOTE GETSKELEMENTPROP))
(MOVD? (QUOTE PUTSKETCHELEMENTPROP)
(QUOTE PUTSKELEMENTPROP))
(MOVD? (QUOTE SKETCH.CREATE.IMAGE.OBJECT)
(QUOTE SKETCH.IMAGE.OBJECT.ELEMENT))
(INIT.SKETCH.ELEMENTS)
(PUTPROPS SKETCHELEMENTS COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (11570 21734 (INIT.SKETCH.ELEMENTS 11580 . 19280) (CREATE.SKETCH.ELEMENT.TYPE 19282 .
20575) (SKETCH.ELEMENT.TYPEP 20577 . 20910) (SKETCH.ELEMENT.NAMEP 20912 . 21175) (
\CURSOR.IN.MIDDLE.MENU 21177 . 21732)) (21771 22312 (SKETCHINCOLORP 21781 . 22031) (READ.COLOR.CHANGE
22033 . 22310)) (22733 24378 (\POSSIBLECOLOR 22743 . 23284) (RGBP 23286 . 23906) (HLSP 23908 . 24376))
(24379 26609 (SK.CREATE.DEFAULT.FILLING 24389 . 24626) (SKFILLINGP 24628 . 25142) (SK.INSURE.FILLING
25144 . 26270) (SK.INSURE.COLOR 26272 . 26607)) (26610 45639 (SKETCH.CREATE.CIRCLE 26620 . 27337) (
CIRCLE.EXPANDFN 27339 . 29758) (CIRCLE.DRAWFN 29760 . 32403) (CIRCLE.INPUTFN 32405 . 34023) (
SK.UPDATE.CIRCLE.AFTER.CHANGE 34025 . 34436) (SK.READ.CIRCLE.POINT 34438 . 34921) (SK.SHOW.CIRCLE
34923 . 35618) (CIRCLE.INSIDEFN 35620 . 36756) (CIRCLE.REGIONFN 36758 . 37768) (CIRCLE.GLOBALREGIONFN
37770 . 39174) (CIRCLE.TRANSLATE 39176 . 40052) (CIRCLE.TRANSFORMFN 40054 . 41281) (
CIRCLE.TRANSLATEPTS 41283 . 42712) (SK.CIRCLE.CREATE 42714 . 43419) (SET.CIRCLE.SCALE 43421 . 44152) (
SK.BRUSH.READCHANGE 44154 . 45637)) (45640 47018 (BRUSHP 45650 . 46219) (SK.INSURE.BRUSH 46221 . 46657
) (SK.INSURE.DASHING 46659 . 47016)) (58354 82111 (SKETCH.CREATE.ELLIPSE 58364 . 58944) (
ELLIPSE.EXPANDFN 58946 . 61401) (ELLIPSE.DRAWFN 61403 . 64047) (ELLIPSE.INPUTFN 64049 . 66196) (
SK.READ.ELLIPSE.MAJOR.PT 66198 . 66737) (SK.SHOW.ELLIPSE.MAJOR.RADIUS 66739 . 67442) (
SK.READ.ELLIPSE.MINOR.PT 67444 . 68113) (SK.SHOW.ELLIPSE.MINOR.RADIUS 68115 . 68911) (ELLIPSE.INSIDEFN
68913 . 69692) (ELLIPSE.CREATE 69694 . 70659) (SK.UPDATE.ELLIPSE.AFTER.CHANGE 70661 . 71098) (
ELLIPSE.REGIONFN 71100 . 73009) (ELLIPSE.GLOBALREGIONFN 73011 . 74682) (ELLIPSE.TRANSLATEFN 74684 .
75829) (ELLIPSE.TRANSFORMFN 75831 . 76877) (ELLIPSE.TRANSLATEPTS 76879 . 78699) (MARK.SPOT 78701 .
79777) (DISTANCEBETWEEN 79779 . 80276) (SK.DISTANCE.TO 80278 . 80599) (SQUARE 80601 . 80647) (
COMPUTE.ELLIPSE.ORIENTATION 80649 . 81323) (SK.COMPUTE.ELLIPSE.MINOR.RADIUS.PT 81325 . 82109)) (83226
112497 (SKETCH.CREATE.OPEN.CURVE 83236 . 83710) (OPENCURVE.INPUTFN 83712 . 84406) (SK.CURVE.CREATE
84408 . 85186) (MAXXEXTENT 85188 . 85897) (MAXYEXTENT 85899 . 86608) (KNOT.SET.SCALE.FIELD 86610 .
87426) (OPENCURVE.DRAWFN 87428 . 88299) (OPENCURVE.EXPANDFN 88301 . 90403) (OPENCURVE.READCHANGEFN
90405 . 92220) (OPENCURVE.TRANSFORMFN 92222 . 93669) (OPENCURVE.TRANSLATEPTSFN 93671 . 94696) (
SKETCH.CREATE.CLOSED.CURVE 94698 . 95127) (CLOSEDCURVE.DRAWFN 95129 . 95921) (CLOSEDCURVE.EXPANDFN
95923 . 98162) (CLOSEDCURVE.REGIONFN 98164 . 98981) (CLOSEDCURVE.GLOBALREGIONFN 98983 . 100131) (
READ.LIST.OF.POINTS 100133 . 101418) (CLOSEDCURVE.INPUTFN 101420 . 102017) (CLOSEDCURVE.READCHANGEFN
102019 . 103706) (CLOSEDCURVE.TRANSFORMFN 103708 . 104757) (CLOSEDCURVE.TRANSLATEPTSFN 104759 . 105748
) (INVISIBLEPARTP 105750 . 106161) (SHOWSKETCHPOINT 106163 . 106510) (SHOWSKETCHXY 106512 . 107023) (
KNOTS.REGIONFN 107025 . 107721) (OPENWIRE.GLOBALREGIONFN 107723 . 108591) (CURVE.REGIONFN 108593 .
109388) (OPENCURVE.GLOBALREGIONFN 109390 . 110495) (KNOTS.TRANSLATEFN 110497 . 111342) (
REGION.CONTAINING.PTS 111344 . 112495)) (112498 128096 (CHANGE.ELTS.BRUSH.SIZE 112508 . 113102) (
CHANGE.ELTS.BRUSH 113104 . 113536) (CHANGE.ELTS.BRUSH.SHAPE 113538 . 113997) (SK.CHANGE.BRUSH.SHAPE
113999 . 116740) (SK.CHANGE.BRUSH.COLOR 116742 . 119768) (SK.CHANGE.BRUSH.SIZE 119770 . 123159) (
SK.CHANGE.ANGLE 123161 . 125170) (SK.CHANGE.ARC.DIRECTION 125172 . 126401) (SK.SET.DEFAULT.BRUSH.SIZE
126403 . 126978) (READSIZECHANGE 126980 . 128094)) (128097 129172 (SK.CHANGE.ELEMENT.KNOTS 128107 .
129170)) (129173 129765 (SK.INSURE.POINT.LIST 129183 . 129576) (SK.INSURE.POSITION 129578 . 129763)) (
130991 154631 (SKETCH.CREATE.WIRE 131001 . 131469) (CLOSEDWIRE.EXPANDFN 131471 . 133513) (
KNOTS.INSIDEFN 133515 . 134098) (OPEN.WIRE.DRAWFN 134100 . 134599) (WIRE.EXPANDFN 134601 . 136606) (
SK.UPDATE.WIRE.ELT.AFTER.CHANGE 136608 . 137176) (OPENWIRE.READCHANGEFN 137178 . 138658) (
OPENWIRE.TRANSFORMFN 138660 . 140068) (OPENWIRE.TRANSLATEPTSFN 140070 . 141101) (SK.EXPAND.ARROWHEADS
141103 . 143468) (WIRE.INPUTFN 143470 . 144784) (SK.READ.WIRE.POINTS 144786 . 145150) (
SK.READ.POINTS.WITH.FEEDBACK 145152 . 147262) (OPENWIRE.FEEDBACKFN 147264 . 147944) (
CLOSEDWIRE.FEEDBACKFN 147946 . 149043) (CLOSEDWIRE.REGIONFN 149045 . 149752) (
CLOSEDWIRE.GLOBALREGIONFN 149754 . 150668) (SK.WIRE.CREATE 150670 . 151469) (WIRE.ADD.POINT.TO.END
151471 . 152406) (READ.ARROW.CHANGE 152408 . 154244) (CHANGE.ELTS.ARROWHEADS 154246 . 154629)) (154632
161743 (SKETCH.CREATE.CLOSED.WIRE 154642 . 155115) (CLOSED.WIRE.INPUTFN 155117 . 155452) (
CLOSED.WIRE.DRAWFN 155454 . 157232) (CLOSEDWIRE.READCHANGEFN 157234 . 159608) (CLOSEDWIRE.TRANSFORMFN
159610 . 160655) (CLOSEDWIRE.TRANSLATEPTSFN 160657 . 161741)) (161744 187470 (CHANGED.ARROW 161754 .
163531) (SK.CHANGE.ARROWHEAD 163533 . 164044) (SK.CHANGE.ARROWHEAD1 164046 . 166884) (
SK.CREATE.ARROWHEAD 166886 . 167332) (SK.ARROWHEAD.CREATE 167334 . 168559) (SK.ARROWHEAD.END.TEST
168561 . 169303) (READ.ARROWHEAD.END 169305 . 170462) (ARROW.HEAD.POSITIONS 170464 . 172225) (
ARROWHEAD.POINTS.LIST 172227 . 175665) (CURVE.ARROWHEAD.POINTS 175667 . 176461) (LEFT.MOST.IS.BEGINP
176463 . 177247) (WIRE.ARROWHEAD.POINTS 177249 . 178596) (DRAWARROWHEADS 178598 . 180176) (
SK.SET.ARROWHEAD.LENGTH 180178 . 181103) (SK.SET.ARROWHEAD.ANGLE 181105 . 182008) (
SK.SET.ARROWHEAD.TYPE 182010 . 183215) (SK.SET.LINE.ARROWHEAD 183217 . 184717) (
SK.UPDATE.ARROWHEAD.FORMAT 184719 . 186467) (SK.SET.LINE.LENGTH.MODE 186469 . 187468)) (187471 188717
(SK.INSURE.ARROWHEADS 187481 . 188171) (SK.ARROWHEADP 188173 . 188715)) (190141 245167 (
SKETCH.CREATE.TEXT 190151 . 190634) (TEXT.CHANGEFN 190636 . 190958) (TEXT.READCHANGEFN 190960 . 195429
) (\SK.READ.FONT.SIZE1 195431 . 196960) (SK.TEXT.ELT.WITH.SAME.FIELDS 196962 . 198406) (
SK.READFONTFAMILY 198408 . 199589) (CLOSE.PROMPT.WINDOW 199591 . 199996) (TEXT.DRAWFN 199998 . 200669)
(TEXT.DRAWFN1 200671 . 203124) (TEXT.INSIDEFN 203126 . 203585) (TEXT.EXPANDFN 203587 . 207317) (
SK.TEXT.LINE.REGIONS 207319 . 208756) (SK.PICK.FONT 208758 . 209964) (SK.NEXTSIZEFONT 209966 . 211115)
(SK.DECREASING.FONT.LIST 211117 . 212390) (SK.GUESS.FONTSAVAILABLE 212392 . 216440) (
TEXT.UPDATE.GLOBAL.REGIONS 216442 . 217541) (REL.MOVE.REGION 217543 . 218001) (LTEXT.LINE.REGIONS
218003 . 220568) (TEXT.INPUTFN 220570 . 221086) (READ.TEXT 221088 . 221777) (TEXT.POSITION.AND.CREATE
221779 . 223761) (CREATE.TEXT.ELEMENT 223763 . 224413) (SK.UPDATE.TEXT.AFTER.CHANGE 224415 . 224853) (
SK.TEXT.FROM.TEXTBOX 224855 . 226593) (TEXT.SET.GLOBAL.REGIONS 226595 . 227768) (TEXT.REGIONFN 227770
. 228375) (TEXT.GLOBALREGIONFN 228377 . 229036) (TEXT.TRANSLATEFN 229038 . 230029) (TEXT.TRANSFORMFN
230031 . 231021) (TEXT.TRANSLATEPTSFN 231023 . 231545) (TEXT.UPDATEFN 231547 . 235272) (SK.CHANGE.TEXT
235274 . 243029) (TEXT.SET.SCALES 243031 . 243949) (SK.FONT.LIST 243951 . 244367) (
BREAK.AT.CARRIAGE.RETURNS 244369 . 245165)) (245443 255532 (SK.SET.FONT 245453 . 246655) (
SK.SET.TEXT.FONT 246657 . 247343) (SK.SET.TEXT.SIZE 247345 . 247962) (SK.SET.TEXT.HORIZ.ALIGN 247964
. 249052) (SK.READFONTSIZE 249054 . 250610) (SK.COLLECT.FONT.SIZES 250612 . 252806) (
SK.SET.TEXT.VERT.ALIGN 252808 . 254159) (SK.SET.TEXT.LOOKS 254161 . 255004) (SK.SET.DEFAULT.TEXT.FACE
255006 . 255530)) (255533 256217 (CREATE.SKETCH.TERMTABLE 255543 . 256215)) (256218 258231 (
SK.FONT.LIST 256228 . 256644) (SK.INSURE.FONT 256646 . 257227) (SK.INSURE.STYLE 257229 . 257794) (
SK.INSURE.TEXT 257796 . 258229)) (258801 299732 (SKETCH.CREATE.TEXTBOX 258811 . 259668) (
SK.BREAK.INTO.LINES 259670 . 267106) (SK.BRUSH.SIZE 267108 . 267474) (SK.TEXTBOX.CREATE 267476 .
268218) (SK.TEXTBOX.CREATE1 268220 . 268894) (SK.UPDATE.TEXTBOX.AFTER.CHANGE 268896 . 269458) (
SK.TEXTBOX.POSITION.IN.BOX 269460 . 270849) (TEXTBOX.CHANGEFN 270851 . 271248) (TEXTBOX.DRAWFN 271250
. 274946) (SK.TEXTURE.AROUND.REGIONS 274948 . 277505) (TEXTBOX.EXPANDFN 277507 . 284111) (
TEXTBOX.INPUTFN 284113 . 285508) (TEXTBOX.INSIDEFN 285510 . 285936) (TEXTBOX.REGIONFN 285938 . 286706)
(TEXTBOX.GLOBALREGIONFN 286708 . 287089) (TEXTBOX.SET.GLOBAL.REGIONS 287091 . 288424) (
TEXTBOX.TRANSLATEFN 288426 . 289693) (TEXTBOX.TRANSLATEPTSFN 289695 . 292191) (TEXTBOX.TRANSFORMFN
292193 . 293569) (TEXTBOX.UPDATEFN 293571 . 295347) (TEXTBOX.READCHANGEFN 295349 . 297662) (
SK.TEXTBOX.TEXT.POSITION 297664 . 298051) (SK.TEXTBOX.FROM.TEXT 298053 . 299311) (ADD.EOLS 299313 .
299730)) (300178 302450 (SK.SET.TEXTBOX.VERT.ALIGN 300188 . 301426) (SK.SET.TEXTBOX.HORIZ.ALIGN 301428
. 302448)) (302876 330247 (SKETCH.CREATE.BOX 302886 . 303343) (SK.BOX.DRAWFN 303345 . 304268) (
BOX.DRAWFN1 304270 . 305738) (KNOTS.OF.REGION 305740 . 306714) (SK.DRAWAREABOX 306716 . 308050) (
SK.BOX.EXPANDFN 308052 . 310850) (SK.BOX.GETREGIONFN 310852 . 311928) (BOX.SET.SCALES 311930 . 312828)
(SK.BOX.INPUTFN 312830 . 314394) (SK.BOX.CREATE 314396 . 314828) (SK.BOX.INSIDEFN 314830 . 315226) (
SK.BOX.REGIONFN 315228 . 315732) (SK.BOX.GLOBALREGIONFN 315734 . 316100) (SK.BOX.READCHANGEFN 316102
. 318183) (SK.CHANGE.FILLING 318185 . 320330) (SK.CHANGE.FILLING.COLOR 320332 . 322451) (
SK.BOX.TRANSLATEFN 322453 . 323225) (SK.BOX.TRANSFORMFN 323227 . 324053) (SK.BOX.TRANSLATEPTSFN 324055
. 326207) (UNSCALE.REGION.FROM.SKETCHW 326209 . 326637) (UNSCALE.REGION.TO.GRID 326639 . 327619) (
INCREASEREGION 327621 . 328153) (INSUREREGIONSIZE 328155 . 329126) (EXPANDREGION 329128 . 329877) (
REGION.FROM.COORDINATES 329879 . 330245)) (330715 350901 (SKETCH.CREATE.ARC 330725 . 331336) (
ARC.DRAWFN 331338 . 332249) (ARC.EXPANDFN 332251 . 333787) (ARC.INPUTFN 333789 . 337521) (
SK.INVERT.CIRCLE 337523 . 338280) (SK.READ.ARC.ANGLE.POINT 338282 . 338811) (SK.SHOW.ARC 338813 .
339407) (ARC.CREATE 339409 . 340082) (SK.UPDATE.ARC.AFTER.CHANGE 340084 . 340483) (ARC.MOVEFN 340485
. 342039) (ARC.TRANSLATEPTS 342041 . 343352) (ARC.INSIDEFN 343354 . 344069) (ARC.REGIONFN 344071 .
344854) (ARC.GLOBALREGIONFN 344856 . 346122) (ARC.TRANSLATE 346124 . 346804) (ARC.TRANSFORMFN 346806
. 349129) (ARC.READCHANGEFN 349131 . 350899)) (350902 356946 (SK.COMPUTE.ARC.ANGLE.PT 350912 . 351640
) (SK.COMPUTE.ARC.PTS 351642 . 354173) (SK.SET.ARC.DIRECTION 354175 . 354685) (SK.SET.ARC.DIRECTION.CW
354687 . 354871) (SK.SET.ARC.DIRECTION.CCW 354873 . 355107) (SK.COMPUTE.SLOPE.OF.LINE 355109 . 355587
) (SK.CREATE.ARC.USING 355589 . 356183) (SET.ARC.SCALES 356185 . 356944)) (356947 357428 (
SK.INSURE.DIRECTION 356957 . 357426)) (358844 391159 (GETSKETCHELEMENTPROP 358854 . 360123) (
\SK.GET.BRUSH 360125 . 361072) (\SK.GET.FILLING 361074 . 362089) (\SK.GET.ARROWHEADS 362091 . 362919)
(\SK.GET.FONT 362921 . 363450) (\SK.GET.JUSTIFICATION 363452 . 364025) (\SK.GET.DIRECTION 364027 .
364571) (\SK.GET.DASHING 364573 . 365584) (PUTSKETCHELEMENTPROP 365586 . 367602) (\SK.PUT.FONT 367604
. 368442) (\SK.PUT.JUSTIFICATION 368444 . 369380) (\SK.PUT.DIRECTION 369382 . 370042) (
\SK.PUT.DASHING 370044 . 371223) (\SK.PUT.BRUSH 371225 . 372937) (\SK.PUT.ARROWHEADS 372939 . 373980)
(\SKELT.PUT.FILLING 373982 . 375063) (SK.COPY.ELEMENT.PROPERTY.LIST 375065 . 375486) (SKETCH.UPDATE
375488 . 376179) (SKETCH.UPDATE1 376181 . 376926) (\SKELT.GET.SCALE 376928 . 377898) (\SKELT.PUT.SCALE
377900 . 379054) (\SKELT.PUT.DATA 379056 . 380666) (SK.REPLACE.TEXT.IN.ELEMENT 380668 . 381489) (
\SKELT.GET.DATA 381491 . 382345) (\SK.GET.1STCONTROLPT 382347 . 383573) (\SK.PUT.1STCONTROLPT 383575
. 385570) (\SK.GET.2NDCONTROLPT 385572 . 386493) (\SK.PUT.2NDCONTROLPT 386495 . 388490) (
\SK.GET.3RDCONTROLPT 388492 . 389373) (\SK.PUT.3RDCONTROLPT 389375 . 391157)) (391160 391832 (
LOWERLEFTCORNER 391170 . 391454) (UPPERRIGHTCORNER 391456 . 391830)))))
STOP