(FILECREATED "14-AUG-83 16:55:38" {PHYLUM}<LISPCORE>SOURCES>ADISPLAY.;97 135186
changes to: (VARS ADISPLAYCOMS)
(FNS \SHOWCARET)
previous date: "27-JUL-83 19:48:46" {PHYLUM}<LISPCORE>SOURCES>ADISPLAY.;96)
(* Copyright (c) 1982, 1983 by Xerox Corporation)
(PRETTYCOMPRINT ADISPLAYCOMS)
(RPAQQ ADISPLAYCOMS [(COMS (* Interlisp-D dependent stuff.)
(EXPORT (RECORDS REGION BITMAP BITMAPWORD DISPLAYSTREAM POSITION CURSOR
MOUSEEVENT))
(DECLARE: DONTCOPY (EXPORT (RECORDS BitBltTable PILOTBBT)))
(INITRECORDS BitBltTable PILOTBBT)
(* patches to arithmetic system; eventually should go away)
(CONSTANTS (BITSPERINTEGER 32))
(FNS \BBTCURVEPT)
(FNS CREATETEXTUREFROMBITMAP READBITMAP PRINTBITMAP PRINTCURSOR
\WRITEBITMAP)
(FNS \GETINTEGERPART \CONVERTTOFRACTION)
(CONSTANTS (INTEGERBITS 12)))
[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 (* more displaystream functions)
(EXPORT (MACROS DSPOPERATION DSPSOURCETYPE DSPXPOSITION DSPYPOSITION DSPYOFFSET
DSPLEFTMARGIN DSPRIGHTMARGIN DSPTEXTURE)
(DECLARE: EVAL@COMPILE DONTCOPY (FNS CDSPACCESS))
(BLOCKS (NIL CDSPACCESS)))
(FNS CREATEREGION REGIONP INTERSECTREGIONS UNIONREGIONS REGIONSINTERSECTP SUBREGIONP
EXTENDREGION EXTENDREGIONBOTTOM EXTENDREGIONLEFT EXTENDREGIONRIGHT EXTENDREGIONTOP
INSIDEP STRINGREGION))
(COMS (* line and spline drawing.)
[COMS (* Brushes and brush initialization)
(FNS \BRUSHBITMAP \GETBRUSH \GETBRUSHBBT \InitCurveBrushes)
(VARS BrushIndexList BrushInitializationList)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (\InitCurveBrushes)))
(DECLARE: DONTCOPY (GLOBALVARS BrushIndexList BrushInitializationList
\CurveBrushArray))
(GLOBALRESOURCES (\BRUSHBBT (create PILOTBBT]
(* Lines)
(FNS DRAWLINE DRAWTO DRAWBETWEEN RELDRAWTO RELMOVETO MOVETOUPPERLEFT)
(FNS \CLIPANDDRAWLINE \CLIPANDDRAWLINE1 \CLIPCODE \LEASTPTAT \GREATESTPTAT \DRAWLINE1)
(DECLARE: DONTCOPY (MACROS .DRAWLINEX. .DRAWLINEY.))
(* Curves)
(FNS DRAWCIRCLE DRAWELLIPSE DRAWCURVE DRAWPOINT \LINEWITHBRUSH \LINEWITHBRUSH1)
(FNS EVALPOLY LOADPOLY PARAMETRICSPLINE \CURVE \CURVE2 \CURVEEND \CURVESTART
\FDIFS/FROM/DERIVS)
(DECLARE: DONTCOPY (RECORDS POLYNOMIAL SPLINE))
(DECLARE: DONTCOPY (EXPORT (MACROS HALF)))
(DECLARE: DONTCOPY (MACROS \CURVEPT .SETUP.FOR.\BBTCURVEPT. \CIRCLEPTS \CURVESMOOTH))
(DECLARE: DONTCOPY (EXPORT (MACROS \FILLCIRCLEBLT)))
(FNS FILLCIRCLE \LINEBLT))
[COMS (* making and copying bitmaps)
(FNS SCREENBITMAP BITMAPP BITMAPHEIGHT BITMAPWIDTH 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 MOVETO INVERTW)
(FNS DSPCOLOR DSPBACKCOLOR)
(EXPORT (CONSTANTS (BLACKSHADE 65535)
(WHITESHADE 0))
(VARS (GRAYSHADE 43605)
(BLACKCOLOR 0)
(WHITECOLOR 7))
(ADDVARS (GLOBALVARS GRAYSHADE WHITECOLOR BLACKCOLOR))
(MACROS DSPXOFFSET))
(DECLARE: EVAL@COMPILE DONTCOPY (MACROS \FCHARWIDTH \CHARCODEP \MACRO.MX))
(MACROS DSPRUBOUTCHAR)
(FNS DSPCLEOL DSPRUBOUTCHAR \DSPMOVELR \DSPTOTALCHARWIDTH))
[COMS (* caret functions. Some are in LLDISPLAY but only those that are necessary when no
caret is being displayed.)
(FNS \SHOWCARET CARET)
(BITMAPS \DefaultCaret \DefaultCursor)
(DECLARE: DONTEVAL@LOAD DOCOPY (INITVARS (DEFAULTCARET (CURSORCREATE \DefaultCaret 0 4))
(DEFAULTCURSOR (CURSORCREATE \DefaultCursor 0
15))
(\CARETDOWN T)
(\CARETRATE 333)
(\CARETFLASHTIME (SETUPTIMER 0))
(TIMERINTERVAL 250))
(P (CARET T)))
(DECLARE: DONTCOPY (GLOBALVARS DEFAULTCARET DEFAULTCURSOR)
(EXPORT (MACROS \CHECKCARET]
(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 FIXP])
(DATATYPE BITMAP ((BITMAPBASE POINTER)
(BITMAPRASTERWIDTH WORD)
(BITMAPHEIGHT WORD)
(BITMAPWIDTH WORD)
(BITMAPBITSPERPIXEL WORD))
BITMAPBITSPERPIXEL ← 1 (BLOCKRECORD BITMAP ((BitMapHiLoc WORD)
(BitMapLoLoc WORD))
(* overlay inital pointer)
))
(BLOCKRECORD BITMAPWORD ((BITS WORD)))
(DATATYPE DISPLAYSTREAM (\SFXPOSITION \SFYPOSITION \SFXOFFSET \SFYOFFSET \SFDestination
\SFClippingRegion \SFFONT \SFSlowPrintingCase \SFWIDTHSCACHE
(* array of the distance to be moved in X when each
character is printed.)
\SFOFFSETSCACHE \SFCOLOR \SFLINEFEED \SFRightMargin
\SFLeftMargin \SFScroll \SFOFD \SFOPERATION \SFSOURCETYPE
(\SFClippingLeft WORD)
(\SFClippingRight WORD)
(\SFClippingBottom WORD)
(\SFClippingTop WORD)
(\SFTexture WORD)
(\SFHELDFLG FLAG)
(XWINDOWHINT XPOINTER)
(\SFPILOTBBT POINTER)
(* For Pilot testing)
\SFXSCALE \SFYSCALE \SFCHARIMAGEWIDTHS
(* array of image widths for each character)
\SFEOLFN \SFPAGEFULLFN)
\SFLeftMargin ← 0 \SFRightMargin ← SCREENWIDTH \SFXPOSITION ← 0 \SFYPOSITION ← 0 \SFXOFFSET
← 0 \SFYOFFSET ← 0 \SFClippingRegion ←(create REGION)
\SFDestination ←(SCREENBITMAP)
\SFXSCALE ← 1 \SFYSCALE ← 1 [ACCESSFNS ((\SFFOREGROUNDCOLOR
(OR (CAR (fetch (DISPLAYSTREAM \SFCOLOR)
of DATUM))
BLACKCOLOR))
(\SFBACKGROUNDCOLOR
(OR (CDR (fetch (DISPLAYSTREAM \SFCOLOR)
of DATUM))
WHITECOLOR])
(RECORD POSITION (XCOORD . YCOORD)
[TYPE? (AND (LISTP DATUM)
(NUMBERP (CAR DATUM))
(NUMBERP (CDR DATUM])
(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])
(RECORD MOUSEEVENT (MOUSEX MOUSEY MOUSEBUTTONS KEYBOARD MOUSETIME))
]
(/DECLAREDATATYPE (QUOTE BITMAP)
(QUOTE (POINTER WORD WORD WORD WORD)))
(/DECLAREDATATYPE (QUOTE DISPLAYSTREAM)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
POINTER WORD WORD WORD WORD WORD FLAG XPOINTER POINTER POINTER
POINTER POINTER POINTER POINTER)))
(* END EXPORTED DEFINITIONS)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(DATATYPE BitBltTable ((BBTFunction WORD)
(BBTUnused WORD)
(BBTDBCA WORD)
(BBTDBMR WORD)
(BBTDLX WORD)
(BBTDTY WORD)
(BBTDW WORD)
(BBTDH WORD)
(BBTSBCA WORD)
(BBTSBMR WORD)
(BBTSLX WORD)
(BBTSTY WORD)
(BBTGray0 WORD)
(BBTGray1 WORD)
(BBTGray2 WORD)
(BBTGray3 WORD)
(BBTSLoloc WORD)
(BBTSHiloc WORD)
(BBTDLoloc WORD)
(BBTDHiloc WORD)) (* must fall on even word for alto emulator microcode.)
(BLOCKRECORD BitBltTable ((BBTLONG FLAG)
(NIL BITS 11)
(BBTSOURCETYPE BITS 2)
(BBTOPERATION BITS 2)))
[ACCESSFNS BitBltTable ([BBTSOURCE (\VAG2 (fetch BBTSHiloc of DATUM)
(fetch BBTSLoloc of DATUM))
(PROGN (replace BBTSHiloc of DATUM
with (\HILOC NEWVALUE))
(replace BBTSLoloc of DATUM
with (\LOLOC NEWVALUE]
(BBTDEST (\VAG2 (fetch BBTDHiloc of DATUM)
(fetch BBTDLoloc of DATUM))
(PROGN (replace BBTDHiloc of DATUM with (\HILOC NEWVALUE))
(replace BBTDLoloc of DATUM with (\LOLOC NEWVALUE])
(DATATYPE PILOTBBT ((PBTDESTLO WORD)
(PBTDESTHI WORD)
(PBTDESTBIT WORD) (* Destination bit address)
(PBTDESTBPL SIGNEDWORD) (* Destination bits per line -- distance in bits to move
between items)
(PBTSOURCELO WORD)
(PBTSOURCEHI WORD)
(PBTSOURCEBIT WORD) (* Source bit address)
(PBTSOURCEBPL SIGNEDWORD) (* Source bits per line)
(PBTWIDTH WORD) (* Width of an item in bits)
(PBTHEIGHT WORD) (* Number of items -- height in scanlines)
(PBTFLAGS WORD)
(NIL 5 WORD) (* Unused, needed to make 16-alignment)
)
(BLOCKRECORD PILOTBBT ((NIL 7 WORD)
(NIL BITS 4) (* Overlay on PBTSOURCEBPL when PBTUSEGRAY)
(PBTGRAYOFFSET BITS 4) (* Offset in gray block where BITBLT should start)
(PBTGRAYWIDTHLESSONE BITS 4)
(* Width-1 of gray block in words)
(PBTGRAYHEIGHTLESSONE BITS 4)
(* Height-1 of gray block)
(NIL 2 WORD) (* Overlay on PBTFLAGS ...)
(PBTBACKWARD FLAG)
(PBTDISJOINT FLAG)
(PBTDISJOINTITEMS FLAG)
(PBTUSEGRAY FLAG)
(PBTSOURCETYPE BITS 1)
(PBTOPERATION BITS 2)
(NIL BITS 9)))
[ACCESSFNS PILOTBBT ([PBTSOURCE (\VAG2 (fetch PBTSOURCEHI of DATUM)
(fetch PBTSOURCELO of DATUM))
(PROGN (replace PBTSOURCEHI of DATUM
with (\HILOC NEWVALUE))
(replace PBTSOURCELO of DATUM
with (\LOLOC NEWVALUE]
(PBTDEST (\VAG2 (fetch PBTDESTHI of DATUM)
(fetch PBTDESTLO of DATUM))
(PROGN (replace PBTDESTHI of DATUM with (\HILOC NEWVALUE))
(replace PBTDESTLO of DATUM with (\LOLOC NEWVALUE])
]
(/DECLAREDATATYPE (QUOTE BitBltTable)
(QUOTE (WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD
WORD WORD WORD WORD WORD)))
(/DECLAREDATATYPE (QUOTE PILOTBBT)
(QUOTE (WORD WORD WORD SIGNEDWORD WORD WORD WORD SIGNEDWORD WORD WORD WORD WORD
WORD WORD WORD WORD)))
(* END EXPORTED DEFINITIONS)
)
(/DECLAREDATATYPE (QUOTE BitBltTable)
(QUOTE (WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD
WORD WORD WORD WORD WORD)))
(/DECLAREDATATYPE (QUOTE PILOTBBT)
(QUOTE (WORD WORD WORD SIGNEDWORD WORD WORD WORD SIGNEDWORD WORD WORD WORD WORD
WORD WORD WORD WORD)))
(* patches to arithmetic system; eventually should go away)
(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 DS) (* rrb "29-DEC-82 10:45")
(* 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
[(ILESSP 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 BRUSHHEIGHT 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 (DSPSOURCETYPE NIL DS)
(QUOTE ERASE))
(\PILOTBITBLT BBT 0) (* reset the source to point to the color bitmap.)
[COND
((ILESSP 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 (DSPSOURCETYPE NIL DS)
(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])
)
(DEFINEQ
(CREATETEXTUREFROMBITMAP
[LAMBDA (BITMAP) (* rrb "13-AUG-81 11:42")
(* 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))
(TEXTURE 0))
[for X from 0 to 3 do (for Y from 0 to 3
do (COND
([NOT (ZEROP (BITMAPBIT BITMAP (IREMAINDER X W)
(IREMAINDER Y H]
(SETQ TEXTURE (LOGOR TEXTURE
(\BITMASK (IPLUS (ITIMES (IDIFFERENCE
3 Y)
4)
X]
(RETURN TEXTURE])
(READBITMAP
[LAMBDA (WIDTH HEIGHT BPI) (* rrb "17-DEC-82 16:26")
(* reads the a bitmap from the input file.)
(SKIPSEPRS)
(OR (EQ (READC)
(QUOTE %())
(ERROR "BAD FORMAT OF BITMAP IN FILE"))
[COND
((NULL WIDTH) (* Parameters can be a separate expression on the file.)
(SETQ WIDTH (RATOM))
(SETQ HEIGHT (RATOM]
(PROG (BASE (BM (BITMAPCREATE WIDTH HEIGHT))
(OFD (\GETOFD NIL (QUOTE INPUT)))
(W (FOLDHI WIDTH BITSPERWORD)))
(SETQ BASE (fetch BITMAPBASE of BM))
(SKIPSEPRS OFD)
[COND
((OR (EQ WIDTH 0)
(EQ HEIGHT 0)))
[(EQ (SKIPSEPRS)
(QUOTE %"))
(FRPTQ HEIGHT (SKIPSEPRS OFD)
(OR (EQ (\BIN OFD)
(CHARCODE %"))
(GO BAD))
(FRPTQ W [\PUTBASEBYTE BASE 0 (LOGOR (LLSH (IDIFFERENCE (\BIN OFD)
(SUB1 (CHARCODE A)))
4)
(IDIFFERENCE (\BIN OFD)
(SUB1 (CHARCODE A]
[\PUTBASEBYTE BASE 1 (LOGOR (LLSH (IDIFFERENCE (\BIN OFD)
(SUB1 (CHARCODE A)))
4)
(IDIFFERENCE (\BIN OFD)
(SUB1 (CHARCODE A]
(SETQ BASE (\ADDBASE BASE 1)))
(OR (EQ (\BIN OFD)
(CHARCODE %"))
(GO BAD]
((NEQ (OR BPI (SETQ BPI (RATOM)))
BITSPERWORD)
(ERROR " Reading bitmaps of a different word size not implemented yet."))
(T (FRPTQ HEIGHT (FRPTQ W (replace (BITMAPWORD BITS) of BASE with (READ))
(SETQ BASE (\ADDBASE BASE 1]
(SKIPSEPRS)
(OR (EQ (\BIN OFD)
(CHARCODE %)))
(GO BAD))
(RETURN BM)
BAD (ERROR "BAD FORMAT OF BITMAP IN FILE"])
(PRINTBITMAP
[LAMBDA (BITMAP) (* rmk: "26-APR-82 19:38")
(* Writes a bitmap on the primary output 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 NIL "(" .P2 (fetch BITMAPWIDTH of BM)
, .P2 (fetch BITMAPHEIGHT of BM)) (* Enclose in list so that compile-copying works)
(* now write out contents.)
(\WRITEBITMAP BM)
(PRIN1 ")"])
(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) (* rmk: "26-MAY-82 22:47")
(* writes the contents of a bitmap onto the currently
open output file.)
(PROG (LIM (BASE (fetch BITMAPBASE of BITMAP))
(OFD (GETOFD NIL (QUOTE OUTPUT)))
(W (fetch BITMAPRASTERWIDTH of BITMAP)))
(FRPTQ (fetch BITMAPHEIGHT of BITMAP)
(TERPRI)
(\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) (* jds " 8-OCT-82 18:53")
(* 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
([ZEROP (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))
)
(* 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)
(* more displaystream functions)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS DSPOPERATION MACRO (ARGS (CDSPACCESS ARGS (QUOTE \SFOPERATION))))
(PUTPROPS DSPSOURCETYPE MACRO (ARGS (CDSPACCESS ARGS (QUOTE \SFSOURCETYPE))))
(PUTPROPS DSPXPOSITION MACRO (TAIL (CDSPACCESS TAIL (QUOTE \SFXPOSITION))))
(PUTPROPS DSPYPOSITION MACRO (ARGS (CDSPACCESS ARGS (QUOTE \SFYPOSITION))))
(PUTPROPS DSPYOFFSET MACRO (ARGS (CDSPACCESS ARGS (QUOTE \SFYOFFSET))))
(PUTPROPS DSPLEFTMARGIN MACRO (ARGS (CDSPACCESS ARGS (QUOTE \SFLeftMargin))))
(PUTPROPS DSPRIGHTMARGIN MACRO (ARGS (CDSPACCESS ARGS (QUOTE \SFRightMargin))))
(PUTPROPS DSPTEXTURE MACRO (ARGS (CDSPACCESS ARGS (QUOTE \SFTexture))))
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DEFINEQ
(CDSPACCESS
[LAMBDA (ARGS FIELD) (* lmm "16-NOV-82 16:38")
(* compute macro for calls to DSPXPOSITION and DSPYPOSITION, and the offset fields. Looks for calls which are only
accessing the current value and also which default to the current stream.)
(COND
((CAR ARGS)
(QUOTE IGNOREMACRO))
(T (* return current value)
(BQUOTE (ffetch , FIELD of (\DTEST , (CADR ARGS)
(QUOTE DISPLAYSTREAM])
)
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: NIL CDSPACCESS)
]
(* END EXPORTED DEFINITIONS)
(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 "14-JUN-82 18:33")
(AND (type? REGION X)
X])
(INTERSECTREGIONS
[LAMBDA REGIONS (* rrb "29-APR-83 17:14")
(* returns the largest region that is contained in all
of REGIONS)
(COND
((EQ REGIONS 0)
(create REGION
LEFT ←(CONSTANT (IMINUS (IQUOTIENT MAX.INTEGER 2)))
BOTTOM ←(CONSTANT (IMINUS (IQUOTIENT MAX.INTEGER 2)))
WIDTH ← MAX.INTEGER
HEIGHT ← MAX.INTEGER))
(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 (* rrb "29-DEC-81 11:23")
(* returns the smallest region that encloses all of
REGIONS)
(COND
((ZEROP 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 X Y) (* rrb "20-JAN-82 09:56")
(* returns T if the position X Y is inside the region REGION. If X is a position, returns T if that position is
inside of REGION)
(COND
((AND (NUMBERP X)
(NUMBERP Y))
(INSIDE? REGION X Y))
((POSITIONP X)
(INSIDE? REGION (fetch (POSITION XCOORD) of X)
(fetch (POSITION YCOORD) of X)))
((NUMBERP X)
(\ILLEGAL.ARG Y))
(T (\ILLEGAL.ARG X])
(STRINGREGION
[LAMBDA (STR WINDOW PRIN2FLG RDTBL) (* rrb "26-AUG-82 16:54")
(* returns the region taken up by STR if it were printed
at the current position of WINDOW)
(create REGION
LEFT ←(DSPXPOSITION NIL WINDOW)
BOTTOM ←(IDIFFERENCE (DSPYPOSITION NIL WINDOW)
(FONTPROP WINDOW (QUOTE DESCENT)))
WIDTH ←(STRINGWIDTH STR WINDOW PRIN2FLG RDTBL)
HEIGHT ←(FONTPROP WINDOW (QUOTE HEIGHT])
)
(* line and spline drawing.)
(* Brushes and brush initialization)
(DEFINEQ
(\BRUSHBITMAP
[LAMBDA (BRUSHSHAPE BRUSHWIDTH) (* rmk: "11-SEP-81 17:00")
(* returns the bitmap for the brush of the shape and size. Recognizes the brush shapes SQUARE, HORIZONTAL, VERTICAL,
DIAGONAL; everything else is round. See comments on \InitCurveBrushes.)
(DECLARE (GLOBALVARS \CurveBrushArray \CurveBrushIndexArray))
(ELT \CurveBrushArray (ELT \CurveBrushIndexArray (IPLUS (ITIMES (SELECTQ BRUSHSHAPE
(ROUND 0)
(SQUARE 1)
(HORIZONTAL 2)
(VERTICAL 3)
(DIAGONAL 4)
(\ILLEGAL.ARG BRUSHSHAPE)
)
5)
(COND
((EQ 1 BRUSHWIDTH)
1)
((IGREATERP BRUSHWIDTH 16)
(* 16 is largest)
5)
((IGREATERP BRUSHWIDTH 6)
(* determine the offset of the rounded brush width. 1 for 1, 2 for 2 or 3, 3 for 4 5 6, 4 for 7 8 9 10 11, 5 for 12
13 14 15 16.0)
(COND
((IGREATERP BRUSHWIDTH 11)
5)
(T 4)))
((IGREATERP BRUSHWIDTH 3)
3)
(T 2])
(\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 DS BBT) (* rrb "28-MAR-83 16:43")
(* 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 \SFDestination of DS))
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 (DSPSOURCETYPE NIL DS)
(SELECTQ (DSPOPERATION NIL DS)
((REPLACE PAINT)
(QUOTE PAINT))
((INVERT ERASE)
(QUOTE ERASE))
(SHOULDNT)))
BBT])
(\InitCurveBrushes
[LAMBDA NIL (* rmk: " 1-APR-82 22:21")
(* creates an aray of bitmaps which are the brushes for the possible shapes and sizes. Values for Brush shapes are
0=round, 1=rectangular, 2=horizontal, 3=vertical, 4=diagonal. The brush size can be any value between 1 and 16 but
is rounded to 1, 2, 4, 8 or 16)
(DECLARE (GLOBALVARS \CurveBrushArray \CurveBrushIndexArray))
(SETQ \CurveBrushArray (ARRAY 20 (QUOTE POINTER)))
(for I from 1 to 20 as SPECS in BrushInitializationList bind TEMP
do [SETA \CurveBrushArray I (SETQ TEMP (BITMAPCREATE (CAR SPECS)
(CADR SPECS]
(SETQ TEMP (fetch BITMAPBASE of TEMP))
(for LINE from 0 as VALUE in (CDDR SPECS) do (\PUTBASE TEMP LINE VALUE)))
(* make an index table to use brush shapes more than
once.)
(SETQ \CurveBrushIndexArray (ARRAY 25 (QUOTE SMALLPOSP)))
(for I from 1 as INDEX in BrushIndexList do (SETA \CurveBrushIndexArray I INDEX])
)
(RPAQQ BrushIndexList (1 2 3 4 5 1 2 6 7 8 1 9 10 11 12 1 13 14 15 16 1 17 18 19 20))
(RPAQQ BrushInitializationList ((1 1 32768)
(16 2 384 384)
(16 4 384 960 960 384)
(16 8 960 2016 4080 4080 4080 4080 2016 960)
(16 16 2016 8184 16380 32766 32766 65535 65535 65535 65535 65535 65535 32766 32766 16380 8184
2016)
(16 4 960 960 960 960)
(16 8 4080 4080 4080 4080 4080 4080 4080 4080)
(16 16 65535 65535 65535 65535 65535 65535 65535 65535 65535 65535 65535 65535 65535 65535
65535 65535)
(16 1 384)
(16 1 960)
(16 1 4080)
(16 1 65535)
(16 2 256 256)
(16 4 256 256 256 256)
(16 8 256 256 256 256 256 256 256 256)
(16 16 256 256 256 256 256 256 256 256 256 256 256 256 256 256 256 256)
(16 2 128 256)
(16 4 64 128 256 512)
(16 8 16 32 64 128 256 512 1024 2048)
(16 16 1 2 4 8 16 32 64 128 256 512 1024 2048 4096 8192 16384 32768)))
(DECLARE: DONTEVAL@LOAD DOCOPY
(\InitCurveBrushes)
)
(DECLARE: DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS BrushIndexList BrushInitializationList \CurveBrushArray)
)
)
(RPAQQ \BRUSHBBT NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \BRUSHBBT)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(PUTDEF (QUOTE \BRUSHBBT)
(QUOTE GLOBALRESOURCES)
(QUOTE (create PILOTBBT)))
)
(* Lines)
(DEFINEQ
(DRAWLINE
[LAMBDA (X1 Y1 X2 Y2 WIDTH OPERATION DS COLOR) (* rrb " 5-DEC-82 20:34")
(FIXR Y2))
DS)
[COND
((NULL WIDTH)
1)
((OR (FIXP WIDTH)
(FIXR WIDTH]
(SELECTQ OPERATION
(NIL (ffetch \SFOPERATION of DS))
((REPLACE PAINT INVERT ERASE)
OPERATION)
(\ILLEGAL.ARG OPERATION))
(ffetch \SFDestination of DS)
(ffetch \SFClippingLeft of DS)
(SUB1 (ffetch \SFClippingRight of DS))
(ffetch \SFClippingBottom of DS)
(SUB1 (ffetch \SFClippingTop of DS))
DS COLOR)
(MOVETO X2 Y2 DS])
(DRAWTO
[LAMBDA (X Y WIDTH OPERATION DS COLOR) (* rrb " 4-DEC-82 17:14")
(* draws a line fro the current position of display
stream DS to absolute position X,Y.)
(SETQ DS (\SFInsureDisplayStream DS))
(DRAWLINE (DSPXPOSITION NIL DS)
(DSPYPOSITION NIL DS)
X Y WIDTH OPERATION DS COLOR])
(DRAWBETWEEN
[LAMBDA (PT1 PT2 WIDTH OPERATION STREAM COLOR) (* rmk: "18-JUL-83 12:41")
(* draws a line bwteen two points)
(DRAWLINE (fetch XCOORD of PT1)
(fetch YCOORD of PT1)
(fetch XCOORD of PT2)
(fetch YCOORD of PT2)
WIDTH OPERATION STREAM COLOR])
(RELDRAWTO
[LAMBDA (DX DY WIDTH MODE DS COLOR) (* rrb " 4-DEC-82 17:15")
(* Draws a vector from the current position)
(SETQ DS (\SFInsureDisplayStream DS))
(DRAWTO (IPLUS (DSPXPOSITION NIL DS)
DX)
(IPLUS (DSPYPOSITION NIL DS)
DY)
WIDTH MODE DS COLOR])
(RELMOVETO
[LAMBDA (DX DY DS) (* rrb " 1-MAR-80 20:28")
(* moves the position by a vector)
(DSPXPOSITION [IPLUS DX (DSPXPOSITION NIL (SETQ DS (\SFInsureDisplayStream DS]
DS)
(DSPYPOSITION (IPLUS DY (DSPYPOSITION NIL DS))
DS])
(MOVETOUPPERLEFT
[LAMBDA (WINDOW REGION) (* rrb " 5-FEB-82 09:25")
(* moves the current position to the upper left corner
so that the first line of text will all appear.)
(PROG [(REGION (COND
((type? REGION REGION)
REGION)
(T (DSPCLIPPINGREGION NIL WINDOW]
(RETURN (MOVETO (fetch (REGION LEFT) of REGION)
(IDIFFERENCE (fetch (REGION PTOP) of REGION)
(FONTPROP (DSPFONT NIL WINDOW)
(QUOTE ASCENT)))
WINDOW])
)
(DEFINEQ
(\CLIPANDDRAWLINE
[LAMBDA (X1 Y1 X2 Y2 WIDTH OPERATION BITMAP LEFT RIGHT BOTTOM TOP DS COLOR)
(* bvm: "21-JAN-83 11:37")
(* 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)))
(COND
[(EQ X1 X2) (* special case of vertical line.)
[COND
((IGREATERP WIDTH 2)
(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.TOP.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.TOP.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)
(* rrb "21-DEC-82 16:49")
(* DS is passed so that window can be uninterruptably
brought to top.)
(PROG (CX1 CY1 CX2 CY2 CA1 CA2 TEMP DX DY YMOVEUP HALFDX HALFDY)
(* LEFT, RIGHT, BOTTOM, TOP are set to the boundaries of
the clipping region)
(* arrange things so that dx is positive.)
(COND
((IGREATERP X1 X2) (* switch points)
(SETQ DX (IDIFFERENCE X1 X2))
(SETQ TEMP X1)
(SETQ X1 X2)
(SETQ X2 TEMP)
(SETQ TEMP Y1)
(SETQ Y1 Y2)
(SETQ Y2 TEMP))) (* save the original points for the clipping
computation.)
(SETQ CX1 X1)
(SETQ CX2 X2)
(SETQ CY1 Y1)
(SETQ CY2 Y2) (* 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)) (* determine the sectors in which the points fall.)
(SETQ CA2 (\CLIPCODE CX2 CY2 LEFT RIGHT TOP BOTTOM))
(SETQ CA1 (\CLIPCODE CX1 CY1 LEFT RIGHT TOP BOTTOM))
CLIPLP
[COND
((NOT (ZEROP (LOGAND CA1 CA2))) (* line is entirely out of clipping region)
(RETURN NIL))
((ZEROP (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)
(SETQ CA1 (fetch BITMAPRASTERWIDTH of BITMAP))
(RETURN
(.WHILE.TOP.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 CA1))
(T CA1))
OPERATION
(fetch BITMAPBASE of BITMAP)
CA1))
((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 CA1))
(T CA1))
OPERATION
(fetch BITMAPBASE of BITMAP)
CA1
(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)
(* lmm "22-SEP-82 10:01")
(DECLARE (LOCALVARS . T))
(* 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.)
(PROG (MAPPTR MASK WORDOFFSET)
(* keep word offset from bitmapbase so that the YINC can be negative or positive. Used to use \ADDBASE directly
but negative case was not in micro code and ran much slower.)
(SETQ WORDOFFSET (IPLUS (ITIMES Y0 RASTERWIDTH)
(FOLDLO X0 BITSPERWORD)))
(SETQ MAPPTR (\ADDBASE BITMAPBASE WORDOFFSET))
(SETQ MASK (\BITMASK X0))
(SETQ X0 0)
(SETQ Y0 0)
(COND
[(IGEQ DX DY) (* X is the fastest mover.)
(SELECTQ MODE
(INVERT (.DRAWLINEX. (QUOTE INVERT)))
(ERASE (.DRAWLINEX. (QUOTE ERASE)))
(.DRAWLINEX. (QUOTE REPLACE/PAINT]
(T (* Y is the fastest mover.)
(SELECTQ MODE
(INVERT (.DRAWLINEY. (QUOTE INVERT)))
(ERASE (.DRAWLINEY. (QUOTE ERASE)))
(.DRAWLINEY. (QUOTE REPLACE/PAINT])
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS .DRAWLINEX. MACRO [(MODE)
(until (IGREATERP X0 XLIMIT)
do (* main loop)
[replace (BITMAPWORD BITS) of MAPPTR
with (SELECTQ MODE
(INVERT (LOGXOR MASK (fetch (BITMAPWORD BITS)
of MAPPTR)))
(ERASE (LOGAND (LOGXOR MASK WORDMASK)
(fetch (BITMAPWORD BITS)
of MAPPTR)))
(PROGN
(* case is PAINT or REPLACE. Legality of OPERATION has
been checked by \CLIPANDDRAWLINE1)
(LOGOR MASK (fetch (BITMAPWORD BITS)
of MAPPTR]
[COND
([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY]
(COND
((IGREATERP (SETQ Y0 (ADD1 Y0))
YLIMIT)
(RETURN)))
(SETQ CDL (IDIFFERENCE CDL DX))
(SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET
(IPLUS WORDOFFSET YINC]
(SETQ MASK (LRSH MASK 1))
(COND
((ZEROP MASK) (* crossed word boundary)
[SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET
(ADD1 WORDOFFSET]
(SETQ MASK 32768)))
(SETQ X0 (ADD1 X0])
(PUTPROPS .DRAWLINEY. MACRO [(MODE)
(until (IGREATERP Y0 YLIMIT)
do (* main loop)
[replace (BITMAPWORD BITS) of MAPPTR
with (SELECTQ MODE
(INVERT (LOGXOR MASK (fetch (BITMAPWORD BITS)
of MAPPTR)))
(ERASE (LOGAND (LOGXOR MASK WORDMASK)
(fetch (BITMAPWORD BITS)
of MAPPTR)))
(PROGN
(* case is PAINT or REPLACE. Legality of OPERATION has
been checked by \CLIPANDDRAWLINE1)
(LOGOR MASK (fetch (BITMAPWORD BITS)
of MAPPTR]
[COND
([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX]
(COND
((IGREATERP (SETQ X0 (ADD1 X0))
XLIMIT)
(RETURN)))
(SETQ CDL (IDIFFERENCE CDL DY))
(SETQ MASK (LRSH MASK 1))
(COND
((ZEROP MASK) (* crossed word boundary)
[SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET
(ADD1 WORDOFFSET]
(SETQ MASK 32768]
[SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET
(IPLUS WORDOFFSET YINC]
(SETQ Y0 (ADD1 Y0])
)
)
(* Curves)
(DEFINEQ
(DRAWCIRCLE
[LAMBDA (CENTERX CENTERY RADIUS BRUSH DASHING WINDOW) (* rrb " 9-MAY-83 11:08")
(* DRAWCIRCLE 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 (DS (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 (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 (SETQ DS (\SFInsureDisplayStream WINDOW))
(.SETUP.FOR.\BBTCURVEPT.)
(SELECTQ NBITS
(1 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX
(FOLDLO
BRUSHWIDTH 2))
DS)))
(4 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE
CENTERX
(FOLDLO (LRSH BRUSHWIDTH 2)
2))
DS)))
(8 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE
CENTERX
(FOLDLO (LRSH BRUSHWIDTH 3)
2))
DS)))
(SHOULDNT)) (* take into account the brush thickness.)
(SETQ CY (\DSPTRANSFORMY (IDIFFERENCE CENTERY (FOLDLO BRUSHHEIGHT
2))
DS))
(* Move the window to top while interruptable, but
verify that it is still there uninterruptably with
drawing points)
(\INSURETOPWDS DS)))
[COND
((EQ RADIUS 1) (* put a single brush down.)
(* draw the top and bottom most points.)
[COND
(USERFN (APPLY* USERFN CX CY WINDOW))
(T (.WHILE.TOP.DS. DS (\CURVEPT CX CY]
(RETURN))
(T (* draw the top and bottom most points.)
(COND
(USERFN (APPLY* USERFN CX (IPLUS CY RADIUS)
WINDOW)
(APPLY* USERFN CX (IDIFFERENCE CY RADIUS)
WINDOW))
(T (.WHILE.TOP.DS. DS (\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 (ZEROP 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 WINDOW)
(APPLY* USERFN (IDIFFERENCE CX X)
CY WINDOW))
(T (.WHILE.TOP.DS. DS (\CURVEPT (IPLUS CX X)
CY)
(\CURVEPT (IDIFFERENCE CX X)
CY]
(T [COND
(USERFN (APPLY* USERFN (IPLUS CX X)
(IPLUS CY Y)
WINDOW)
(APPLY* USERFN (IDIFFERENCE CX X)
(IPLUS CY Y)
WINDOW)
(APPLY* USERFN (IPLUS CX X)
(IDIFFERENCE CY Y)
WINDOW)
(APPLY* USERFN (IDIFFERENCE CX X)
(IDIFFERENCE CY Y)
WINDOW))
(T (.WHILE.TOP.DS. DS (\CIRCLEPTS CX CY X Y]
(GO LP)))
(AND WINDOW (MOVETO CENTERX CENTERY WINDOW))
(RETURN NIL])
(DRAWELLIPSE
[LAMBDA (CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING WINDOW)
(* rrb "12-JUL-83 14:05")
(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 displaystream is left at
the center of the ellipse.)
(PROG ((CENTERX (FIXR CENTERX))
(CENTERY (FIXR CENTERY))
(SEMIMINORRADIUS (FIXR SEMIMINORRADIUS))
(SEMIMAJORRADIUS (FIXR SEMIMAJORRADIUS)))
(COND
((OR (ZEROP SEMIMINORRADIUS)
(ZEROP SEMIMAJORRADIUS))
(AND WINDOW (MOVETO CENTERX CENTERY WINDOW))
(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 (DS 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
(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 (SETQ DS (\SFInsureDisplayStream WINDOW))
(.SETUP.FOR.\BBTCURVEPT.)
(* take into account the brush thickness.)
(SELECTQ NBITS
(1 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX
(FOLDLO
BRUSHWIDTH 2))
DS)))
(4 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE
CENTERX
(FOLDLO (LRSH BRUSHWIDTH
2)
2))
DS)))
(8 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE
CENTERX
(FOLDLO (LRSH BRUSHWIDTH
3)
2))
DS)))
(SHOULDNT))
(SETQ CY (\DSPTRANSFORMY (IDIFFERENCE CENTERY (FOLDLO
BRUSHHEIGHT 2))
DS))
(* Move the window to top while interruptable, but
verify that it is still there uninterruptably with
drawing points)
(\INSURETOPWDS DS)))
(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)
(AND WINDOW (MOVETO CENTERX CENTERY WINDOW))
(RETURN NIL)))
[COND
(USERFN (APPLY* USERFN (IPLUS CX x)
(IPLUS CYPlusOffset y)
WINDOW)
(APPLY* USERFN (IDIFFERENCE CX x)
(IDIFFERENCE CYMinusOffset y)
WINDOW))
(T (.WHILE.TOP.DS. DS (\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
((ZEROP 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
[LAMBDA (KNOTS CLOSED BRUSH DASHING WINDOW) (* rmk: "30-MAY-83 09:31")
(* draws a spline curve with a given brush.)
(GLOBALRESOURCE \BRUSHBBT
(PROG ([DASHLST (AND DASHING (OR (LISTP DASHING)
(\ILLEGAL.ARG DASHING]
(BBT \BRUSHBBT)
LKNOT)
(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 WINDOW))
(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 WINDOW BBT))
(\CURVE2 (PARAMETRICSPLINE
(COND
([AND CLOSED (NOT (EQUAL (CAR KNOTS)
(SETQ LKNOT
(CAR (LAST KNOTS]
(CONS LKNOT KNOTS))
(T KNOTS))
CLOSED)
BRUSH DASHLST BBT WINDOW))
(RETURN WINDOW])
(DRAWPOINT
[LAMBDA (X Y BRUSH WINDOW) (* rrb " 9-DEC-82 13:18")
(* draws a brush point at position X Y)
(PROG ((BRUSHBM (\GETBRUSH BRUSH)))
(RETURN (BITBLT BRUSHBM 0 0 WINDOW (IDIFFERENCE X (HALF (fetch (BITMAP BITMAPWIDTH)
of BRUSHBM)))
(IDIFFERENCE X (HALF (fetch (BITMAP BITMAPHEIGHT) of BRUSHBM])
(\LINEWITHBRUSH
[LAMBDA (X1 Y1 X2 Y2 BRUSH DASHLST WINDOW BBT) (* rmk: "26-MAY-83 22:26")
(* draws a line with a brush)
(DECLARE (LOCALVARS . T))
(PROG (DS 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))
(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.)
(* move the display stream position before the
coordinates are clobbered.)
(AND WINDOW (MOVETO X2 Y2 WINDOW))
(COND
((NOT USERFN)
(SETQ DS (\SFInsureDisplayStream WINDOW))
(.SETUP.FOR.\BBTCURVEPT.)
(SELECTQ NBITS
(1 (SETQ X1 (\DSPTRANSFORMX (IDIFFERENCE X1 (SETQ HALFBRUSHWIDTH
(FOLDLO BRUSHWIDTH 2)))
DS)))
(4 (SETQ X1 (\DSPTRANSFORMX (IDIFFERENCE X1 (SETQ HALFBRUSHWIDTH
(FOLDLO (LRSH BRUSHWIDTH 2)
2)))
DS)))
(8 (SETQ X1 (\DSPTRANSFORMX (IDIFFERENCE X1 (SETQ HALFBRUSHWIDTH
(FOLDLO (LRSH BRUSHWIDTH 3)
2)))
DS)))
(SHOULDNT))
(SETQ X2 (\DSPTRANSFORMX (IDIFFERENCE X2 HALFBRUSHWIDTH)
DS))
(SETQ Y1 (\DSPTRANSFORMY (IDIFFERENCE Y1 (SETQ HALFBRUSHHEIGHT (FOLDLO BRUSHHEIGHT 2)))
DS)) (* take into account the brush thickness.)
(SETQ Y2 (\DSPTRANSFORMY (IDIFFERENCE Y2 HALFBRUSHHEIGHT)
DS)) (* Move the window to top while interruptable, but
verify that it is still there uninterruptably with
drawing points)
(\INSURETOPWDS DS))) (* 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 WINDOW)))
[COND
(DASHTAIL (* do dashing.)
(COND
((ZEROP (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 WINDOW)))
[COND
(DASHTAIL (* do dashing.)
(COND
((ZEROP (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. DS (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
((ZEROP (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
((ZEROP (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])
(\LINEWITHBRUSH1
[LAMBDA (X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH)
(* rrb "28-MAR-83 16:46")
(DECLARE (LOCALVARS . T))
(* 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.)
(PROG NIL
(COND
[(IGEQ DX DY) (* X is the fastest mover.)
(until (IGREATERP X0 XLIMIT)
do (* main loop)
(\CURVEPT X0 Y0)
[COND
([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY]
(COND
((IGREATERP (SETQ Y0 (IPLUS Y0 YINC))
YLIMIT)
(RETURN)))
(SETQ CDL (IDIFFERENCE CDL DX]
(SETQ X0 (ADD1 X0]
(T (* Y is the fastest mover.)
(until (IGREATERP Y0 YLIMIT)
do (* main loop)
(\CURVEPT X0 Y0)
[COND
([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX]
(COND
((IGREATERP (SETQ X0 (ADD1 X0))
XLIMIT)
(RETURN)))
(SETQ CDL (IDIFFERENCE CDL DY]
(SETQ Y0 (IPLUS Y0 YINC])
)
(DEFINEQ
(EVALPOLY
[LAMBDA (POLY X DEGREE) (* edited: " 8-SEP-81 14:05")
(PROG (VALUE)
(SETQ VALUE (fetch (POLYNOMIAL A) of POLY))
[COND
((IGEQ DEGREE 1)
(SETQ VALUE (FPLUS (FTIMES VALUE X)
(fetch (POLYNOMIAL B) of POLY]
[COND
((IGEQ DEGREE 2)
(SETQ VALUE (FPLUS (FTIMES VALUE X)
(fetch (POLYNOMIAL C) of POLY]
[COND
((IGEQ DEGREE 3)
(SETQ VALUE (FPLUS (FTIMES VALUE X)
(fetch (POLYNOMIAL D) of POLY]
(RETURN VALUE])
(LOADPOLY
[LAMBDA (POLY POLYPRIME A B C D) (* rrb "21-DEC-82 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: "26-MAY-83 22:46")
(* 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)
(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))
(COND
([NOT (EQUAL (CAR KNOTS)
(CAR (LAST KNOTS]
(SETQ KNOTS (CONS (CAR (LAST KNOTS))
KNOTS]
(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
X ← X
Y ← Y
DX ← DX
DY ← DY
DDX ← DDX
DDY ← DDY
DDDX ← DDDX
DDDY ← DDDY))
(RETURN SPLINE])
(\CURVE
[LAMBDA (X0 Y0 X1 Y1 DX DY DDX DDY DDDX DDDY N BRUSHBM DS BBT ENDING USERFN WINDOW)
(* rrb " 9-MAY-83 11:38")
(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 (SETQ OLDX (\DSPTRANSFORMX (IDIFFERENCE X0 (LRSH BRUSHWIDTH 1))
DS))
(SETQ OLDY (\DSPTRANSFORMY (IDIFFERENCE Y0 (LRSH BRUSHHEIGHT 1))
DS] (* draw origin point)
(\CURVESMOOTH OLDX OLDY USERFN WINDOW) (* convert the derivatives to fractional
representation.)
(* \CONVERTTOFRACTION always returns a large number
box.)
(SETQ X (\CONVERTTOFRACTION (FPLUS OLDX .5)))
(SETQ Y (\CONVERTTOFRACTION (FPLUS OLDY .5)))
(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 WINDOW)))
(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 WINDOW)
(\BOXIPLUS TX DELTAX)
(\BOXIPLUS TY DELTAY] (* draw the end point)
[COND
(USERFN (\CURVESMOOTH X1 Y1 USERFN WINDOW))
(T (\CURVESMOOTH (\DSPTRANSFORMX (IDIFFERENCE X1 (LRSH BRUSHWIDTH 1))
DS)
(\DSPTRANSFORMY (IDIFFERENCE Y1 (LRSH BRUSHHEIGHT 1))
DS]
(AND WINDOW (MOVETO X1 Y1 WINDOW]
(COND
(ENDING (\CURVESMOOTH (IPLUS \CURX \CURX (IMINUS \OLDX))
(IPLUS \CURY \CURY (IMINUS \OLDY))
USERFN WINDOW)
(\CURVESMOOTH (IPLUS \CURX \CURX (IMINUS \OLDX))
(IPLUS \CURY \CURY (IMINUS \OLDY))
USERFN WINDOW)))
(RETURN NIL])
(\CURVE2
[LAMBDA (SPLINE BRUSH DASHLST BBT WINDOW) (* rmk: "26-MAY-83 22:41")
(DECLARE (SPECVARS . T)) (* Should declare most of these variables local but
currently have the \CURVE function between here and
\CURVEBBT so can't)
(PROG (DS 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))
(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
((NOT USERFN)
(SETQ DS (\SFInsureDisplayStream WINDOW)) (* if calling user fn, don't bother with set up and
leave points in window coordinates.)
(.SETUP.FOR.\BBTCURVEPT.) (* Do it interruptably here to get set up, then
uninterruptably when drawing points)
(\INSURETOPWDS DS)))
(\CURVESTART (ELT (fetch X of SPLINE)
1)
(ELT (fetch Y of SPLINE)
1))
[bind PERSEG for KNOT from 1 to (SUB1 (fetch #KNOTS of SPLINE))
do (SETQ X0 (ELT (fetch X of SPLINE)
KNOT))
(SETQ Y0 (ELT (fetch Y of SPLINE)
KNOT))
(SETQ X1 (ELT (fetch X of SPLINE)
(ADD1 KNOT)))
(SETQ Y1 (ELT (fetch Y of SPLINE)
(ADD1 KNOT)))
(SETQ DX (ELT (fetch DX of SPLINE)
KNOT))
(SETQ DY (ELT (fetch DY of SPLINE)
KNOT))
(SETQ DDX (ELT (fetch DDX of SPLINE)
KNOT))
(SETQ DDY (ELT (fetch DDY of SPLINE)
KNOT))
(SETQ DDDX (ELT (fetch DDDX of SPLINE)
KNOT))
(SETQ DDDY (ELT (fetch DDDY of SPLINE)
KNOT))
(SETQ NPOINTS (FOLDLO (ITIMES (IMAX (IABS (IDIFFERENCE X1 X0))
(IABS (IDIFFERENCE Y1 Y0)))
3)
2))
[COND
((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 DS BBT NIL
USERFN WINDOW))
(T (.WHILE.TOP.DS. DS
(\CURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y NPOINTS BRUSHBM DS
BBT NIL]
(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 (EVALPOLY XPOLY TT 3))
(SETQ Y1 (EVALPOLY YPOLY TT 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 DS BBT NIL
USERFN WINDOW))
(T (.WHILE.TOP.DS. DS
(\CURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y 64 BRUSHBM
DS BBT NIL]
(SETQ X0 X1)
(SETQ Y0 Y1)
(SETQ DDX (FPLUS DDX DDDX/PER/SEG))
(SETQ DDY (FPLUS DDY DDDY/PER/SEG))
(SETQ DX (EVALPOLY X/PRIME/POLY TT 2))
(SETQ DY (EVALPOLY Y/PRIME/POLY TT 2]
(COND
(USERFN (\CURVE 0 0 0 0 0 0 0 0 0 0 0 BRUSHBM DS BBT T USERFN WINDOW))
(T (.WHILE.TOP.DS. DS
(\CURVE 0 0 0 0 0 0 0 0 0 0 0 BRUSHBM DS BBT T])
(\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])
(\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
[DECLARE: EVAL@COMPILE
(BLOCKRECORD POLYNOMIAL (A B C D)
(CREATE (fetch (ARRAYP BASE) of (ARRAY 4))))
(RECORD SPLINE (#KNOTS X Y DX DY DDX DDY DDDX DDDY))
]
)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS HALF MACRO ((X)
(LRSH X 1)))
)
(* END EXPORTED DEFINITIONS)
)
(DECLARE: DONTCOPY
(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 DS])
(PUTPROPS .SETUP.FOR.\BBTCURVEPT. MACRO [NIL (* rrb " 9-DEC-82 10:52")
(PROGN (SETQ BOTTOM (ffetch \SFClippingBottom of DS))
(SETQ TOP (ffetch \SFClippingTop of DS))
(SETQ RIGHTPLUS1 (ffetch \SFClippingRight of DS))
(SETQ LEFT (ffetch \SFClippingLeft of DS))
(SETQ DestinationBitMap (ffetch \SFDestination of DS))
(SETQ OPERATION (SELECTQ (DSPOPERATION NIL DS)
((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 DS))
(T (QUOTE WHITE]
(SETQ OPERATION (QUOTE REPLACE)))
(T (SETQ COLOR (COND
[(AND (LISTP BRUSH)
(CAR (LISTP (CDDR BRUSH]
((DSPCOLOR NIL DS))
(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 DS 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]
(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 WINDOW)
(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
WINDOW))
(T (.WHILE.TOP.DS. DS
(\CURVEPT
\OLDX \OLDY]
(COND
(DASHTAIL (COND
((ZEROP (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))))
)
)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(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)
)
(DEFINEQ
(FILLCIRCLE
[LAMBDA (CENTERX CENTERY RADIUS TEXTURE DS) (* rrb "18-APR-83 20:07")
(SETQ DS (\SFInsureDisplayStream DS))
(COND
((OR (NOT (NUMBERP RADIUS))
(ILESSP (SETQ RADIUS (FIXR RADIUS))
0))
(\ILLEGAL.ARG RADIUS))
(T (GLOBALRESOURCE \BRUSHBBT
(PROG ((DestinationBitMap (fetch \SFDestination of DS))
(LEFT (fetch \SFClippingLeft of DS))
(RIGHT (SUB1 (fetch \SFClippingRight of DS)))
(TOP (SUB1 (fetch \SFClippingTop of DS)))
(BOTTOM (fetch \SFClippingBottom of DS))
DESTINATIONBASE RASTERWIDTH (X 0)
(Y RADIUS)
(D (ITIMES 2 (IDIFFERENCE 1 RADIUS)))
(OPERATION (DSPOPERATION NIL DS))
CX CY TEXTUREBM GRAYHEIGHT GRAYWIDTH GRAYBASE NBITS (FCBBT \BRUSHBBT))
(SETQ NBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DestinationBitMap))
[SETQ TEXTUREBM
(COND
((BITMAPP TEXTURE)
(SETQ GRAYBASE (fetch (BITMAP BITMAPBASE) of TEXTURE))
TEXTURE)
([AND (NEQ NBITS 1)
(BITMAPP (SETQ TEXTURE
(COLORTEXTUREFROMCOLOR#
(COLORNUMBERP (OR TEXTURE (DSPCOLOR NIL DS]
(SETQ GRAYBASE (fetch (BITMAP BITMAPBASE) of TEXTURE))
TEXTURE)
([OR (FIXP TEXTURE)
(AND (NULL TEXTURE)
(SETQ TEXTURE (DSPTEXTURE NIL DS]
(* 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 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 DS))
(SETQ CY (\DSPTRANSFORMY CENTERY DS))
(* change Y TOP and BOTTOM to be in bitmap coordinates)
(SETQ CY (\SFInvert DestinationBitMap CY))
[SETQ BOTTOM (PROG1 (SUB1 (\SFInvert DestinationBitMap TOP))
(SETQ TOP (SUB1 (\SFInvert DestinationBitMap
BOTTOM]
(\INSURETOPWDS DS) (* 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. DS
(\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 (ZEROP 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. DS (\LINEBLT FCBBT (IDIFFERENCE CX X)
CY
(IPLUS CX X)
DESTINATIONBASE RASTERWIDTH LEFT
RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT
GRAYBASE NBITS)))
(T (.WHILE.TOP.DS. DS (\FILLCIRCLEBLT CX CY X Y))
(SETQ Y (SUB1 Y))
(GO LP)))
(MOVETO CENTERX CENTERY DS)
(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 "21-DEC-82 16:18")
(* returns the height in pixels of a bitmap.)
(fetch (BITMAP BITMAPHEIGHT) of BITMAP])
(BITMAPWIDTH
[LAMBDA (BM) (* rrb "21-DEC-82 16:20")
(* returns the width of a bitmap in pixels)
(SELECTQ (fetch (BITMAP BITMAPBITSPERPIXEL) of BM)
(1 (ffetch (BITMAP BITMAPWIDTH) of BM))
(4 (LRSH (ffetch (BITMAP BITMAPWIDTH) of BM)
2))
(8 (LRSH (ffetch (BITMAP BITMAPWIDTH) of BM)
3))
(SHOULDNT])
(BITSPERPIXEL
[LAMBDA (BITMAP) (* rrb "21-DEC-82 16:21")
(* returns the height in pixels of a bitmap.)
(fetch (BITMAP BITMAPBITSPERPIXEL) of 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 ((X)
(type? BITMAP X)))
)
(ADDTOVAR GLOBALVARS SCREENHEIGHT SCREENWIDTH ScreenBitMap)
(* END EXPORTED DEFINITIONS)
)
(* Display stream functions that are not needed in the primitive system)
(DEFINEQ
(CLOSEDISPLAYSTREAM
[LAMBDA NIL
(STOPDISPLAY])
(DSPFILL
[LAMBDA (REGION TEXTURE OPERATION DISPLAYSTREAM)
(* rmk: "20-JUL-83 12:58")
(* wipes a region of a displaystream
with texture.)
(* if TEXTURE is NIL, defaults to the
current texture)
(SETQ DISPLAYSTREAM (\SFInsureDisplayStream DISPLAYSTREAM))
(OR REGION (SETQ REGION (DSPCLIPPINGREGION NIL DISPLAYSTREAM)))
(BITBLT NIL NIL NIL DISPLAYSTREAM (fetch LEFT of REGION)
(fetch BOTTOM of REGION)
(fetch WIDTH of REGION)
(fetch HEIGHT of REGION)
(QUOTE TEXTURE)
(OR OPERATION (ffetch \SFOPERATION of DISPLAYSTREAM))
(OR TEXTURE (ffetch \SFTexture of DISPLAYSTREAM])
(MOVETO
[LAMBDA (X Y DS) (* edited: "16-APR-80 13:26")
(* sets both the X and Y positions in a Display Stream)
(DSPXPOSITION X DS)
(DSPYPOSITION Y DS])
(INVERTW
[LAMBDA (WIN) (* rrb "29-DEC-82 11:00")
(* inverts a window and returns the window.
Used in RESETFORMS.)
(DSPFILL (DSPCLIPPINGREGION NIL WIN)
BLACKSHADE
(QUOTE INVERT)
WIN)
WIN])
)
(DEFINEQ
(DSPCOLOR
[LAMBDA (COLOR DSP) (* rrb " 7-OCT-82 10:41")
(* sets and returns a display stream's foreground
color.)
(PROG [(NOWCOLOR (fetch (DISPLAYSTREAM \SFCOLOR) of (SETQ DSP (\SFInsureDisplayStream DSP]
(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 (DISPLAYSTREAM \SFCOLOR) of DSP
with (CONS COLOR BLACKCOLOR))
WHITECOLOR))
(\SFFixFont DSP)))
(T (OR (CAR NOWCOLOR)
WHITECOLOR])
(DSPBACKCOLOR
[LAMBDA (COLOR DSP) (* rrb " 7-OCT-82 10:41")
(* sets and returns a display stream's background
color.)
(PROG [(COLORCELL (fetch (DISPLAYSTREAM \SFCOLOR) of (SETQ DSP (\SFInsureDisplayStream DSP]
(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 (DISPLAYSTREAM \SFCOLOR) of DSP
with (CONS WHITECOLOR COLOR))
BLACKCOLOR))
(\SFFixFont DSP)))
(T (OR (CDR COLORCELL)
BLACKCOLOR])
)
(* 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)
(DECLARE: EVAL@COMPILE
(PUTPROPS DSPXOFFSET MACRO (ARGS (CDSPACCESS ARGS (QUOTE \SFXOFFSET))))
)
(* END EXPORTED DEFINITIONS)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS \FCHARWIDTH MACRO (OPENLAMBDA (CHARCODE FONT)
(\FGETWIDTH (ffetch (ARRAYP BASE)
of (ffetch \SFWidths of FONT))
CHARCODE)))
(PUTPROPS \CHARCODEP DMACRO [OPENLAMBDA (X)
(AND (SMALLP X)
(IGEQ X 0)
(ILEQ X (CONSTANT (SUB1 (EXPT 2 BITSPERBYTE])
(PUTPROPS \CHARCODEP MACRO [(C)
(AND (SMALLP C)
(IGEQ C 0)
(ILEQ C (CONSTANT (SUB1 (LLSH 1 8])
(PUTPROPS \MACRO.MX MACRO [Z (PROG ((X (EXPANDMACRO (CAR Z)
T)))
(COND
((EQ X (CAR Z))
(ERROR "No macro property -- \MACRO.MX" X))
(T (RETURN X])
)
)
(DECLARE: EVAL@COMPILE
(PUTPROPS DSPRUBOUTCHAR MACRO ((DS CHAR X Y TTBL)
(\DSPMOVELR DS CHAR X Y TTBL NIL T)))
)
(DEFINEQ
(DSPCLEOL
(LAMBDA (DS XPOS YPOS HEIGHT) (* JonL " 1-MAY-83 05:07")
(SETQ DS (\SFInsureDisplayStream DS))
(\CHECKCARET DS)
(BITBLT NIL NIL NIL DS (OR (FIXP XPOS)
(SETQ XPOS (DSPLEFTMARGIN NIL DS)))
(OR (FIXP YPOS)
(IDIFFERENCE (DSPYPOSITION NIL DS)
(FONTDESCENT DS)))
(IMAX 0 (IDIFFERENCE (DSPRIGHTMARGIN NIL DS)
XPOS))
(OR (FIXP HEIGHT)
(IMINUS (DSPLINEFEED NIL DS)))
(QUOTE TEXTURE)
(QUOTE REPLACE))))
(DSPRUBOUTCHAR
[LAMBDA (STREAM CHAR X Y TTBL) (* rmk: "18-JUL-83 13:00")
(if (\DISPLAYSTREAMP CHAR)
then (* Some older code may use the CHAR argument first.
Newer code will be converted by the macro expansion of
DSPRUBOUTCHAR)
(SETQ STREAM (PROG1 CHAR (SETQ CHAR STREAM)))
(SETQ TTBL X)
(SETQ X)
(SETQ Y))
(\MACRO.MX (DSPRUBOUTCHAR (\SFInsureDisplayStream STREAM)
CHAR X Y TTBL))])
(\DSPMOVELR
[LAMBDA (DS CHAR X Y TTBL RIGHTWARDSFLG ERASEFLG) (* JonL "27-JUL-83 19:46")
(* 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.)
(SETQ DS (\SFInsureDisplayStream DS))
(PROG ((FONT (DSPFONT NIL DS))
(DEFAULTPOS? (AND (NULL X)
(NULL Y)))
WIDTH)
(OR ERASEFLG DEFAULTPOS? (SHOULDNT)) (* CURSORLEFT and CURSORRIGHT commands aren't allowed to
start from anywhere except current spot)
(SETQ WIDTH (\DSPTOTALCHARWIDTH FONT CHAR TTBL))
(* 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.)
(if (NULL WIDTH)
then (RETURN)
elseif (ZEROP WIDTH)
then (* Ha, what an easy case)
(RETURN T))
(OR (FIXP X)
(SETQ X (DSPXPOSITION NIL DS)))
(OR (FIXP Y)
(SETQ Y (DSPYPOSITION NIL DS)))
(if (if RIGHTWARDSFLG
then (IGREATERP (add X WIDTH)
(DSPRIGHTMARGIN NIL DS))
else (ILESSP (add X (IMINUS WIDTH))
(DSPLEFTMARGIN NIL DS)))
then (* 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.)
(if ERASEFLG
then (* And do the erasure if requested)
(PROG ((YPRIME (IDIFFERENCE Y (FONTDESCENT FONT)))
(HEIGHT (FONTHEIGHT FONT)))
(if (NOT DEFAULTPOS?)
then (MOVETO X Y DSK) (* 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)
))
(DSPXPOSITION X DS) (* Now do the move.)
(RETURN T])
(\DSPTOTALCHARWIDTH
(LAMBDA (FONT CHAR TTBL) (* JonL " 1-MAY-83 02:01")
(PROG ((WIDTH (\FCHARWIDTH (if (\CHARCODEP CHAR)
then CHAR
else (SETQ CHAR)
(CHARCODE M))
FONT)))
(* 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.)
(if CHAR
then (* Patch up for possible multiple-characterr printings
etc)
(SELECTC (fetch CCECHO of (\SYNCODE (fetch (TERMTABLEP TERMSA)
of (OR (TERMTABLEP TTBL)
\PRIMTERMTABLE))
CHAR))
(INDICATE.CCE (if (IGEQ CHAR (CHARCODE #↑@))
then (* A "meta" character that standardly prints out with a
# prefix)
(add WIDTH (\FCHARWIDTH (CHARCODE #)
FONT)))
(if (ILEQ (IMOD CHAR (CONSTANT (LLSH 1 7)))
(CHARCODE ↑Z))
then (* A "control" character that standardly prints out with
a ↑ prefix)
(add WIDTH (\FCHARWIDTH (CHARCODE ↑)
FONT))))
(SIMULATE.CCE (SELCHARQ CHAR
((EOL CR LF TAB BELL)
(* Sorry, cant "backup" blindly)
(RETURN))
((ESCAPE)
(SETQ WIDTH (\FCHARWIDTH (CHARCODE $)
FONT)))
NIL))
(REAL.CCE (SELCHARQ CHAR
((EOL CR LF TAB)
(* Sorry, cant "backup" blindly)
(RETURN))
NIL))
(IGNORE.CCE (* Ha, this is an easy one!)
(RETURN 0))
NIL)) (* Now do the move.)
(RETURN WIDTH))))
)
(* caret functions. Some are in LLDISPLAY but only those that are necessary when no caret is
being displayed.)
(DEFINEQ
(\SHOWCARET
[LAMBDA (DS) (* lmm "14-AUG-83 16:38")
(DECLARE (GLOBALVARS \CARETDOWN \CARETFLG \CARETFLASHTIME \CARETRATE \CARET))
(* changes the caret from on to off or off to on.)
(UNINTERRUPTABLY
(* if going to have carets in more than one displaystream, or several crets going at once, then probably want to
collaps all this global information into a single record.)
(* note the time of the next change.)
(* must be done without creating boxes because happens
during keyboard wait.)
(SETQ \CARETFLASHTIME (SETUPTIMER \CARETRATE \CARETFLASHTIME))
(SETQ \CARETFLG (NULL \CARETFLG)) (* \CARETFLG indicates whether caret is on or off.
necessary so it can be turned off before the character
is echoed)
(* \CARETDOWN indicates that the caret was taken down so
that it will go back up quickly.)
(SETQ \CARETDOWN NIL)
(BITBLT (fetch CURSORBITMAP of \CARET)
0 0 DS (IDIFFERENCE (DSPXPOSITION NIL DS)
(fetch CURSORHOTSPOTX of \CARET))
(IDIFFERENCE (DSPYPOSITION NIL DS)
(fetch CURSORHOTSPOTY of \CARET))
CURSORWIDTH CURSORHEIGHT (QUOTE INPUT)
(QUOTE INVERT)))])
(CARET
[LAMBDA (NEWCARET) (* rrb " 4-NOV-82 11:30")
(* Changes the input caret)
(\CHECKCARET (TTYDISPLAYSTREAM)) (* turn off existing caret if it is on)
(PROG1 (COND
[\CARET (create CURSOR using \CARET CURSORHOTSPOT ←(create POSITION
using (fetch CURSORHOTSPOT
of \CARET]
(T (QUOTE OFF)))
(COND
(NEWCARET (COND
((EQ NEWCARET (QUOTE OFF))
(SETQ \CARET NIL))
((EQ NEWCARET T)
(SETQ \CARET DEFAULTCARET))
((type? CURSOR NEWCARET)
(SETQ \CARET NEWCARET))
(T (LISPERROR "ILLEGAL ARG" NEWCARET])
)
(RPAQ \DefaultCaret (READBITMAP))
(16 16
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"A@@@"
"CH@@"
"FL@@"
"LF@@"
"HB@@"
"@@@@"
"@@@@")
(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? DEFAULTCARET (CURSORCREATE \DefaultCaret 0 4))
(RPAQ? DEFAULTCURSOR (CURSORCREATE \DefaultCursor 0 15))
(RPAQ? \CARETDOWN T)
(RPAQ? \CARETRATE 333)
(RPAQ? \CARETFLASHTIME (SETUPTIMER 0))
(RPAQ? TIMERINTERVAL 250)
(CARET T)
)
(DECLARE: DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS DEFAULTCARET DEFAULTCURSOR)
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS \CHECKCARET MACRO (X (PROG [(DS (EXPANDMACRO (CAR X)
T))
(TTYD (EXPANDMACRO (QUOTE (TTYDISPLAYSTREAM))
T))
(FORM (QUOTE (PROGN (AND \CARETFLG (\SHOWCARET (TTYDISPLAYSTREAM
)))
(SETQ \CARETDOWN T]
(* \CARETDOWN is set so that caret will come up
quickly.)
[COND
((CONSTANTEXPRESSIONP DS)
(ERROR X "CONSTANT ARG TO \CHECKCARET??"))
((NOT (EQUAL TTYD DS))
(* (BQUOTE (COND ((AND (EQ , DS
(TTYDISPLAYSTREAM)) \CARET) , FORM))))
(SETQ FORM (LIST (QUOTE COND)
(LIST (LIST (QUOTE AND)
(LIST (QUOTE EQ)
DS
(QUOTE (TTYDISPLAYSTREAM))
)
(QUOTE \CARET))
FORM]
(RETURN FORM))))
)
(* END EXPORTED DEFINITIONS)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA UNIONREGIONS INTERSECTREGIONS)
)
(PUTPROPS ADISPLAY COPYRIGHT ("Xerox Corporation" 1982 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (12788 17247 (\BBTCURVEPT 12798 . 17245)) (17248 22720 (CREATETEXTUREFROMBITMAP 17258 .
18035) (READBITMAP 18037 . 19805) (PRINTBITMAP 19807 . 20785) (PRINTCURSOR 20787 . 21676) (
\WRITEBITMAP 21678 . 22718)) (22721 24528 (\GETINTEGERPART 22731 . 23825) (\CONVERTTOFRACTION 23827 .
24526)) (24659 25452 (CURSORP 24669 . 24936) (CURSORBITMAP 24938 . 24982) (CreateCursorBitMap 24984 .
25450)) (26588 27143 (CDSPACCESS 26598 . 27141)) (27252 36833 (CREATEREGION 27262 . 27570) (REGIONP
27572 . 27711) (INTERSECTREGIONS 27713 . 29345) (UNIONREGIONS 29347 . 30836) (REGIONSINTERSECTP 30838
. 31407) (SUBREGIONP 31409 . 32028) (EXTENDREGION 32030 . 33699) (EXTENDREGIONBOTTOM 33701 . 34268) (
EXTENDREGIONLEFT 34270 . 34814) (EXTENDREGIONRIGHT 34816 . 35301) (EXTENDREGIONTOP 35303 . 35777) (
INSIDEP 35779 . 36298) (STRINGREGION 36300 . 36831)) (36916 40983 (\BRUSHBITMAP 36926 . 38150) (
\GETBRUSH 38152 . 38455) (\GETBRUSHBBT 38457 . 39797) (\InitCurveBrushes 39799 . 40981)) (42275 45669
(DRAWLINE 42285 . 43525) (DRAWTO 43527 . 43949) (DRAWBETWEEN 43951 . 44356) (RELDRAWTO 44358 . 44739)
(RELMOVETO 44741 . 45043) (MOVETOUPPERLEFT 45045 . 45667)) (45670 59531 (\CLIPANDDRAWLINE 45680 .
49683) (\CLIPANDDRAWLINE1 49685 . 55929) (\CLIPCODE 55931 . 56922) (\LEASTPTAT 56924 . 57416) (
\GREATESTPTAT 57418 . 57927) (\DRAWLINE1 57929 . 59529)) (62095 86693 (DRAWCIRCLE 62105 . 66876) (
DRAWELLIPSE 66878 . 76883) (DRAWCURVE 76885 . 78397) (DRAWPOINT 78399 . 78858) (\LINEWITHBRUSH 78860
. 85130) (\LINEWITHBRUSH1 85132 . 86691)) (86694 103914 (EVALPOLY 86704 . 87292) (LOADPOLY 87294 .
87854) (PARAMETRICSPLINE 87856 . 93958) (\CURVE 93960 . 97222) (\CURVE2 97224 . 102330) (\CURVEEND
102332 . 102829) (\CURVESTART 102831 . 103222) (\FDIFS/FROM/DERIVS 103224 . 103912)) (110665 118332 (
FILLCIRCLE 110675 . 116221) (\LINEBLT 116223 . 118330)) (118372 120177 (SCREENBITMAP 118382 . 118544)
(BITMAPP 118546 . 118769) (BITMAPHEIGHT 118771 . 119043) (BITMAPWIDTH 119045 . 119538) (BITSPERPIXEL
119540 . 119818) (CLR 119820 . 120175)) (120825 122301 (CLOSEDISPLAYSTREAM 120835 . 120889) (DSPFILL
120891 . 121720) (MOVETO 121722 . 121944) (INVERTW 121946 . 122299)) (122302 123938 (DSPCOLOR 122312
. 123118) (DSPBACKCOLOR 123120 . 123936)) (125224 130751 (DSPCLEOL 125234 . 125739) (DSPRUBOUTCHAR
125741 . 126299) (\DSPMOVELR 126301 . 128776) (\DSPTOTALCHARWIDTH 128778 . 130749)) (130872 133180 (
\SHOWCARET 130882 . 132428) (CARET 132430 . 133178)))))
STOP