(FILECREATED "11-Oct-85 15:00:49" {ERIS}<LISPCORE>NEWWINDOWS>ADISPLAY.;1 153265
changes to: (FNS \DRAWLINE.DISPLAY \CLIPANDDRAWLINE \CLIPANDDRAWLINE1)
previous date: " 4-Oct-85 18:24:26" {ERIS}<LISPCORE>SOURCES>ADISPLAY.;68)
(* Copyright (c) 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT ADISPLAYCOMS)
(RPAQQ ADISPLAYCOMS [(COMS (* Interlisp-D dependent stuff.)
(EXPORT (RECORDS REGION BITMAP BITMAPWORD POSITION CURSOR MOUSEEVENT))
(SYSRECORDS PILOTBBT \DISPLAYDATA)
(CONSTANTS (BITSPERINTEGER 32))
(FNS \BBTCURVEPT \CHANGEBACKGROUND.DISPLAY
\CHANGEBACKGROUNDBORDER.DISPLAY)
(FNS CREATETEXTUREFROMBITMAP PRINTBITMAP PRINTCURSOR \WRITEBITMAP)
(FNS \GETINTEGERPART \CONVERTTOFRACTION)
(CONSTANTS (INTEGERBITS 12)))
(COMS * CARETCOMS)
[COMS (* cursor functions not on LLDISPLAY)
(FNS CURSORP CURSORBITMAP CreateCursorBitMap)
(EXPORT (MACROS CURSORBITMAP)
(CONSTANTS (CURSORHEIGHT 16)
(CURSORWIDTH 16))
(DECLARE: EVAL@COMPILE (ADDVARS (GLOBALVARS CursorBitMap]
(COMS (* Region functions)
(FNS CREATEREGION REGIONP INTERSECTREGIONS UNIONREGIONS REGIONSINTERSECTP SUBREGIONP
EXTENDREGION EXTENDREGIONBOTTOM EXTENDREGIONLEFT EXTENDREGIONRIGHT EXTENDREGIONTOP
INSIDEP STRINGREGION))
(COMS (* line and spline drawing.)
(COMS (* Brushes and brush initialization)
(GLOBALRESOURCES \BRUSHBBT)
(FNS \BRUSHBITMAP \GETBRUSH \GETBRUSHBBT \InitCurveBrushes \BrushFromWidth)
(FNS \MakeBrush.DIAGONAL \MakeBrush.HORIZONTAL \MakeBrush.VERTICAL
\MakeBrush.SQUARE \MakeBrush.ROUND)
(FNS INSTALLBRUSH)
(VARS \BrushNames)
(ADDVARS (\BrushAList))
(RECORDS BRUSHITEM)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (\InitCurveBrushes)))
(DECLARE: DONTCOPY (GLOBALVARS \BrushList)))
(* Lines)
(FNS \DRAWLINE.DISPLAY RELMOVETO MOVETOUPPERLEFT)
(FNS \CLIPANDDRAWLINE \CLIPANDDRAWLINE1 \CLIPCODE \LEASTPTAT \GREATESTPTAT \DRAWLINE1
\DRAWLINE.UFN)
(DECLARE: DONTCOPY (MACROS .DRAWLINEX. .DRAWLINEY.))
(* Curves)
(FNS \DRAWCIRCLE.DISPLAY \DRAWARC.DISPLAY \DRAWARC.GENERIC \COMPUTE.ARC.POINTS
\DRAWELLIPSE.DISPLAY \DRAWCURVE.DISPLAY DRAWPOINT \LINEWITHBRUSH)
(FNS LOADPOLY PARAMETRICSPLINE \CURVE \CURVE2 \CURVEEND \CURVESLOPE \CURVESTART
\FDIFS/FROM/DERIVS)
(DECLARE: DONTCOPY (* Used by drawcurve)
(EXPORT (RECORDS POLYNOMIAL SPLINE)))
(DECLARE: DONTCOPY (EXPORT (MACROS HALF \FILLCIRCLEBLT))
(MACROS \CURVEPT .SETUP.FOR.\BBTCURVEPT. \CIRCLEPTS \CURVESMOOTH))
(FNS \FILLCIRCLE.DISPLAY \LINEBLT))
[COMS (* making and copying bitmaps)
(FNS SCREENBITMAP BITMAPP BITMAPHEIGHT BITMAPPROP BITSPERPIXEL CLR)
(EXPORT (FILEPKGCOMS BITMAPS CURSORS))
(DECLARE: EVAL@COMPILE (EXPORT (MACROS SCREENBITMAP BITMAPP)
(ADDVARS (GLOBALVARS SCREENHEIGHT SCREENWIDTH
ScreenBitMap]
[COMS (* Display stream functions that are not needed in the primitive system)
(FNS CLOSEDISPLAYSTREAM DSPFILL INVERTW)
(FNS \DSPCOLOR.DISPLAY \DSPBACKCOLOR.DISPLAY DSPEOLFN)
(EXPORT (CONSTANTS (BLACKSHADE 65535)
(WHITESHADE 0))
(VARS (GRAYSHADE 43605)
(BLACKCOLOR 0)
(WHITECOLOR 7))
(ADDVARS (GLOBALVARS GRAYSHADE WHITECOLOR BLACKCOLOR)))
(MACROS DSPRUBOUTCHAR)
(FNS DSPCLEOL DSPRUBOUTCHAR \DSPMOVELR)
(COMS (* for cursor)
(BITMAPS \DefaultCursor)
[DECLARE: DONTEVAL@LOAD DOCOPY (INITVARS (DEFAULTCURSOR (CURSORCREATE
\DefaultCursor 0
15]
(DECLARE: DONTCOPY (GLOBALVARS DEFAULTCURSOR]
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA UNIONREGIONS
INTERSECTREGIONS])
(* Interlisp-D dependent stuff.)
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(RECORD REGION (LEFT BOTTOM WIDTH HEIGHT)
LEFT ← -16383 BOTTOM ← -16383 WIDTH ← 32767 HEIGHT ← 32767
[ACCESSFNS ((TOP (IPLUS (fetch (REGION BOTTOM) of DATUM)
(fetch (REGION HEIGHT) of DATUM)
-1))
(PTOP (IPLUS (fetch (REGION BOTTOM) of DATUM)
(fetch (REGION HEIGHT) of DATUM)))
(RIGHT (IPLUS (fetch (REGION LEFT) of DATUM)
(fetch (REGION WIDTH) of DATUM)
-1))
(PRIGHT (IPLUS (fetch (REGION LEFT) of DATUM)
(fetch (REGION WIDTH) of DATUM]
[TYPE? (AND (EQLENGTH DATUM 4)
(EVERY DATUM (FUNCTION NUMBERP]
(SYSTEM))
(DATATYPE BITMAP ((BITMAPBASE POINTER)
(BITMAPRASTERWIDTH WORD)
(BITMAPHEIGHT WORD)
(BITMAPWIDTH WORD)
(BITMAPBITSPERPIXEL WORD))
BITMAPBITSPERPIXEL ← 1 (BLOCKRECORD BITMAP ((BitMapHiLoc WORD)
(BitMapLoLoc WORD))
(* overlay inital pointer)
)
(SYSTEM))
(BLOCKRECORD BITMAPWORD ((BITS WORD))
(SYSTEM))
(RECORD POSITION (XCOORD . YCOORD)
[TYPE? (AND (LISTP DATUM)
(NUMBERP (CAR DATUM))
(NUMBERP (CDR DATUM]
(SYSTEM))
(RECORD CURSOR (CURSORBITMAP . CURSORHOTSPOT)
CURSORHOTSPOT ←(create POSITION)
[ACCESSFNS ((CURSORHOTSPOTX (fetch (POSITION XCOORD)
of (fetch (CURSOR CURSORHOTSPOT)
of DATUM))
(replace (POSITION XCOORD)
of (fetch (CURSOR CURSORHOTSPOT)
of DATUM)
with NEWVALUE))
(CURSORHOTSPOTY (fetch (POSITION YCOORD)
of (fetch (CURSOR CURSORHOTSPOT)
of DATUM))
(replace (POSITION YCOORD)
of (fetch (CURSOR CURSORHOTSPOT)
of DATUM)
with NEWVALUE]
[TYPE? (AND (type? BITMAP (fetch (CURSOR CURSORBITMAP)
of (LISTP DATUM)))
(type? POSITION (fetch (CURSOR CURSORHOTSPOT) of DATUM]
(SYSTEM))
(RECORD MOUSEEVENT (MOUSEX MOUSEY MOUSEBUTTONS KEYBOARD MOUSETIME)
(SYSTEM))
]
(/DECLAREDATATYPE (QUOTE BITMAP)
(QUOTE (POINTER WORD WORD WORD WORD))
[QUOTE ((BITMAP 0 POINTER)
(BITMAP 2 (BITS . 15))
(BITMAP 3 (BITS . 15))
(BITMAP 4 (BITS . 15))
(BITMAP 5 (BITS . 15]
(QUOTE 6))
(* END EXPORTED DEFINITIONS)
[ADDTOVAR SYSTEMRECLST
(DATATYPE PILOTBBT ((PBTDESTLO WORD)
(PBTDESTHI WORD)
(PBTDESTBIT WORD)
(PBTDESTBPL SIGNEDWORD)
(PBTSOURCELO WORD)
(PBTSOURCEHI WORD)
(PBTSOURCEBIT WORD)
(PBTSOURCEBPL SIGNEDWORD)
(PBTWIDTH WORD)
(PBTHEIGHT WORD)
(PBTFLAGS WORD)
(NIL 5 WORD)))
(DATATYPE \DISPLAYDATA (DDXPOSITION DDYPOSITION DDXOFFSET DDYOFFSET DDDestination DDClippingRegion
DDFONT DDSlowPrintingCase DDWIDTHSCACHE DDOFFSETSCACHE DDCOLOR
DDLINEFEED DDRightMargin DDLeftMargin DDScroll DDOPERATION
DDSOURCETYPE (DDClippingLeft WORD)
(DDClippingRight WORD)
(DDClippingBottom WORD)
(DDClippingTop WORD)
(DDobsoletefield WORD)
(DDHELDFLG FLAG)
(XWINDOWHINT XPOINTER)
(DDPILOTBBT POINTER)
DDXSCALE DDYSCALE DDCHARIMAGEWIDTHS DDEOLFN DDPAGEFULLFN
DDTexture DDMICAXPOS DDMICAYPOS DDMICARIGHTMARGIN DDCHARSET
(DDCHARSETASCENT WORD)
(DDCHARSETDESCENT WORD)
DDCHARHEIGHTDELTA
(DDSPACEWIDTH WORD)))
]
(DECLARE: EVAL@COMPILE
(RPAQQ BITSPERINTEGER 32)
(CONSTANTS (BITSPERINTEGER 32))
)
(DEFINEQ
(\BBTCURVEPT
[LAMBDA (X Y BBT LEFT BRUSHWIDTH LEFTMINUSBRUSH RIGHTPLUS1 NBITSRIGHTPLUS1 TOPMINUSBRUSH
DestinationBitMap BRUSHHEIGHT BOTTOMMINUSBRUSH TOP BRUSHBASE DESTINATIONBASE RASTERWIDTH
BRUSHRASTERWIDTH COLORBRUSHBASE NBITS DISPLAYDATA)
(* hdj " 9-Jan-85 20:37")
(* Called by \CURVEPT macro. Draws a brush point by bitblting BRUSHBM to point X,Y in DestinationBitMap.
BBT is a BitBlt table where everything is already set except the source and destination addresses, width and height.
In other words, only the easy stuff)
(* set the width fields of the bbt)
[PROG (CLIPPEDTOP STY)
[COND
[(ILEQ Y TOPMINUSBRUSH) (* the top part of the brush is visible)
(SETQ CLIPPEDTOP (IPLUS Y BRUSHHEIGHT))
(replace PBTSOURCE of BBT with BRUSHBASE)
(replace PBTHEIGHT of BBT with (IMIN BRUSHHEIGHT (IDIFFERENCE Y BOTTOMMINUSBRUSH]
(T (* only the bottom is visible)
(SETQ CLIPPEDTOP TOP)
[replace PBTSOURCE of BBT with (\ADDBASE BRUSHBASE (ITIMES BRUSHRASTERWIDTH
(SETQ STY (IDIFFERENCE
Y TOPMINUSBRUSH]
(replace PBTHEIGHT of BBT with (IDIFFERENCE (IMIN BRUSHHEIGHT (IDIFFERENCE Y
BOTTOMMINUSBRUSH))
STY]
(replace PBTDEST of BBT with (\ADDBASE DESTINATIONBASE (ITIMES RASTERWIDTH
(\SFInvert DestinationBitMap
CLIPPEDTOP]
[COND
(COLORBRUSHBASE [COND
[(ILESSP X LEFT) (* only the right part of the brush is visible)
(* FOR NOW BRUTE FORCE WITH NBITS CHECK)
[replace PBTDESTBIT of BBT with (COND
((EQ NBITS 4)
(LLSH LEFT 2))
(T (LLSH LEFT 3]
(replace PBTSOURCEBIT of BBT
with (PROG ((COLORLEFT
(LLSH [IDIFFERENCE BRUSHWIDTH
(replace PBTWIDTH of BBT
with (COND
((EQ NBITS 4)
(LLSH (IDIFFERENCE X
LEFTMINUSBRUSH)
2))
(T (LLSH (IDIFFERENCE X
LEFTMINUSBRUSH)
3]
2)))
(RETURN (COND
((EQ NBITS 4)
COLORLEFT)
(T (LLSH COLORLEFT 1]
(T (* left edge is visible)
[replace PBTDESTBIT of BBT with (SETQ X (COND
((EQ NBITS 4)
(LLSH X 2))
(T (LLSH X 3]
(replace PBTSOURCEBIT of BBT with 0)
(* set width to the amount that is visible)
(replace PBTWIDTH of BBT with (IMIN BRUSHWIDTH (IDIFFERENCE
NBITSRIGHTPLUS1 X]
(* if color brush is used, the ground must be cleared
before the brush is put in.)
(\SETPBTFUNCTION BBT (ffetch DDSOURCETYPE of DISPLAYDATA)
(QUOTE ERASE))
(\PILOTBITBLT BBT 0) (* reset the source to point to the color bitmap.)
[COND
((ILEQ Y TOPMINUSBRUSH) (* the top part of the brush is visible)
(replace PBTSOURCE of BBT with COLORBRUSHBASE))
(T (* only the bottom is visible)
(replace PBTSOURCE of BBT with (\ADDBASE COLORBRUSHBASE
(ITIMES BRUSHRASTERWIDTH
(IDIFFERENCE Y
TOPMINUSBRUSH]
(\SETPBTFUNCTION BBT (ffetch DDSOURCETYPE of DISPLAYDATA)
(QUOTE PAINT)))
(T (COND
[(ILESSP X LEFT) (* only the right part of the brush is visible)
(replace PBTDESTBIT of BBT with LEFT)
(replace PBTSOURCEBIT of BBT with (IDIFFERENCE BRUSHWIDTH (replace PBTWIDTH
of BBT
with (IDIFFERENCE X
LEFTMINUSBRUSH]
(T (* left edge is visible)
(replace PBTDESTBIT of BBT with X)
(replace PBTSOURCEBIT of BBT with 0) (* set width to the amount that is visible)
(replace PBTWIDTH of BBT with (IMIN BRUSHWIDTH (IDIFFERENCE RIGHTPLUS1 X]
(\PILOTBITBLT BBT 0])
(\CHANGEBACKGROUND.DISPLAY
[LAMBDA (DISPLAY SHADE) (* hdj "20-May-85 18:13")
(* changes the window world background to SHADE)
(COND
((OR (EQ SHADE T)
(NULL SHADE))
(SETQ SHADE WINDOWBACKGROUNDSHADE))
((NOT (OR (TEXTUREP SHADE)
(BITMAPP SHADE)))
(\ILLEGAL.ARG SHADE)))
(PROG ((OPENWINDOWS (OPENWINDOWS)))
(for W in OPENWINDOWS do (\CLOSEW1 W))
(RETURN (PROG1 (OR (fetch (WSDATA WSBACKGROUND) of (fetch (FDEV WINDOWDATA) of DISPLAY))
WINDOWBACKGROUNDSHADE)
(replace (WSDATA WSBACKGROUND) of (fetch (FDEV WINDOWDATA) of DISPLAY)
with (SETQ CURRENTBACKGROUNDSHADE SHADE))
[COND
((TEXTUREP SHADE)
(\CLEARBM (SCREENBITMAP)
SHADE))
((BITMAPP SHADE)
(TILE SHADE (SCREENBITMAP]
(for W in OPENWINDOWS do (\OPENW1 W])
(\CHANGEBACKGROUNDBORDER.DISPLAY
[LAMBDA (DISPLAY SHADE) (* MPL "27-Jul-85 22:54")
(* Changes the screen border on a Dandelion.
(or dove) SHADE is a 8x2 pattern)
(SELECTC \MACHINETYPE
[\DANDELION (PROG1 (fetch DLDISPBORDER of \IOPAGE)
(AND (SMALLP SHADE)
(replace DLDISPBORDER of \IOPAGE with SHADE]
[\DAYBREAK (PROG1 (\DoveDisplay.GetBorderPattern)
(AND (SMALLP SHADE)
(\DoveDisplay.SetBorderPattern SHADE]
0])
)
(DEFINEQ
(CREATETEXTUREFROMBITMAP
[LAMBDA (BITMAP) (* rrb "17-May-84 11:22")
(* creates a texture object from the lower left corner
of a bitmap)
(OR (BITMAPP BITMAP)
(\ILLEGAL.ARG BITMAP))
(PROG ((H (fetch BITMAPHEIGHT of BITMAP))
(W (fetch BITMAPWIDTH of BITMAP))
TEXTHEIGHT TEXTURE)
(COND
((AND (OR (EQ W 2)
(EQ W 4))
(OR (EQ H 2)
(EQ H 4))) (* small texture will match bitmap exactly so use
integer representation.)
(SETQ TEXTURE 0)
[for X from 0 to 3 do (for Y from 0 to 3
do (COND
([NOT (EQ 0 (BITMAPBIT BITMAP (IREMAINDER X W)
(IREMAINDER Y H]
(SETQ TEXTURE
(LOGOR TEXTURE (\BITMASK (IPLUS (ITIMES (IDIFFERENCE
3 Y)
4)
X]
(RETURN TEXTURE))
((AND (EQ W 16)
(ILESSP H 17)) (* if it is already 16 by n n<=16, use it.)
(RETURN BITMAP))
(T (* make a 16 bit wide one.)
(SETQ TEXTURE (BITMAPCREATE 16 (IMIN H 16)))
(for X from 0 by W to 16 do (BITBLT BITMAP 0 0 TEXTURE X 0 W H (QUOTE INPUT)
(QUOTE REPLACE)))
(RETURN TEXTURE])
(PRINTBITMAP
[LAMBDA (BITMAP FILE) (* rrb "14-NOV-83 11:45")
(* Writes a bitmap on A file such that READBITMAP will
read it back in.)
(DECLARE (LOCALVARS . T))
(PROG ((BM BITMAP))
(COND
((type? BITMAP BITMAP))
([AND (LITATOM BITMAP)
(type? BITMAP (SETQ BM (EVALV BITMAP] (* Coerce litatoms for compatibility with original
specification)
)
(T (printout T "******** " BITMAP " is not a BITMAP." T)
(RETURN NIL)))
(printout FILE "(" .P2 (BITMAPWIDTH BM)
, .P2 (BITMAPHEIGHT BM)) (* if the number of bits per pixel is not 1, write it
out.)
(COND
((NEQ (BITSPERPIXEL BM)
1)
(SPACES 1 FILE)
(PRIN2 (BITSPERPIXEL BM)
FILE))) (* Enclose in list so that compile-copying works)
(* now write out contents.)
(\WRITEBITMAP BM FILE)
(PRIN1 ")" FILE])
(PRINTCURSOR
[LAMBDA (VAR) (* rmk: " 3-APR-82 13:52")
(* Writes an expression that will define the cursor
value of VAR)
(PROG (CUR)
(COND
([NOT (type? CURSOR (SETQ CUR (EVALV VAR (QUOTE PRINTCURSOR]
(printout T "******** " VAR " is not a CURSOR." T)
(RETURN NIL))) (* writeout defining form.)
[PRINT (LIST (QUOTE RPAQ)
VAR
(LIST (QUOTE CURSORCREATE)
(QUOTE (READBITMAP))
(fetch CURSORHOTSPOTX of CUR)
(fetch CURSORHOTSPOTY of CUR] (* now write out contents of the cursor bitmap.)
(PRINTBITMAP (fetch CURSORBITMAP of CUR])
(\WRITEBITMAP
[LAMBDA (BITMAP FILE) (* rrb "10-NOV-83 15:09")
(* writes the contents of a bitmap onto the currently
open output file.)
(PROG (LIM (BASE (fetch BITMAPBASE of BITMAP))
(OFD (GETSTREAM FILE (QUOTE OUTPUT)))
(W (fetch BITMAPRASTERWIDTH of BITMAP)))
(FRPTQ (fetch BITMAPHEIGHT of BITMAP)
(TERPRI FILE)
(\BOUT OFD (CHARCODE %"))
(SETQ LIM (\ADDBASE BASE W))
(until (EQ BASE LIM)
do (\BOUT OFD (IPLUS (SUB1 (CHARCODE A))
(LRSH (\GETBASEBYTE BASE 0)
4)))
(\BOUT OFD (IPLUS (SUB1 (CHARCODE A))
(LOGAND (\GETBASEBYTE BASE 0)
15)))
(\BOUT OFD (IPLUS (SUB1 (CHARCODE A))
(LRSH (\GETBASEBYTE BASE 1)
4)))
(\BOUT OFD (IPLUS (SUB1 (CHARCODE A))
(LOGAND (\GETBASEBYTE BASE 1)
15)))
(SETQ BASE (\ADDBASE BASE 1)))
(\BOUT OFD (CHARCODE %"])
)
(DEFINEQ
(\GETINTEGERPART
(LAMBDA (FRACT) (* JonL " 7-May-84 02:43")
(* gets the integer part of a fixed point number. The integer part has INTEGERBITS worth of significant bits the
leftmost of which is sign.)
(PROG (HIPART (ROUNDER (COND
((EQ 0 (LOGAND (fetch (FIXP HINUM) of FRACT)
(CONSTANT (LLSH 1 (IDIFFERENCE BITSPERWORD (ADD1
INTEGERBITS)))))
)
0)
(T 1))))
(* assumes that the number of significant bits -
INTEGERBITS -
is less than can fit in the high order of the two words allocated for the integer.)
(RETURN (COND
((IGREATERP (SETQ HIPART (LRSH (fetch (FIXP HINUM) of FRACT)
(CONSTANT (IDIFFERENCE BITSPERWORD INTEGERBITS))))
(CONSTANT (EXPT 2 (SUB1 INTEGERBITS))))
(* the sign bit is on, make it negative.)
(IDIFFERENCE (IDIFFERENCE HIPART (CONSTANT (EXPT 2 INTEGERBITS)))
ROUNDER))
(T (IPLUS HIPART ROUNDER)))))))
(\CONVERTTOFRACTION
[LAMBDA (FLOAT) (* rmk: " 3-JUL-82 23:29")
(* converts a floating point number into a fixed point number with INTEGERBITS worth of integer part.
Always returns a large integer so that the box can be clobbered.)
(PROG (RESULT BOX)
(RETURN (COND
([SMALLP (SETQ RESULT (FIX (FTIMES FLOAT (CONSTANT (FLOAT (EXPT 2
(IDIFFERENCE
BITSPERINTEGER
INTEGERBITS]
(* clobber a created box.)
(PutUnboxed (SETQ BOX (CREATECELL \FIXP))
RESULT)
BOX)
(T RESULT])
)
(DECLARE: EVAL@COMPILE
(RPAQQ INTEGERBITS 12)
(CONSTANTS (INTEGERBITS 12))
)
(RPAQQ CARETCOMS ((BITMAPS \DefaultCaret)
(INITVARS (\CARET.UP NIL (* global. NIL if no caret showing, otherwise a CARET1
record with CURSOR, stream, x, y, and RATE
(= off rate)))
(\CARET.DEFAULT NIL (* global = default caret to put up. An instance of
CARET1 datatype))
(\CARET.TIMER (SETUPTIMER 0)
(* time for next caret action))
(DEFAULTCARET (CONS \DefaultCaret (CONS 3 4)))
(DEFAULTCARETRATE 333 (* default rate for flashing caret))
(\CARET.ON.RATE DEFAULTCARETRATE)
(\CARET.OFF.RATE DEFAULTCARETRATE)
(\CARET.FORCED.OFF.RATE 0))
(ADDVARS (\SYSTEMTIMERVARS \CARET.TIMER))
(DECLARE: DONTCOPY (RECORDS CARET1))
(INITRECORDS CARET1)
(FNS CARET \CARET.CREATE \CARET.DOWN \CARET.FLASH? \CARET.SHOW CARETRATE
\CARET.FLASH.AGAIN \CARET.FLASH.MULTIPLE \CARET.FLASH)
(* some declarations are on LLDISPLAY -- macro for \CHECKCARET and globalvar
declaration for \CARET.UP)
(GLOBALVARS \CARET.DEFAULT \CARET.ON.RATE \CARET.OFF.RATE DEFAULTCARET
\CARET.TIMER \CARET.UP \CARET.FORCED.OFF.RATE)
(DECLARE: DONTEVAL@LOAD DOCOPY (ADDVARS (TTYBACKGROUNDFNS \CARET.FLASH?)))
(FNS \AREAVISIBLE? \REGIONOVERLAPAREAP \AREAINREGIONP)
(P (CARET T))))
(RPAQ \DefaultCaret (READBITMAP))
(7 6
"A@@@"
"CH@@"
"CH@@"
"FL@@"
"FL@@"
"LF@@")
(RPAQ? \CARET.UP NIL (* global. NIL if no caret showing, otherwise a CARET1 record with CURSOR,
stream, x, y, and RATE (= off rate)))
(RPAQ? \CARET.DEFAULT NIL (* global = default caret to put up. An instance of CARET1 datatype))
(RPAQ? \CARET.TIMER (SETUPTIMER 0)
(* time for next caret action))
(RPAQ? DEFAULTCARET (CONS \DefaultCaret (CONS 3 4)))
(RPAQ? DEFAULTCARETRATE 333 (* default rate for flashing caret))
(RPAQ? \CARET.ON.RATE DEFAULTCARETRATE)
(RPAQ? \CARET.OFF.RATE DEFAULTCARETRATE)
(RPAQ? \CARET.FORCED.OFF.RATE 0)
(ADDTOVAR \SYSTEMTIMERVARS \CARET.TIMER)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD CARET1 (* a record that describes a SHOWING caret)
(STREAM (* the stream the caret is showing in)
STREAMX (* the X position stream relative that it was shown
at)
STREAMY (* the Y position stream relative that it was shown
at)
CURSOR (* the cursor bitmap + x and y that this caret
represents)
RATE
(* the "down rate" for this caret, in ticks. After comes down (when \CARET.TIMER expires), \CARET.TIMER will be
rescheduled to put something up. This is the rate to use)
(* NEXT for threading carets together)
. NEXT))
]
)
(DEFINEQ
(CARET
[LAMBDA (NEWCARET) (* lmm " 3-May-84 11:43")
(* changes the "system default" caret)
(PROG1 (COND
(\CARET.DEFAULT (* merely stored as a "cursor" record for simplicity)
(create CURSOR using (fetch (CARET1 CURSOR) of \CARET.DEFAULT)))
(T (QUOTE OFF)))
(COND
(NEWCARET (\CHECKCARET)
(CARETRATE (CARETRATE)) (* make sure the caret rate is set)
(SETQ \CARET.DEFAULT (SELECTQ NEWCARET
[T (COND
((EQ DEFAULTCARET (QUOTE OFF))
NIL)
((CURSORP DEFAULTCARET)
(create CARET1
CURSOR ← DEFAULTCARET))
(T (ERROR "DEFAULTCARET is not a cursor"
DEFAULTCARET]
(OFF NIL)
(COND
((CURSORP NEWCARET)
(create CARET1
CURSOR ← NEWCARET))
(T (LISPERROR "ILLEGAL ARG" NEWCARET])
(\CARET.CREATE
[LAMBDA (CURSOR) (* jds "11-Jul-85 19:38")
(create CARET1
CURSOR ←(OR CURSOR DEFAULTCARET])
(\CARET.DOWN
[LAMBDA (STREAM INTERVAL UNLESSOCCLUDED) (* lmm " 4-May-84 18:15")
(* take caret down if it is up. If you take it down, reschedule to put it back up in INTERVAL
(or 0) -
often called thru \CHECKCARET macro)
(COND
(\CARET.UP (COND
([OR (NULL STREAM)
(fetch (CARET1 NEXT) of \CARET.UP)
(EQ (fetch (CARET1 STREAM) of \CARET.UP)
(COND
((type? WINDOW STREAM)
(fetch (WINDOW DSP) of STREAM))
(T STREAM]
[while (UNINTERRUPTABLY
[COND
((\CARET.SHOW \CARET.UP UNLESSOCCLUDED)
(* take caret down and set global state)
(replace (CARET1 STREAM) of \CARET.UP with NIL)
(SETQ \CARET.UP (fetch (CARET1 NEXT) of \CARET.UP])]
(SETUPTIMER (OR INTERVAL \CARET.FORCED.OFF.RATE)
\CARET.TIMER])
(\CARET.FLASH?
[LAMBDA (STREAM CARET ONRATE OFFRATE X Y) (* AJB "17-Jul-85 12:47")
(* * Flashes the CARET at the ONRATE/OFFRATE at the X,Y position in the current TTY window. If CARET is NIL, uses
\CARET.DEFAULT as the caret. Takes either a display stream or a textstream as the destination stream to flash the
caret. The caret is not flashed on a shift-selection in a window)
(COND
(\CARET.UP [COND
((TIMEREXPIRED? \CARET.TIMER)
(\CARET.DOWN NIL (fetch (CARET1 RATE) of \CARET.UP)
(OR (KEYDOWNP (QUOTE LSHIFT))
(KEYDOWNP (QUOTE RSHIFT))
(KEYDOWNP (QUOTE COPY]
NIL)
((AND (OR CARET (SETQ CARET \CARET.DEFAULT))
(TIMEREXPIRED? \CARET.TIMER)
[OR [DISPLAYSTREAMP (OR STREAM (SETQ STREAM (TTYDISPLAYSTREAM]
(AND (IMAGESTREAMTYPEP STREAM (QUOTE TEXT))
(SETQ STREAM (WINDOWPROP (CAR (FETCH (TEXTOBJ \WINDOW) OF (TEXTOBJ STREAM)))
(QUOTE DSP]
(\CARET.FLASH CARET STREAM OFFRATE (OR (KEYDOWNP (QUOTE LSHIFT))
(KEYDOWNP (QUOTE RSHIFT))
(KEYDOWNP (QUOTE COPY)))
X Y))
(* \CARET.DEFAULT is NIL if by default the caret is OFF -
the KEYDOWNP clause is a hack to detect whether we are doing a copy-select)
(replace (CARET1 NEXT) of CARET with NIL) (* Since this function is displaying a new caret,
destroy any chaining of multiple carets)
(SETUPTIMER (OR ONRATE \CARET.ON.RATE)
\CARET.TIMER)
T])
(\CARET.SHOW
[LAMBDA (CARET UNLESSOCCLUDED) (* lmm " 8-Aug-84 11:00")
(PROG ((DS (fetch (CARET1 STREAM) of CARET)))
(RETURN (PROG ((DD (fetch IMAGEDATA of DS))
(CARETWIN (WFROMDS DS))
(CBMX 0)
(CBMY 0)
(CARETBM (fetch (CARET1 CURSORBITMAP) of CARET))
CWX CWY CARETBMWIDTH CARETBMHEIGHT CLIPREG CLIPVAR)
(SETQ CWX (fetch (CARET1 STREAMX) of CARET))
(SETQ CWY (fetch (CARET1 STREAMY) of CARET))
(SETQ CARETBMWIDTH (BITMAPWIDTH CARETBM))
(SETQ CARETBMHEIGHT (fetch (BITMAP BITMAPHEIGHT) of CARETBM))
(* calculate how much to reduce the caret region by do
to the clipping region of the window.)
(SETQ CLIPREG (fetch (\DISPLAYDATA DDClippingRegion) of DD))
(COND
((IGREATERP (SETQ CLIPVAR (fetch (REGION LEFT) of CLIPREG))
CWX)
[SETQ CARETBMWIDTH (IDIFFERENCE CARETBMWIDTH (SETQ CBMX (IDIFFERENCE
CLIPVAR CWX]
(SETQ CWX CLIPVAR)))
(COND
((IGREATERP CARETBMWIDTH (SETQ CLIPVAR (IDIFFERENCE
(IPLUS CLIPVAR (fetch (REGION WIDTH) of CLIPREG))
CWX)))
(SETQ CARETBMWIDTH CLIPVAR)))
(COND
((IGREATERP (SETQ CLIPVAR (fetch (REGION BOTTOM) of CLIPREG))
CWY)
[SETQ CARETBMHEIGHT (IDIFFERENCE CARETBMHEIGHT (SETQ CBMY
(IDIFFERENCE CLIPVAR CWY]
(SETQ CWY CLIPVAR)))
(COND
((IGREATERP CARETBMHEIGHT (SETQ CLIPVAR (IDIFFERENCE
(IPLUS CLIPVAR (fetch (REGION HEIGHT) of CLIPREG))
CWY)))
(SETQ CARETBMHEIGHT CLIPVAR))) (* note the time of the next change.
This must be done without creating boxes because happens
during keyboard wait.)
(COND
((OR (ILESSP CARETBMWIDTH 1)
(ILESSP CARETBMHEIGHT 1)) (* caret isn't within clipping region.)
(RETURN T))) (* convert the base of the caret location to screen
coordinates.)
(SETQ CWX (\DSPTRANSFORMX CWX DD))
(SETQ CWY (\DSPTRANSFORMY CWY DD))
(* having only this section uninterruptable leaves open the possibility that the window moves or the timer is
wrong but these will only mess up the display and are low frequency events.)
(COND
[(AND (OPENWP CARETWIN)
(\AREAVISIBLE? CARETWIN CWX CWY (IPLUS CWX (SUB1 CARETBMWIDTH))
(IPLUS CWY (SUB1 CARETBMHEIGHT]
(UNLESSOCCLUDED (RETURN))
(T (TOTOPW CARETWIN)))
(BITBLT CARETBM CBMX CBMY (SCREENBITMAP)
CWX CWY CARETBMWIDTH CARETBMHEIGHT (QUOTE INPUT)
(QUOTE INVERT))
(RETURN T])
(CARETRATE
[LAMBDA (ONRATE OFFRATE) (* lmm " 3-May-84 11:35")
(* sets the default caret rate
(s) to be ONRATE/OFFRATE in milliseconds)
(PROG1 (COND
((EQ \CARET.ON.RATE \CARET.OFF.RATE)
\CARET.ON.RATE)
(T (CONS \CARET.ON.RATE \CARET.OFF.RATE)))
(COND
((OR ONRATE OFFRATE)
(SETUPTIMER 0 \CARET.TIMER)
(SETQ \CARET.ON.RATE (OR (FIXP ONRATE)
(FIX DEFAULTCARETRATE)))
(SETQ \CARET.OFF.RATE (OR (FIXP OFFRATE)
\CARET.ON.RATE])
(\CARET.FLASH.AGAIN
[LAMBDA (CARET STREAM X Y) (* AJB "14-Aug-85 17:04")
(LET ((OCARET \CARET.UP))
(COND
([AND OCARET CARET (DISPLAYSTREAMP (OR STREAM (SETQ STREAM (TTYDISPLAYSTREAM]
(for (OC ← OCARET) by (fetch (CARET1 NEXT) of OC)
do (COND
[(NULL OC)
(RETURN (COND
((\CARET.FLASH CARET STREAM (fetch (CARET1 RATE) of \CARET.UP)
(OR (KEYDOWNP (QUOTE LSHIFT))
(KEYDOWNP (QUOTE RSHIFT))
(KEYDOWNP (QUOTE COPY)))
X Y) (* OK, showed this one)
(OR (EQ \CARET.UP CARET)
(SHOULDNT))
(replace (CARET1 NEXT) of CARET with OCARET]
((EQ OC CARET) (* this CARET is already showing)
(RETURN])
(\CARET.FLASH.MULTIPLE
[LAMBDA (STREAMS CARETS ONRATE OFFRATE) (* AJB "14-Aug-85 17:10")
(* this is probably just a template for how to flash
multiple carets)
(COND
((\CARET.FLASH? (CAR STREAMS)
(CAR CARETS)
ONRATE OFFRATE)
(for STR in (CDR STREAMS) as CARET in (CDR CARETS) do (\CARET.FLASH.AGAIN CARET STR])
(\CARET.FLASH
[LAMBDA (CARET STREAM RATE UNLESSOCCLUDED X Y) (* lmm "10-Feb-85 20:33")
(replace (CARET1 STREAM) of CARET with STREAM)
(replace (CARET1 STREAMX) of CARET with (IDIFFERENCE (OR X (DSPXPOSITION NIL STREAM))
(fetch (CARET1 CURSORHOTSPOTX) of CARET)))
(replace (CARET1 STREAMY) of CARET with (IDIFFERENCE (OR Y (DSPYPOSITION NIL STREAM))
(fetch (CARET1 CURSORHOTSPOTY) of CARET)))
(replace (CARET1 RATE) of CARET with (OR RATE \CARET.OFF.RATE))
(UNINTERRUPTABLY
(COND
((\CARET.SHOW CARET UNLESSOCCLUDED)
(SETQ \CARET.UP CARET)
T)))])
)
(* some declarations are on LLDISPLAY -- macro for \CHECKCARET and globalvar declaration for
\CARET.UP)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \CARET.DEFAULT \CARET.ON.RATE \CARET.OFF.RATE DEFAULTCARET \CARET.TIMER \CARET.UP
\CARET.FORCED.OFF.RATE)
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(ADDTOVAR TTYBACKGROUNDFNS \CARET.FLASH?)
)
(DEFINEQ
(\AREAVISIBLE?
[LAMBDA (WIN LFT BTM RGHT TOP) (* rrb "14-OCT-83 15:41")
(* is the area whose screen limits are LFT BTM RGHT and
TOP eniretly visible within WIN,)
(PROG ((WPTR TOPW))
(COND
((NOT (\AREAINREGIONP (fetch (WINDOW REG) of WIN)
LFT BTM RGHT TOP)) (* if the caret region isn't completely within the
window, forget it.)
(RETURN)))
LP (COND
((EQ WPTR WIN)
(RETURN T))
((\REGIONOVERLAPAREAP (fetch (WINDOW REG) of WPTR)
LFT BTM RGHT TOP)
(RETURN NIL))
((SETQ WPTR (fetch (WINDOW NEXTW) of WPTR))
(GO LP])
(\REGIONOVERLAPAREAP
[LAMBDA (REG LFT BTM RGHT TOP) (* rrb "14-OCT-83 15:18")
(* is there any overlap between the region REG and the
area defined by left bottom right and top?)
(NOT (OR (IGREATERP (fetch LEFT of REG)
RGHT)
(IGREATERP LFT (fetch RIGHT of REG))
(IGREATERP (fetch BOTTOM of REG)
TOP)
(IGREATERP BTM (fetch TOP of REG])
(\AREAINREGIONP
[LAMBDA (REGION LFT BTM RGHT TOP) (* rrb "14-OCT-83 15:32")
(AND (IGEQ LFT (fetch LEFT of REGION))
(IGEQ BTM (fetch BOTTOM of REGION))
(IGEQ (fetch PRIGHT of REGION)
RGHT)
(IGEQ (fetch PTOP of REGION)
TOP])
)
(CARET T)
(* cursor functions not on LLDISPLAY)
(DEFINEQ
(CURSORP
[LAMBDA (X) (* rrb "14-JUN-82 18:32")
(* is X a cursor?)
(AND (LISTP X)
(BITMAPP (CAR X))
(type? POSITION (CDR X))
X])
(CURSORBITMAP
[LAMBDA NIL CursorBitMap])
(CreateCursorBitMap
[LAMBDA (ARRAY) (* rmk: " 1-APR-82 22:20")
(* makes a bitmap out of an array of values.)
(PROG ((BM (BITMAPCREATE 16 16))
BASE)
(SETQ BASE (ffetch BITMAPBASE of BM))
(for I from 0 to 15 do (\PUTBASE BASE I (LOGAND (ELT ARRAY (ADD1 I))
WORDMASK)))
(RETURN BM])
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS CURSORBITMAP MACRO (NIL CursorBitMap))
)
(DECLARE: EVAL@COMPILE
(RPAQQ CURSORHEIGHT 16)
(RPAQQ CURSORWIDTH 16)
(CONSTANTS (CURSORHEIGHT 16)
(CURSORWIDTH 16))
)
(DECLARE: EVAL@COMPILE
(ADDTOVAR GLOBALVARS CursorBitMap)
)
(* END EXPORTED DEFINITIONS)
(* Region functions)
(DEFINEQ
(CREATEREGION
[LAMBDA (LEFT BOTTOM WIDTH HEIGHT) (* rrb "17-JUN-83 08:56")
(* creates a region structure.)
(create REGION
LEFT ← LEFT
BOTTOM ← BOTTOM
WIDTH ← WIDTH
HEIGHT ← HEIGHT])
(REGIONP
[LAMBDA (X) (* rrb "29-Jun-84 18:00")
(AND (type? REGION X)
X])
(INTERSECTREGIONS
[LAMBDA REGIONS (* rrb " 4-Oct-85 16:00")
(* returns the largest region that is contained in all
of REGIONS)
(COND
((EQ REGIONS 0) (* this is documented as returning a very large
region. This one covers the entire FIXP range so
should work for many purposes.
rrb)
(create REGION
LEFT ←(SUB1 MIN.FIXP)
BOTTOM ←(SUB1 MIN.FIXP)
WIDTH ←(PLUS (TIMES 2 MAX.FIXP)
4)
HEIGHT ←(PLUS (TIMES 2 MAX.FIXP)
4)))
(T (PROG ((REG (ARG REGIONS 1))
LFT RGHT BTTM TP)
(SETQ LFT (fetch (REGION LEFT) of REG))
[SETQ RGHT (SUB1 (IPLUS LFT (fetch (REGION WIDTH) of REG]
(SETQ BTTM (fetch (REGION BOTTOM) of REG))
[SETQ TP (SUB1 (IPLUS BTTM (fetch (REGION HEIGHT) of REG]
[for I from 2 thru REGIONS
do (SETQ REG (ARG REGIONS I))
[COND
((IGREATERP (fetch (REGION LEFT) of REG)
LFT)
(SETQ LFT (fetch (REGION LEFT) of REG]
[COND
((IGREATERP (fetch (REGION BOTTOM) of REG)
BTTM)
(SETQ BTTM (fetch (REGION BOTTOM) of REG]
[COND
((ILESSP (fetch (REGION RIGHT) of REG)
RGHT)
(SETQ RGHT (fetch (REGION RIGHT) of REG]
(COND
((ILESSP (fetch (REGION TOP) of REG)
TP)
(SETQ TP (fetch (REGION TOP) of REG]
(RETURN (COND
((AND (IGEQ RGHT LFT)
(IGEQ TP BTTM))
(create REGION
LEFT ← LFT
BOTTOM ← BTTM
WIDTH ←(ADD1 (IDIFFERENCE RGHT LFT))
HEIGHT ←(ADD1 (IDIFFERENCE TP BTTM])
(UNIONREGIONS
(LAMBDA REGIONS (* JonL " 7-May-84 02:58")
(* returns the smallest region that encloses all of
REGIONS)
(COND
((EQ 0 REGIONS)
NIL)
(T (PROG (REG LFT RGHT BTTM TP)
(SETQ REG (ARG REGIONS 1))
(SETQ LFT (fetch (REGION LEFT) of REG))
(SETQ RGHT (fetch (REGION RIGHT) of REG))
(SETQ BTTM (fetch (REGION BOTTOM) of REG))
(SETQ TP (fetch (REGION TOP) of REG))
(for I from 2 thru REGIONS
do (SETQ REG (ARG REGIONS I))
(COND
((ILESSP (fetch (REGION LEFT) of REG)
LFT)
(SETQ LFT (fetch (REGION LEFT) of REG))))
(COND
((ILESSP (fetch (REGION BOTTOM) of REG)
BTTM)
(SETQ BTTM (fetch (REGION BOTTOM) of REG))))
(COND
((IGREATERP (fetch (REGION RIGHT) of REG)
RGHT)
(SETQ RGHT (fetch (REGION RIGHT) of REG))))
(COND
((IGREATERP (fetch (REGION TOP) of REG)
TP)
(SETQ TP (fetch (REGION TOP) of REG)))))
(RETURN (create REGION
LEFT ← LFT
BOTTOM ← BTTM
WIDTH ←(ADD1 (IDIFFERENCE RGHT LFT))
HEIGHT ←(ADD1 (IDIFFERENCE TP BTTM)))))))))
(REGIONSINTERSECTP
[LAMBDA (REGION1 REGION2) (* rrb "16-AUG-81 08:29")
(* determines if two regions intersect)
(NOT (OR (IGREATERP (fetch LEFT of REGION1)
(fetch RIGHT of REGION2))
(IGREATERP (fetch LEFT of REGION2)
(fetch RIGHT of REGION1))
(IGREATERP (fetch BOTTOM of REGION1)
(fetch TOP of REGION2))
(IGREATERP (fetch BOTTOM of REGION2)
(fetch TOP of REGION1])
(SUBREGIONP
[LAMBDA (LARGEREGION SMALLREGION) (* rrb "25-JUN-82 15:09")
(* determines if small region is a subset of large region. (SUBREGIONP (QUOTE (9 0 100 100))
(QUOTE (0 10 100 80))))
(AND (IGEQ (fetch LEFT of SMALLREGION)
(fetch LEFT of LARGEREGION))
(IGEQ (fetch BOTTOM of SMALLREGION)
(fetch BOTTOM of LARGEREGION))
(IGEQ (fetch PRIGHT of LARGEREGION)
(fetch PRIGHT of SMALLREGION))
(IGEQ (fetch PTOP of LARGEREGION)
(fetch PTOP of SMALLREGION])
(EXTENDREGION
[LAMBDA (REGION INCLUDEREGION) (* rrb " 5-FEB-82 09:25")
(* destructively extends REGION to include
INCLUDEREGION)
[COND
((IGREATERP (fetch (REGION LEFT) of REGION)
(fetch (REGION LEFT) of INCLUDEREGION))
(replace (REGION WIDTH) of REGION with (IDIFFERENCE (fetch (REGION PRIGHT) of REGION)
(fetch (REGION LEFT) of INCLUDEREGION)))
(replace (REGION LEFT) of REGION with (fetch (REGION LEFT) of INCLUDEREGION]
[COND
((IGREATERP (fetch (REGION BOTTOM) of REGION)
(fetch (REGION BOTTOM) of INCLUDEREGION))
(replace (REGION HEIGHT) of REGION with (IDIFFERENCE (fetch (REGION PTOP) of REGION)
(fetch (REGION BOTTOM) of INCLUDEREGION))
)
(replace (REGION BOTTOM) of REGION with (fetch (REGION BOTTOM) of INCLUDEREGION]
[COND
((IGREATERP (fetch (REGION RIGHT) of INCLUDEREGION)
(fetch (REGION RIGHT) of REGION))
(replace (REGION WIDTH) of REGION with (ADD1 (IDIFFERENCE (fetch (REGION RIGHT) of
INCLUDEREGION)
(fetch (REGION LEFT) of REGION]
[COND
((IGREATERP (fetch (REGION TOP) of INCLUDEREGION)
(fetch (REGION TOP) of REGION))
(replace (REGION HEIGHT) of REGION with (ADD1 (IDIFFERENCE (fetch (REGION TOP) of
INCLUDEREGION)
(fetch (REGION BOTTOM)
of REGION]
REGION])
(EXTENDREGIONBOTTOM
[LAMBDA (REG NEWBOTTOM) (* rrb "29-DEC-81 10:02")
(* extends a region to the bottom)
(PROG ((OLDBOTTOM (fetch (REGION BOTTOM) of REG)))
[COND
((IGREATERP OLDBOTTOM NEWBOTTOM)
(replace (REGION BOTTOM) of REG with NEWBOTTOM)
(replace (REGION HEIGHT) of REG with (IPLUS (fetch (REGION HEIGHT) of REG)
(IDIFFERENCE OLDBOTTOM NEWBOTTOM]
(RETURN REG])
(EXTENDREGIONLEFT
[LAMBDA (REG NEWLEFT) (* rrb "29-DEC-81 09:37")
(* extends a region to the left)
(PROG ((OLDLEFT (fetch (REGION LEFT) of REG)))
[COND
((IGREATERP OLDLEFT NEWLEFT)
(replace (REGION LEFT) of REG with NEWLEFT)
(replace (REGION WIDTH) of REG with (IPLUS (fetch (REGION WIDTH) of REG)
(IDIFFERENCE OLDLEFT NEWLEFT]
(RETURN REG])
(EXTENDREGIONRIGHT
[LAMBDA (REG NEWRIGHT) (* rrb "29-DEC-81 10:06")
(* extends a region to the left)
(PROG ((OLDRIGHT (fetch (REGION RIGHT) of REG)))
[COND
((ILESSP OLDRIGHT NEWRIGHT)
(replace (REGION WIDTH) of REG with (IPLUS (fetch (REGION WIDTH) of REG)
(IDIFFERENCE NEWRIGHT OLDRIGHT]
(RETURN REG])
(EXTENDREGIONTOP
[LAMBDA (REG NEWTOP) (* rrb "29-DEC-81 10:07")
(* extends a region to the left)
(PROG ((OLDTOP (fetch (REGION TOP) of REG)))
[COND
((ILESSP OLDTOP NEWTOP)
(replace (REGION HEIGHT) of REG with (IPLUS (fetch (REGION HEIGHT) of REG)
(IDIFFERENCE NEWTOP OLDTOP]
(RETURN REG])
(INSIDEP
[LAMBDA (REGION POSORX Y) (* rrb "18-May-84 21:04")
(* returns T if the position X Y is inside the region REGION. If POSORX is a position, returns T if that position
is inside of REGION)
(COND
((WINDOWP REGION)
(INSIDEP (DSPCLIPPINGREGION NIL REGION)
POSORX Y))
(T (COND
((AND (NUMBERP POSORX)
(NUMBERP Y))
(INSIDE? REGION POSORX Y))
((POSITIONP POSORX)
(INSIDE? REGION (fetch (POSITION XCOORD) of POSORX)
(fetch (POSITION YCOORD) of POSORX)))
((NUMBERP POSORX)
(\ILLEGAL.ARG Y))
(T (\ILLEGAL.ARG POSORX])
(STRINGREGION
[LAMBDA (STR STREAM PRIN2FLG RDTBL) (* rmk: "25-AUG-83 18:06")
(* returns the region taken up by STR if it were printed
at the current position of STREAM)
(create REGION
LEFT ←(DSPXPOSITION NIL STREAM)
BOTTOM ←(IDIFFERENCE (DSPYPOSITION NIL STREAM)
(FONTPROP STREAM (QUOTE DESCENT)))
WIDTH ←(STRINGWIDTH STR STREAM PRIN2FLG RDTBL)
HEIGHT ←(FONTPROP STREAM (QUOTE HEIGHT])
)
(* line and spline drawing.)
(* Brushes and brush initialization)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTDEF (QUOTE \BRUSHBBT)
(QUOTE RESOURCES)
(QUOTE (NEW (create PILOTBBT]
)
)
(/SETTOPVAL (QUOTE \\BRUSHBBT.GLOBALRESOURCE))
(DEFINEQ
(\BRUSHBITMAP
[LAMBDA (BRUSHSHAPE BRUSHWIDTH) (* rrb "30-Apr-85 14:19")
(* * returns the bitmap for the brush of the shape and size. See comments on \InitCurveBrushes.)
(DECLARE (GLOBALVARS \BrushAList))
(LET [(BRUSHES&METHOD (CDR (OR (FASSOC BRUSHSHAPE \BrushAList)
(\ILLEGAL.ARG BRUSHSHAPE]
(COND
((NOT (GREATERP BRUSHWIDTH 0)) (* if brush is 0 or negative, return an empty brush.
Might want to error but this would require users to
handle it.)
(BITMAPCREATE 0 0))
((ILESSP BRUSHWIDTH 17)
(ELT (fetch (BRUSHITEM BRUSHARRAY) of BRUSHES&METHOD)
BRUSHWIDTH))
[(CDR (FASSOC BRUSHWIDTH (fetch (BRUSHITEM BRUSHCACHE) of BRUSHES&METHOD]
(T (* cache the brush bitmap. This is done so that the
brush creation methods don't have to be efficient.)
(LET ((NEWBRUSHBM (APPLY* (fetch (BRUSHITEM CREATEMETHOD) of BRUSHES&METHOD)
BRUSHWIDTH)))
(replace (BRUSHITEM BRUSHCACHE) of BRUSHES&METHOD with (CONS (CONS BRUSHWIDTH NEWBRUSHBM)
(fetch (BRUSHITEM
BRUSHCACHE)
of BRUSHES&METHOD)))
NEWBRUSHBM])
(\GETBRUSH
[LAMBDA (BRUSH) (* rmk: " 6-OCT-81 21:18")
(COND
((type? BITMAP BRUSH)
BRUSH)
[(LISTP BRUSH)
(\BRUSHBITMAP (CAR BRUSH)
(CAR (LISTP (CDR BRUSH]
(T (\BRUSHBITMAP (QUOTE ROUND)
(OR BRUSH 1])
(\GETBRUSHBBT
[LAMBDA (BRUSHBM DISPLAYDATA BBT) (* rmk: "25-AUG-83 12:10")
(* Initializes BBT for the BRUSHBM and DS and returns
BBT, unless the BRUSHBM is a 1-point brush, in which
case it returns NIL.)
(COND
((AND (EQ (fetch BITMAPHEIGHT of BRUSHBM)
1)
(EQ (fetch BITMAPWIDTH of BRUSHBM)
1)
(EQ (BITMAPBIT BRUSHBM 0 0)
1)) (* special case of single point brush shape.)
NIL)
(T (* update as many fields in the brush bitblt table as
possible from DS.)
(replace PBTDESTBPL of BBT with (UNFOLD (fetch BITMAPRASTERWIDTH
of (fetch DDDestination of DISPLAYDATA))
BITSPERWORD))
(replace PBTSOURCEBPL of BBT with (UNFOLD (fetch BITMAPRASTERWIDTH of BRUSHBM)
BITSPERWORD))
(replace PBTFLAGS of BBT with 0)
(replace PBTDISJOINT of BBT with T)
(\SETPBTFUNCTION BBT (ffetch DDSOURCETYPE of DISPLAYDATA)
(SELECTQ (ffetch DDOPERATION of DISPLAYDATA)
((REPLACE PAINT)
(QUOTE PAINT))
((INVERT ERASE)
(QUOTE ERASE))
(SHOULDNT)))
BBT])
(\InitCurveBrushes
[LAMBDA NIL (* hdj " 7-Nov-84 16:41")
(DECLARE (GLOBALVARS \BrushNames \BrushAList \SingleBitBitmap))
(BITMAPBIT (SETQ \SingleBitBitmap (BITMAPCREATE 1 1))
0 0 1)
(for BRUSHNAME in \BrushNames do (LET ((BARRAY (ARRAY 16 (QUOTE POINTER)
NIL 1))
(CREATIONMETHOD (PACK* "\MakeBrush." BRUSHNAME)))
(SETA BARRAY 1 \SingleBitBitmap)
(for SIZE from 2 to 16 do (SETA BARRAY SIZE (APPLY*
CREATIONMETHOD
SIZE)))
(INSTALLBRUSH BRUSHNAME CREATIONMETHOD BARRAY])
(\BrushFromWidth
[LAMBDA (W) (* hdj " 5-Nov-84 16:47")
(LIST (QUOTE ROUND)
W])
)
(DEFINEQ
(\MakeBrush.DIAGONAL
[LAMBDA (SIZE) (* hdj " 5-Nov-84 16:10")
(LET ((BM (BITMAPCREATE SIZE SIZE)))
(for X from 0 to (SUB1 SIZE) do (BITMAPBIT BM X X 1))
BM])
(\MakeBrush.HORIZONTAL
[LAMBDA (SIZE) (* hdj " 5-Nov-84 16:06")
(* * create a brush that has a horizontal line across it halfway down)
(LET ((BM (BITMAPCREATE SIZE SIZE)))
(BITBLT NIL NIL NIL BM 0 (SUB1 (FOLDHI SIZE 2))
NIL 1 (QUOTE TEXTURE)
(QUOTE REPLACE)
BLACKSHADE)
BM])
(\MakeBrush.VERTICAL
[LAMBDA (SIZE) (* hdj " 5-Nov-84 16:06")
(LET ((BM (BITMAPCREATE SIZE SIZE)))
(BITBLT NIL NIL NIL BM (SUB1 (FOLDHI SIZE 2))
0 1 SIZE (QUOTE TEXTURE)
(QUOTE REPLACE)
BLACKSHADE)
BM])
(\MakeBrush.SQUARE
[LAMBDA (SIZE) (* hdj " 5-Nov-84 15:32")
(if (EQ SIZE 1)
then \SingleBitBitmap
else (LET ((BM (BITMAPCREATE SIZE SIZE)))
(BITBLT NIL NIL NIL BM NIL NIL NIL NIL (QUOTE TEXTURE)
(QUOTE REPLACE)
BLACKSHADE)
BM])
(\MakeBrush.ROUND
[LAMBDA (SIZE) (* rrb "30-Apr-85 14:17")
(* changed to use FILLCIRCLE)
(LET* ([RADIUS (SUB1 (HALF (ADD1 SIZE]
(BITMAP (BITMAPCREATE SIZE SIZE))
(DESTINATIONBASE (fetch BITMAPBASE of BITMAP)))
(PROG1 BITMAP (SELECTQ SIZE
(1 (BITMAPBIT BITMAP 0 0 1))
(2 (\PUTBASE DESTINATIONBASE 0 (MASK.1'S 14 2))
(\PUTBASE DESTINATIONBASE 1 (MASK.1'S 14 2)))
(3 (\PUTBASE DESTINATIONBASE 0 (MASK.1'S 14 1))
(\PUTBASE DESTINATIONBASE 1 (MASK.1'S 13 3))
(\PUTBASE DESTINATIONBASE 2 (MASK.1'S 14 1)))
(4 (\PUTBASE DESTINATIONBASE 0 (MASK.1'S 13 2))
(\PUTBASE DESTINATIONBASE 1 (MASK.1'S 12 4))
(\PUTBASE DESTINATIONBASE 2 (MASK.1'S 12 4))
(\PUTBASE DESTINATIONBASE 3 (MASK.1'S 13 2)))
(5 (\PUTBASE DESTINATIONBASE 0 (MASK.1'S 12 3))
(\PUTBASE DESTINATIONBASE 1 (MASK.1'S 11 5))
(\PUTBASE DESTINATIONBASE 2 (MASK.1'S 11 5))
(\PUTBASE DESTINATIONBASE 3 (MASK.1'S 11 5))
(\PUTBASE DESTINATIONBASE 4 (MASK.1'S 12 3)))
(6 (\PUTBASE DESTINATIONBASE 0 (MASK.1'S 12 2))
(\PUTBASE DESTINATIONBASE 1 (MASK.1'S 11 4))
(\PUTBASE DESTINATIONBASE 2 (MASK.1'S 10 6))
(\PUTBASE DESTINATIONBASE 3 (MASK.1'S 10 6))
(\PUTBASE DESTINATIONBASE 4 (MASK.1'S 11 4))
(\PUTBASE DESTINATIONBASE 5 (MASK.1'S 12 2)))
(PROG ((DS (DSPCREATE BITMAP)))
(FILLCIRCLE (HALF SIZE)
(HALF SIZE)
(HALF (SUB1 SIZE))
BLACKSHADE DS)
(RETURN BITMAP])
)
(DEFINEQ
(INSTALLBRUSH
[LAMBDA (BRUSHNAME BRUSHFN BRUSHARRAY) (* hdj " 7-Nov-84 16:41")
(DECLARE (GLOBALVARS \BrushAList))
[LET ((OLDENTRY (FASSOC BRUSHNAME \BrushAList)))
(if OLDENTRY
then (AND BRUSHARRAY (replace (BRUSHITEM BRUSHARRAY) of (CDR OLDENTRY) with BRUSHARRAY))
(AND BRUSHFN (replace (BRUSHITEM CREATEMETHOD) of (CDR OLDENTRY) with BRUSHFN))
else [if (AND BRUSHFN (NOT (ARRAYP BRUSHARRAY)))
then (SETQ BRUSHARRAY (ARRAY 16 (QUOTE POINTER)
NIL 1))
(for X from 1 to 16 do (SETA BRUSHARRAY X (APPLY* BRUSHFN X]
(push \BrushAList (CONS BRUSHNAME (create BRUSHITEM
BRUSHARRAY ← BRUSHARRAY
CREATEMETHOD ← BRUSHFN]
NIL])
)
(RPAQQ \BrushNames (ROUND SQUARE DIAGONAL HORIZONTAL VERTICAL))
(ADDTOVAR \BrushAList )
[DECLARE: EVAL@COMPILE
(RECORD BRUSHITEM (BRUSHARRAY CREATEMETHOD . BRUSHCACHE))
]
(DECLARE: DONTEVAL@LOAD DOCOPY
(\InitCurveBrushes)
)
(DECLARE: DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \BrushList)
)
)
(* Lines)
(DEFINEQ
(\DRAWLINE.DISPLAY
[LAMBDA (DISPLAYSTREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING)
(* hdj "11-Oct-85 14:01")
(* DISPLAYSTREAM is guaranteed to be a display-stream.
Draws a line from x1,y1 to x2,y2 leaving the position
at x2,y2)
[COND
[DASHING (GLOBALRESOURCE \BRUSHBBT (LET ((BBT \BRUSHBBT)
(BRUSH (LIST (QUOTE ROUND)
WIDTH COLOR)))
(\LINEWITHBRUSH X1 Y1 X2 Y2 BRUSH (\GOOD.DASHLST
DASHING BRUSH)
DISPLAYSTREAM BBT]
(T (PROG ((DD (fetch IMAGEDATA of DISPLAYSTREAM)))
(\INSURE.WRITABLE.DS DISPLAYSTREAM) (* bring the window to the top)
(\CLIPANDDRAWLINE (\DSPTRANSFORMX (OR (FIXP X1)
(FIXR X1))
DD)
(\DSPTRANSFORMY (OR (FIXP Y1)
(FIXR Y1))
DD)
(\DSPTRANSFORMX (OR (FIXP X2)
(FIXR X2))
DD)
(\DSPTRANSFORMY (OR (FIXP Y2)
(FIXR Y2))
DD)
[COND
((NULL WIDTH)
1)
((OR (FIXP WIDTH)
(FIXR WIDTH]
(SELECTQ OPERATION
(NIL (ffetch DDOPERATION of DD))
((REPLACE PAINT INVERT ERASE)
OPERATION)
(\ILLEGAL.ARG OPERATION))
(ffetch DDDestination of DD)
(ffetch DDClippingLeft of DD)
(SUB1 (ffetch DDClippingRight of DD))
(ffetch DDClippingBottom of DD)
(SUB1 (ffetch DDClippingTop of DD))
DISPLAYSTREAM COLOR] (* the generic case of MOVETO is used so that the
hardcopy streams get handled as well.)
(MOVETO X2 Y2 DISPLAYSTREAM])
(RELMOVETO
[LAMBDA (DX DY STREAM) (* rmk: "25-AUG-83 18:13")
(* moves the position by a vector)
(DSPXPOSITION [IPLUS DX (DSPXPOSITION NIL (SETQ STREAM (\OUTSTREAMARG STREAM]
STREAM)
(DSPYPOSITION (IPLUS DY (DSPYPOSITION NIL STREAM))
STREAM])
(MOVETOUPPERLEFT
[LAMBDA (STREAM REGION) (* hdj " 5-Jul-85 12:19")
(* moves the current position to the upper left corner
so that the first line of text will all appear.)
(PROG [(ASCENT (FONTPROP (DSPFONT NIL STREAM)
(QUOTE ASCENT]
(COND
((AND REGION (OR (type? REGION REGION)
(\ILLEGAL.ARG REGION)))
(MOVETO (fetch (REGION LEFT) of REGION)
(IDIFFERENCE (fetch (REGION PTOP) of REGION)
ASCENT)
STREAM))
(T (MOVETO (DSPLEFTMARGIN NIL STREAM)
(IDIFFERENCE (fetch (REGION PTOP) of (DSPCLIPPINGREGION NIL STREAM))
ASCENT)
STREAM)))
(RETURN STREAM])
)
(DEFINEQ
(\CLIPANDDRAWLINE
[LAMBDA (X1 Y1 X2 Y2 WIDTH OPERATION BITMAP LEFT RIGHT BOTTOM TOP DS COLOR)
(* hdj "11-Oct-85 14:01")
(* draws a line from {X1,Y1} to {X2,Y2} clipped to region specified by LEFT RIGHT BOTTOM and TOP.
This code is a transliterated version of the BCPL routine that was in chat.)
(* assumes that the width is at least 1)
(* DS is passed so that window can be uninterruptably
brought to top.)
(COND
[(NEQ (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)
1) (* make adjustments in case of color.)
(COND
((EQ OPERATION (QUOTE ERASE)) (* treat erase as paint of background)
(SETQ COLOR (COLORNUMBERP (DSPBACKCOLOR NIL DS)))
(SETQ OPERATION (QUOTE PAINT)))
(T (SETQ COLOR (COLORNUMBERP (OR COLOR (DSPCOLOR NIL DS]
(T (SETQ COLOR BLACKSHADE)))
(PROG NIL
(COND
[(EQ X1 X2) (* special case of vertical line.)
[COND
((IGREATERP WIDTH 2)
(COND
[(EQ Y1 Y2)
(* special case. Since we don't know whether the guy is headed horizontally or vertically, put out a round brush
This is a fairly infrequent case because I didn't get any bug reports on it in three years so efficiency is not a
consideration.)
(RETURN (.WHILE.TOP.DS. DS (DRAWPOINT X1 Y1 (LIST (QUOTE ROUND)
WIDTH COLOR)
(DSPDESTINATION NIL DS)
OPERATION]
(T (SETQ X1 (SETQ X2 (IDIFFERENCE X1 (LRSH (SUB1 WIDTH)
1]
(PROG (MIN MAX)
(RETURN (COND
([OR (IGREATERP X1 RIGHT)
(IGEQ LEFT (SETQ X2 (IPLUS X1 WIDTH)))
(IGREATERP (SETQ MIN (IMIN Y1 Y2))
TOP)
(IGREATERP BOTTOM (SETQ MAX (IMAX Y1 Y2]
(* outside clippingregion.)
NIL)
(T (.WHILE.WRITABLE.DS. DS (BITBLT NIL 0 0 BITMAP
(SETQ X1 (IMAX X1 LEFT))
(SETQ MIN
(IMAX MIN BOTTOM))
(IDIFFERENCE
(IMIN X2 (ADD1 RIGHT))
X1)
(ADD1 (IDIFFERENCE
(IMIN MAX TOP)
MIN))
(QUOTE TEXTURE)
OPERATION COLOR]
[(EQ Y1 Y2) (* special case of horizontal line.)
[COND
((IGREATERP WIDTH 2)
(SETQ Y1 (SETQ Y2 (IDIFFERENCE Y1 (LRSH (SUB1 WIDTH)
1]
(PROG (MIN MAX)
(RETURN (COND
([OR (IGREATERP Y1 TOP)
(IGEQ BOTTOM (SETQ Y2 (IPLUS Y1 WIDTH)))
(IGREATERP (SETQ MIN (IMIN X1 X2))
RIGHT)
(IGREATERP LEFT (SETQ MAX (IMAX X1 X2]
(* outside clippingregion.)
NIL)
(T (.WHILE.WRITABLE.DS. DS (BITBLT NIL 0 0 BITMAP
(SETQ MIN
(IMAX MIN LEFT))
(SETQ Y1 (IMAX Y1 BOTTOM)
)
(ADD1 (IDIFFERENCE
(IMIN MAX RIGHT)
MIN))
(IDIFFERENCE
(IMIN Y2 (ADD1 TOP))
Y1)
(QUOTE TEXTURE)
OPERATION COLOR]
((EQ WIDTH 1) (* special case of width 1)
(\CLIPANDDRAWLINE1 X1 Y1 X2 Y2 OPERATION BITMAP LEFT RIGHT BOTTOM TOP DS COLOR))
((IGREATERP (IABS (IDIFFERENCE X1 X2))
(IABS (IDIFFERENCE Y1 Y2))) (* slope is more horizontal, so make line grow in the
positive y direction.)
[COND
((IGREATERP WIDTH 2)
(PROG ((HALFWIDTH (LRSH (SUB1 WIDTH)
1)))
(SETQ Y1 (IDIFFERENCE Y1 HALFWIDTH))
(SETQ Y2 (IDIFFERENCE Y2 HALFWIDTH]
(for I from Y1 to (SUB1 (IPLUS Y1 WIDTH)) as J from Y2
do (\CLIPANDDRAWLINE1 X1 I X2 J OPERATION BITMAP LEFT RIGHT BOTTOM TOP DS
COLOR)))
(T (* slope is more vertical, so make line grow in the
positive x direction.)
[COND
((IGREATERP WIDTH 2)
(PROG ((HALFWIDTH (LRSH (SUB1 WIDTH)
1)))
(SETQ X1 (IDIFFERENCE X1 HALFWIDTH))
(SETQ X2 (IDIFFERENCE X2 HALFWIDTH]
(for I from X1 to (SUB1 (IPLUS X1 WIDTH)) as J from X2
do (\CLIPANDDRAWLINE1 I Y1 J Y2 OPERATION BITMAP LEFT RIGHT BOTTOM TOP DS
COLOR])
(\CLIPANDDRAWLINE1
[LAMBDA (X1 Y1 X2 Y2 OPERATION BITMAP LEFT RIGHT BOTTOM TOP DS COLOR)
(* hdj "11-Oct-85 14:01")
(* LEFT, RIGHT, BOTTOM, TOP are set to the boundaries
of the clipping region)
(* DS is passed so that window can be uninterruptably
brought to top.)
(PROG (DX DY YMOVEUP HALFDX HALFDY (BMRASTERWIDTH (fetch BITMAPRASTERWIDTH of BITMAP)))
(COND
((IGREATERP X1 X2) (* switch points so DX is always positive.)
(SETQ HALFDX X1)
(SETQ X1 X2)
(SETQ X2 HALFDX)
(SETQ HALFDX Y1)
(SETQ Y1 Y2)
(SETQ Y2 HALFDX))) (* calculate differences and sign of Y movement.)
(SETQ HALFDX (LRSH (SETQ DX (IDIFFERENCE X2 X1))
1))
(SETQ HALFDY (LRSH [SETQ DY (COND
((IGREATERP Y2 Y1)
(SETQ YMOVEUP T)
(IDIFFERENCE Y2 Y1))
(T (IDIFFERENCE Y1 Y2]
1))
(COND
((AND (IGEQ X1 LEFT)
(IGEQ RIGHT X2)
[COND
(YMOVEUP (AND (IGEQ Y1 BOTTOM)
(IGEQ TOP Y2)))
(T (AND (IGEQ Y2 BOTTOM)
(IGEQ TOP Y1]
(EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)
1)) (* line is completely visible, fast case.)
(.WHILE.WRITABLE.DS. DS (\DRAWLINE1 X1 (SUB1 (\SFInvert BITMAP Y1))
DX DY DX DY (COND
((IGREATERP DX DY)
(* X is the fastest mover.)
HALFDX)
(T
(* y is the fastest mover.)
HALFDY))
(COND
(YMOVEUP
(* y is moving in positive direction but bits are
stored inversely)
(IMINUS BMRASTERWIDTH))
(T BMRASTERWIDTH))
OPERATION
(fetch BITMAPBASE of BITMAP)
BMRASTERWIDTH)))
(T
(PROG ((CX1 X1)
(CY1 Y1)
(CX2 X2)
(CY2 Y2)
(CA1 (\CLIPCODE X1 Y1 LEFT RIGHT TOP BOTTOM))
(CA2 (\CLIPCODE X2 Y2 LEFT RIGHT TOP BOTTOM)))
(* save the original points for the clipping
computation.)
(* determine the sectors in which the points fall.)
CLIPLP
[COND
((NOT (EQ 0 (LOGAND CA1 CA2)))
(* line is entirely out of clipping region)
(RETURN NIL))
((EQ 0 (IPLUS CA1 CA2)) (* line is completely visible)
(* \SFInvert has an off by one bug that everybody else
in LLDISPLAY uses to save computation so SUB1 from
what you would expect.)
(* reuse the variable CA1)
(RETURN
(.WHILE.WRITABLE.DS.
DS
(SELECTQ
(fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)
(1 (\DRAWLINE1
CX1
(SUB1 (\SFInvert BITMAP CY1))
(IDIFFERENCE CX2 CX1)
(COND
(YMOVEUP (IDIFFERENCE CY2 CY1))
(T (IDIFFERENCE CY1 CY2)))
DX DY (COND
((IGREATERP DX DY)
(* X is the fastest mover.)
(IREMAINDER (IPLUS (ITIMES DY (IDIFFERENCE CX1 X1))
HALFDX)
DX))
(T (* y is the fastest mover.)
(IREMAINDER (IPLUS [ITIMES DX
(COND
(YMOVEUP (IDIFFERENCE
CY1 Y1))
(T (IDIFFERENCE
Y1 CY1]
HALFDY)
DY)))
(COND
(YMOVEUP (* y is moving in positive direction but bits are
stored inversely)
(IMINUS BMRASTERWIDTH))
(T BMRASTERWIDTH))
OPERATION
(fetch BITMAPBASE of BITMAP)
BMRASTERWIDTH))
((4 8)
(\DRAWCOLORLINE1
CX1
(SUB1 (\SFInvert BITMAP CY1))
(IDIFFERENCE CX2 CX1)
(COND
(YMOVEUP (IDIFFERENCE CY2 CY1))
(T (IDIFFERENCE CY1 CY2)))
DX DY (COND
((IGREATERP DX DY)
(* X is the fastest mover.)
(IREMAINDER (IPLUS (ITIMES DY (IDIFFERENCE CX1 X1))
HALFDX)
DX))
(T (* y is the fastest mover.)
(IREMAINDER (IPLUS [ITIMES DX
(COND
(YMOVEUP (IDIFFERENCE
CY1 Y1))
(T (IDIFFERENCE
Y1 CY1]
HALFDY)
DY)))
(COND
(YMOVEUP (* y is moving in positive direction but bits are
stored inversely)
(IMINUS BMRASTERWIDTH))
(T BMRASTERWIDTH))
OPERATION
(fetch BITMAPBASE of BITMAP)
BMRASTERWIDTH
(fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)
COLOR))
(SHOULDNT]
[COND
((NEQ CA1 0)
(* now move point CX1 CY1 so that one of the coordinates is on one of the boundaries. Which boundary is done first
was copied from BCPL.)
(COND
((IGREATERP CA1 7) (* y1 less than bottom)
(* calculate the least X for which Y will be at
bottom.)
[SETQ CX1 (IPLUS X1 (\LEASTPTAT DX DY (IDIFFERENCE BOTTOM Y1]
(SETQ CY1 BOTTOM))
((IGREATERP CA1 3) (* y1 is greater than top)
[SETQ CX1 (IPLUS X1 (\LEASTPTAT DX DY (IDIFFERENCE Y1 TOP]
(SETQ CY1 TOP))
(T (* x1 is less than left)
[SETQ CY1 (COND
[YMOVEUP (IPLUS Y1 (\LEASTPTAT DY DX (IDIFFERENCE LEFT X1]
(T (IDIFFERENCE Y1 (\LEASTPTAT DY DX (IDIFFERENCE LEFT X1]
(SETQ CX1 LEFT)))
(SETQ CA1 (\CLIPCODE CX1 CY1 LEFT RIGHT TOP BOTTOM)))
(T (* now move point CX2 CY2 so that one of the
coordinates is on one of the boundaries)
(COND
((IGREATERP CA2 7) (* y2 less than bottom)
[SETQ CX2 (IPLUS X1 (\GREATESTPTAT DX DY (IDIFFERENCE Y1
BOTTOM]
(SETQ CY2 BOTTOM))
((IGREATERP CA2 3) (* y2 is greater than top)
[SETQ CX2 (IPLUS X1 (\GREATESTPTAT DX DY (IDIFFERENCE TOP Y1]
(SETQ CY2 TOP))
(T (* x2 is greater than right)
[SETQ CY2 (COND
[YMOVEUP (IPLUS Y1 (\GREATESTPTAT DY DX (IDIFFERENCE
RIGHT X1]
(T (IDIFFERENCE Y1 (\GREATESTPTAT DY DX (IDIFFERENCE
RIGHT X1]
(SETQ CX2 RIGHT)))
(SETQ CA2 (\CLIPCODE CX2 CY2 LEFT RIGHT TOP BOTTOM]
(GO CLIPLP])
(\CLIPCODE
[LAMBDA (X Y LEFT RIGHT TOP BOTTOM) (* rrb " 4-DEC-80 10:34")
(* determines the sector code for a point wrt a region.
Used to clip things quickly.)
(* RIGHT and TOP are one past the region.)
(COND
((ILESSP X LEFT) (* falls to left of region)
(COND
((IGREATERP Y TOP) (* left above)
5)
((ILESSP Y BOTTOM) (* left below)
9)
(T (* left inside)
1)))
((IGREATERP X RIGHT) (* right)
(COND
((IGREATERP Y TOP) (* right above)
6)
((ILESSP Y BOTTOM) (* right below)
10)
(T (* right inside)
2)))
((IGREATERP Y TOP) (* inside top)
4)
((ILESSP Y BOTTOM) (* inside below)
8)
(T (* inside 0)
0])
(\LEASTPTAT
[LAMBDA (DA DB THISB) (* rrb " 7-JAN-82 11:56")
(* determines the smallest value in the dimension A that would give a B coordinate of THISB if a line were drawn
from the point (0,0) with a slope of DA/DB.)
(COND
((IGREATERP DA DB)
(ADD1 (IQUOTIENT (IPLUS (IDIFFERENCE (ITIMES THISB DA)
(HALF DA))
-1)
DB)))
(T (IQUOTIENT (IPLUS (ITIMES THISB DA)
(HALF DB))
DB])
(\GREATESTPTAT
[LAMBDA (DA DB THISB) (* rrb " 7-JAN-82 14:24")
(* determines the largest value in the dimension A that would give a B coordinate of THISB if a line were drawn
from the point (0,0) with a slope of DA/DB.)
(COND
((IGREATERP DA DB)
(IQUOTIENT (IPLUS (IDIFFERENCE (ITIMES (ADD1 THISB)
DA)
(HALF DA))
-1)
DB))
(T (IQUOTIENT (IPLUS (ITIMES THISB DA)
(HALF DB))
DB])
(\DRAWLINE1
[LAMBDA (X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH)
(* mpl " 2-Jan-84 18:00")
(* this was changed to interface with the opcode for
line drawing. It probably be incorporated into the
places it is called.)
(* draws a line starting at X0,Y0 at a slope of DX/DY until reaching either XLIMIT or YLIMIT with an initial
overflow bucket size of CDL in MODE. Arranged so that the clipping routines can determine what the exact location
of the end point of the clipped line is wrt line drawing coordinates eg. amount in overflow bucket.
XLIMIT and YLIMIT are the number of points to be moved in that direction.)
(\DRAWLINE.UFN (\ADDBASE BITMAPBASE (IPLUS (ITIMES Y0 RASTERWIDTH)
(FOLDLO X0 BITSPERWORD)))
(LOGAND X0 15)
DX YINC DY (SELECTQ MODE
(INVERT 2)
(ERASE 1)
0)
CDL
(ADD1 XLIMIT)
(ADD1 YLIMIT])
(\DRAWLINE.UFN
[LAMBDA (FIRSTADDR FIRSTBIT XDELTA YINCR YDELTA OPERATIONCODE INITIALBUCKET PIXELSINX PIXELSINY)
(* rrb "28-Dec-83 12:29")
(* FIRSTADDR is the address of the word which contains the first point. FIRSTBIT is the address of the first bit
in FIRSTADDR. XDELTA and YDELTA are how far the complete line has to move in X and Y respectively;
both are positive quantities. YINCR is the amount the address should be incremented if the Y coordinate changes
and can be either positive or negative. OPERATIONCODE is 0 for REPLACE, 1 for ERASE and 2 for INVERT.
INITIALBUCKET is between 0 and the maximum of DX and DY and gives the starting amount of the bucket used to
determine when to increment in the slower moving direction. PIXELSINX and PIXELSINY indicates how many pixels
should be drawn in the X and Y direction.)
(DECLARE (LOCALVARS . T))
(PROG ((MASK (\BITMASK FIRSTBIT)))
(COND
[(IGEQ XDELTA YDELTA) (* X is the fastest mover.)
(SELECTQ OPERATIONCODE
(0 (.DRAWLINEX. (QUOTE REPLACE/PAINT)))
(1 (.DRAWLINEX. (QUOTE ERASE)))
(.DRAWLINEX. (QUOTE INVERT]
(T (* Y is the fastest mover.)
(SELECTQ OPERATIONCODE
(0 (.DRAWLINEY. (QUOTE REPLACE/PAINT)))
(1 (.DRAWLINEY. (QUOTE ERASE)))
(.DRAWLINEY. (QUOTE INVERT])
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTPROPS .DRAWLINEX. MACRO ((MODE)
(bind ((NY ← 0))
for PT from 1 to PIXELSINX do (* main loop)
[replace (BITMAPWORD BITS)
of FIRSTADDR with (SELECTQ MODE (INVERT (LOGXOR MASK (fetch (BITMAPWORD
BITS)
of FIRSTADDR)))
(ERASE (LOGAND (LOGXOR MASK WORDMASK)
(fetch (BITMAPWORD BITS)
of FIRSTADDR)))
(PROGN (* case is PAINT or REPLACE. Legality of
OPERATION has been checked by
\CLIPANDDRAWLINE1)
(LOGOR MASK (fetch (BITMAPWORD BITS)
of FIRSTADDR]
[COND ([NOT (IGREATERP XDELTA (SETQ INITIALBUCKET (IPLUS INITIALBUCKET YDELTA]
(* increment in the Y direction)
(COND ((EQ (SETQ NY (ADD1 NY))
PIXELSINY)
(RETURN)))
(SETQ INITIALBUCKET (IDIFFERENCE INITIALBUCKET XDELTA))
(SETQ FIRSTADDR (\ADDBASE FIRSTADDR YINCR]
(SETQ MASK (LRSH MASK 1))
(COND ((EQ 0 MASK)
(* crossed word boundary)
(SETQ FIRSTADDR (\ADDBASE FIRSTADDR 1))
(SETQ MASK 32768]
[PUTPROPS .DRAWLINEY. MACRO ((MODE)
(bind ((NX ← 0))
for PT from 1 to PIXELSINY do (* main loop)
[replace (BITMAPWORD BITS)
of FIRSTADDR with (SELECTQ MODE (INVERT (LOGXOR MASK (fetch (BITMAPWORD
BITS)
of FIRSTADDR)))
(ERASE (LOGAND (LOGXOR MASK WORDMASK)
(fetch (BITMAPWORD BITS)
of FIRSTADDR)))
(PROGN (* case is PAINT or REPLACE. Legality of
OPERATION has been checked by
\CLIPANDDRAWLINE1)
(LOGOR MASK (fetch (BITMAPWORD BITS)
of FIRSTADDR]
[COND ([NOT (IGREATERP YDELTA (SETQ INITIALBUCKET (IPLUS INITIALBUCKET XDELTA]
(COND ((EQ (SETQ NX (ADD1 NX))
PIXELSINX)
(RETURN)))
(SETQ INITIALBUCKET (IDIFFERENCE INITIALBUCKET YDELTA))
(SETQ MASK (LRSH MASK 1))
(COND ((EQ 0 MASK)
(* crossed word boundary)
(SETQ FIRSTADDR (\ADDBASE FIRSTADDR 1))
(SETQ MASK 32768]
(SETQ FIRSTADDR (\ADDBASE FIRSTADDR YINCR]
)
)
(* Curves)
(DEFINEQ
(\DRAWCIRCLE.DISPLAY
[LAMBDA (DISPLAYSTREAM CENTERX CENTERY RADIUS BRUSH DASHING)
(* JonL " 7-May-84 02:46")
(* \DRAWCIRCLE.DISPLAY extended for color.
Color is specified by either BRUSH or the DSPCOLOR of
DS.)
(DECLARE (LOCALVARS . T))
(COND
((OR (NOT (NUMBERP RADIUS))
(ILESSP (SETQ RADIUS (FIXR RADIUS))
0))
(\ILLEGAL.ARG RADIUS))
((EQ RADIUS 0) (* don't draw anything.)
NIL)
(T (GLOBALRESOURCE \BRUSHBBT
(PROG ((X 0)
(Y RADIUS)
(D (ITIMES 2 (IDIFFERENCE 1 RADIUS)))
DestinationBitMap LEFT RIGHTPLUS1 TOP BOTTOM BRUSHWIDTH BRUSHHEIGHT
LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE
BRUSHBASE RASTERWIDTH BRUSHRASTERWIDTH NBITSRIGHTPLUS1 OPERATION
HEIGHTMINUS1 CX CY (BBT \BRUSHBBT)
COLOR COLORBRUSHBASE NBITS (DISPLAYDATA (fetch IMAGEDATA
of DISPLAYSTREAM))
(USERFN (AND (LITATOM BRUSH)
BRUSH))) (* many of these variables are used by the macro for
\CURVEPT that passes them to \BBTCURVEPT and
.SETUP.FOR.\BBTCURVEPT. sets them up.)
(COND
(USERFN (* if calling user fn, don't bother with set up and
leave points in stream coordinates.)
(SETQ CX CENTERX)
(SETQ CY CENTERY))
(T (.SETUP.FOR.\BBTCURVEPT.)
(SELECTQ NBITS
(1 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX
(FOLDLO
BRUSHWIDTH 2))
DISPLAYDATA)))
(4 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE
CENTERX
(FOLDLO (LRSH BRUSHWIDTH 2)
2))
DISPLAYDATA)))
(8 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE
CENTERX
(FOLDLO (LRSH BRUSHWIDTH 3)
2))
DISPLAYDATA)))
(SHOULDNT)) (* take into account the brush thickness.)
(SETQ CY (\DSPTRANSFORMY (IDIFFERENCE CENTERY (FOLDLO BRUSHHEIGHT
2))
DISPLAYDATA))
(* Move the window to top while interruptable, but
verify that it is still there uninterruptably with
drawing points)
(\INSURETOPWDS DISPLAYSTREAM)))
[COND
((EQ RADIUS 1) (* put a single brush down.)
(* draw the top and bottom most points.)
[COND
(USERFN (APPLY* USERFN CX CY DISPLAYSTREAM))
(T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVEPT CX CY]
(RETURN))
(T (* draw the top and bottom most points.)
(COND
(USERFN (APPLY* USERFN CX (IPLUS CY RADIUS)
DISPLAYSTREAM)
(APPLY* USERFN CX (IDIFFERENCE CY RADIUS)
DISPLAYSTREAM))
(T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVEPT CX (IPLUS CY RADIUS))
(\CURVEPT CX (IDIFFERENCE CY RADIUS]
LP (* (UNFOLD x 2) is used instead of
(ITIMES x 2))
[COND
[(IGREATERP 0 D)
(SETQ X (ADD1 X))
(COND
((IGREATERP (UNFOLD (IPLUS D Y)
2)
1)
(SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y)
2)
4))
(SETQ Y (SUB1 Y)))
(T (SETQ D (IPLUS D (UNFOLD X 2)
1]
((OR (EQ 0 D)
(IGREATERP X D))
(SETQ X (ADD1 X))
(SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y)
2)
4))
(SETQ Y (SUB1 Y)))
(T (SETQ D (IPLUS (IDIFFERENCE D (UNFOLD Y 2))
3))
(SETQ Y (SUB1 Y]
(COND
[(EQ Y 0) (* left most and right most points are drawn specially
so that they are not duplicated which leaves a hole in
XOR mode.)
(COND
(USERFN (APPLY* USERFN (IPLUS CX X)
CY DISPLAYSTREAM)
(APPLY* USERFN (IDIFFERENCE CX X)
CY DISPLAYSTREAM))
(T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVEPT (IPLUS CX X)
CY)
(\CURVEPT (IDIFFERENCE CX X)
CY]
(T [COND
(USERFN (APPLY* USERFN (IPLUS CX X)
(IPLUS CY Y)
DISPLAYSTREAM)
(APPLY* USERFN (IDIFFERENCE CX X)
(IPLUS CY Y)
DISPLAYSTREAM)
(APPLY* USERFN (IPLUS CX X)
(IDIFFERENCE CY Y)
DISPLAYSTREAM)
(APPLY* USERFN (IDIFFERENCE CX X)
(IDIFFERENCE CY Y)
DISPLAYSTREAM))
(T (.WHILE.TOP.DS. DISPLAYSTREAM (\CIRCLEPTS CX CY X Y]
(GO LP)))
(MOVETO CENTERX CENTERY DISPLAYSTREAM)
(RETURN NIL])
(\DRAWARC.DISPLAY
[LAMBDA (STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING)
(* draws an arc on the display)
(\DRAWARC.GENERIC STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING])
(\DRAWARC.GENERIC
[LAMBDA (STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING)
(* rrb " 4-Oct-85 18:23")
(* draws an arc by drawing a curve.)
(COND
((AND (GREATERP 360 NDEGREES)
(LESSP -360 NDEGREES))
(DRAWCURVE (\COMPUTE.ARC.POINTS CENTERX CENTERY RADIUS STARTANGLE NDEGREES)
NIL BRUSH DASHING STREAM))
(T (* use circle drawing which could be faster)
(DRAWCIRCLE CENTERX CENTERY RADIUS BRUSH DASHING STREAM])
(\COMPUTE.ARC.POINTS
[LAMBDA (CENTERX CENTERY RADIUS STARTANGLE NDEGREES) (* DECLARATIONS: FLOATING)
(* rrb " 4-Oct-85 18:21")
(* computes a list of knots that a spline goes through
to make an arc)
(PROG ((MODNDEGREES (REMAINDER NDEGREES 360.0))
ANGLEINCR)
(* 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 MODNDEGREES
(IMIN (IMAX (ABS (FIX (FQUOTIENT MODNDEGREES 10.0)))
5)
(PROGN (* don't have more than a knot every 5 pts)
(IMAX (ABS (FIX (QUOTIENT (TIMES RADIUS 6.3
(QUOTIENT
MODNDEGREES
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.)
(RETURN (for ANGLE from STARTANGLE to (PLUS STARTANGLE MODNDEGREES
(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])
(\DRAWELLIPSE.DISPLAY
[LAMBDA (DISPLAYSTREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING)
(* JonL " 7-May-84 02:45")
(DECLARE (LOCALVARS . T))
(* Draws an ellipse. At ORIENTATION 0, the semimajor axis is horizontal, the semiminor axis vertical.
Orientation is positive in the counterclockwise direction. The current location in the stream is left at the
center of the ellipse.)
(PROG ((CENTERX (FIXR CENTERX))
(CENTERY (FIXR CENTERY))
(SEMIMINORRADIUS (FIXR SEMIMINORRADIUS))
(SEMIMAJORRADIUS (FIXR SEMIMAJORRADIUS)))
(COND
((OR (EQ 0 SEMIMINORRADIUS)
(EQ 0 SEMIMAJORRADIUS))
(MOVETO CENTERX CENTERY DISPLAYSTREAM)
(RETURN)))
(COND
((ILESSP SEMIMINORRADIUS 1)
(\ILLEGAL.ARG SEMIMINORRADIUS))
((ILESSP SEMIMAJORRADIUS 1)
(\ILLEGAL.ARG SEMIMAJORRADIUS))
((OR (NULL ORIENTATION)
(EQ SEMIMINORRADIUS SEMIMAJORRADIUS))
(SETQ ORIENTATION 0))
((NULL (NUMBERP ORIENTATION))
(\ILLEGAL.ARG ORIENTATION)))
(* This function is the implementation of the algorithm given in
"Algorithm for drawing ellipses or hyperbolae with a digital plotter" by Pitteway appearing in Computer Journal
10: (3) Nov 1967.0 The input parameters are used to determine the ellipse equation (1/8) Ayy+
(1/8) Bxx+ (1/4) Gxy+ (1/4) Ux+ (1/4) Vy= (1/4) K which specifies a translated version of the desired ellipse.
This ellipse passes through the mesh point (0,0), the initial point of the algorithm. The power of 2 factors
reflect an implementation convenience.)
(GLOBALRESOURCE \BRUSHBBT
(PROG (DestinationBitMap LEFT RIGHTPLUS1 BOTTOM TOP BOTTOMMINUSBRUSH
TOPMINUSBRUSH LEFTMINUSBRUSH DESTINATIONBASE
BRUSHBASE BRUSHHEIGHT BRUSHWIDTH RASTERWIDTH
BRUSHRASTERWIDTH BRUSHBM OPERATION HEIGHTMINUS1
(BBT \BRUSHBBT)
(cosOrientation (COS ORIENTATION))
(sinOrientation (SIN ORIENTATION))
(SEMIMINORRADIUSSQUARED (ITIMES SEMIMINORRADIUS
SEMIMINORRADIUS))
(SEMIMAJORRADIUSSQUARED (ITIMES SEMIMAJORRADIUS
SEMIMAJORRADIUS))
(x 0)
(y 0)
(x2 1)
x1 y1 y2 k1 k2 k3 a b d w A B G U V K CX CY
yOffset CYPlusOffset CYMinusOffset NBITSRIGHTPLUS1
COLORBRUSHBASE COLOR NBITS
(DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM))
(USERFN (AND (LITATOM BRUSH)
BRUSH)))
(* many of these variables are used by the macro for
\CURVEPT that passes them to \BBTCURVEPT and
.SETUP.FOR.\BBTCURVEPT. sets them up.)
(COND
(USERFN (* if calling user fn, don't bother with set up and
leave points in window coordinates.)
(SETQ CX CENTERX)
(SETQ CY CENTERY))
(T (.SETUP.FOR.\BBTCURVEPT.)
(* take into account the brush thickness.)
(SELECTQ NBITS
(1 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX
(FOLDLO
BRUSHWIDTH 2))
DISPLAYDATA)))
(4 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE
CENTERX
(FOLDLO (LRSH BRUSHWIDTH
2)
2))
DISPLAYDATA)))
(8 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE
CENTERX
(FOLDLO (LRSH BRUSHWIDTH
3)
2))
DISPLAYDATA)))
(SHOULDNT))
(SETQ CY (\DSPTRANSFORMY (IDIFFERENCE CENTERY (FOLDLO
BRUSHHEIGHT 2))
DISPLAYDATA))
(* Move the window to top while interruptable, but
verify that it is still there uninterruptably with
drawing points)
(\INSURETOPWDS DISPLAYSTREAM)))
(SETQ A (FPLUS (FTIMES SEMIMAJORRADIUSSQUARED cosOrientation
cosOrientation)
(FTIMES SEMIMINORRADIUSSQUARED sinOrientation
sinOrientation)))
(SETQ B (LSH (FIXR (FPLUS (FTIMES SEMIMINORRADIUSSQUARED
cosOrientation cosOrientation)
(FTIMES SEMIMAJORRADIUSSQUARED
sinOrientation sinOrientation)))
3))
(SETQ G (FTIMES cosOrientation sinOrientation
(LSH (IDIFFERENCE SEMIMINORRADIUSSQUARED
SEMIMAJORRADIUSSQUARED)
1)))
[SETQ yOffset (FIXR (FQUOTIENT (ITIMES SEMIMINORRADIUS
SEMIMAJORRADIUS)
(SQRT A]
(SETQ CYPlusOffset (IPLUS CY yOffset))
(SETQ CYMinusOffset (IDIFFERENCE CY yOffset))
(SETQ U (LSH (FIXR (FTIMES A (LSH yOffset 1)))
2))
(SETQ V (LSH (FIXR (FTIMES G yOffset))
2))
(SETQ K (LSH [FIXR (FDIFFERENCE (ITIMES SEMIMINORRADIUSSQUARED
SEMIMAJORRADIUSSQUARED)
(FTIMES A (ITIMES yOffset yOffset]
2))
(SETQ A (LSH (FIXR A)
3))
(SETQ G (LSH (FIXR G)
2))
(* The algorithm is incremental and iterates through the octants of a cartesian plane. The octants are labeled
from 1 through 8 beginning above the positive X axis and proceeding counterclockwise. Decisions in making the
incremental steps are determined according to the error term d which is updated according to the curvature terms a
and b. k1, k2, and k3 are used to correct the error and curvature terms at octant boundaries.
The initial values of these terms depends on the octant in which drawing begins. The initial move steps
(x1,y1) and (x2,y2) also depend on the starting octant.)
[COND
[(ILESSP (ABS U)
(ABS V))
(SETQ x1 0)
(COND
[(MINUSP V) (* start in octant 2)
(SETQ y1 1)
(SETQ y2 1)
(SETQ k1 (IMINUS A))
(SETQ k2 (IDIFFERENCE k1 G))
(SETQ k3 (IDIFFERENCE k2 (IPLUS B G)))
(SETQ b (IPLUS U (RSH (IPLUS A G)
1)))
(SETQ a (IMINUS (IPLUS b V)))
(SETQ d (IPLUS b (RSH B 3)
(RSH V 1)
(IMINUS K]
(T (* start in octant 7)
(SETQ y1 -1)
(SETQ y2 -1)
(SETQ k1 A)
(SETQ k2 (IDIFFERENCE k1 G))
(SETQ k3 (IPLUS k2 B (IMINUS G)))
(SETQ b (IPLUS U (RSH (IDIFFERENCE G A)
1)))
(SETQ a (IDIFFERENCE V b))
(SETQ d (IPLUS b K (IMINUS (IPLUS (RSH V 1)
(RSH B 3]
(T (SETQ x1 1)
(SETQ y1 0)
(COND
[(MINUSP V) (* start in octant 1)
(SETQ y2 1)
(SETQ k1 B)
(SETQ k2 (IPLUS k1 G))
(SETQ k3 (IPLUS k2 A G))
[SETQ b (IMINUS (IPLUS V (RSH (IPLUS B G)
1]
(SETQ a (IDIFFERENCE U b))
(SETQ d (IPLUS b K (IMINUS (IPLUS (RSH A 3)
(RSH U 1]
(T (* start in octant 8)
(SETQ y2 -1)
(SETQ k1 (IMINUS B))
(SETQ k2 (IPLUS k1 G))
(SETQ k3 (IPLUS k2 G (IMINUS A)))
(SETQ b (IPLUS V (RSH (IDIFFERENCE B G)
1)))
(SETQ a (IDIFFERENCE U b))
(SETQ d (IPLUS b (RSH A 3)
(IMINUS (IPLUS K (RSH U 1]
(* The ellipse equation describes an ellipse of the desired size and ORIENTATION centered at
(0,0) and then dropped yOffset mesh points so that it will pass through (0,0). Thus, the intended starting point
is (CX, CY+yOffset) where (CX, CY) is the center of the desired ellipse. Drawing is accomplished with point
relative steps. In each octant, the error term d is used to choose between move 1 (an axis move) and move 2
(a diagonal move).)
MOVE[COND
((MINUSP d) (* move 1)
(SETQ x (IPLUS x x1))
(SETQ y (IPLUS y y1))
(SETQ b (IDIFFERENCE b k1))
(SETQ a (IPLUS a k2))
(SETQ d (IPLUS b d)))
(T (* move 2)
(SETQ x (IPLUS x x2))
(SETQ y (IPLUS y y2))
(SETQ b (IDIFFERENCE b k2))
(SETQ a (IPLUS a k3))
(SETQ d (IDIFFERENCE d a]
(COND
((MINUSP x)
(MOVETO CENTERX CENTERY DISPLAYSTREAM)
(RETURN NIL)))
[COND
(USERFN (APPLY* USERFN (IPLUS CX x)
(IPLUS CYPlusOffset y)
DISPLAYSTREAM)
(APPLY* USERFN (IDIFFERENCE CX x)
(IDIFFERENCE CYMinusOffset y)
DISPLAYSTREAM))
(T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVEPT (IPLUS CX x)
(IPLUS CYPlusOffset y))
(\CURVEPT (IDIFFERENCE CX x)
(IDIFFERENCE CYMinusOffset y]
(AND (MINUSP b)
(GO SQUARE))
DIAGONAL
(OR (MINUSP a)
(GO MOVE)) (* diagonal octant change)
(SETQ x1 (IDIFFERENCE x2 x1))
(SETQ y1 (IDIFFERENCE y2 y1))
(SETQ w (IDIFFERENCE (LSH k2 1)
k3))
(SETQ k1 (IDIFFERENCE w k1))
(SETQ k2 (IDIFFERENCE k2 k3))
(SETQ k3 (IMINUS k3))
[SETQ b (IPLUS b a (IMINUS (RSH (ADD1 k2)
1]
[SETQ d (IPLUS b (RSH (IPLUS k3 4)
3)
(IMINUS d)
(IMINUS (RSH (ADD1 a)
1]
(SETQ a (IDIFFERENCE (RSH (ADD1 w)
1)
a))
(OR (MINUSP b)
(GO MOVE))
SQUARE (* square octant change)
[COND
((EQ 0 x1)
(SETQ x2 (IMINUS x2)))
(T (SETQ y2 (IMINUS y2]
(SETQ w (IDIFFERENCE k2 k1))
(SETQ k1 (IMINUS k1))
(SETQ k2 (IPLUS w k1))
(SETQ k3 (IDIFFERENCE (LSH w 2)
k3))
(SETQ b (IDIFFERENCE (IMINUS b)
w))
(SETQ d (IDIFFERENCE (IDIFFERENCE b a)
d))
(SETQ a (IDIFFERENCE (IDIFFERENCE a w)
(LSH b 1)))
(GO DIAGONAL])
(\DRAWCURVE.DISPLAY
[LAMBDA (DISPLAYSTREAM KNOTS CLOSED BRUSH DASHING) (* hdj "17-Jun-85 11:46")
(* draws a spline curve with a given brush.)
(GLOBALRESOURCE \BRUSHBBT (PROG ((BBT \BRUSHBBT)
(DASHLST (\GOOD.DASHLST DASHING BRUSH)))
(SELECTQ (LENGTH KNOTS)
(0 (* No knots => empty curve rather than error?)
NIL)
(1 (* only one knot, put down a brush shape)
(OR (type? POSITION (CAR KNOTS))
(ERROR "bad knot" (CAR KNOTS)))
(DRAWPOINT (fetch XCOORD of (CAR KNOTS))
(fetch YCOORD of (CAR KNOTS))
BRUSH DISPLAYSTREAM))
(2 (OR (type? POSITION (CAR KNOTS))
(ERROR "bad knot" (CAR KNOTS)))
(OR (type? POSITION (CADR KNOTS))
(ERROR "bad knot" (CADR KNOTS)))
(\LINEWITHBRUSH (fetch XCOORD of (CAR KNOTS))
(fetch YCOORD of (CAR KNOTS))
(fetch XCOORD of (CADR KNOTS))
(fetch YCOORD of (CADR KNOTS))
BRUSH DASHLST DISPLAYSTREAM BBT))
(\CURVE2 (PARAMETRICSPLINE KNOTS CLOSED)
BRUSH DASHLST BBT DISPLAYSTREAM))
(RETURN DISPLAYSTREAM])
(DRAWPOINT
[LAMBDA (X Y BRUSH WINDOW OPERATION) (* rrb "30-Apr-85 10:54")
(* draws a brush point at position X Y)
(PROG ((BRUSHBM (\GETBRUSH BRUSH))) (* SUB1 is to put extra bit of even brush on the top or
left.)
(RETURN (BITBLT BRUSHBM 0 0 WINDOW [IDIFFERENCE X (HALF (SUB1 (fetch (BITMAP BITMAPWIDTH)
of BRUSHBM]
[IDIFFERENCE Y (HALF (SUB1 (fetch (BITMAP BITMAPHEIGHT) of BRUSHBM]
NIL NIL NIL OPERATION])
(\LINEWITHBRUSH
[LAMBDA (X1 Y1 X2 Y2 BRUSH DASHLST DISPLAYSTREAM BBT) (* rrb "29-Apr-85 17:31")
(* draws a line with a brush on a guaranteed
display-stream DISPLAYSTREAM)
(DECLARE (LOCALVARS . T))
(PROG (DestinationBitMap LEFT RIGHTPLUS1 TOP BOTTOM BRUSHWIDTH BRUSHHEIGHT LEFTMINUSBRUSH
BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE BRUSHBASE
RASTERWIDTH BRUSHRASTERWIDTH NBITSRIGHTPLUS1 OPERATION HEIGHTMINUS1
COLOR COLORBRUSHBASE NBITS HALFBRUSHWIDTH HALFBRUSHHEIGHT DX DY YINC CDL
(DASHON T)
(DASHTAIL DASHLST)
(DASHCNT (CAR DASHLST))
(DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM))
(USERFN (AND (LITATOM BRUSH)
BRUSH))
(DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM)))
(* many of these variables are used by the macro for
\CURVEPT that passes them to \BBTCURVEPT and
.SETUP.FOR.\BBTCURVEPT. sets them up.)
(* move the display stream position before the
coordinates are clobbered.)
(COND
((NOT USERFN)
(.SETUP.FOR.\BBTCURVEPT.)
(SELECTQ NBITS
(1 (* SUB1 is so that the extra bit goes on the top and
right as it is documented as doing for lines.)
(SETQ X1 (\DSPTRANSFORMX (IDIFFERENCE X1 (SETQ HALFBRUSHWIDTH
(FOLDLO (SUB1 BRUSHWIDTH)
2)))
DISPLAYDATA)))
(4 (SETQ X1 (\DSPTRANSFORMX (IDIFFERENCE X1 (SETQ HALFBRUSHWIDTH
(FOLDLO (LRSH (SUB1 BRUSHWIDTH)
2)
2)))
DISPLAYDATA)))
(8 (SETQ X1 (\DSPTRANSFORMX (IDIFFERENCE X1 (SETQ HALFBRUSHWIDTH
(FOLDLO (LRSH (SUB1 BRUSHWIDTH)
3)
2)))
DISPLAYDATA)))
(SHOULDNT))
(SETQ X2 (\DSPTRANSFORMX (IDIFFERENCE X2 HALFBRUSHWIDTH)
DISPLAYDATA))
(SETQ Y1 (\DSPTRANSFORMY (IDIFFERENCE Y1 (SETQ HALFBRUSHHEIGHT (FOLDLO (SUB1
BRUSHHEIGHT)
2)))
DISPLAYDATA)) (* take into account the brush thickness.)
(SETQ Y2 (\DSPTRANSFORMY (IDIFFERENCE Y2 HALFBRUSHHEIGHT)
DISPLAYDATA)) (* Move the window to top while interruptable, but
verify that it is still there uninterruptably with
drawing points)
(\INSURETOPWDS DISPLAYSTREAM))) (* arrange things so that dx is positive.)
(COND
((IGREATERP X1 X2) (* switch points)
(swap X1 X2)
(swap Y1 Y2)))
(SETQ DX (ADD1 (IDIFFERENCE X2 X1)))
[SETQ DY (ADD1 (COND
((IGREATERP Y2 Y1)
(SETQ YINC 1)
(IDIFFERENCE Y2 Y1))
(T (SETQ YINC -1)
(IDIFFERENCE Y1 Y2]
[SETQ CDL (HALF (COND
((IGREATERP DX DY) (* set up the bucket so that the ends will be the
same.)
(IREMAINDER DX DY))
(T (IREMAINDER DY DX]
[COND
[USERFN (* if user function is being called, don't bother
bringing window to top uninterruptably.)
(COND
((IGEQ DX DY) (* X is the fastest mover.)
(until (IGREATERP X1 X2)
do (* main loop)
(COND
(DASHON (APPLY* USERFN X1 Y1 DISPLAYSTREAM)))
[COND
(DASHTAIL (* do dashing.)
(COND
((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT)))
(SETQ DASHON (NOT DASHON))
(SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL))
DASHLST))
(SETQ DASHCNT (CAR DASHTAIL]
[COND
((NOT (IGREATERP DX (add CDL DY)))
(add Y1 YINC)
(COND
((COND
((EQ YINC -1)
(ILESSP Y1 Y2))
((IGREATERP Y1 Y2)))
(RETURN)))
(SETQ CDL (IDIFFERENCE CDL DX]
(add X1 1)))
(T (* Y is the fastest mover.)
(until (COND
((EQ YINC -1)
(ILESSP Y1 Y2))
((IGREATERP Y1 Y2)))
do (* main loop)
(COND
(DASHON (APPLY* USERFN X1 Y1 DISPLAYSTREAM)))
[COND
(DASHTAIL (* do dashing.)
(COND
((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT)))
(SETQ DASHON (NOT DASHON))
(SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL))
DASHLST))
(SETQ DASHCNT (CAR DASHTAIL]
[COND
([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX]
(COND
((IGREATERP (SETQ X1 (ADD1 X1))
X2)
(RETURN)))
(SETQ CDL (IDIFFERENCE CDL DY]
(add Y1 YINC]
(T (* when we put the points down make it uninterruptable)
(.WHILE.TOP.DS. DISPLAYSTREAM
(COND
[(IGEQ DX DY) (* X is the fastest mover.)
(until (IGREATERP X1 X2)
do (* main loop)
(COND
(DASHON (\CURVEPT X1 Y1)))
[COND
(DASHTAIL (* do dashing.)
(COND
((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT)))
(SETQ DASHON (NOT DASHON))
(SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL))
DASHLST))
(SETQ DASHCNT (CAR DASHTAIL]
[COND
([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY]
(SETQ Y1 (IPLUS Y1 YINC))
(COND
((COND
((EQ YINC -1)
(ILESSP Y1 Y2))
((IGREATERP Y1 Y2)))
(RETURN)))
(SETQ CDL (IDIFFERENCE CDL DX]
(SETQ X1 (ADD1 X1]
(T (* Y is the fastest mover.)
(until (COND
((EQ YINC -1)
(ILESSP Y1 Y2))
((IGREATERP Y1 Y2)))
do (* main loop)
(COND
(DASHON (\CURVEPT X1 Y1)))
[COND
(DASHTAIL (* do dashing.)
(COND
((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT)))
(SETQ DASHON (NOT DASHON))
(SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL))
DASHLST))
(SETQ DASHCNT (CAR DASHTAIL]
[COND
([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX]
(COND
((IGREATERP (SETQ X1 (ADD1 X1))
X2)
(RETURN)))
(SETQ CDL (IDIFFERENCE CDL DY]
(SETQ Y1 (IPLUS Y1 YINC]
(RETURN NIL])
)
(DEFINEQ
(LOADPOLY
[LAMBDA (POLY POLYPRIME A B C D) (* hdj "13-Mar-85 18:01")
(replace (POLYNOMIAL A) of POLY with (FQUOTIENT A 6.0))
(replace (POLYNOMIAL B) of POLY with (FQUOTIENT B 2.0))
(replace (POLYNOMIAL C) of POLY with C)
(replace (POLYNOMIAL D) of POLY with D)
(replace (POLYNOMIAL A) of POLYPRIME with (FQUOTIENT A 2.0))
(replace (POLYNOMIAL B) of POLYPRIME with B)
(replace (POLYNOMIAL C) of POLYPRIME with C])
(PARAMETRICSPLINE
[LAMBDA (KNOTS CLOSEDFLG SPLINE) (* rmk: "30-Nov-84 17:02")
(* KNOTS is a non-NIL list of knots, CLOSEDFLG =>
closed curve)
(PROG (DX DY DDX DDY DDDX DDDY #KNOTS A BX BY X Y SX SY A C R D2X D2Y I)
[COND
(CLOSEDFLG (* Wrap around)
(push KNOTS (CAR (LAST KNOTS]
(SETQ #KNOTS (LENGTH KNOTS))
(SETQ DX (ARRAY #KNOTS 0 0.0))
(SETQ DDX (ARRAY #KNOTS 0 0.0))
(SETQ DDDX (ARRAY #KNOTS 0 0.0))
(SETQ DY (ARRAY #KNOTS 0 0.0))
(SETQ DDY (ARRAY #KNOTS 0 0.0))
(SETQ DDDY (ARRAY #KNOTS 0 0.0))
(SETQ X (ARRAY #KNOTS 0 0.0))
(SETQ Y (ARRAY #KNOTS 0 0.0))
(for KNOT in KNOTS as I from 1 to #KNOTS
do (OR (type? POSITION KNOT)
(ERROR "bad knot" KNOT))
(SETA X I (CAR KNOT))
(SETA Y I (CDR KNOT)))
(SETQ A (ARRAY #KNOTS 0 0.0))
(SETQ BX (ARRAY #KNOTS 0 0.0))
(SETQ BY (ARRAY #KNOTS 0 0.0))
[COND
(CLOSEDFLG (SETQ C (ARRAY #KNOTS 0 0.0))
(SETQ R (ARRAY #KNOTS 0 0.0))
(SETQ SX (ARRAY #KNOTS 0 0.0))
(SETQ SY (ARRAY #KNOTS 0 0.0]
(SETA A 1 4.0)
[for I from 2 to (IDIFFERENCE #KNOTS 2) do (SETA A I (FDIFFERENCE
4.0
(FQUOTIENT 1.0 (ELT A (SUB1 I]
[COND
(CLOSEDFLG (SETA C 1 1.0)
(for I from 2 to (IDIFFERENCE #KNOTS 2)
do (SETA C I (FMINUS (FQUOTIENT (ELT C (SUB1 I))
(ELT A (SUB1 I]
[COND
((IGEQ #KNOTS 3)
(COND
[CLOSEDFLG [SETA BX 1 (FTIMES 6.0 (FPLUS (ELT X 2)
(FMINUS (FTIMES 2.0 (ELT X 1)))
(ELT X (SUB1 #KNOTS]
[SETA BY 1 (FTIMES 6.0 (FPLUS (ELT Y 2)
(FMINUS (FTIMES 2.0 (ELT Y 1)))
(ELT Y (SUB1 #KNOTS]
[for I from 2 to (IDIFFERENCE #KNOTS 2)
do [SETA BX I (FDIFFERENCE [FTIMES 6.0
(FPLUS (ELT X (ADD1 I))
(FMINUS (FTIMES 2.0
(ELT X I)))
(ELT X (SUB1 I]
(FQUOTIENT (ELT BX (SUB1 I))
(ELT A (SUB1 I]
(SETA BY I (FDIFFERENCE [FTIMES 6.0
(FPLUS (ELT Y (ADD1 I))
(FMINUS (FTIMES 2.0
(ELT Y I)))
(ELT Y (SUB1 I]
(FQUOTIENT (ELT BY (SUB1 I))
(ELT A (SUB1 I]
(SETA R (SUB1 #KNOTS)
1.0)
(SETA SX (SUB1 #KNOTS)
0.0)
(SETA SY (SUB1 #KNOTS)
0.0)
(for I from (IDIFFERENCE #KNOTS 2) to 1 by -1
do [SETA R I (FMINUS (FQUOTIENT (FPLUS (ELT R (ADD1 I))
(ELT C I))
(ELT A I]
(SETA SX I (FQUOTIENT (FDIFFERENCE (ELT BX I)
(ELT SX (ADD1 I)))
(ELT A I)))
(SETA SY I (FQUOTIENT (FDIFFERENCE (ELT BY I)
(ELT SY (ADD1 I)))
(ELT A I]
(T [SETA BX 1 (FTIMES 6.0 (FPLUS (FDIFFERENCE (ELT X 3)
(FTIMES 2.0 (ELT X 2)))
(ELT X 1]
[SETA BY 1 (FTIMES 6.0 (FPLUS (FDIFFERENCE (ELT Y 3)
(FTIMES 2.0 (ELT Y 2)))
(ELT Y 1]
(for I from 2 to (IDIFFERENCE #KNOTS 2)
do [SETA BX I (FDIFFERENCE (FTIMES 6.0
(FPLUS [FDIFFERENCE
(ELT X (IPLUS I 2))
(FTIMES 2 (ELT X (ADD1 I]
(ELT X I)))
(FQUOTIENT (ELT BX (SUB1 I))
(ELT A (SUB1 I]
(SETA BY I (FDIFFERENCE (FTIMES 6.0
(FPLUS [FDIFFERENCE
(ELT Y (IPLUS I 2))
(FTIMES 2 (ELT Y (ADD1 I]
(ELT Y I)))
(FQUOTIENT (ELT BY (SUB1 I))
(ELT A (SUB1 I]
[COND
(CLOSEDFLG [SETQ D2X (FPLUS (ELT X #KNOTS)
[FMINUS (FTIMES 2.0 (ELT X (SUB1 #KNOTS]
(ELT X (IDIFFERENCE #KNOTS 2]
[SETQ D2Y (FPLUS (ELT Y #KNOTS)
[FMINUS (FTIMES 2.0 (ELT Y (SUB1 #KNOTS]
(ELT Y (IDIFFERENCE #KNOTS 2]
(SETA DDX (SUB1 #KNOTS)
(FQUOTIENT (FDIFFERENCE (FDIFFERENCE (FTIMES D2X 6.0)
(ELT SX 1))
(ELT SX (IDIFFERENCE #KNOTS 2)))
(FPLUS (ELT R 1)
(ELT R (IDIFFERENCE #KNOTS 2))
4.0)))
(SETA DDY (SUB1 #KNOTS)
(FQUOTIENT (FDIFFERENCE (FDIFFERENCE (FTIMES D2Y 6.0)
(ELT SY 1))
(ELT SY (IDIFFERENCE #KNOTS 2)))
(FPLUS (ELT R 1)
(ELT R (IDIFFERENCE #KNOTS 2))
4.0)))
[for I from 1 to (IDIFFERENCE #KNOTS 2)
do [SETA DDX I (FPLUS (ELT SX I)
(FTIMES (ELT R I)
(ELT DDX (SUB1 #KNOTS]
(SETA DDY I (FPLUS (ELT SY I)
(FTIMES (ELT R I)
(ELT DDY (SUB1 #KNOTS]
(SETA DDX #KNOTS (ELT DDX 1))
(SETA DDY #KNOTS (ELT DDY 1)))
(T (* COMPUTE SECOND DERIVATIVES.)
[SETA DDX 1 (SETA DDY 1 (SETA DDX #KNOTS (SETA DDY #KNOTS 0.0]
(for I from (SUB1 #KNOTS) to 2 by -1
do [SETA DDX I (FQUOTIENT (FDIFFERENCE (ELT BX (SUB1 I))
(ELT DDX (ADD1 I)))
(ELT A (SUB1 I]
(SETA DDY I (FQUOTIENT (FDIFFERENCE (ELT BY (SUB1 I))
(ELT DDY (ADD1 I)))
(ELT A (SUB1 I]
[for I from 1 to (SUB1 #KNOTS)
do (* COMPUTE 1ST & 3RD DERIVATIVES)
(SETA DX I (FDIFFERENCE (FDIFFERENCE (ELT X (ADD1 I))
(ELT X I))
(FQUOTIENT (FPLUS (FTIMES 2 (ELT DDX I))
(ELT DDX (ADD1 I)))
6.0)))
(SETA DY I (FDIFFERENCE (FDIFFERENCE (ELT Y (ADD1 I))
(ELT Y I))
(FQUOTIENT (FPLUS (FTIMES 2 (ELT DDY I))
(ELT DDY (ADD1 I)))
6.0)))
(SETA DDDX I (FDIFFERENCE (ELT DDX (ADD1 I))
(ELT DDX I)))
(SETA DDDY I (FDIFFERENCE (ELT DDY (ADD1 I))
(ELT DDY I]
(SETQ SPLINE
(create SPLINE
#KNOTS ← #KNOTS
SPLINEX ← X
SPLINEY ← Y
SPLINEDX ← DX
SPLINEDY ← DY
SPLINEDDX ← DDX
SPLINEDDY ← DDY
SPLINEDDDX ← DDDX
SPLINEDDDY ← DDDY))
(RETURN SPLINE])
(\CURVE
[LAMBDA (X0 Y0 X1 Y1 DX DY DDX DDY DDDX DDDY N BRUSHBM DISPLAYDATA BBT ENDING USERFN DISPLAYSTREAM)
(* rrb "30-Apr-85 12:44")
(DECLARE (LOCALVARS . T))
(* Puts a spline segment down. Since it calls BitBlt1 directly, it must clip to both clipping region and the size of
the destination bit map.)
(PROG (OLDX X Y OLDY DELTAX DELTAY DELTA TX TY OOLDX OOLDY)
[COND
((NEQ N 0)
[COND
(USERFN (* if there is a user fn, stay in his coordinates.)
(SETQ OLDX X0)
(SETQ OLDY Y0))
(T (* SUB1 on brush size is to cause the extra bit to be
in the top left direction as is documented for lines.)
(SETQ OLDX (\DSPTRANSFORMX (IDIFFERENCE X0 (LRSH (SUB1 BRUSHWIDTH)
1))
DISPLAYDATA))
(SETQ OLDY (\DSPTRANSFORMY (IDIFFERENCE Y0 (LRSH (SUB1 BRUSHHEIGHT)
1))
DISPLAYDATA] (* draw origin point)
(\CURVESMOOTH OLDX OLDY USERFN DISPLAYSTREAM)
(* convert the derivatives to fractional
representation.)
(* \CONVERTTOFRACTION always returns a large number
box. This uses .49 because .5 causes rounding up.)
(SETQ X (\CONVERTTOFRACTION (FPLUS OLDX .49)))
(SETQ Y (\CONVERTTOFRACTION (FPLUS OLDY .49)))
(SETQ DX (\CONVERTTOFRACTION DX))
(SETQ DY (\CONVERTTOFRACTION DY))
(SETQ DDX (\CONVERTTOFRACTION DDX))
(SETQ DDY (\CONVERTTOFRACTION DDY))
(SETQ DDDX (\CONVERTTOFRACTION DDDX))
(SETQ DDDY (\CONVERTTOFRACTION DDDY))
[for I from 1 to N
do (* uses \BOXIPLUS to save box and also set the new
value of the variable.)
(\BOXIPLUS X DX)
(\BOXIPLUS DX DDX)
(\BOXIPLUS DDX DDDX)
(\BOXIPLUS Y DY)
(\BOXIPLUS DY DDY)
(\BOXIPLUS DDY DDDY)
(SETQ OOLDX OLDX)
(SETQ OOLDY OLDY)
(SETQ DELTAX (IDIFFERENCE (SETQ OLDX (\GETINTEGERPART X))
OOLDX))
(SETQ DELTAY (IDIFFERENCE (SETQ OLDY (\GETINTEGERPART Y))
OOLDY))
(SETQ DELTA (IMAX (IABS DELTAX)
(IABS DELTAY)))
(COND
((EQ DELTA 1)
(\CURVESMOOTH OLDX OLDY USERFN DISPLAYSTREAM)))
(COND
((IGREATERP DELTA 1)
(SETQ DELTAX (\CONVERTTOFRACTION (FQUOTIENT DELTAX DELTA)))
(SETQ DELTAY (\CONVERTTOFRACTION (FQUOTIENT DELTAY DELTA)))
(SETQ TX (\CONVERTTOFRACTION OOLDX))
(SETQ TY (\CONVERTTOFRACTION OOLDY))
(for I from 0 to DELTA
do (\CURVESMOOTH (\GETINTEGERPART TX)
(\GETINTEGERPART TY)
USERFN DISPLAYSTREAM)
(\BOXIPLUS TX DELTAX)
(\BOXIPLUS TY DELTAY] (* draw the end point)
(COND
(USERFN (\CURVESMOOTH X1 Y1 USERFN DISPLAYSTREAM))
(T (\CURVESMOOTH (\DSPTRANSFORMX (IDIFFERENCE X1 (LRSH (SUB1 BRUSHWIDTH)
1))
DISPLAYDATA)
(\DSPTRANSFORMY (IDIFFERENCE Y1 (LRSH (SUB1 BRUSHHEIGHT)
1))
DISPLAYDATA)
NIL DISPLAYSTREAM)))
(AND DISPLAYSTREAM (MOVETO X1 Y1 DISPLAYSTREAM]
(COND
(ENDING (\CURVESMOOTH (IPLUS \CURX \CURX (IMINUS \OLDX))
(IPLUS \CURY \CURY (IMINUS \OLDY))
USERFN DISPLAYSTREAM)
(\CURVESMOOTH (IPLUS \CURX \CURX (IMINUS \OLDX))
(IPLUS \CURY \CURY (IMINUS \OLDY))
USERFN DISPLAYSTREAM)))
(RETURN NIL])
(\CURVE2
[LAMBDA (SPLINE BRUSH DASHLST BBT DISPLAYSTREAM) (* rrb " 1-Oct-85 09:18")
(DECLARE (SPECVARS . T))
(* DISPLAYSTREAM is guaranteed to be a display-stream. Should declare most of these variables local but currently
have the \CURVE function between here and \CURVEBBT so can't)
(PROG (BRUSHBM DestinationBitMap OPERATION BRUSHWIDTH BRUSHHEIGHT BRUSHBASE BRUSHRASTERWIDTH LEFT
RIGHTPLUS1 TOP BOTTOM DESTINATIONBASE LEFTMINUSBRUSH BOTTOMMINUSBRUSH
TOPMINUSBRUSH RASTERWIDTH NBITSRIGHTPLUS1 HEIGHTMINUS1 COLOR COLORBRUSHBASE NBITS
\CURX \CURY \OLDX \OLDY \OLDERX \OLDERY LKNOT (DASHON T)
(DASHTAIL DASHLST)
(DASHCNT (CAR DASHLST))
NPOINTS NSEGS POINTSPERSEG DX D2X D3X DY D2Y D3Y D1 D2 D3 X0 Y0 X1 Y1 DX DDX DDDX
DY DDY DDDY (XPOLY (create POLYNOMIAL))
(X/PRIME/POLY (create POLYNOMIAL))
(YPOLY (create POLYNOMIAL))
(Y/PRIME/POLY (create POLYNOMIAL))
(DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM))
(USERFN (AND (LITATOM BRUSH)
BRUSH))) (* many of these variables are used by the macro for
\CURVEPT that passes them to \BBTCURVEPT and
.SETUP.FOR.\BBTCURVEPT. sets them up.)
[COND
(USERFN (* if calling user fn, don't bother with set up and
leave points in window coordinates.)
(\CURVESTART (ELT (fetch (SPLINE SPLINEX) of SPLINE)
1)
(ELT (fetch (SPLINE SPLINEY) of SPLINE)
1)))
(T (.SETUP.FOR.\BBTCURVEPT.) (* Do it interruptably here to get set up, then
uninterruptably when drawing points)
(\INSURETOPWDS DISPLAYSTREAM) (* curve pts will be kept in screen coordinates, start
smoothing values there.)
(\CURVESTART (\DSPTRANSFORMX (IDIFFERENCE (ELT (fetch (SPLINE SPLINEX) of SPLINE)
1)
(LRSH (SUB1 BRUSHWIDTH)
1))
DISPLAYDATA)
(\DSPTRANSFORMY (IDIFFERENCE (ELT (fetch (SPLINE SPLINEY) of SPLINE)
1)
(LRSH (SUB1 BRUSHHEIGHT)
1))
DISPLAYDATA]
[bind PERSEG for KNOT from 1 to (SUB1 (fetch #KNOTS of SPLINE))
do (SETQ X0 (ELT (fetch (SPLINE SPLINEX) of SPLINE)
KNOT))
(SETQ Y0 (ELT (fetch (SPLINE SPLINEY) of SPLINE)
KNOT))
(SETQ X1 (ELT (fetch (SPLINE SPLINEX) of SPLINE)
(ADD1 KNOT)))
(SETQ Y1 (ELT (fetch (SPLINE SPLINEY) of SPLINE)
(ADD1 KNOT)))
(SETQ DX (ELT (fetch (SPLINE SPLINEDX) of SPLINE)
KNOT))
(SETQ DY (ELT (fetch (SPLINE SPLINEDY) of SPLINE)
KNOT))
(SETQ DDX (ELT (fetch SPLINEDDX of SPLINE)
KNOT))
(SETQ DDY (ELT (fetch SPLINEDDY of SPLINE)
KNOT))
(SETQ DDDX (ELT (fetch SPLINEDDDX of SPLINE)
KNOT))
(SETQ DDDY (ELT (fetch SPLINEDDDY of SPLINE)
KNOT))
(SETQ NPOINTS (FOLDLO (ITIMES (IMAX (IABS (IDIFFERENCE X1 X0))
(IABS (IDIFFERENCE Y1 Y0)))
3)
2))
[COND
((EQ NPOINTS 0)
(* I don't understand why but certains cases e.g. knots = (QUOTE ((96 . 104) (96 . 105) (96 . 105)
(96 . 106))) cause NPOINTS to be 0 and generate a divide by 0 error. rrb -
1-oct-85)
(RETURN))
((ILEQ NPOINTS 64)
(SETQ NSEGS 1)
(SETQ POINTSPERSEG NPOINTS))
(T (SETQ NSEGS (FOLDLO NPOINTS 64))
(SETQ POINTSPERSEG 64)
(SETQ NPOINTS (UNFOLD NSEGS 64]
(SETQ D1 (FQUOTIENT 1.0 NPOINTS))
(SETQ D2 (FTIMES D1 D1))
(SETQ D3 (FTIMES D2 D1))
(SETQ D3X (FTIMES D3 DDDX))
(SETQ D3Y (FTIMES D3 DDDY))
(COND
[(EQ NSEGS 1)
[SETQ DX (FPLUS (FTIMES D1 DX)
(FTIMES DDX D2 .5)
(FTIMES DDDX D3 (CONSTANT (FQUOTIENT 1.0 6.0]
(SETQ D2X (FPLUS (FTIMES D2 DDX)
(FTIMES D3 DDDX)))
[SETQ DY (FPLUS (FTIMES D1 DY)
(FTIMES D2 DDY .5)
(FTIMES D3 DDDY (CONSTANT (FQUOTIENT 1.0 6.0]
(SETQ D2Y (FPLUS (FTIMES D2 DDY)
(FTIMES D3 DDDY)))
(COND
(USERFN (\CURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y NPOINTS BRUSHBM DISPLAYDATA
BBT NIL USERFN DISPLAYSTREAM))
(T (.WHILE.TOP.DS. DISPLAYSTREAM
(\CURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y NPOINTS BRUSHBM
DISPLAYDATA BBT NIL NIL DISPLAYSTREAM]
(T (SETQ PERSEG (FQUOTIENT 1.0 NSEGS))
(LOADPOLY XPOLY X/PRIME/POLY DDDX DDX DX X0)
(LOADPOLY YPOLY Y/PRIME/POLY DDDY DDY DY Y0)
(bind (TT ← 0.0)
(DDDX/PER/SEG ←(FTIMES DDDX PERSEG))
(DDDY/PER/SEG ←(FTIMES DDDY PERSEG))
[D3XFACTOR ←(FTIMES D3 DDDX (CONSTANT (FQUOTIENT 1.0 6.0]
[D3YFACTOR ←(FTIMES D3 DDDY (CONSTANT (FQUOTIENT 1.0 6.0] for I
from 0 to (SUB1 NSEGS)
do (SETQ TT (FPLUS TT PERSEG))
(SETQ X1 (POLYEVAL TT XPOLY 3))
(SETQ Y1 (POLYEVAL TT YPOLY 3))
(SETQ DX (FPLUS (FTIMES D1 DX)
(FTIMES D2 DDX .5)
D3XFACTOR))
(SETQ D2X (FPLUS (FTIMES D2 DDX)
(FTIMES D3 DDDX)))
(SETQ DY (FPLUS (FTIMES D1 DY)
(FTIMES D2 DDY .5)
D3YFACTOR))
(SETQ D2Y (FPLUS (FTIMES D2 DDY)
(FTIMES D3 DDDY)))
[COND
(USERFN (\CURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y 64 BRUSHBM DISPLAYDATA
BBT NIL USERFN DISPLAYSTREAM))
(T (.WHILE.TOP.DS. DISPLAYSTREAM
(\CURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y 64 BRUSHBM
DISPLAYDATA BBT NIL NIL DISPLAYSTREAM]
(SETQ X0 X1)
(SETQ Y0 Y1)
(SETQ DDX (FPLUS DDX DDDX/PER/SEG))
(SETQ DDY (FPLUS DDY DDDY/PER/SEG))
(SETQ DX (POLYEVAL TT X/PRIME/POLY 2))
(SETQ DY (POLYEVAL TT Y/PRIME/POLY 2]
(COND
(USERFN (\CURVE 0 0 0 0 0 0 0 0 0 0 0 BRUSHBM DISPLAYDATA BBT T USERFN DISPLAYSTREAM))
(T (.WHILE.TOP.DS. DISPLAYSTREAM
(\CURVE 0 0 0 0 0 0 0 0 0 0 0 BRUSHBM DISPLAYDATA BBT T NIL
DISPLAYSTREAM])
(\CURVEEND
[LAMBDA NIL (* rrb " 5-JAN-82 17:24")
(* Put out the last two points, using \CURVEPT, since
they were held back for smoothing.)
(PROG ((X \CURX)
(Y \CURY)
(DX (IDIFFERENCE \CURX \OLDX))
(DY (IDIFFERENCE \CURY \OLDY)))
(for I from 1 to 2 do (\CURVESMOOTH (SETQ X (IPLUS X DX))
(SETQ Y (IPLUS Y DY])
(\CURVESLOPE
[LAMBDA (KNOTS ENDFLG) (* rrb "30-Nov-84 18:17")
(* returns a CONS of DX DY that gives the slope of the curve thru KNOTS. If ENDFLG is NIL, it is at the beginning.
If ENDFLG is T, it is at the last point.)
(PROG (DX DY PARAMS (#KNOTS (LENGTH KNOTS)))
(RETURN (SELECTQ #KNOTS
((0 1) (* define slope as horizontal)
(QUOTE (1 . 0)))
[2 (CONS (DIFFERENCE (fetch (POSITION XCOORD) of (CADR KNOTS))
(fetch (POSITION XCOORD) of (CAR KNOTS)))
(DIFFERENCE (fetch (POSITION YCOORD) of (CADR KNOTS))
(fetch (POSITION YCOORD) of (CAR KNOTS]
(PROGN [SETQ PARAMS (COND
[ENDFLG (PARAMETRICSPLINE (REVERSE (NLEFT KNOTS
(IMIN #KNOTS 4]
(T (PARAMETRICSPLINE (COND
((EQ #KNOTS 3)
(LIST (CAR KNOTS)
(CADR KNOTS)
(CADDR KNOTS)))
(T (LIST (CAR KNOTS)
(CADR KNOTS)
(CADDR KNOTS)
(CADDDR KNOTS]
(SETQ DX (ELT (fetch (SPLINE SPLINEDX) of PARAMS)
1))
(SETQ DY (ELT (fetch (SPLINE SPLINEDY) of PARAMS)
1))
(if ENDFLG
then (CONS (MINUS DX)
(MINUS DY))
else (CONS DX DY])
(\CURVESTART
[LAMBDA (X Y) (* jds "27-OCT-81 15:48")
(* Set up the init vals for \OLDER* \OLD* \CUR*, for
curve smoothing in \CURVEPT.)
(SETQ \OLDERX X)
(SETQ \OLDX X)
(SETQ \CURX X)
(SETQ \OLDERY Y)
(SETQ \OLDY Y)
(SETQ \CURY Y])
(\FDIFS/FROM/DERIVS
[LAMBDA (DZ DDZ DDDZ RAD NSTEPS) (* rrb "12-MAY-81 10:59")
(* the derivatives of the function, plus a scale factor
(radius for drawing circles) See
"Spline Curve Techniques", equations 2.18.)
(PROG (S SS SSS)
(SETQ S (FQUOTIENT 1.0 NSTEPS))
(SETQ SS (FTIMES S S))
(SETQ SSS (FTIMES SS S))
(SETQ S (FTIMES S DZ RAD))
(SETQ SS (FTIMES SS DDZ RAD))
(SETQ SSS (FTIMES SSS DDDZ RAD))
(RETURN (LIST (FPLUS S (FQUOTIENT SS 2.0)
(FQUOTIENT SSS 6.0))
(FPLUS SS SSS)
SSS])
)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(ARRAYRECORD POLYNOMIAL (A B C D)
(CREATE (ARRAY 4 (QUOTE FLOATP)))
(SYSTEM))
(RECORD SPLINE (#KNOTS SPLINEX SPLINEY SPLINEDX SPLINEDY SPLINEDDX SPLINEDDY SPLINEDDDX SPLINEDDDY))
]
(* END EXPORTED DEFINITIONS)
)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS HALF MACRO ((X)
(LRSH X 1)))
(PUTPROPS \FILLCIRCLEBLT MACRO (OPENLAMBDA (CX CY X Y)
(* calls bitblt twice to fill in one line of the circle.)
(\LINEBLT FCBBT (IDIFFERENCE CX X)
(IPLUS CY Y)
(IPLUS CX X)
DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM
TOP GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS)
(\LINEBLT FCBBT (IDIFFERENCE CX X)
(IDIFFERENCE CY Y)
(IPLUS CX X)
DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM
TOP GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS)))
)
(* END EXPORTED DEFINITIONS)
(DECLARE: EVAL@COMPILE
[PUTPROPS \CURVEPT MACRO
(OPENLAMBDA (X Y)
(* puts a brush shape at point X,Y. Assumes X and Y have been corrected so that
it is the lower left corner of the brush. Does a clipping to the region
defined by LEFT RIGHTPLUS1 BOTTOM and LEFTMINUSBRUSH TOPMINUSBRUSH
BOTTOMMINUSBRUSH.)
(COND ((OR (ILEQ X LEFTMINUSBRUSH)
(IGEQ X RIGHTPLUS1)
(ILEQ Y BOTTOMMINUSBRUSH)
(IGEQ Y TOP))
(* Brush is entirely out of region)
NIL)
((NULL BBT)
(* Special case of single point brush)
(\FBITMAPBIT DESTINATIONBASE X Y OPERATION HEIGHTMINUS1 RASTERWIDTH))
(T (* Some part of the brush in in the region)
(\BBTCURVEPT X Y BBT LEFT BRUSHWIDTH LEFTMINUSBRUSH RIGHTPLUS1
NBITSRIGHTPLUS1 TOPMINUSBRUSH DestinationBitMap
BRUSHHEIGHT BOTTOMMINUSBRUSH TOP BRUSHBASE
DESTINATIONBASE RASTERWIDTH BRUSHRASTERWIDTH
COLORBRUSHBASE NBITS DISPLAYDATA]
[PUTPROPS .SETUP.FOR.\BBTCURVEPT. MACRO
(NIL (* rrb " 9-DEC-82 10:52")
(PROGN (SETQ BOTTOM (ffetch DDClippingBottom of DISPLAYDATA))
(SETQ TOP (ffetch DDClippingTop of DISPLAYDATA))
(SETQ RIGHTPLUS1 (ffetch DDClippingRight of DISPLAYDATA))
(SETQ LEFT (ffetch DDClippingLeft of DISPLAYDATA))
(SETQ DestinationBitMap (ffetch DDDestination of DISPLAYDATA))
(SETQ OPERATION (SELECTQ (ffetch DDOPERATION of DISPLAYDATA)
((INVERT ERASE)
(QUOTE ERASE))
(QUOTE REPLACE)))
[COND [(NEQ (SETQ NBITS (fetch (BITMAP BITMAPBITSPERPIXEL)
of DestinationBitMap))
1)
(* need to use color brush. For this case, set BRUSHBM to the ground
bitmap and COLORBRUSHBM to the colors to be added.)
(* save only the pointer to the bitmap)
(SETQ BRUSHBM (\GETCOLORBRUSH BRUSH (COND ((EQ NBITS 4)
15)
(T 255))
NBITS))
[COND ((EQ OPERATION (QUOTE ERASE))
(* for an ERASE operation, paint in background color.)
[SETQ COLOR (COND ((DSPBACKCOLOR NIL DISPLAYSTREAM))
(T (QUOTE WHITE]
(SETQ OPERATION (QUOTE REPLACE)))
(T (SETQ COLOR (COND [(AND (LISTP BRUSH)
(CAR (LISTP (CDDR BRUSH]
((DSPCOLOR NIL DISPLAYSTREAM))
(T (QUOTE BLACK]
(* only save the base of the color brush because everything else is the
same as BRUSHBM.)
(SETQ COLORBRUSHBASE (fetch (BITMAP BITMAPBASE)
of
(\GETCOLORBRUSH BRUSH COLOR NBITS]
(T (SETQ BRUSHBM (\GETBRUSH BRUSH]
(SETQ RASTERWIDTH (fetch BITMAPRASTERWIDTH of DestinationBitMap))
(SETQ DESTINATIONBASE (fetch BITMAPBASE of DestinationBitMap))
(SETQ BBT (\GETBRUSHBBT BRUSHBM DISPLAYDATA BBT))
(SETQ BRUSHBASE (fetch BITMAPBASE of BRUSHBM))
(* keep Brush width and raster width in number of bits units.)
(SETQ BRUSHRASTERWIDTH (fetch BITMAPRASTERWIDTH of BRUSHBM))
(SETQ BRUSHWIDTH (fetch BITMAPWIDTH of BRUSHBM))
[COND ((NOT BBT)
(* BBT is NIL if single point brush. Set the destination bitmap base.)
(SETQ HEIGHTMINUS1 (SUB1 (fetch BITMAPHEIGHT of DestinationBitMap)))
(COND ((EQ (ffetch DDOPERATION of DISPLAYDATA)
(QUOTE INVERT))
(* really do invert in single brush case.)
(SETQ OPERATION (QUOTE INVERT]
(SELECTQ NBITS (1 (SETQ LEFTMINUSBRUSH (IDIFFERENCE LEFT BRUSHWIDTH)))
(4 (SETQ LEFTMINUSBRUSH (IDIFFERENCE LEFT (LRSH BRUSHWIDTH 2)))
(* this would have to be recalculated each point if coordinates
were kept in pixels to translate it to number of bits.)
(SETQ NBITSRIGHTPLUS1 (LLSH RIGHTPLUS1 2)))
(8 (SETQ LEFTMINUSBRUSH (IDIFFERENCE LEFT (LRSH BRUSHWIDTH 3)))
(SETQ NBITSRIGHTPLUS1 (LLSH RIGHTPLUS1 3)))
(SHOULDNT))
(SETQ BRUSHHEIGHT (fetch BITMAPHEIGHT of BRUSHBM))
(SETQ BOTTOMMINUSBRUSH (IDIFFERENCE BOTTOM BRUSHHEIGHT))
(SETQ TOPMINUSBRUSH (IDIFFERENCE TOP BRUSHHEIGHT]
[PUTPROPS \CIRCLEPTS MACRO (OPENLAMBDA (CX CY X Y)
(\CURVEPT (IPLUS CX X)
(IPLUS CY Y))
(\CURVEPT (IDIFFERENCE CX X)
(IPLUS CY Y))
(\CURVEPT (IPLUS CX X)
(IDIFFERENCE CY Y))
(\CURVEPT (IDIFFERENCE CX X)
(IDIFFERENCE CY Y]
[PUTPROPS \CURVESMOOTH MACRO (OPENLAMBDA (NEWX NEWY USERFN DISPLAYSTREAM)
(PROG [(DX (IABS (IDIFFERENCE NEWX \OLDX)))
(DY (IABS (IDIFFERENCE NEWY \OLDY]
(COND ((OR (IGREATERP DX 1)
(IGREATERP DY 1))
[COND
((NEQ [IPLUS (ADD1 (IDIFFERENCE \OLDX \OLDERX)
)
(ITIMES 3
(ADD1 (IDIFFERENCE
\OLDY \OLDERY]
4)
[COND (DASHON (COND
(USERFN (APPLY* USERFN \OLDX
\OLDY
DISPLAYSTREAM))
(T (.WHILE.TOP.DS.
DISPLAYSTREAM
(\CURVEPT \OLDX \OLDY]
(COND
(DASHTAIL
(COND ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT)
))
(SETQ DASHON (NOT DASHON))
(SETQ DASHTAIL
(OR (LISTP (CDR DASHTAIL))
DASHLST))
(SETQ DASHCNT (CAR DASHTAIL]
(SETQ \OLDERX \OLDX)
(SETQ \OLDERY \OLDY)
(SETQ \OLDX \CURX)
(SETQ \OLDY \CURY)))
(SETQ \CURX NEWX)
(SETQ \CURY NEWY]
)
)
(DEFINEQ
(\FILLCIRCLE.DISPLAY
[LAMBDA (DISPLAYSTREAM CENTERX CENTERY RADIUS TEXTURE) (* rrb "30-Apr-85 14:14")
(* DISPLAYSTREAM is guaranteed to be a display stream)
(COND
((OR (NOT (NUMBERP RADIUS))
(ILESSP (SETQ RADIUS (FIXR RADIUS))
0))
(\ILLEGAL.ARG RADIUS))
(T (GLOBALRESOURCE \BRUSHBBT
(PROG (TOP BOTTOM RIGHT LEFT OPERATION DestinationBitMap
(DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM))
(X 0)
(Y RADIUS)
(D (ITIMES 2 (IDIFFERENCE 1 RADIUS)))
DESTINATIONBASE RASTERWIDTH CX CY TEXTUREBM GRAYHEIGHT GRAYWIDTH
GRAYBASE NBITS (FCBBT \BRUSHBBT))
(SETQ TOP (SUB1 (fetch DDClippingTop of DISPLAYDATA)))
(SETQ BOTTOM (fetch DDClippingBottom of DISPLAYDATA))
(SETQ LEFT (fetch DDClippingLeft of DISPLAYDATA))
(SETQ RIGHT (SUB1 (fetch DDClippingRight of DISPLAYDATA)))
(SETQ OPERATION (ffetch DDOPERATION of DISPLAYDATA))
(SETQ DestinationBitMap (fetch DDDestination of DISPLAYDATA))
(SETQ NBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DestinationBitMap))
[SETQ TEXTUREBM
(COND
((BITMAPP TEXTURE))
[(AND (NEQ NBITS 1)
(BITMAPP (COLORTEXTUREFROMCOLOR# (COLORNUMBERP
(OR TEXTURE
(DSPCOLOR NIL
DISPLAYSTREAM]
[(AND (NULL TEXTURE)
(BITMAPP (ffetch DDTexture of DISPLAYDATA]
([OR (FIXP TEXTURE)
(AND (NULL TEXTURE)
(SETQ TEXTURE (ffetch DDTexture of DISPLAYDATA]
(* create bitmap for the texture.
Could reuse a bitmap but for now this is good enough.)
(SETQ TEXTUREBM (BITMAPCREATE 16 4))
(SETQ GRAYBASE (fetch (BITMAP BITMAPBASE) of TEXTUREBM))
(\PUTBASE GRAYBASE 0 (\SFReplicate (LOGAND (LRSH TEXTURE 12)
15)))
(\PUTBASE GRAYBASE 1 (\SFReplicate (LOGAND (LRSH TEXTURE 8)
15)))
(\PUTBASE GRAYBASE 2 (\SFReplicate (LOGAND (LRSH TEXTURE 4)
15)))
(\PUTBASE GRAYBASE 3 (\SFReplicate (LOGAND TEXTURE 15)))
TEXTUREBM)
(T (\ILLEGAL.ARG TEXTURE]
(SETQ GRAYBASE (fetch (BITMAP BITMAPBASE) of TEXTUREBM))
(SETQ DESTINATIONBASE (fetch BITMAPBASE of DestinationBitMap))
(SETQ RASTERWIDTH (fetch BITMAPRASTERWIDTH of DestinationBitMap))
(* update as many fields in the brush bitblt table as
possible from DS.)
(replace PBTFLAGS of FCBBT with 0)
(replace PBTDESTBPL of FCBBT with (UNFOLD RASTERWIDTH BITSPERWORD))
(* clear gray information. PBTSOURCEBPL is used for
gray information too.)
(replace PBTSOURCEBPL of FCBBT with 0)
(replace PBTUSEGRAY of FCBBT with T)
[replace PBTGRAYWIDTHLESSONE of FCBBT
with (SUB1 (SETQ GRAYWIDTH (IMIN (fetch (BITMAP BITMAPWIDTH)
of TEXTUREBM)
16]
[replace PBTGRAYHEIGHTLESSONE of FCBBT
with (SUB1 (SETQ GRAYHEIGHT (IMIN (fetch (BITMAP BITMAPHEIGHT)
of TEXTUREBM)
16]
(replace PBTDISJOINT of FCBBT with T)
(\SETPBTFUNCTION FCBBT (QUOTE TEXTURE)
OPERATION)
(replace PBTHEIGHT of FCBBT with 1)
(* take into account the brush thickness.)
(SETQ CX (\DSPTRANSFORMX CENTERX DISPLAYDATA))
(SETQ CY (\DSPTRANSFORMY CENTERY DISPLAYDATA))
(* change Y TOP and BOTTOM to be in bitmap coordinates)
(SETQ CY (SUB1 (\SFInvert DestinationBitMap CY)))
[SETQ BOTTOM (PROG1 (SUB1 (\SFInvert DestinationBitMap TOP))
(SETQ TOP (SUB1 (\SFInvert DestinationBitMap
BOTTOM]
(\INSURETOPWDS DISPLAYSTREAM)
(* Move the window to top while interruptable, but
verify that it is still there uninterruptably with
drawing points)
(COND
((EQ RADIUS 0) (* put a single point down. Use \LINEBLT to get proper
texture. NIL)
(.WHILE.TOP.DS. DISPLAYSTREAM
(\LINEBLT FCBBT CX CY CX DESTINATIONBASE
RASTERWIDTH LEFT RIGHT BOTTOM TOP
GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS))
(RETURN)))
LP (* (UNFOLD x 2) is used instead of
(ITIMES x 2))
[COND
[(IGREATERP 0 D)
(SETQ X (ADD1 X))
(COND
((IGREATERP (UNFOLD (IPLUS D Y)
2)
1)
(SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y)
2)
4)))
(T (SETQ D (IPLUS D (UNFOLD X 2)
1)) (* don't draw unless Y changes.)
(GO LP]
((OR (EQ 0 D)
(IGREATERP X D))
(SETQ X (ADD1 X))
(SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y)
2)
4)))
(T (SETQ D (IPLUS (IDIFFERENCE D (UNFOLD Y 2))
3]
(COND
((EQ Y 0) (* draw the middle line differently to avoid
duplication.)
(.WHILE.TOP.DS. DISPLAYSTREAM (\LINEBLT FCBBT (IDIFFERENCE CX X)
CY
(IPLUS CX X)
DESTINATIONBASE
RASTERWIDTH LEFT RIGHT
BOTTOM TOP GRAYWIDTH
GRAYHEIGHT GRAYBASE NBITS))
)
(T (.WHILE.TOP.DS. DISPLAYSTREAM (\FILLCIRCLEBLT CX CY X Y))
(SETQ Y (SUB1 Y))
(GO LP)))
(MOVETO CENTERX CENTERY DISPLAYSTREAM)
(RETURN NIL])
(\LINEBLT
[LAMBDA (BBT X Y XRIGHT DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT
GRAYBASE NBITS) (* rrb "21-DEC-82 16:53")
(* fills in the changing fields of a bit blt tablt to
draw one line of aan area.)
(PROG NIL
(COND
((ILESSP X LEFT)
(SETQ X LEFT)))
(COND
((IGREATERP XRIGHT RIGHT)
(SETQ XRIGHT RIGHT)))
(COND
((OR (IGREATERP X XRIGHT)
(IGREATERP Y TOP)
(IGREATERP BOTTOM Y))
(RETURN)))
(replace PBTDEST of BBT with (\ADDBASE DESTINATIONBASE (ITIMES RASTERWIDTH Y)))
[replace PBTSOURCE of BBT with (\ADDBASE GRAYBASE (replace PBTGRAYOFFSET of BBT
with (MOD Y GRAYHEIGHT]
(SELECTQ NBITS
[1 (replace PBTDESTBIT of BBT with X)
(replace PBTSOURCEBIT of BBT with (MOD X GRAYWIDTH))
(replace PBTWIDTH of BBT with (ADD1 (IDIFFERENCE XRIGHT X]
(4 (* color case, shift x values {which are in pixels} into
bit values.)
(replace PBTDESTBIT of BBT with (SETQ X (LLSH X 2)))
(* if TEXTURE is not a multiple of nbits wide this is
probably garbage.)
(replace PBTSOURCEBIT of BBT with (MOD X GRAYWIDTH))
(replace PBTWIDTH of BBT with (IDIFFERENCE (LLSH (ADD1 XRIGHT)
2)
X)))
(8 (* color case, shift x values {which are in pixels} into
bit values.)
(replace PBTDESTBIT of BBT with (SETQ X (LLSH X 3)))
(replace PBTSOURCEBIT of BBT with (MOD X GRAYWIDTH))
(replace PBTWIDTH of BBT with (IDIFFERENCE (LLSH (ADD1 XRIGHT)
3)
X)))
(SHOULDNT))
(\PILOTBITBLT BBT 0])
)
(* making and copying bitmaps)
(DEFINEQ
(SCREENBITMAP
[LAMBDA NIL (* lmm "22-MAR-81 10:46")
(* normally macros out)
ScreenBitMap])
(BITMAPP
[LAMBDA (X) (* rrb "25-JUN-82 15:21")
(* is x a bitmap?)
(AND (type? BITMAP X)
X])
(BITMAPHEIGHT
[LAMBDA (BITMAP) (* rrb "17-Jul-84 16:10")
(* returns the height in pixels of a bitmap.)
(fetch (BITMAP BITMAPHEIGHT) of (\DTEST BITMAP (QUOTE BITMAP])
(BITMAPPROP
[LAMBDA (BITMAP PROP) (* hdj "14-Dec-84 15:03")
(COND
((\DTEST BITMAP (QUOTE BITMAP))
(SELECTQ PROP
(WIDTH (BITMAPWIDTH BITMAP))
(HEIGHT (BITMAPHEIGHT BITMAP))
(BITSPERPIXEL (BITSPERPIXEL BITMAP))
((RASTERWIDTH WORDWIDTH)
(fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP))
NIL))
(T (\ILLEGAL.ARG BITMAP])
(BITSPERPIXEL
[LAMBDA (BITMAP) (* rrb "17-Jul-84 16:10")
(* returns the height in pixels of a bitmap.)
(fetch (BITMAP BITMAPBITSPERPIXEL) of (\DTEST BITMAP (QUOTE BITMAP])
(CLR
[LAMBDA (DS) (* rrb "13-AUG-81 11:44")
(* clears a display stream. Default to the tty.
screen)
(BITBLT NIL 0 0 (OR DS (TTYDISPLAYSTREAM))
0 0 NIL NIL (QUOTE TEXTURE)
(QUOTE REPLACE)
WHITESHADE])
)
(* FOLLOWING DEFINITIONS EXPORTED)
(PUTDEF (QUOTE BITMAPS) (QUOTE FILEPKGCOMS) [QUOTE ((COM MACRO (X (VARS . X])
(PUTDEF (QUOTE CURSORS) (QUOTE FILEPKGCOMS) [QUOTE ((COM MACRO (X (E (MAPC (QUOTE X)
(QUOTE PRINTCURSOR])
(* END EXPORTED DEFINITIONS)
(DECLARE: EVAL@COMPILE
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS SCREENBITMAP MACRO (NIL ScreenBitMap))
(PUTPROPS BITMAPP MACRO (OPENLAMBDA (X)
(AND (type? BITMAP X)
X)))
)
(ADDTOVAR GLOBALVARS SCREENHEIGHT SCREENWIDTH ScreenBitMap)
(* END EXPORTED DEFINITIONS)
)
(* Display stream functions that are not needed in the primitive system)
(DEFINEQ
(CLOSEDISPLAYSTREAM
[LAMBDA NIL (* rrb " 3-Apr-84 19:47")
(\STOPDISPLAY])
(DSPFILL
[LAMBDA (REGION TEXTURE OPERATION STREAM) (* rmk: " 4-Dec-84 09:48")
(* wipes a region of an imagestream with texture.)
(* TEXTURE and OPERATION default to those of STREAM)
(PROG ((STRM (\OUTSTREAMARG STREAM)))
(OR REGION (SETQ REGION (DSPCLIPPINGREGION NIL STRM)))
(RETURN (BLTSHADE TEXTURE STRM (fetch LEFT of REGION)
(fetch BOTTOM of REGION)
(fetch WIDTH of REGION)
(fetch HEIGHT of REGION)
OPERATION])
(INVERTW
[LAMBDA (WIN SHADE) (* rrb "18-May-84 21:52")
(* inverts a window and returns the window.
Used in RESETFORMS.)
(DSPFILL (DSPCLIPPINGREGION NIL WIN)
(OR SHADE BLACKSHADE)
(QUOTE INVERT)
WIN)
WIN])
)
(DEFINEQ
(\DSPCOLOR.DISPLAY
[LAMBDA (STREAM COLOR) (* rmk: "12-Sep-84 09:52")
(* sets and returns a display stream's foreground
color.)
(PROG (NOWCOLOR (DD (\GETDISPLAYDATA STREAM)))
(SETQ NOWCOLOR (fetch DDCOLOR of DD))
(RETURN (COND
(COLOR (OR (\POSSIBLECOLOR COLOR)
(\ILLEGAL.ARG COLOR))
(PROG1 (COND
(NOWCOLOR (PROG1 (CAR NOWCOLOR)
(RPLACA NOWCOLOR COLOR)))
(T (* no color cell yet, make one.)
(replace DDCOLOR of DD with (CONS COLOR BLACKCOLOR))
WHITECOLOR))
(\SFFixFont STREAM DD)))
(T (OR (CAR NOWCOLOR)
WHITECOLOR])
(\DSPBACKCOLOR.DISPLAY
[LAMBDA (STREAM COLOR) (* rmk: "12-Sep-84 09:54")
(* sets and returns a display stream's background
color.)
(PROG (COLORCELL (DD (\GETDISPLAYDATA STREAM)))
(SETQ COLORCELL (fetch DDCOLOR of DD))
(RETURN (COND
(COLOR (OR (\POSSIBLECOLOR COLOR)
(\ILLEGAL.ARG COLOR))
(PROG1 (COND
(COLORCELL (PROG1 (CDR COLORCELL)
(RPLACD COLORCELL COLOR)))
(T (* no color cell yet, make one.)
(replace DDCOLOR of DD with (CONS WHITECOLOR COLOR))
BLACKCOLOR))
(\SFFixFont STREAM DD)))
(T (OR (CDR COLORCELL)
BLACKCOLOR])
(DSPEOLFN
[LAMBDA (EOLFN DISPLAYSTREAM) (* rrb "18-May-84 21:44")
(* sets the end of line function for a displaystream. EOLFN will be called every EOL with the argument of the
display stream. If EOLFN is (QUOTE OFF,) the eolfn is cleared.)
(PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM)))
(RETURN (PROG1 (COND
((fetch (\DISPLAYDATA DDEOLFN) of DD))
(T (QUOTE OFF)))
(AND EOLFN (COND
[(LITATOM EOLFN)
(replace (\DISPLAYDATA DDEOLFN) of DD
with (COND
((EQ EOLFN (QUOTE OFF))
NIL)
(T EOLFN]
(T (\ILLEGAL.ARG EOLFN])
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(RPAQQ BLACKSHADE 65535)
(RPAQQ WHITESHADE 0)
(CONSTANTS (BLACKSHADE 65535)
(WHITESHADE 0))
)
(RPAQQ GRAYSHADE 43605)
(RPAQQ BLACKCOLOR 0)
(RPAQQ WHITECOLOR 7)
(ADDTOVAR GLOBALVARS GRAYSHADE WHITECOLOR BLACKCOLOR)
(* END EXPORTED DEFINITIONS)
(DECLARE: EVAL@COMPILE
(PUTPROPS DSPRUBOUTCHAR MACRO ((DS CHAR X Y TTBL)
(\DSPMOVELR DS CHAR X Y TTBL NIL T)))
)
(DEFINEQ
(DSPCLEOL
[LAMBDA (DISPLAYSTREAM XPOS YPOS HEIGHT) (* lmm " 3-May-84 10:31")
(\CHECKCARET DISPLAYSTREAM)
(PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM DISPLAYSTREAM)))
(RETURN (BITBLT NIL NIL NIL DISPLAYSTREAM (OR (FIXP XPOS)
(SETQ XPOS (ffetch DDLeftMargin of DD)))
[OR (FIXP YPOS)
(IDIFFERENCE (ffetch DDYPOSITION of DD)
(FONTPROP DISPLAYSTREAM (QUOTE DESCENT]
(IMAX 0 (IDIFFERENCE (ffetch DDRightMargin of DD)
XPOS))
(OR (FIXP HEIGHT)
(IMINUS (ffetch DDLINEFEED of DD)))
(QUOTE TEXTURE)
(QUOTE REPLACE])
(DSPRUBOUTCHAR
[LAMBDA (STREAM CHAR X Y TTBL) (* rmk: "25-AUG-83 11:42")
(if (DISPLAYSTREAMP CHAR)
then (* Some older code may use the CHAR argument first.
Newer code will be converted by the macro expansion of
DSPRUBOUTCHAR)
(swap STREAM CHAR)
(SETQ TTBL X)
(SETQ X)
(SETQ Y))
(\MACRO.MX (DSPRUBOUTCHAR (PROGN (\GETDISPLAYDATA STREAM STREAM)
STREAM)
CHAR X Y TTBL))])
(\DSPMOVELR
(LAMBDA (DS CHAR X Y TTBL RIGHTWARDSFLG ERASEFLG) (* JonL " 7-May-84 02:47")
(* Moves the cursor "leftwards" (or "rightwards" if RIGHTWARDSFLG is non-null) over any main character and control
or meta indicators. Returns NIL if the move can't be determined, such as trying to move left when already at the
left margin. Effaces (or "Rubs out") any bits moved over if ERASEFLG is non-null.)
((LAMBDA (DD)
(* * Must do the \GETDISPLAYDATA first, since it may reset DS when it coerces to a DISPLAYSTREAM)
(PROG ((WIDTH (\STREAMCHARWIDTH (COND
((CHARCODEP CHAR)
CHAR)
(T (CHARCODE M)))
DS TTBL))
(DEFAULTPOS? (AND (NULL X)
(NULL Y))))
(OR ERASEFLG DEFAULTPOS? (SHOULDNT)) (* CURSORLEFT and CURSORRIGHT commands aren't allowed to
start from anywhere except current spot)
(* Note that if CHAR is not specified and DS has a variable-pitch font, then the results may be somewhat random.
Smart terminal drivers thus can work well only on fixed-pitch fonts.)
(COND
((NULL WIDTH)
(RETURN))
((EQ 0 WIDTH) (* Ha, what an easy case)
(RETURN T)))
(OR (FIXP X)
(SETQ X (ffetch DDXPOSITION of DD)))
(OR (FIXP Y)
(SETQ Y (ffetch DDYPOSITION of DD)))
(COND
((COND
(RIGHTWARDSFLG (IGREATERP (add X WIDTH)
(ffetch DDRightMargin of DD)))
(T (ILESSP (add X (IMINUS WIDTH))
(ffetch DDLeftMargin of DD))))
(* If we can't do the full backup, then return NIL to
signal this fact)
(RETURN)))
(\CHECKCARET DS) (* Take down the caret, if there is one, just in case we
are moving over it.)
(COND
(ERASEFLG (* And do the erasure if requested)
((LAMBDA (FONT)
(PROG ((YPRIME (IDIFFERENCE Y (FONTDESCENT FONT)))
(HEIGHT (FONTHEIGHT FONT)))
(COND
((NOT DEFAULTPOS?)
(MOVETO X Y DS) (* Backup over the bits, and "wipe" them out.)
))
(BITBLT NIL 0 0 DS X YPRIME WIDTH HEIGHT (QUOTE TEXTURE)
(QUOTE REPLACE))
(* wipe out some bits)
))
(ffetch DDFONT of DD))))
(DSPXPOSITION X DS) (* Now do the move.)
(RETURN T)))
(\GETDISPLAYDATA DS DS))))
)
(* for cursor)
(RPAQ \DefaultCursor (READBITMAP))
(16 16
"H@@@"
"L@@@"
"N@@@"
"O@@@"
"OH@@"
"OL@@"
"ON@@"
"O@@@"
"MH@@"
"IH@@"
"@L@@"
"@L@@"
"@F@@"
"@F@@"
"@C@@"
"@C@@")
(DECLARE: DONTEVAL@LOAD DOCOPY
(RPAQ? DEFAULTCURSOR (CURSORCREATE \DefaultCursor 0 15))
)
(DECLARE: DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS DEFAULTCURSOR)
)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA UNIONREGIONS INTERSECTREGIONS)
)
(PUTPROPS ADISPLAY COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (7799 14399 (\BBTCURVEPT 7809 . 12653) (\CHANGEBACKGROUND.DISPLAY 12655 . 13749) (
\CHANGEBACKGROUNDBORDER.DISPLAY 13751 . 14397)) (14400 18957 (CREATETEXTUREFROMBITMAP 14410 . 15873) (
PRINTBITMAP 15875 . 17068) (PRINTCURSOR 17070 . 17905) (\WRITEBITMAP 17907 . 18955)) (18958 20792 (
\GETINTEGERPART 18968 . 20087) (\CONVERTTOFRACTION 20089 . 20790)) (23826 33150 (CARET 23836 . 24904)
(\CARET.CREATE 24906 . 25085) (\CARET.DOWN 25087 . 26076) (\CARET.FLASH? 26078 . 27635) (\CARET.SHOW
27637 . 30489) (CARETRATE 30491 . 31106) (\CARET.FLASH.AGAIN 31108 . 31938) (\CARET.FLASH.MULTIPLE
31940 . 32415) (\CARET.FLASH 32417 . 33148)) (33506 35121 (\AREAVISIBLE? 33516 . 34288) (
\REGIONOVERLAPAREAP 34290 . 34802) (\AREAINREGIONP 34804 . 35119)) (35178 35975 (CURSORP 35188 . 35455
) (CURSORBITMAP 35457 . 35503) (CreateCursorBitMap 35505 . 35973)) (36350 46387 (CREATEREGION 36360 .
36668) (REGIONP 36670 . 36809) (INTERSECTREGIONS 36811 . 38840) (UNIONREGIONS 38842 . 40241) (
REGIONSINTERSECTP 40243 . 40812) (SUBREGIONP 40814 . 41433) (EXTENDREGION 41435 . 43104) (
EXTENDREGIONBOTTOM 43106 . 43673) (EXTENDREGIONLEFT 43675 . 44219) (EXTENDREGIONRIGHT 44221 . 44706) (
EXTENDREGIONTOP 44708 . 45182) (INSIDEP 45184 . 45851) (STRINGREGION 45853 . 46385)) (46641 50591 (
\BRUSHBITMAP 46651 . 48037) (\GETBRUSH 48039 . 48343) (\GETBRUSHBBT 48345 . 49738) (\InitCurveBrushes
49740 . 50437) (\BrushFromWidth 50439 . 50589)) (50592 53692 (\MakeBrush.DIAGONAL 50602 . 50857) (
\MakeBrush.HORIZONTAL 50859 . 51261) (\MakeBrush.VERTICAL 51263 . 51576) (\MakeBrush.SQUARE 51578 .
51928) (\MakeBrush.ROUND 51930 . 53690)) (53693 54567 (INSTALLBRUSH 53703 . 54565)) (54910 58094 (
\DRAWLINE.DISPLAY 54920 . 56855) (RELMOVETO 56857 . 57225) (MOVETOUPPERLEFT 57227 . 58092)) (58095
75887 (\CLIPANDDRAWLINE 58105 . 63167) (\CLIPANDDRAWLINE1 63169 . 70921) (\CLIPCODE 70923 . 72247) (
\LEASTPTAT 72249 . 72741) (\GREATESTPTAT 72743 . 73252) (\DRAWLINE1 73254 . 74366) (\DRAWLINE.UFN
74368 . 75885)) (78000 105314 (\DRAWCIRCLE.DISPLAY 78010 . 82946) (\DRAWARC.DISPLAY 82948 . 83234) (
\DRAWARC.GENERIC 83236 . 83911) (\COMPUTE.ARC.POINTS 83913 . 85598) (\DRAWELLIPSE.DISPLAY 85600 .
95797) (\DRAWCURVE.DISPLAY 95799 . 97196) (DRAWPOINT 97198 . 97826) (\LINEWITHBRUSH 97828 . 105312)) (
105315 127177 (LOADPOLY 105325 . 105897) (PARAMETRICSPLINE 105899 . 113319) (\CURVE 113321 . 117351) (
\CURVE2 117353 . 124046) (\CURVEEND 124048 . 124548) (\CURVESLOPE 124550 . 126089) (\CURVESTART 126091
. 126482) (\FDIFS/FROM/DERIVS 126484 . 127175)) (133642 142263 (\FILLCIRCLE.DISPLAY 133652 . 140152)
(\LINEBLT 140154 . 142261)) (142303 144152 (SCREENBITMAP 142313 . 142529) (BITMAPP 142531 . 142754) (
BITMAPHEIGHT 142756 . 143050) (BITMAPPROP 143052 . 143491) (BITSPERPIXEL 143493 . 143793) (CLR 143795
. 144150)) (144815 146008 (CLOSEDISPLAYSTREAM 144825 . 144959) (DSPFILL 144961 . 145640) (INVERTW
145642 . 146006)) (146009 148312 (\DSPCOLOR.DISPLAY 146019 . 146820) (\DSPBACKCOLOR.DISPLAY 146822 .
147634) (DSPEOLFN 147636 . 148310)) (148773 152649 (DSPCLEOL 148783 . 149433) (DSPRUBOUTCHAR 149435 .
149993) (\DSPMOVELR 149995 . 152647)))))
STOP