From 9ada6de6b930e5d277add99fe293de6a92c42289 Mon Sep 17 00:00:00 2001 From: Larry Masinter Date: Tue, 28 Feb 2023 05:48:41 -0800 Subject: [PATCH 1/3] Revert changes in \DRAWLINE.DISPLAY and add BIGBITMAPS to loadup & exports --- sources/ADISPLAY | 4497 -------------------------------------- sources/ADISPLAY.LCOM | Bin 70819 -> 71761 bytes sources/FILESETS | 6 +- sources/LOADUP-LISP | 19 +- sources/LOADUP-LISP.LCOM | Bin 3524 -> 3566 bytes 5 files changed, 15 insertions(+), 4507 deletions(-) diff --git a/sources/ADISPLAY b/sources/ADISPLAY index 7e3bd10d..5f25ddd2 100644 --- a/sources/ADISPLAY +++ b/sources/ADISPLAY @@ -1,4500 +1,3 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "13-Jun-2021 14:03:35"  -{DSK}kaplan>Local>medley3.5>git-medley>sources>ADISPLAY.;10 248693 - - changes to%: (FNS \DRAWLINE.DISPLAY) - (VARS ADISPLAYCOMS) - - previous date%: "15-Sep-94 17:07:04" -{DSK}kaplan>Local>medley3.5>git-medley>sources>ADISPLAY.;8) - - -(* ; " -Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation. -") - -(PRETTYCOMPRINT ADISPLAYCOMS) - -(RPAQQ ADISPLAYCOMS - [(COMS (* ; "COMPILE SUPPORT") - (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) - WINDOW))) - (P (MOVD? 'NILL 'BIGBITMAPP)) - (COMS (* ; "Interlisp-D dependent stuff.") - (EXPORT (RECORDS REGION BITMAP BITMAPWORD POSITION CURSOR MOUSEEVENT SCREENREGION - SCREENPOSITION)) - (SYSRECORDS PILOTBBT \DISPLAYDATA) - (CONSTANTS (BITSPERINTEGER 32)) - (FNS \BBTCURVEPT) - (FNS CREATETEXTUREFROMBITMAP PRINTBITMAP PRINT-BITMAPS-NICELY PRINTCURSOR \WRITEBITMAP) - (P (DEFPRINT 'BITMAP 'PRINT-BITMAPS-NICELY)) - (FNS \GETINTEGERPART \CONVERTTOFRACTION) - (CONSTANTS (INTEGERBITS 12))) - [COMS (* ; - "cursor functions not on LLDISPLAY") - (FNS CURSORP CURSORBITMAP CreateCursorBitMap) - (EXPORT (MACROS CURSORBITMAP) - (CONSTANTS (HARDCURSORHEIGHT 16) - (HARDCURSORWIDTH 16)) - (DECLARE%: EVAL@COMPILE (ADDVARS (GLOBALVARS CursorBitMap] - (COMS * CARETCOMS) - (COMS (* ; "Region functions") - (FNS CREATEREGION REGIONP INTERSECTREGIONS UNIONREGIONS REGIONSINTERSECTP SUBREGIONP - EXTENDREGION EXTENDREGIONBOTTOM EXTENDREGIONLEFT EXTENDREGIONRIGHT EXTENDREGIONTOP - INSIDEP STRINGREGION)) - (COMS (* ; "line and spline drawing.") - (COMS (* ; - "Brushes and brush initialization") - (GLOBALRESOURCES \BRUSHBBT) - (FNS \BRUSHBITMAP \GETBRUSH \GETBRUSHBBT \InitCurveBrushes \BrushFromWidth) - (FNS \MAKEBRUSH.DIAGONAL \MAKEBRUSH.HORIZONTAL \MAKEBRUSH.VERTICAL - \MAKEBRUSH.SQUARE \MAKEBRUSH.ROUND) - (FNS INSTALLBRUSH) - (VARS \BrushNames) - (INITVARS (KNOWN.BRUSHES NIL) - (\BrushAList NIL)) - (RECORDS BRUSHITEM) - (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\InitCurveBrushes))) - (DECLARE%: DONTCOPY (GLOBALVARS \BrushAList KNOWN.BRUSHES))) - (* ; "Lines") - (FNS \DRAWLINE.DISPLAY RELMOVETO MOVETOUPPERLEFT) - (FNS \CLIPANDDRAWLINE \CLIPANDDRAWLINE1 \CLIPCODE \LEASTPTAT \GREATESTPTAT \DRAWLINE1 - \DRAWLINE.UFN) - (DECLARE%: DONTCOPY (MACROS .DRAWLINEX. .DRAWLINEY.)) - (* ; "Curves") - (FNS \DRAWCIRCLE.DISPLAY \DRAWARC.DISPLAY \DRAWARC.GENERIC \COMPUTE.ARC.POINTS - \DRAWELLIPSE.DISPLAY \DRAWCURVE.DISPLAY \DRAWPOINT.DISPLAY \DRAWPOLYGON.DISPLAY - \LINEWITHBRUSH) - (FNS LOADPOLY PARAMETRICSPLINE \CURVE \CURVE2 \CURVEEND \CURVESLOPE \CURVESTART - \FDIFS/FROM/DERIVS) - (DECLARE%: DONTCOPY (* ; "Used by drawcurve") - (EXPORT (RECORDS POLYNOMIAL SPLINE))) - (DECLARE%: DONTCOPY (EXPORT (MACROS HALF \FILLCIRCLEBLT)) - (MACROS \CURVEPT .SETUP.FOR.\BBTCURVEPT. \CIRCLEPTS \CURVESMOOTH)) - (FNS \FILLCIRCLE.DISPLAY \LINEBLT)) - [COMS (* ; "making and copying bitmaps") - (FNS SCREENBITMAP BITMAPP BITMAPHEIGHT BITSPERPIXEL) - (EXPORT (FILEPKGCOMS BITMAPS CURSORS)) - (DECLARE%: EVAL@COMPILE (EXPORT (ADDVARS (GLOBALVARS SCREENHEIGHT SCREENWIDTH - ScreenBitMap] - [COMS (* ; - "Display stream functions that are not needed in the primitive system") - (FNS DSPFILL INVERTW) - (FNS \DSPCOLOR.DISPLAY \DSPBACKCOLOR.DISPLAY DSPEOLFN) - (EXPORT (CONSTANTS (BLACKSHADE 65535) - (WHITESHADE 0)) - (VARS (GRAYSHADE 43605)) - (ADDVARS (GLOBALVARS GRAYSHADE))) - (MACROS DSPRUBOUTCHAR) - (FNS DSPCLEOL DSPRUBOUTCHAR \DSPMOVELR) - (COMS (* ; "for cursor") - (BITMAPS \DefaultCursor) - (FNS \CURSOR.DEFPRINT) - [DECLARE%: DONTEVAL@LOAD DOCOPY (INITVARS (DEFAULTCURSOR (CURSORCREATE - \DefaultCursor - NIL 0 15))) - (P (COND ((NULL \CURRENTCURSOR) - (SETQ \CURRENTCURSOR DEFAULTCURSOR))) - (DEFPRINT 'CURSOR '\CURSOR.DEFPRINT] - (DECLARE%: DONTCOPY (GLOBALVARS DEFAULTCURSOR] - [COMS (* ; - "stuff to interpret colors as textures which is needed even in system that don't have color.") - (FNS TEXTUREOFCOLOR \PRIMARYTEXTURE \LEVELTEXTURE INSURE.B&W.TEXTURE INSURE.RGB.COLOR - \LOOKUPCOLORNAME RGBP HLSP HLSTORGB \HLSVALUEFN) - (VARS COLORNAMES) - (GLOBALVARS COLORNAMES) - (DECLARE%: DONTCOPY (GLOBALVARS BLACKSHADE16 DARKGRAY16 MEDIUMGRAY16 LIGHTGRAY16 - WHITESHADE16 REDTEXTURE GREENTEXTURE BLUETEXTURE)) - (UGLYVARS BLACKSHADE16 DARKGRAY16 MEDIUMGRAY16 LIGHTGRAY16 WHITESHADE16 REDTEXTURE - GREENTEXTURE BLUETEXTURE) - (DECLARE%: DONTCOPY (* ; "Used by drawcurve") - (EXPORT (RECORDS HLS RGB] - (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) - (NLAML) - (LAMA UNIONREGIONS - INTERSECTREGIONS]) - - - -(* ; "COMPILE SUPPORT") - -(DECLARE%: EVAL@COMPILE DONTCOPY - -(FILESLOAD (LOADCOMP) - WINDOW) -) - -(MOVD? 'NILL 'BIGBITMAPP) - - - -(* ; "Interlisp-D dependent stuff.") - -(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE - -(RECORD REGION (LEFT BOTTOM WIDTH HEIGHT) - LEFT _ -16383 BOTTOM _ -16383 WIDTH _ 32767 HEIGHT _ 32767 - [ACCESSFNS ((TOP (IPLUS (fetch (REGION BOTTOM) of DATUM) - (fetch (REGION HEIGHT) of DATUM) - -1)) - (PTOP (IPLUS (fetch (REGION BOTTOM) of DATUM) - (fetch (REGION HEIGHT) of DATUM))) - (RIGHT (IPLUS (fetch (REGION LEFT) of DATUM) - (fetch (REGION WIDTH) of DATUM) - -1)) - (PRIGHT (IPLUS (fetch (REGION LEFT) of DATUM) - (fetch (REGION WIDTH) of DATUM] - [TYPE? (AND (EQLENGTH DATUM 4) - (EVERY DATUM (FUNCTION NUMBERP] - (SYSTEM)) - -(DATATYPE BITMAP ((BITMAPBASE POINTER) - (BITMAPRASTERWIDTH WORD) - (BITMAPHEIGHT WORD) - (BITMAPWIDTH WORD) - (BITMAPBITSPERPIXEL WORD)) - BITMAPBITSPERPIXEL _ 1 (BLOCKRECORD BITMAP ((BitMapHiLoc WORD) - (BitMapLoLoc WORD)) - (* ; "overlay initial pointer") - ) - (SYSTEM)) - -(BLOCKRECORD BITMAPWORD ((BITS WORD)) - (SYSTEM)) - -(RECORD POSITION (XCOORD . YCOORD) - [TYPE? (AND (LISTP DATUM) - (NUMBERP (CAR DATUM)) - (NUMBERP (CDR DATUM] - (SYSTEM)) - -(DATATYPE CURSOR (CUIMAGE CUMASK CUHOTSPOTX CUHOTSPOTY CUDATA) - [ACCESSFNS ((CUBITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) - of (fetch (CURSOR CUIMAGE) of DATUM] - (SYSTEM)) - -(RECORD MOUSEEVENT (MOUSEX MOUSEY MOUSEBUTTONS KEYBOARD MOUSETIME) - (SYSTEM)) - -(RECORD SCREENREGION (SCREEN . REGION) - (SUBRECORD REGION) - [TYPE? (AND (LISTP DATUM) - (type? SCREEN (CAR DATUM)) - (type? REGION (CDR DATUM] - (SYSTEM)) - -(RECORD SCREENPOSITION (SCREEN . POSITION) - (SUBRECORD POSITION) - [TYPE? (AND (LISTP DATUM) - (type? SCREEN (CAR DATUM)) - (type? POSITION (CDR DATUM] - (SYSTEM)) -) - -(/DECLAREDATATYPE 'BITMAP '(POINTER WORD WORD WORD WORD) - '((BITMAP 0 POINTER) - (BITMAP 2 (BITS . 15)) - (BITMAP 3 (BITS . 15)) - (BITMAP 4 (BITS . 15)) - (BITMAP 5 (BITS . 15))) - '6) - -(/DECLAREDATATYPE 'CURSOR '(POINTER POINTER POINTER POINTER POINTER) - '((CURSOR 0 POINTER) - (CURSOR 2 POINTER) - (CURSOR 4 POINTER) - (CURSOR 6 POINTER) - (CURSOR 8 POINTER)) - '10) - -(* "END EXPORTED DEFINITIONS") - -(ADDTOVAR SYSTEMRECLST - -(DATATYPE PILOTBBT ((PBTDESTLO WORD) - (PBTDESTHI WORD) - (PBTDESTBIT WORD) - (PBTDESTBPL SIGNEDWORD) - (PBTSOURCELO WORD) - (PBTSOURCEHI WORD) - (PBTSOURCEBIT WORD) - (PBTSOURCEBPL SIGNEDWORD) - (PBTWIDTH WORD) - (PBTHEIGHT WORD) - (PBTFLAGS WORD) - (NIL 5 WORD))) - -(DATATYPE \DISPLAYDATA - (DDXPOSITION DDYPOSITION DDXOFFSET DDYOFFSET DDDestination DDClippingRegion DDFONT - DDSlowPrintingCase DDWIDTHSCACHE DDOFFSETSCACHE DDCOLOR DDLINEFEED DDRightMargin - DDLeftMargin DDScroll DDOPERATION DDSOURCETYPE (DDClippingLeft WORD) - (DDClippingRight WORD) - (DDClippingBottom WORD) - (DDClippingTop WORD) - (NIL WORD) - (DDHELDFLG FLAG) - (XWINDOWHINT XPOINTER) - (DDPILOTBBT POINTER) - DDXSCALE DDYSCALE DDCHARIMAGEWIDTHS DDEOLFN DDPAGEFULLFN DDTexture DDMICAXPOS - DDMICAYPOS DDMICARIGHTMARGIN DDCHARSET (DDCHARSETASCENT WORD) - (DDCHARSETDESCENT WORD) - DDCHARHEIGHTDELTA - (DDSPACEWIDTH WORD))) -) -(DECLARE%: EVAL@COMPILE - -(RPAQQ BITSPERINTEGER 32) - - -(CONSTANTS (BITSPERINTEGER 32)) -) (DEFINEQ -(\BBTCURVEPT - [LAMBDA (X Y BBT LEFT BRUSHWIDTH LEFTMINUSBRUSH RIGHTPLUS1 NBITSRIGHTPLUS1 TOPMINUSBRUSH - DestinationBitMap BRUSHHEIGHT BOTTOMMINUSBRUSH TOP BRUSHBASE DESTINATIONBASE RASTERWIDTH - BRUSHRASTERWIDTH COLORBRUSHBASE NBITS DISPLAYDATA) - (* kbr%: "27-Aug-86 23:17") - - (* ;; "Called by \CURVEPT macro. Draws a brush point by bitblting BRUSHBM to point X,Y in DestinationBitMap. BBT is a BitBlt table where everything is already set except the source and destination addresses, width and height. In other words, only the easy stuff") - (* ; "set the width fields of the bbt") - [PROG (CLIPPEDTOP STY) - [COND - [(ILEQ Y TOPMINUSBRUSH) (* ; - "the top part of the brush is visible") - (SETQ CLIPPEDTOP (IPLUS Y BRUSHHEIGHT)) - (replace PBTSOURCE of BBT with BRUSHBASE) - (freplace 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] - (freplace PBTHEIGHT of BBT with (IDIFFERENCE (IMIN BRUSHHEIGHT - (IDIFFERENCE Y - BOTTOMMINUSBRUSH - )) - STY] - (freplace 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") - [freplace PBTDESTBIT of BBT with (COND - ((EQ NBITS 4) - (LLSH LEFT 2)) - (T (LLSH LEFT 3] - (freplace PBTSOURCEBIT of BBT - with (IDIFFERENCE BRUSHWIDTH - (freplace PBTWIDTH of BBT - with (COND - ((EQ NBITS 4) - (LLSH (IDIFFERENCE X LEFTMINUSBRUSH) - 2)) - (T (LLSH (IDIFFERENCE X LEFTMINUSBRUSH) - 3] - (T (* ; "left edge is visible") - [freplace PBTDESTBIT of BBT with (SETQ X - (COND - ((EQ NBITS 4) - (LLSH X 2)) - (T (LLSH X 3] - (freplace PBTSOURCEBIT of BBT with 0) - (* ; - "set width to the amount that is visible") - (freplace PBTWIDTH of BBT with (IMIN BRUSHWIDTH - (IDIFFERENCE - NBITSRIGHTPLUS1 - X] - (* ; - "if color brush is used, the ground must be cleared before the brush is put in.") - (\SETPBTFUNCTION BBT (ffetch DDSOURCETYPE of DISPLAYDATA) - 'ERASE) - (\PILOTBITBLT BBT 0) (* ; - "reset the source to point to the color bitmap.") - [COND - ((ILEQ Y TOPMINUSBRUSH) (* ; - "the top part of the brush is visible") - (freplace PBTSOURCE of BBT with COLORBRUSHBASE)) - (T (* ; "only the bottom is visible") - (freplace PBTSOURCE of BBT with (\ADDBASE COLORBRUSHBASE - (ITIMES BRUSHRASTERWIDTH - (IDIFFERENCE Y - TOPMINUSBRUSH] - (\SETPBTFUNCTION BBT (ffetch DDSOURCETYPE of DISPLAYDATA) - 'PAINT)) - (T (COND - [(ILESSP X LEFT) (* ; - "only the right part of the brush is visible") - (freplace PBTDESTBIT of BBT with LEFT) - (freplace PBTSOURCEBIT of BBT with (IDIFFERENCE BRUSHWIDTH - (freplace PBTWIDTH - of BBT - with (IDIFFERENCE X - LEFTMINUSBRUSH - ] - (T (* ; "left edge is visible") - (freplace PBTDESTBIT of BBT with X) - (freplace PBTSOURCEBIT of BBT with 0) - (* ; - "set width to the amount that is visible") - (freplace PBTWIDTH of BBT with (IMIN BRUSHWIDTH (IDIFFERENCE RIGHTPLUS1 X - ] - (\PILOTBITBLT BBT 0]) ) -(DEFINEQ - -(CREATETEXTUREFROMBITMAP - [LAMBDA (BITMAP) (* rrb "17-May-84 11:22") - - (* ;; "creates a texture object from the lower left corner of a bitmap") - - (OR (BITMAPP BITMAP) - (\ILLEGAL.ARG BITMAP)) - (PROG ((H (fetch BITMAPHEIGHT of BITMAP)) - (W (fetch BITMAPWIDTH of BITMAP)) - TEXTHEIGHT TEXTURE) - (COND - ((AND (OR (EQ W 2) - (EQ W 4)) - (OR (EQ H 2) - (EQ H 4))) (* ; - "small texture will match bitmap exactly so use integer representation.") - (SETQ TEXTURE 0) - [for X from 0 to 3 - do (for Y from 0 to 3 - do (COND - ([NOT (EQ 0 (BITMAPBIT BITMAP (IREMAINDER X W) - (IREMAINDER Y H] - (SETQ TEXTURE (LOGOR TEXTURE - (\BITMASK (IPLUS (ITIMES (IDIFFERENCE - 3 Y) - 4) - X] - (RETURN TEXTURE)) - ((AND (EQ W 16) - (ILESSP H 17)) (* ; - "if it is already 16 by n n<=16, use it.") - (RETURN BITMAP)) - (T (* ; "make a 16 bit wide one.") - (SETQ TEXTURE (BITMAPCREATE 16 (IMIN H 16))) - (for X from 0 by W to 16 - do (BITBLT BITMAP 0 0 TEXTURE X 0 W H 'INPUT 'REPLACE)) - (RETURN TEXTURE]) - -(PRINTBITMAP - [LAMBDA (BITMAP FILE) (* ; "Edited 1-Dec-86 16:24 by Pavel") - -(* ;;; "Writes a bitmap on a file such that READBITMAP will read it back in.") - - (DECLARE (LOCALVARS . T)) - (PROG ((BM BITMAP)) - (COND - ((type? BITMAP BITMAP)) - ([AND (LITATOM BITMAP) - (type? BITMAP (SETQ BM (EVALV BITMAP] (* ; - "Coerce litatoms for compatibility with original specification") - ) - (T (printout T "******** " BITMAP " is not a BITMAP." T) - (RETURN NIL))) - (printout FILE "(" .P2 (BITMAPWIDTH BM) - %, .P2 (BITMAPHEIGHT BM)) (* ; - "if the number of bits per pixel is not 1, write it out.") - (COND - ((NEQ (BITSPERPIXEL BM) - 1) - (SPACES 1 FILE) - (PRIN2 (BITSPERPIXEL BM) - FILE))) (* ; - "Enclose in list so that compile-copying works.") - (\WRITEBITMAP BM FILE) (* ; "Now write out contents.") - (PRIN1 ")" FILE]) - -(PRINT-BITMAPS-NICELY - [LAMBDA (BITMAP STREAM) (* ; "Edited 20-Mar-87 17:06 by jop") - -(* ;;; "The syntax for bitmaps is") - - (* ;; "#*(width height [bits-per-pixel])XXXXXX...") - -(* ;;; "where WIDTH and HEIGHT are the dimensions of the bitmap, BITS-PER-PIXEL can be omitted if it is equal to one, and the X's are single characters between @ and O (in ASCII), each representing four bits. There will be exactly (* (ceiling (* WIDTH BITS-PER-PIXEL) 16) 4) characters for each row of the bitmap and exactly HEIGHT rows. Note that there are no spaces allowed between the * and the (, between the ) and the first X, or anywhere inside the string of X's. Also, the character after the last X must not be of type OTHER.") - -(* ;;; "This function %"observes%" *print-length*: it truncates after printing *print-length* characters in the bitmap's representation.") - - (if (OR (NULL STREAM) - (NULL *PRINT-ARRAY*)) - then - - (* ;; "Let it be printed in the normal way, with an address.") - - NIL - else - - (* ;; "Print this bitmap in the preferred way.") - - (LET* ((WIDTH (BITMAPWIDTH BITMAP)) - (HEIGHT (BITMAPHEIGHT BITMAP)) - (BITS-PER-PIXEL (BITSPERPIXEL BITMAP)) - (BASE (fetch BITMAPBASE of BITMAP)) - (QUAD-CHARS-PER-ROW (FOLDHI (CL:* WIDTH BITS-PER-PIXEL) - 16)) - (CHARS-SO-FAR *PRINT-LENGTH*)) - (PRINTOUT STREAM "#*(" .P2 WIDTH " " .P2 HEIGHT) - (if (NEQ BITS-PER-PIXEL 1) - then (PRINTOUT STREAM " " .P2 BITS-PER-PIXEL)) - (PRINTOUT STREAM ")") - (PROG NIL - [CL:MACROLET [(ELIDE? NIL `(IF (AND CHARS-SO-FAR (EQ 0 (CL:DECF - CHARS-SO-FAR - ))) - THEN (PRINTOUT STREAM "...") - (GO OUT] - (CL:DOTIMES (ROW HEIGHT) - (CL:DOTIMES (QUAD QUAD-CHARS-PER-ROW) - (CL:WRITE-CHAR (CL:INT-CHAR (+ (LRSH (\GETBASEBYTE BASE 0) - 4) - (CL:CHAR-INT #\@))) - STREAM) - (ELIDE?) - (CL:WRITE-CHAR (CL:INT-CHAR (+ (LOGAND (\GETBASEBYTE BASE 0) - 15) - (CL:CHAR-INT #\@))) - STREAM) - (ELIDE?) - (CL:WRITE-CHAR (CL:INT-CHAR (+ (LRSH (\GETBASEBYTE BASE 1) - 4) - (CL:CHAR-INT #\@))) - STREAM) - (ELIDE?) - (CL:WRITE-CHAR (CL:INT-CHAR (+ (LOGAND (\GETBASEBYTE BASE 1) - 15) - (CL:CHAR-INT #\@))) - STREAM) - (ELIDE?) - (SETQ BASE (\ADDBASE BASE 1))))] - OUT (RETURN T]) - -(PRINTCURSOR - [LAMBDA (VAR) (* ; "Edited 2-Dec-86 14:15 by Pavel") - - (* ;; "Writes an expression that will define the cursor value of VAR") - - (PROG (CUR IMAGE MASK) - (COND - ([NOT (type? CURSOR (SETQ CUR (EVALV VAR 'PRINTCURSOR] - (printout T "******** " VAR " is not a CURSOR." T) - (RETURN NIL))) (* ; "write out defining form.") - (\CURSORBITSPERPIXEL CUR 1) - (SETQ IMAGE (fetch (CURSOR CUIMAGE) of CUR)) - (SETQ MASK (fetch (CURSOR CUMASK) of CUR)) - (PRINT `(RPAQ ,VAR (CURSORCREATE ',IMAGE ',(AND (NOT (EQ IMAGE MASK)) - MASK) - ,(fetch (CURSOR CUHOTSPOTX) of CUR) - ,(fetch (CURSOR CUHOTSPOTY) of CUR]) - -(\WRITEBITMAP - [LAMBDA (BITMAP FILE) (* ; "Edited 1-Dec-86 16:24 by Pavel") - -(* ;;; "writes the contents of a bitmap onto the currently open output file.") - - (PROG (LIM (BASE (fetch BITMAPBASE of BITMAP)) - (OFD (GETSTREAM FILE 'OUTPUT)) - (W (fetch BITMAPRASTERWIDTH of BITMAP))) - (FRPTQ (fetch BITMAPHEIGHT of BITMAP) - (TERPRI FILE) - (\BOUT OFD (CHARCODE %")) - (SETQ LIM (\ADDBASE BASE W)) - (until (EQ BASE LIM) do (\BOUT OFD (IPLUS (SUB1 (CHARCODE A)) - (LRSH (\GETBASEBYTE BASE 0) - 4))) - (\BOUT OFD (IPLUS (SUB1 (CHARCODE A)) - (LOGAND (\GETBASEBYTE BASE 0) - 15))) - (\BOUT OFD (IPLUS (SUB1 (CHARCODE A)) - (LRSH (\GETBASEBYTE BASE 1) - 4))) - (\BOUT OFD (IPLUS (SUB1 (CHARCODE A)) - (LOGAND (\GETBASEBYTE BASE 1) - 15))) - (SETQ BASE (\ADDBASE BASE 1))) - (\BOUT OFD (CHARCODE %"]) -) - -(DEFPRINT 'BITMAP 'PRINT-BITMAPS-NICELY) -(DEFINEQ - -(\GETINTEGERPART - [LAMBDA (FRACT) (* JonL " 7-May-84 02:43") - - (* ;; "gets the integer part of a fixed point number. The integer part has INTEGERBITS worth of significant bits the leftmost of which is sign.") - - (PROG [HIPART (ROUNDER (COND - ([EQ 0 (LOGAND (fetch (FIXP HINUM) of FRACT) - (CONSTANT (LLSH 1 (IDIFFERENCE BITSPERWORD (ADD1 - INTEGERBITS - ] - 0) - (T 1] - - (* ;; "assumes that the number of significant bits --- INTEGERBITS --- is less than can fit in the high order of the two words allocated for the integer.") - - (RETURN (COND - ([IGREATERP [SETQ HIPART (LRSH (fetch (FIXP HINUM) of FRACT) - (CONSTANT (IDIFFERENCE BITSPERWORD INTEGERBITS] - (CONSTANT (EXPT 2 (SUB1 INTEGERBITS] - (* ; - "the sign bit is on, make it negative.") - (IDIFFERENCE (IDIFFERENCE HIPART (CONSTANT (EXPT 2 INTEGERBITS))) - ROUNDER)) - (T (IPLUS HIPART ROUNDER]) - -(\CONVERTTOFRACTION - [LAMBDA (FLOAT) (* rmk%: " 3-JUL-82 23:29") - - (* ;; "converts a floating point number into a fixed point number with INTEGERBITS worth of integer part. Always returns a large integer so that the box can be clobbered.") - - (PROG (RESULT BOX) - (RETURN (COND - ([SMALLP (SETQ RESULT (FIX (FTIMES FLOAT (CONSTANT (FLOAT (EXPT 2 - (IDIFFERENCE - BITSPERINTEGER - INTEGERBITS] - (* ; "clobber a created box.") - (PutUnboxed (SETQ BOX (CREATECELL \FIXP)) - RESULT) - BOX) - (T RESULT]) -) -(DECLARE%: EVAL@COMPILE - -(RPAQQ INTEGERBITS 12) - - -(CONSTANTS (INTEGERBITS 12)) -) - - - -(* ; "cursor functions not on LLDISPLAY") - -(DEFINEQ - -(CURSORP - [LAMBDA (X) (* kbr%: " 5-Jul-85 17:54") - (* ; "is X a cursor?") - (type? CURSOR 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 HARDCURSORHEIGHT 16) - -(RPAQQ HARDCURSORWIDTH 16) - - -(CONSTANTS (HARDCURSORHEIGHT 16) - (HARDCURSORWIDTH 16)) -) -(DECLARE%: EVAL@COMPILE - -(ADDTOVAR GLOBALVARS CursorBitMap) -) - -(* "END EXPORTED DEFINITIONS") - - -(RPAQQ CARETCOMS - ((BITMAPS \DefaultCaret) - (INITVARS (\CARET.UP NIL - - (* ;; "global. NIL if no caret showing, otherwise a CARET1 record with CURSOR, stream, x, y, and RATE (= off rate)") -) - (\CARET.DEFAULT NIL (* ; - "global = default caret to put up. An instance of CARET1 datatype") - ) - (\CARET.TIMER (SETUPTIMER 0) - (* ; "time for next caret action")) - (DEFAULTCARET (CURSORCREATE \DefaultCaret NIL 3 4)) - (DEFAULTCARETRATE 333 (* ; "default rate for flashing caret") - ) - (\CARET.ON.RATE DEFAULTCARETRATE) - (\CARET.OFF.RATE DEFAULTCARETRATE) - (\CARET.FORCED.OFF.RATE 0)) - (ADDVARS (\SYSTEMTIMERVARS \CARET.TIMER)) - (DECLARE%: DONTCOPY (RECORDS CARET1)) - (INITRECORDS CARET1) - (FNS CARET \CARET.CREATE \CARET.DOWN \CARET.FLASH? \CARET.SHOW CARETRATE \CARET.FLASH.AGAIN - \CARET.FLASH.MULTIPLE \CARET.FLASH) - (FNS \MEDW.CARET.SHOW) - (* ; "some declarations are on LLDISPLAY -- macro for \CHECKCARET and globalvar declaration for \CARET.UP") - (GLOBALVARS \CARET.DEFAULT \CARET.ON.RATE \CARET.OFF.RATE DEFAULTCARET \CARET.TIMER \CARET.UP - \CARET.FORCED.OFF.RATE) - (DECLARE%: DONTEVAL@LOAD DOCOPY (ADDVARS (TTYBACKGROUNDFNS \CARET.FLASH?))) - (FNS \AREAVISIBLE? \REGIONOVERLAPAREAP \AREAINREGIONP) - (P (CARET T)))) - -(RPAQQ \DefaultCaret #*(7 6)A@@@CH@@CH@@FL@@FL@@LF@@) - -(RPAQ? \CARET.UP NIL - (* ;; "global. NIL if no caret showing, otherwise a CARET1 record with CURSOR, stream, x, y, and RATE (= off rate)") -) - -(RPAQ? \CARET.DEFAULT NIL (* ; - "global = default caret to put up. An instance of CARET1 datatype") -) - -(RPAQ? \CARET.TIMER (SETUPTIMER 0) - (* ; "time for next caret action")) - -(RPAQ? DEFAULTCARET (CURSORCREATE \DefaultCaret NIL 3 4)) - -(RPAQ? DEFAULTCARETRATE 333 (* ; "default rate for flashing caret") -) - -(RPAQ? \CARET.ON.RATE DEFAULTCARETRATE) - -(RPAQ? \CARET.OFF.RATE DEFAULTCARETRATE) - -(RPAQ? \CARET.FORCED.OFF.RATE 0) - -(ADDTOVAR \SYSTEMTIMERVARS \CARET.TIMER) -(DECLARE%: DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RECORD CARET1 (* ; - "a record that describes a SHOWING caret") - (STREAM (* ; - "the stream the caret is showing in") - STREAMX (* ; - "the X position stream relative that it was shown at") - STREAMY (* ; - "the Y position stream relative that it was shown at") - CURSOR (* ; - "the cursor bitmap + x and y that this caret represents") - RATE (* ; "the 'down rate' for this caret, in ticks. After comes down (when \CARET.TIMER expires), \CARET.TIMER will be rescheduled to put something up. This is the rate to use") - (* ; - "NEXT for threading carets together") - . NEXT)) -) -) -(DEFINEQ - -(CARET - [LAMBDA (NEWCARET) (* kbr%: " 6-Jul-85 16:13") - (* ; - "changes the 'system default' caret") - (PROG1 (COND - (\CARET.DEFAULT (* ; - "merely stored as a 'cursor' record for simplicity") - (fetch (CARET1 CURSOR) of \CARET.DEFAULT)) - (T 'OFF)) - [COND - (NEWCARET (\CHECKCARET) - (CARETRATE (CARETRATE)) (* ; "make sure the caret rate is set") - (SETQ \CARET.DEFAULT (SELECTQ NEWCARET - (T (COND - ((EQ DEFAULTCARET 'OFF) - NIL) - ((CURSORP DEFAULTCARET) - (create CARET1 - CURSOR _ DEFAULTCARET)) - (T (ERROR "DEFAULTCARET is not a cursor" - DEFAULTCARET)))) - (OFF NIL) - (COND - ((CURSORP NEWCARET) - (create CARET1 - CURSOR _ NEWCARET)) - (T (LISPERROR "ILLEGAL ARG" NEWCARET])]) - -(\CARET.CREATE - [LAMBDA (CURSOR) (* jds "11-Jul-85 19:38") - (create CARET1 - CURSOR _ (OR CURSOR DEFAULTCARET]) - -(\CARET.DOWN - [LAMBDA (STREAM INTERVAL UNLESSOCCLUDED) (* lmm " 4-May-84 18:15") - - (* ;; "take caret down if it is up. If you take it down, reschedule to put it back up in INTERVAL (or 0) --- often called thru \CHECKCARET macro") - - (COND - (\CARET.UP (COND - ([OR (NULL STREAM) - (fetch (CARET1 NEXT) of \CARET.UP) - (EQ (fetch (CARET1 STREAM) of \CARET.UP) - (COND - ((type? WINDOW STREAM) - (fetch (WINDOW DSP) of STREAM)) - (T STREAM] - [while (UNINTERRUPTABLY - [COND - ((\CARET.SHOW \CARET.UP UNLESSOCCLUDED) - (* ; - "take caret down and set global state") - (replace (CARET1 STREAM) of \CARET.UP with - NIL) - (SETQ \CARET.UP (fetch (CARET1 NEXT) of \CARET.UP])] - (SETUPTIMER (OR INTERVAL \CARET.FORCED.OFF.RATE) - \CARET.TIMER]) - -(\CARET.FLASH? - [LAMBDA (STREAM CARET ONRATE OFFRATE X Y) (* AJB "17-Jul-85 12:47") - -(* ;;; "Flashes the CARET at the ONRATE/OFFRATE at the X,Y position in the current TTY window. If CARET is NIL, uses \CARET.DEFAULT as the caret. Takes either a display stream or a textstream as the destination stream to flash the caret. The caret is not flashed on a shift-selection in a window") - - (COND - (\CARET.UP [COND - ((TIMEREXPIRED? \CARET.TIMER) - (\CARET.DOWN NIL (fetch (CARET1 RATE) of \CARET.UP) - (OR (KEYDOWNP 'LSHIFT) - (KEYDOWNP 'RSHIFT) - (KEYDOWNP 'COPY] - NIL) - ((AND (OR CARET (SETQ CARET \CARET.DEFAULT)) - (TIMEREXPIRED? \CARET.TIMER) - [OR [DISPLAYSTREAMP (OR STREAM (SETQ STREAM (TTYDISPLAYSTREAM] - (AND (IMAGESTREAMTYPEP STREAM 'TEXT) - (SETQ STREAM (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW) of (TEXTOBJ - STREAM))) - 'DSP] - (\CARET.FLASH CARET STREAM OFFRATE (OR (KEYDOWNP 'LSHIFT) - (KEYDOWNP 'RSHIFT) - (KEYDOWNP 'COPY)) - X Y)) - - (* ;; "\CARET.DEFAULT is NIL if by default the caret is OFF --- the KEYDOWNP clause is a hack to detect whether we are doing a copy-select") - - (replace (CARET1 NEXT) of CARET with NIL)(* ; - "Since this function is displaying a new caret, destroy any chaining of multiple carets") - (SETUPTIMER (OR ONRATE \CARET.ON.RATE) - \CARET.TIMER) - T]) - -(\CARET.SHOW - [LAMBDA (CARET UNLESSOCCLUDED) (* ; "Edited 25-Feb-94 16:53 by sybalsky") - - (* ;; "GENERIC caret flasher.") - - (LET (DS) - (SETQ DS (fetch (CARET1 STREAM) of CARET)) - (WINDOWOP 'SCCARETFLASH (FETCH (WINDOW SCREEN) OF (FETCH (\DISPLAYDATA - XWINDOWHINT) - OF (FETCH (STREAM - IMAGEDATA) - OF DS))) - CARET UNLESSOCCLUDED]) - -(CARETRATE - [LAMBDA (ONRATE OFFRATE) (* lmm " 3-May-84 11:35") - - (* ;; "sets the default caret rate (s) to be ONRATE/OFFRATE in milliseconds") - - (PROG1 (COND - ((EQ \CARET.ON.RATE \CARET.OFF.RATE) - \CARET.ON.RATE) - (T (CONS \CARET.ON.RATE \CARET.OFF.RATE))) - [COND - ((OR ONRATE OFFRATE) - (SETUPTIMER 0 \CARET.TIMER) - (SETQ \CARET.ON.RATE (OR (FIXP ONRATE) - (FIX DEFAULTCARETRATE))) - (SETQ \CARET.OFF.RATE (OR (FIXP OFFRATE) - \CARET.ON.RATE])]) - -(\CARET.FLASH.AGAIN - [LAMBDA (CARET STREAM X Y) (* AJB "14-Aug-85 17:04") - (LET ((OCARET \CARET.UP)) - (COND - ([AND OCARET CARET (DISPLAYSTREAMP (OR STREAM (SETQ STREAM (TTYDISPLAYSTREAM] - (for (OC _ OCARET) by (fetch (CARET1 NEXT) of OC) - do (COND - [(NULL OC) - (RETURN (COND - ((\CARET.FLASH CARET STREAM (fetch (CARET1 RATE) - of \CARET.UP) - (OR (KEYDOWNP 'LSHIFT) - (KEYDOWNP 'RSHIFT) - (KEYDOWNP 'COPY)) - X Y) (* ; "OK, showed this one") - (OR (EQ \CARET.UP CARET) - (SHOULDNT)) - (replace (CARET1 NEXT) of CARET with OCARET] - ((EQ OC CARET) (* ; "this CARET is already showing") - (RETURN]) - -(\CARET.FLASH.MULTIPLE - [LAMBDA (STREAMS CARETS ONRATE OFFRATE) (* AJB "14-Aug-85 17:10") - (* ; - "this is probably just a template for how to flash multiple carets") - (COND - ((\CARET.FLASH? (CAR STREAMS) - (CAR CARETS) - ONRATE OFFRATE) - (for STR in (CDR STREAMS) as CARET in (CDR CARETS) - do (\CARET.FLASH.AGAIN CARET STR]) - -(\CARET.FLASH - [LAMBDA (CARET STREAM RATE UNLESSOCCLUDED X Y) (* kbr%: " 5-Jul-85 17:51") - (PROG (CURSOR ANSWER) - (SETQ CURSOR (fetch (CARET1 CURSOR) of CARET)) - (replace (CARET1 STREAM) of CARET with STREAM) - (replace (CARET1 STREAMX) of CARET with (IDIFFERENCE (OR X (DSPXPOSITION NIL - STREAM)) - (fetch (CURSOR CUHOTSPOTX) - of CURSOR))) - (replace (CARET1 STREAMY) of CARET with (IDIFFERENCE (OR Y (DSPYPOSITION NIL - STREAM)) - (fetch (CURSOR CUHOTSPOTY) - of CURSOR))) - (replace (CARET1 RATE) of CARET with (OR RATE \CARET.OFF.RATE)) - (UNINTERRUPTABLY - (COND - ((\CARET.SHOW CARET UNLESSOCCLUDED) - (SETQ \CARET.UP CARET) - (SETQ ANSWER T)))) - (RETURN ANSWER]) -) -(DEFINEQ - -(\MEDW.CARET.SHOW - [LAMBDA (SCREEN CARET UNLESSOCCLUDED) (* ; - "Edited 17-Jan-94 10:28 by sybalsky:mv:envos") - - (* ;; "MEDLEY-window-system specific version of \CARET.SHOW (vectored thru the screen). Flash the caret (by inverting its image). UNLESSOCCLUDED controls whether you bring the window to the top if the caret is under some other window.") - - (PROG (DS) - (SETQ DS (fetch (CARET1 STREAM) of CARET)) - (RETURN (PROG (DD CARETWIN CBMX CBMY CURSOR CARETBM CWX CWY CARETBMWIDTH CARETBMHEIGHT - CLIPREG CLIPVAR) - (SETQ DD (fetch (STREAM IMAGEDATA) of DS)) - (SETQ CARETWIN (WFROMDS DS)) - (SETQ CBMX 0) - (SETQ CBMY 0) - (SETQ CURSOR (fetch (CARET1 CURSOR) of CARET)) - (\CURSORBITSPERPIXEL CURSOR (BITSPERPIXEL (DSPDESTINATION NIL CARETWIN))) - (SETQ CARETBM (fetch (CURSOR CUIMAGE) of CURSOR)) - (SETQ CWX (fetch (CARET1 STREAMX) of CARET)) - (SETQ CWY (fetch (CARET1 STREAMY) of CARET)) - (SETQ CARETBMWIDTH (fetch (BITMAP BITMAPWIDTH) of CARETBM)) - (SETQ CARETBMHEIGHT (fetch (BITMAP BITMAPHEIGHT) of CARETBM)) - (* ; - "calculate how much to reduce the caret region by do to the clipping region of the window.") - (SETQ CLIPREG (fetch (\DISPLAYDATA DDClippingRegion) of DD)) - (COND - ((IGREATERP (SETQ CLIPVAR (fetch (REGION LEFT) of CLIPREG)) - CWX) - [SETQ CARETBMWIDTH (IDIFFERENCE CARETBMWIDTH (SETQ CBMX (IDIFFERENCE - CLIPVAR CWX] - (SETQ CWX CLIPVAR))) - (COND - ((IGREATERP CARETBMWIDTH (SETQ CLIPVAR (IDIFFERENCE - (IPLUS CLIPVAR (fetch - (REGION WIDTH) - of CLIPREG)) - CWX))) - (SETQ CARETBMWIDTH CLIPVAR))) - (COND - ((IGREATERP (SETQ CLIPVAR (fetch (REGION BOTTOM) of CLIPREG)) - CWY) - [SETQ CARETBMHEIGHT (IDIFFERENCE CARETBMHEIGHT (SETQ CBMY - (IDIFFERENCE CLIPVAR CWY] - (SETQ CWY CLIPVAR))) - (COND - ((IGREATERP CARETBMHEIGHT (SETQ CLIPVAR (IDIFFERENCE - (IPLUS CLIPVAR - (fetch (REGION HEIGHT) - of CLIPREG)) - CWY))) - (SETQ CARETBMHEIGHT CLIPVAR))) - - (* note the time of the next change. This must be done without creating boxes - because happens during keyboard wait.) - - (COND - ((OR (ILESSP CARETBMWIDTH 1) - (ILESSP CARETBMHEIGHT 1)) (* caret isn't within clipping - region.) - (RETURN T))) (* convert the base of the caret - location to screen coordinates.) - (SETQ CWX (\DSPTRANSFORMX CWX DD)) - (SETQ CWY (\DSPTRANSFORMY CWY DD)) - - (* having only this section uninterruptable leaves open the possibility that - the window moves or the timer is wrong but these will only mess up the display - and are low frequency events.) - - (COND - [(AND (OPENWP CARETWIN) - (\AREAVISIBLE? CARETWIN CWX CWY (IPLUS CWX (SUB1 CARETBMWIDTH)) - (IPLUS CWY (SUB1 CARETBMHEIGHT] - (UNLESSOCCLUDED (RETURN)) - (T (TOTOPW CARETWIN))) - (BITBLT CARETBM CBMX CBMY (DSPDESTINATION NIL CARETWIN) - CWX CWY CARETBMWIDTH CARETBMHEIGHT 'INPUT 'INVERT) - (RETURN T]) -) - - - -(* ; -"some declarations are on LLDISPLAY -- macro for \CHECKCARET and globalvar declaration for \CARET.UP") - -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS \CARET.DEFAULT \CARET.ON.RATE \CARET.OFF.RATE DEFAULTCARET \CARET.TIMER \CARET.UP - \CARET.FORCED.OFF.RATE) -) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(ADDTOVAR TTYBACKGROUNDFNS \CARET.FLASH?) -) -(DEFINEQ - -(\AREAVISIBLE? - [LAMBDA (WIN LFT BTM RGHT TOP) (* kbr%: "18-Feb-86 18:05") - - (* ;; "is the area whose screen limits are LFT BTM RGHT and TOP eniretly visible within WIN,") - - (PROG (WPTR) - (SETQ WPTR (fetch (SCREEN SCTOPW) of (fetch (WINDOW SCREEN) of WIN))) - (COND - ((NOT (\AREAINREGIONP (fetch (WINDOW REG) of WIN) - LFT BTM RGHT TOP)) (* ; - "if the caret region isn't completely within the window, forget it.") - (RETURN))) - LP (COND - ((EQ WPTR WIN) - (RETURN T)) - ((\REGIONOVERLAPAREAP (fetch (WINDOW REG) of WPTR) - LFT BTM RGHT TOP) - (RETURN NIL)) - ((SETQ WPTR (fetch (WINDOW NEXTW) of WPTR)) - (GO LP]) - -(\REGIONOVERLAPAREAP - [LAMBDA (REG LFT BTM RGHT TOP) (* rrb "17-Feb-86 18:50") - - (* ;; - "is there any overlap between the region REG and the area defined by left bottom right and top?") - - (NOT (OR (IGREATERP (fetch (REGION LEFT) of REG) - RGHT) - (IGREATERP LFT (fetch (REGION RIGHT) of REG)) - (IGREATERP (fetch (REGION BOTTOM) of REG) - TOP) - (IGREATERP BTM (fetch (REGION TOP) of REG]) - -(\AREAINREGIONP - [LAMBDA (REGION LFT BTM RGHT TOP) (* rrb "14-OCT-83 15:32") - (AND (IGEQ LFT (fetch LEFT of REGION)) - (IGEQ BTM (fetch BOTTOM of REGION)) - (IGEQ (fetch PRIGHT of REGION) - RGHT) - (IGEQ (fetch PTOP of REGION) - TOP]) -) - -(CARET T) - - - -(* ; "Region functions") - -(DEFINEQ - -(CREATEREGION - [LAMBDA (LEFT BOTTOM WIDTH HEIGHT) (* rrb "17-JUN-83 08:56") - (* ; "creates a region structure.") - (create REGION - LEFT _ LEFT - BOTTOM _ BOTTOM - WIDTH _ WIDTH - HEIGHT _ HEIGHT]) - -(REGIONP - [LAMBDA (X) (* rrb "29-Jun-84 18:00") - (AND (type? REGION X) - X]) - -(INTERSECTREGIONS - [LAMBDA REGIONS (* kbr%: "24-Jan-86 18:30") - - (* ;; "returns the largest region that is contained in all of REGIONS") - - (COND - ((EQ REGIONS 0) - - (* ;; "this is documented as returning a very large region. This one covers the entire FIXP range so should work for many purposes. rrb") - - (create REGION - LEFT _ (SUB1 MIN.FIXP) - BOTTOM _ (SUB1 MIN.FIXP) - WIDTH _ (PLUS (TIMES 2 MAX.FIXP) - 4) - HEIGHT _ (PLUS (TIMES 2 MAX.FIXP) - 4))) - (T (PROG (REG LFT RGHT BTTM TP) - (SETQ REG (ARG REGIONS 1)) - (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 "30-Dec-85 17:07") - - (* ;; "returns the smallest region that encloses all of REGIONS") - - (COND - ((EQ 0 REGIONS) - NIL) - (T (PROG (REG LFT RGHT BTTM TP) - (SETQ REG (ARG REGIONS 1)) - (SETQ LFT (fetch (REGION LEFT) of REG)) - (SETQ RGHT (fetch (REGION PRIGHT) of REG)) - (SETQ BTTM (fetch (REGION BOTTOM) of REG)) - (SETQ TP (fetch (REGION PTOP) of REG)) - [for I from 2 thru REGIONS do (SETQ REG (ARG REGIONS I)) - [COND - ((LESSP (fetch (REGION LEFT) - of REG) - LFT) - (SETQ LFT (fetch (REGION LEFT) - of REG] - [COND - ((LESSP (fetch (REGION BOTTOM) - of REG) - BTTM) - (SETQ BTTM (fetch (REGION BOTTOM - ) - of REG] - [COND - ((GREATERP (fetch (REGION PRIGHT) - of REG) - RGHT) - (SETQ RGHT (fetch (REGION PRIGHT - ) - of REG] - (COND - ((GREATERP (fetch (REGION PTOP) - of REG) - TP) - (SETQ TP (fetch (REGION PTOP) - of REG] - (RETURN (create REGION - LEFT _ LFT - BOTTOM _ BTTM - WIDTH _ (DIFFERENCE RGHT LFT) - HEIGHT _ (DIFFERENCE 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 '(9 0 100 100) '(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 top") - (PROG ((OLDTOP (fetch (REGION TOP) of REG))) - [COND - ((ILESSP OLDTOP NEWTOP) - (replace (REGION HEIGHT) of REG with (IPLUS (fetch (REGION HEIGHT) - of REG) - (IDIFFERENCE NEWTOP OLDTOP] - (RETURN REG]) - -(INSIDEP - [LAMBDA (REGION POSORX Y) (* rrb "18-May-84 21:04") - - (* ;; "returns T if the position X Y is inside the region REGION. If POSORX is a position, returns T if that position is inside of REGION") - - (COND - ((WINDOWP REGION) - (INSIDEP (DSPCLIPPINGREGION NIL REGION) - POSORX Y)) - (T (COND - ((AND (NUMBERP POSORX) - (NUMBERP Y)) - (INSIDE? REGION POSORX Y)) - ((POSITIONP POSORX) - (INSIDE? REGION (fetch (POSITION XCOORD) of POSORX) - (fetch (POSITION YCOORD) of POSORX))) - ((NUMBERP POSORX) - (\ILLEGAL.ARG Y)) - (T (\ILLEGAL.ARG POSORX]) - -(STRINGREGION - [LAMBDA (STR STREAM PRIN2FLG RDTBL) (* rmk%: "25-AUG-83 18:06") - - (* ;; "returns the region taken up by STR if it were printed at the current position of STREAM") - - (create REGION - LEFT _ (DSPXPOSITION NIL STREAM) - BOTTOM _ (IDIFFERENCE (DSPYPOSITION NIL STREAM) - (FONTPROP STREAM 'DESCENT)) - WIDTH _ (STRINGWIDTH STR STREAM PRIN2FLG RDTBL) - HEIGHT _ (FONTPROP STREAM 'HEIGHT]) -) - - - -(* ; "line and spline drawing.") - - - - -(* ; "Brushes and brush initialization") - -(DECLARE%: DONTCOPY -(DECLARE%: EVAL@COMPILE - -[PUTDEF '\BRUSHBBT 'RESOURCES '(NEW (create PILOTBBT] -) -) - -(/SETTOPVAL '\\BRUSHBBT.GLOBALRESOURCE NIL) -(DEFINEQ - -(\BRUSHBITMAP - [LAMBDA (BRUSHSHAPE BRUSHWIDTH) (* rrb " 9-Sep-86 16:30") - -(* ;;; -"returns the bitmap for the brush of the shape and size. See comments on \InitCurveBrushes.") - - (DECLARE (GLOBALVARS \BrushAList)) - (LET [(BRUSHES&METHOD (CDR (OR (FASSOC BRUSHSHAPE \BrushAList) - (\ILLEGAL.ARG BRUSHSHAPE] - (COND - ((NOT (GREATERP BRUSHWIDTH 0)) - - (* ;; "if brush is 0 or negative, return an empty brush. Might want to error but this would require users to handle it.") - - (BITMAPCREATE 0 0)) - [(ILESSP BRUSHWIDTH 17) (* ; - "lowest 16 brushes are stored. FIX them so ELT works.") - (ELT (fetch (BRUSHITEM BRUSHARRAY) of BRUSHES&METHOD) - (COND - ((FIXP BRUSHWIDTH)) - ((GREATERP BRUSHWIDTH 1) - (FIXR BRUSHWIDTH)) - (T 1] - [(CDR (FASSOC BRUSHWIDTH (fetch (BRUSHITEM BRUSHCACHE) of BRUSHES&METHOD] - (T - (* ;; "cache the brush bitmap. This is done so that the brush creation methods don't have to be efficient.") - - (LET ((NEWBRUSHBM (APPLY* (fetch (BRUSHITEM CREATEMETHOD) of BRUSHES&METHOD) - BRUSHWIDTH))) - (replace (BRUSHITEM BRUSHCACHE) of BRUSHES&METHOD - with (CONS (CONS BRUSHWIDTH NEWBRUSHBM) - (fetch (BRUSHITEM BRUSHCACHE) of BRUSHES&METHOD))) - NEWBRUSHBM]) - -(\GETBRUSH - [LAMBDA (BRUSH) (* rrb " 9-Sep-86 16:30") - (COND - ((type? BITMAP BRUSH) - BRUSH) - [(LISTP BRUSH) - (\BRUSHBITMAP (CAR BRUSH) - (CAR (LISTP (CDR BRUSH] - (T (\BRUSHBITMAP 'ROUND (OR BRUSH 1]) - -(\GETBRUSHBBT - [LAMBDA (BRUSHBM DISPLAYDATA BBT) (* kbr%: "18-Aug-85 12:46") - - (* ;; "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 (BITMAP BITMAPHEIGHT) of BRUSHBM) - 1) - (EQ (ffetch (BITMAP 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 (PILOTBBT PBTDESTBPL) of BBT with (UNFOLD (fetch (BITMAP - BITMAPRASTERWIDTH - ) - of - (fetch (\DISPLAYDATA - DDDestination - ) - of DISPLAYDATA)) - BITSPERWORD)) - (freplace (PILOTBBT PBTSOURCEBPL) of BBT with (UNFOLD (ffetch (BITMAP - - BITMAPRASTERWIDTH - ) - of BRUSHBM) - BITSPERWORD)) - (freplace (PILOTBBT PBTFLAGS) of BBT with 0) - (freplace (PILOTBBT PBTDISJOINT) of BBT with T) - (\SETPBTFUNCTION BBT (ffetch (\DISPLAYDATA DDSOURCETYPE) of DISPLAYDATA) - (SELECTQ (ffetch (\DISPLAYDATA DDOPERATION) of DISPLAYDATA) - ((PAINT REPLACE) - 'PAINT) - ((INVERT ERASE) - 'ERASE) - (SHOULDNT))) - BBT]) - -(\InitCurveBrushes - [LAMBDA NIL (* ; "Edited 13-Oct-87 14:31 by jds") - - (* ;; "Set up the initial set of brush specs for curve drawing. \BrushAList is an association list from brush-shape-names to a spec which is an instance of the record BRUSHITEM.") - - (DECLARE (GLOBALVARS \BrushNames \BrushAList \SingleBitBitmap)) - (PROG (BARRAY CREATIONMETHOD) - (SETQ \SingleBitBitmap (BITMAPCREATE 1 1)) - (BITMAPBIT \SingleBitBitmap 0 0 1) - (for BRUSHNAME in \BrushNames do (SETQ BARRAY (ARRAY 16 'POINTER NIL 1)) - (SETQ CREATIONMETHOD (PACK* '\MAKEBRUSH. - BRUSHNAME)) - (SETA BARRAY 1 \SingleBitBitmap) - (for SIZE from 2 to 16 - do (SETA BARRAY SIZE (APPLY* - CREATIONMETHOD - SIZE))) - (INSTALLBRUSH BRUSHNAME CREATIONMETHOD - BARRAY]) - -(\BrushFromWidth - [LAMBDA (W) (* hdj " 5-Nov-84 16:47") - (LIST 'ROUND W]) -) -(DEFINEQ - -(\MAKEBRUSH.DIAGONAL - [LAMBDA (SIZE) (* kbr%: "18-Aug-85 12:51") - (PROG (BM) - (SETQ BM (BITMAPCREATE SIZE SIZE)) - (for X from 0 to (SUB1 SIZE) do (BITMAPBIT BM X X 1)) - (RETURN BM]) - -(\MAKEBRUSH.HORIZONTAL - [LAMBDA (SIZE) (* kbr%: "18-Aug-85 12:52") - -(* ;;; "create a brush that has a horizontal line across it halfway down") - - (PROG (BM) - (SETQ BM (BITMAPCREATE SIZE SIZE)) - (BITBLT NIL NIL NIL BM 0 (SUB1 (FOLDHI SIZE 2)) - NIL 1 'TEXTURE 'REPLACE BLACKSHADE) - (RETURN BM]) - -(\MAKEBRUSH.VERTICAL - [LAMBDA (SIZE) (* kbr%: "18-Aug-85 12:53") - (PROG (BM) - (SETQ BM (BITMAPCREATE SIZE SIZE)) - (BITBLT NIL NIL NIL BM (SUB1 (FOLDHI SIZE 2)) - 0 1 SIZE 'TEXTURE 'REPLACE BLACKSHADE) - (RETURN BM]) - -(\MAKEBRUSH.SQUARE - [LAMBDA (SIZE) (* kbr%: "18-Aug-85 13:07") - (PROG (BM) - (SETQ BM (BITMAPCREATE SIZE SIZE)) - (BITBLT NIL NIL NIL BM NIL NIL NIL NIL 'TEXTURE 'REPLACE BLACKSHADE) - (RETURN BM]) - -(\MAKEBRUSH.ROUND - [LAMBDA (SIZE) (* rrb "15-Sep-86 14:32") - (* ; - "special cased 8 so that it wouldn't have a width of 7. rrb") - (PROG (RADIUS BITMAP BASE) - (SETQ RADIUS (SUB1 (HALF SIZE))) - (SETQ BITMAP (BITMAPCREATE SIZE SIZE)) - (SETQ BASE (fetch (BITMAP BITMAPBASE) of BITMAP)) - (SELECTQ SIZE - (1 (\PUTBASE BASE 0 (MASK.1'S 15 1))) - (2 (\PUTBASE BASE 0 (MASK.1'S 14 2)) - (\PUTBASE BASE 1 (MASK.1'S 14 2))) - (3 (\PUTBASE BASE 0 (MASK.1'S 14 1)) - (\PUTBASE BASE 1 (MASK.1'S 13 3)) - (\PUTBASE BASE 2 (MASK.1'S 14 1))) - (4 (\PUTBASE BASE 0 (MASK.1'S 13 2)) - (\PUTBASE BASE 1 (MASK.1'S 12 4)) - (\PUTBASE BASE 2 (MASK.1'S 12 4)) - (\PUTBASE BASE 3 (MASK.1'S 13 2))) - (5 (\PUTBASE BASE 0 (MASK.1'S 13 1)) - (\PUTBASE BASE 1 (MASK.1'S 12 3)) - (\PUTBASE BASE 2 (MASK.1'S 11 5)) - (\PUTBASE BASE 3 (MASK.1'S 12 3)) - (\PUTBASE BASE 4 (MASK.1'S 13 1))) - (8 (\PUTBASE BASE 0 (MASK.1'S 10 4)) - (\PUTBASE BASE 1 (MASK.1'S 9 6)) - (\PUTBASE BASE 2 (MASK.1'S 8 8)) - (\PUTBASE BASE 3 (MASK.1'S 8 8)) - (\PUTBASE BASE 4 (MASK.1'S 8 8)) - (\PUTBASE BASE 5 (MASK.1'S 8 8)) - (\PUTBASE BASE 6 (MASK.1'S 9 6)) - (\PUTBASE BASE 7 (MASK.1'S 10 4))) - (FILLCIRCLE RADIUS RADIUS RADIUS BLACKSHADE (DSPCREATE BITMAP))) - (RETURN BITMAP]) -) -(DEFINEQ - -(INSTALLBRUSH - [LAMBDA (BRUSHNAME BRUSHFN BRUSHARRAY) (* kbr%: "18-Jan-86 15:27") - (DECLARE (GLOBALVARS \BrushAList)) - (PROG (OLDENTRY) - (SETQ OLDENTRY (FASSOC BRUSHNAME \BrushAList)) - (COND - (OLDENTRY (AND BRUSHARRAY (replace (BRUSHITEM BRUSHARRAY) of (CDR OLDENTRY) - with BRUSHARRAY)) - (AND BRUSHFN (replace (BRUSHITEM CREATEMETHOD) of (CDR OLDENTRY) - with BRUSHFN))) - (T [COND - ((AND BRUSHFN (NOT (ARRAYP BRUSHARRAY))) - (SETQ BRUSHARRAY (ARRAY 16 'POINTER NIL 1)) - (for X from 1 to 16 do (SETA BRUSHARRAY X (APPLY* BRUSHFN X] - (push \BrushAList (CONS BRUSHNAME (create BRUSHITEM - BRUSHARRAY _ BRUSHARRAY - CREATEMETHOD _ BRUSHFN))) - (push KNOWN.BRUSHES BRUSHNAME]) -) - -(RPAQQ \BrushNames (ROUND SQUARE DIAGONAL HORIZONTAL VERTICAL)) - -(RPAQ? KNOWN.BRUSHES NIL) - -(RPAQ? \BrushAList NIL) -(DECLARE%: EVAL@COMPILE - -(RECORD BRUSHITEM (BRUSHARRAY CREATEMETHOD . BRUSHCACHE)) -) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(\InitCurveBrushes) -) -(DECLARE%: DONTCOPY -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS \BrushAList KNOWN.BRUSHES) -) -) - - - -(* ; "Lines") - -(DEFINEQ - -(\DRAWLINE.DISPLAY - [LAMBDA (DISPLAYSTREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING) - (* ; "Edited 13-Jun-2021 14:03 by rmk:") - - (* ;; "DISPLAYSTREAM is guaranteed to be a display-stream. Draws a line from x1,y1 to x2,y2 leaving the position at x2,y2") - - (* ;; "Added handling of brushes (I think, this is actually pretty tricky).") - - (DECLARE (LOCALVARS . T)) - (SELECTQ OPERATION - (NIL (ffetch DDOPERATION of (fetch IMAGEDATA of DISPLAYSTREAM))) - ((REPLACE PAINT INVERT ERASE) - OPERATION) - (\ILLEGAL.ARG OPERATION)) - (\INSURETOPWDS DISPLAYSTREAM) (* ; - "RMK: This was only in the no-dash case, oddly") - (IF (OR DASHING (BRUSHP WIDTH)) - THEN [LET ((BRUSH (INSURE.BRUSH WIDTH))) - (if COLOR - then (replace (BRUSH BRUSHCOLOR) of BRUSH with COLOR)) - (IF (BIGBITMAPP (ffetch DDDestination of (fetch IMAGEDATA - of DISPLAYSTREAM))) - THEN (\DRAWLINE.BIGBM.DASH DISPLAYSTREAM X1 Y1 X2 Y2 BRUSH DASHING - OPERATION) - ELSE (GLOBALRESOURCES \BRUSHBBT (\LINEWITHBRUSH X1 Y1 X2 Y2 BRUSH - (\GOOD.DASHLST DASHING BRUSH) - DISPLAYSTREAM \BRUSHBBT OPERATION] - ELSEIF (BIGBITMAPP (ffetch DDDestination of (fetch IMAGEDATA of - DISPLAYSTREAM - ))) - THEN (\DRAWLINE.BIGBM.NODASH DISPLAYSTREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR) - ELSE (LET ((DD (fetch IMAGEDATA of DISPLAYSTREAM))) - (\CLIPANDDRAWLINE (\DSPTRANSFORMX (OR (FIXP X1) - (FIXR X1)) - DD) - (\DSPTRANSFORMY (OR (FIXP Y1) - (FIXR Y1)) - DD) - (\DSPTRANSFORMX (OR (FIXP X2) - (FIXR X2)) - DD) - (\DSPTRANSFORMY (OR (FIXP Y2) - (FIXR Y2)) - DD) - [COND - ((NULL WIDTH) - 1) - ((OR (FIXP WIDTH) - (FIXR WIDTH] - OPERATION - (ffetch DDDestination of DD) - (ffetch DDClippingLeft of DD) - (SUB1 (ffetch DDClippingRight of DD)) - (ffetch DDClippingBottom of DD) - (SUB1 (ffetch DDClippingTop of DD)) - DISPLAYSTREAM COLOR))) (* ; - "the generic case of MOVETO is used so that the hardcopy streams get handled as well.") - (MOVETO X2 Y2 DISPLAYSTREAM]) - -(RELMOVETO - [LAMBDA (DX DY STREAM) (* rmk%: "25-AUG-83 18:13") - (* ; "moves the position by a vector") - (DSPXPOSITION [IPLUS DX (DSPXPOSITION NIL (SETQ STREAM (\OUTSTREAMARG STREAM] - STREAM) - (DSPYPOSITION (IPLUS DY (DSPYPOSITION NIL STREAM)) - STREAM]) - -(MOVETOUPPERLEFT - [LAMBDA (STREAM REGION) (* hdj " 5-Jul-85 12:19") - - (* ;; "moves the current position to the upper left corner so that the first line of text will all appear.") - - (PROG [(ASCENT (FONTPROP (DSPFONT NIL STREAM) - 'ASCENT] - (COND - ((AND REGION (OR (type? REGION REGION) - (\ILLEGAL.ARG REGION))) - (MOVETO (fetch (REGION LEFT) of REGION) - (IDIFFERENCE (fetch (REGION PTOP) of REGION) - ASCENT) - STREAM)) - (T (MOVETO (DSPLEFTMARGIN NIL STREAM) - (IDIFFERENCE (fetch (REGION PTOP) of (DSPCLIPPINGREGION NIL STREAM)) - ASCENT) - STREAM))) - (RETURN STREAM]) -) -(DEFINEQ - -(\CLIPANDDRAWLINE - [LAMBDA (X1 Y1 X2 Y2 WIDTH OPERATION BITMAP LEFT RIGHT BOTTOM TOP DS COLOR) - (* ; "Edited 21-Aug-91 12:15 by jds") - - (* ;; "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 - ((NOT (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP) - 1)) (* ; - "make adjustments in case of color.") - (SETQ COLOR (COLORNUMBERP (OR COLOR (DSPCOLOR NIL DS)) - (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP))) - (* ; "(COND ((EQ OPERATION 'ERASE) ; treat erase as AND of background (SETQ COLOR (OPPOSITECOLOR COLOR (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)))))") - ) - (T (SETQ COLOR BLACKSHADE))) - (PROG NIL - (COND - [(EQ X1 X2) (* ; "special case of vertical line.") - [COND - ((IGREATERP WIDTH 2) - (COND - [(EQ Y1 Y2) - - (* ;; "special case. Since we don't know whether the guy is headed horizontally or vertically, put out a round brush This is a fairly infrequent case because I didn't get any bug reports on it in three years so efficiency is not a consideration.") - - (RETURN (.WHILE.TOP.DS. DS (\DRAWPOINT.DISPLAY (DSPDESTINATION NIL DS) - X1 Y1 (LIST 'ROUND WIDTH COLOR) - OPERATION] - (T (SETQ X1 (SETQ X2 (IDIFFERENCE X1 (LRSH (SUB1 WIDTH) - 1] - (PROG (MIN MAX) - (RETURN (COND - ([OR (IGREATERP X1 RIGHT) - (IGEQ LEFT (SETQ X2 (IPLUS X1 WIDTH))) - (IGREATERP (SETQ MIN (IMIN Y1 Y2)) - TOP) - (IGREATERP BOTTOM (SETQ MAX (IMAX Y1 Y2] - (* ; "outside clippingregion.") - NIL) - (T (.WHILE.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)) - '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) - '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) - (SETQ 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) - (SETQ 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) - (* JonL " 7-May-84 02:57") - - (* ;; "LEFT, RIGHT, BOTTOM, TOP are set to the boundaries of the clipping region") - - (* ;; "DS is passed so that window can be uninterruptably brought to top.") - - (PROG (DX DY YMOVEUP HALFDX HALFDY (BMRASTERWIDTH (fetch BITMAPRASTERWIDTH of BITMAP))) - (COND - ((IGREATERP X1 X2) (* ; - "switch points so DX is always positive.") - (SETQ HALFDX X1) - (SETQ X1 X2) - (SETQ X2 HALFDX) - (SETQ HALFDX Y1) - (SETQ Y1 Y2) - (SETQ Y2 HALFDX))) (* ; - "calculate differences and sign of Y movement.") - (SETQ HALFDX (LRSH (SETQ DX (IDIFFERENCE X2 X1)) - 1)) - (SETQ HALFDY (LRSH [SETQ DY (COND - ((IGREATERP Y2 Y1) - (SETQ YMOVEUP T) - (IDIFFERENCE Y2 Y1)) - (T (IDIFFERENCE Y1 Y2] - 1)) - (COND - ((AND (IGEQ X1 LEFT) - (IGEQ RIGHT X2) - [COND - (YMOVEUP (AND (IGEQ Y1 BOTTOM) - (IGEQ TOP Y2))) - (T (AND (IGEQ Y2 BOTTOM) - (IGEQ TOP Y1] - (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP) - 1)) (* ; - "line is completely visible, fast case.") - (.WHILE.TOP.DS. DS (\DRAWLINE1 X1 (SUB1 (\SFInvert BITMAP Y1)) - DX DY DX DY (COND - ((IGREATERP DX DY) - (* ; "X is the fastest mover.") - HALFDX) - (T (* ; "y is the fastest mover.") - HALFDY)) - (COND - (YMOVEUP (* ; - "y is moving in positive direction but bits are stored inversely") - (IMINUS BMRASTERWIDTH)) - (T BMRASTERWIDTH)) - OPERATION - (fetch BITMAPBASE of BITMAP) - BMRASTERWIDTH))) - (T - (PROG ((CX1 X1) - (CY1 Y1) - (CX2 X2) - (CY2 Y2) - (CA1 (\CLIPCODE X1 Y1 LEFT RIGHT TOP BOTTOM)) - (CA2 (\CLIPCODE X2 Y2 LEFT RIGHT TOP BOTTOM))) - (* ; - "save the original points for the clipping computation.") - (* ; - "determine the sectors in which the points fall.") - CLIPLP - [COND - ((NOT (EQ 0 (LOGAND CA1 CA2))) (* ; - "line is entirely out of clipping region") - (RETURN NIL)) - ((EQ 0 (IPLUS CA1 CA2)) (* ; "line is completely visible") - - (* ;; "\SFInvert has an off by one bug that everybody else in LLDISPLAY uses to save computation so SUB1 from what you would expect.") - (* ; "reuse the variable CA1") - (RETURN - (.WHILE.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 BMRASTERWIDTH)) - (T BMRASTERWIDTH)) - OPERATION - (fetch BITMAPBASE of BITMAP) - BMRASTERWIDTH)) - ((4 8) - (\DRAWCOLORLINE1 - CX1 - (SUB1 (\SFInvert BITMAP CY1)) - (IDIFFERENCE CX2 CX1) - (COND - (YMOVEUP (IDIFFERENCE CY2 CY1)) - (T (IDIFFERENCE CY1 CY2))) - DX DY (COND - ((IGREATERP DX DY) - (* ; "X is the fastest mover.") - (IREMAINDER (IPLUS (ITIMES DY (IDIFFERENCE CX1 X1)) - HALFDX) - DX)) - (T (* ; "y is the fastest mover.") - (IREMAINDER (IPLUS [ITIMES DX - (COND - (YMOVEUP (IDIFFERENCE - CY1 Y1)) - (T (IDIFFERENCE Y1 CY1] - HALFDY) - DY))) - (COND - (YMOVEUP (* ; - "y is moving in positive direction but bits are stored inversely") - (IMINUS BMRASTERWIDTH)) - (T BMRASTERWIDTH)) - OPERATION - (fetch BITMAPBASE of BITMAP) - BMRASTERWIDTH - (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP) - COLOR)) - (SHOULDNT] - [COND - ((NEQ CA1 0) - - (* ;; "now move point CX1 CY1 so that one of the coordinates is on one of the boundaries. Which boundary is done first was copied from BCPL.") - - (COND - ((IGREATERP CA1 7) (* ; "y1 less than bottom") - (* ; - "calculate the least X for which Y will be at bottom.") - [SETQ CX1 (IPLUS X1 (\LEASTPTAT DX DY (IDIFFERENCE BOTTOM Y1] - (SETQ CY1 BOTTOM)) - ((IGREATERP CA1 3) (* ; "y1 is greater than top") - [SETQ CX1 (IPLUS X1 (\LEASTPTAT DX DY (IDIFFERENCE Y1 TOP] - (SETQ CY1 TOP)) - (T (* ; "x1 is less than left") - [SETQ CY1 (COND - [YMOVEUP (IPLUS Y1 (\LEASTPTAT DY DX (IDIFFERENCE - LEFT X1] - (T (IDIFFERENCE Y1 (\LEASTPTAT DY DX (IDIFFERENCE - LEFT X1] - (SETQ CX1 LEFT))) - (SETQ CA1 (\CLIPCODE CX1 CY1 LEFT RIGHT TOP BOTTOM))) - (T (* ; - "now move point CX2 CY2 so that one of the coordinates is on one of the boundaries") - (COND - ((IGREATERP CA2 7) (* ; "y2 less than bottom") - [SETQ CX2 (IPLUS X1 (\GREATESTPTAT DX DY (IDIFFERENCE Y1 BOTTOM] - (SETQ CY2 BOTTOM)) - ((IGREATERP CA2 3) (* ; "y2 is greater than top") - [SETQ CX2 (IPLUS X1 (\GREATESTPTAT DX DY (IDIFFERENCE TOP Y1] - (SETQ CY2 TOP)) - (T (* ; "x2 is greater than right") - [SETQ CY2 (COND - [YMOVEUP (IPLUS Y1 (\GREATESTPTAT DY DX - (IDIFFERENCE RIGHT X1] - (T (IDIFFERENCE Y1 (\GREATESTPTAT DY DX - (IDIFFERENCE RIGHT X1] - (SETQ CX2 RIGHT))) - (SETQ CA2 (\CLIPCODE CX2 CY2 LEFT RIGHT TOP BOTTOM] - (GO CLIPLP]) - -(\CLIPCODE - [LAMBDA (X Y LEFT RIGHT TOP BOTTOM) (* rrb " 4-DEC-80 10:34") - - (* ;; "determines the sector code for a point wrt a region. Used to clip things quickly.") - - (* ;; "RIGHT and TOP are one past the region.") - - (COND - ((LESSP X LEFT) (* ; "falls to left of region") - (COND - ((GREATERP Y TOP) (* ; "left above") - 5) - ((LESSP Y BOTTOM) (* ; "left below") - 9) - (T (* ; "left inside") - 1))) - ((GREATERP X RIGHT) (* ; "right") - (COND - ((GREATERP Y TOP) (* ; "right above") - 6) - ((LESSP Y BOTTOM) (* ; "right below") - 10) - (T (* ; "right inside") - 2))) - ((GREATERP Y TOP) (* ; "inside top") - 4) - ((LESSP Y BOTTOM) (* ; "inside below") - 8) - (T (* ; "inside 0") - 0]) - -(\LEASTPTAT - [LAMBDA (DA DB THISB) (* rrb " 7-JAN-82 11:56") - - (* ;; "determines the smallest value in the dimension A that would give a B coordinate of THISB if a line were drawn from the point (0,0) with a slope of DA/DB.") - - (COND - ((IGREATERP DA DB) - (ADD1 (IQUOTIENT (IPLUS (IDIFFERENCE (ITIMES THISB DA) - (HALF DA)) - -1) - DB))) - (T (IQUOTIENT (IPLUS (ITIMES THISB DA) - (HALF DB)) - DB]) - -(\GREATESTPTAT - [LAMBDA (DA DB THISB) (* rrb " 7-JAN-82 14:24") - - (* ;; "determines the largest value in the dimension A that would give a B coordinate of THISB if a line were drawn from the point (0,0) with a slope of DA/DB.") - - (COND - ((IGREATERP DA DB) - (IQUOTIENT (IPLUS (IDIFFERENCE (ITIMES (ADD1 THISB) - DA) - (HALF DA)) - -1) - DB)) - (T (IQUOTIENT (IPLUS (ITIMES THISB DA) - (HALF DB)) - DB]) - -(\DRAWLINE1 - [LAMBDA (X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH) - (* mpl " 2-Jan-84 18:00") - - (* ;; "this was changed to interface with the opcode for line drawing. It probably be incorporated into the places it is called.") - - (* ;; "draws a line starting at X0,Y0 at a slope of DX/DY until reaching either XLIMIT or YLIMIT with an initial overflow bucket size of CDL in MODE. Arranged so that the clipping routines can determine what the exact location of the end point of the clipped line is wrt line drawing coordinates eg. amount in overflow bucket. XLIMIT and YLIMIT are the number of points to be moved in that direction.") - - (\DRAWLINE.UFN (\ADDBASE BITMAPBASE (IPLUS (ITIMES Y0 RASTERWIDTH) - (FOLDLO X0 BITSPERWORD))) - (LOGAND X0 15) - DX YINC DY (SELECTQ MODE - (INVERT 2) - (ERASE 1) - 0) - CDL - (ADD1 XLIMIT) - (ADD1 YLIMIT]) - -(\DRAWLINE.UFN - [LAMBDA (FIRSTADDR FIRSTBIT XDELTA YINCR YDELTA OPERATIONCODE INITIALBUCKET PIXELSINX PIXELSINY) - (* jds " 6-Jan-86 11:27") - - (* ;; "FIRSTADDR is the address of the word which contains the first point. FIRSTBIT is the address of the first bit in FIRSTADDR. XDELTA and YDELTA are how far the complete line has to move in X and Y respectively; both are positive quantities. YINCR is the amount the address should be incremented if the Y coordinate changes and can be either positive or negative. OPERATIONCODE is 0 for REPLACE, 1 for ERASE and 2 for INVERT. INITIALBUCKET is between 0 and the maximum of DX and DY and gives the starting amount of the bucket used to determine when to increment in the slower moving direction. PIXELSINX and PIXELSINY indicates how many pixels should be drawn in the X and Y direction.") - - (DECLARE (LOCALVARS . T)) - (PROG ((MASK (\BITMASK FIRSTBIT))) - (COND - [(IGEQ XDELTA YDELTA) (* ; "X is the fastest mover.") - (SELECTQ OPERATIONCODE - (0 (.DRAWLINEX. 'REPLACE/PAINT)) - (1 (.DRAWLINEX. 'ERASE)) - (.DRAWLINEX. 'INVERT] - (T (* ; "Y is the fastest mover.") - (SELECTQ OPERATIONCODE - (0 (.DRAWLINEY. 'REPLACE/PAINT)) - (1 (.DRAWLINEY. 'ERASE)) - (.DRAWLINEY. 'INVERT]) -) -(DECLARE%: DONTCOPY -(DECLARE%: EVAL@COMPILE - -(PUTPROPS .DRAWLINEX. MACRO [(MODE) - (bind (NY _ 0) for PT from 1 to PIXELSINX - do (* ; "main loop") - [replace (BITMAPWORD BITS) of FIRSTADDR - with (SELECTQ MODE - (INVERT (LOGXOR MASK - (fetch (BITMAPWORD - BITS) - of FIRSTADDR))) - (ERASE (LOGAND (LOGXOR MASK WORDMASK) - (fetch (BITMAPWORD - BITS) - of FIRSTADDR))) - (PROGN - (* ; - "case is PAINT or REPLACE. Legality of OPERATION has been checked by \CLIPANDDRAWLINE1") - (LOGOR MASK (fetch - (BITMAPWORD BITS) - of FIRSTADDR] - [COND - ([NOT (IGREATERP XDELTA (SETQ INITIALBUCKET - (IPLUS INITIALBUCKET YDELTA - ] - (* ; "increment in the Y direction") - (COND - ((EQ (SETQ NY (ADD1 NY)) - PIXELSINY) - (RETURN))) - (SETQ INITIALBUCKET (IDIFFERENCE INITIALBUCKET - XDELTA)) - (SETQ FIRSTADDR (\ADDBASE FIRSTADDR YINCR] - (SETQ MASK (LRSH MASK 1)) - (COND - ((EQ 0 MASK)(* ; "crossed word boundary") - (SETQ FIRSTADDR (\ADDBASE FIRSTADDR 1)) - (SETQ MASK 32768]) - -(PUTPROPS .DRAWLINEY. MACRO [(MODE) - (bind (NX _ 0) for PT from 1 to PIXELSINY - do (* ; "main loop") - [replace (BITMAPWORD BITS) of FIRSTADDR - with (SELECTQ MODE - (INVERT (LOGXOR MASK - (fetch (BITMAPWORD - BITS) - of FIRSTADDR))) - (ERASE (LOGAND (LOGXOR MASK WORDMASK) - (fetch (BITMAPWORD - BITS) - of FIRSTADDR))) - (PROGN - (* ; - "case is PAINT or REPLACE. Legality of OPERATION has been checked by \CLIPANDDRAWLINE1") - (LOGOR MASK (fetch - (BITMAPWORD BITS) - of FIRSTADDR] - [COND - ([NOT (IGREATERP YDELTA (SETQ INITIALBUCKET - (IPLUS INITIALBUCKET XDELTA - ] - (COND - ((EQ (SETQ NX (ADD1 NX)) - PIXELSINX) - (RETURN))) - (SETQ INITIALBUCKET (IDIFFERENCE INITIALBUCKET - YDELTA)) - (SETQ MASK (LRSH MASK 1)) - (COND - ((EQ 0 MASK) - (* ; "crossed word boundary") - (SETQ FIRSTADDR (\ADDBASE FIRSTADDR 1)) - (SETQ MASK 32768] - (SETQ FIRSTADDR (\ADDBASE FIRSTADDR YINCR]) -) -) - - - -(* ; "Curves") - -(DEFINEQ - -(\DRAWCIRCLE.DISPLAY - [LAMBDA (DISPLAYSTREAM CENTERX CENTERY RADIUS BRUSH DASHING) - (* kbr%: "15-Feb-86 22:24") - - (* ;; -"\DRAWCIRCLE.DISPLAY extended for color. Color is specified by either BRUSH or the DSPCOLOR of DS.") - - (DECLARE (LOCALVARS . T)) - (COND - ((OR (NOT (NUMBERP RADIUS)) - (ILESSP (SETQ RADIUS (FIXR RADIUS)) - 0)) - (\ILLEGAL.ARG RADIUS)) - ((EQ RADIUS 0) (* ; "don't draw anything.") - NIL) - (DASHING (* ; - "draw it with the arc drawing code which does dashing. Slow but effective.") - - (* ;; "the CDR removes the first point to work around a bug in curve drawing when closed and first and last points the same. AR 4623.0") - - (DRAWCURVE (CDR (\COMPUTE.ARC.POINTS CENTERX CENTERY RADIUS 0 360)) - T BRUSH DASHING DISPLAYSTREAM)) - (T (GLOBALRESOURCE \BRUSHBBT - (PROG (X Y D DestinationBitMap LEFT RIGHTPLUS1 TOP BOTTOM BRUSHWIDTH BRUSHHEIGHT - LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE - BRUSHBASE RASTERWIDTH BRUSHRASTERWIDTH NBITSRIGHTPLUS1 OPERATION - HEIGHTMINUS1 CX CY BBT COLOR COLORBRUSHBASE NBITS DISPLAYDATA USERFN) - (SETQ X 0) - (SETQ Y RADIUS) - (SETQ D (ITIMES 2 (IDIFFERENCE 1 RADIUS))) - (SETQ BBT \BRUSHBBT) - (SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DISPLAYSTREAM)) - (SETQ USERFN (AND (LITATOM BRUSH) - BRUSH)) - - (* ;; "many of these variables are used by the macro for \CURVEPT that passes them to \BBTCURVEPT and .SETUP.FOR.\BBTCURVEPT. sets them up.") - - (COND - (USERFN (* ; - "if calling user fn, don't bother with set up and leave points in stream coordinates.") - (SETQ CX CENTERX) - (SETQ CY CENTERY)) - (T (.SETUP.FOR.\BBTCURVEPT.) - (SELECTQ NBITS - (1 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX (FOLDLO BRUSHWIDTH - 2)) - DISPLAYDATA))) - (4 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX - (FOLDLO (LRSH BRUSHWIDTH 2) - 2)) - DISPLAYDATA))) - (8 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX - (FOLDLO (LRSH BRUSHWIDTH 3) - 2)) - DISPLAYDATA))) - (24 (* ; - "I doubt that this will be right.") - (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX - (FOLDLO (IQUOTIENT BRUSHWIDTH 24 - ) - 2)) - DISPLAYDATA))) - (SHOULDNT)) (* ; - "take into account the brush thickness.") - (SETQ CY (\DSPTRANSFORMY (IDIFFERENCE CENTERY (FOLDLO BRUSHHEIGHT 2)) - DISPLAYDATA)) - - (* ;; "Move the window to top while interruptable, but verify that it is still there uninterruptably with drawing points") - - (\INSURETOPWDS DISPLAYSTREAM))) - [COND - ((EQ RADIUS 1) (* ; "put a single brush down.") - (* ; - "draw the top and bottom most points.") - [COND - (USERFN (APPLY* USERFN CX CY DISPLAYSTREAM)) - (T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVEPT CX CY] - (RETURN)) - (T (* ; - "draw the top and bottom most points.") - (COND - (USERFN (APPLY* USERFN CX (IPLUS CY RADIUS) - DISPLAYSTREAM) - (APPLY* USERFN CX (IDIFFERENCE CY RADIUS) - DISPLAYSTREAM)) - (T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVEPT CX (IPLUS CY RADIUS)) - (\CURVEPT CX (IDIFFERENCE CY RADIUS] - LP (* ; - "(UNFOLD x 2) is used instead of (ITIMES x 2)") - [COND - [(IGREATERP 0 D) - (SETQ X (ADD1 X)) - (COND - ((IGREATERP (UNFOLD (IPLUS D Y) - 2) - 1) - (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y) - 2) - 4)) - (SETQ Y (SUB1 Y))) - (T (SETQ D (IPLUS D (UNFOLD X 2) - 1] - ((OR (EQ 0 D) - (IGREATERP X D)) - (SETQ X (ADD1 X)) - (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y) - 2) - 4)) - (SETQ Y (SUB1 Y))) - (T (SETQ D (IPLUS (IDIFFERENCE D (UNFOLD Y 2)) - 3)) - (SETQ Y (SUB1 Y] - (COND - [(EQ Y 0) - - (* ;; "left most and right most points are drawn specially so that they are not duplicated which leaves a hole in XOR mode.") - - (COND - (USERFN (APPLY* USERFN (IPLUS CX X) - CY DISPLAYSTREAM) - (APPLY* USERFN (IDIFFERENCE CX X) - CY DISPLAYSTREAM)) - (T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVEPT (IPLUS CX X) - CY) - (\CURVEPT (IDIFFERENCE CX X) - CY] - (T [COND - (USERFN (APPLY* USERFN (IPLUS CX X) - (IPLUS CY Y) - DISPLAYSTREAM) - (APPLY* USERFN (IDIFFERENCE CX X) - (IPLUS CY Y) - DISPLAYSTREAM) - (APPLY* USERFN (IPLUS CX X) - (IDIFFERENCE CY Y) - DISPLAYSTREAM) - (APPLY* USERFN (IDIFFERENCE CX X) - (IDIFFERENCE CY Y) - DISPLAYSTREAM)) - (T (.WHILE.TOP.DS. DISPLAYSTREAM (\CIRCLEPTS CX CY X Y] - (GO LP))) - (MOVETO CENTERX CENTERY DISPLAYSTREAM) - (RETURN NIL]) - -(\DRAWARC.DISPLAY - [LAMBDA (STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING) - (* ; "draws an arc on the display") - (\DRAWARC.GENERIC STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING]) - -(\DRAWARC.GENERIC - [LAMBDA (STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING) - (* rrb " 4-Oct-85 18:23") - (* ; - "draws an arc by drawing a curve.") - (COND - ((AND (GREATERP 360 NDEGREES) - (LESSP -360 NDEGREES)) - (DRAWCURVE (\COMPUTE.ARC.POINTS CENTERX CENTERY RADIUS STARTANGLE NDEGREES) - NIL BRUSH DASHING STREAM)) - (T (* ; - "use circle drawing which could be faster") - (DRAWCIRCLE CENTERX CENTERY RADIUS BRUSH DASHING STREAM]) - -(\COMPUTE.ARC.POINTS - [LAMBDA (CENTERX CENTERY RADIUS STARTANGLE NDEGREES) (* DECLARATIONS%: FLOATING) - (* rrb "30-Oct-85 11:48") - - (* ;; "computes a list of knots that a spline goes through to make an arc") - - (PROG ((ANGLESIZE (COND - ((OR (GREATERP NDEGREES 360.0) - (GREATERP -360.0 NDEGREES)) - 360.0) - (T NDEGREES))) - ANGLEINCR) - - (* ;; "calculate an increment close to 10.0 that is exact but always have at least 5 knots and don't have more than a knot every 5 pts") - - [SETQ ANGLEINCR (FQUOTIENT ANGLESIZE - (IMIN (IMAX (ABS (FIX (FQUOTIENT ANGLESIZE 10.0))) - 5) - (PROGN (* ; - "don't have more than a knot every 5 pts") - (IMAX (ABS (FIX (QUOTIENT (TIMES RADIUS 6.3 - (QUOTIENT ANGLESIZE - 360.0)) - 4))) - 3] - - (* ;; "go from initial point to just past the last point. The just past (PLUS BETA (QUOTIENT ANGLEINCR 5.0)) picks up the case where the floating pt rounding error accumulates to be greater than the last point when it is very close to it.") - - (RETURN (for ANGLE from STARTANGLE to (PLUS STARTANGLE ANGLESIZE - (QUOTIENT ANGLEINCR 5.0)) - by ANGLEINCR collect (create POSITION - XCOORD _ [FIXR (PLUS CENTERX - (TIMES RADIUS - (COS ANGLE] - YCOORD _ (FIXR (PLUS CENTERY - (TIMES RADIUS - (SIN ANGLE]) - -(\DRAWELLIPSE.DISPLAY - [LAMBDA (DISPLAYSTREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING) - (* ; "Edited 12-Apr-88 23:58 by FS") - (DECLARE (LOCALVARS . T)) - - (* ;; "Draws an ellipse. At ORIENTATION 0, the semimajor axis is horizontal, the semiminor axis vertical. Orientation is positive in the counterclockwise direction. The current location in the stream is left at the center of the ellipse.") - - (PROG ((CENTERX (FIXR CENTERX)) - (CENTERY (FIXR CENTERY)) - (SEMIMINORRADIUS (FIXR SEMIMINORRADIUS)) - (SEMIMAJORRADIUS (FIXR SEMIMAJORRADIUS))) - (COND - ((OR (EQ 0 SEMIMINORRADIUS) - (EQ 0 SEMIMAJORRADIUS)) - (MOVETO CENTERX CENTERY DISPLAYSTREAM) - (RETURN))) - (COND - ((ILESSP SEMIMINORRADIUS 1) - (\ILLEGAL.ARG SEMIMINORRADIUS)) - ((ILESSP SEMIMAJORRADIUS 1) - (\ILLEGAL.ARG SEMIMAJORRADIUS)) - ((OR (NULL ORIENTATION) - (EQ SEMIMINORRADIUS SEMIMAJORRADIUS)) - (SETQ ORIENTATION 0)) - ((NULL (NUMBERP ORIENTATION)) - (\ILLEGAL.ARG ORIENTATION))) - - (* ;; "If dashing, draw it with the curve drawing code which can do dashing") - - (COND - (DASHING (\DRAWELLIPSE.GENERIC DISPLAYSTREAM CENTERX CENTERY SEMIMINORRADIUS - SEMIMAJORRADIUS ORIENTATION BRUSH DASHING) - (RETURN))) - - (* ;; "If degenerate ellipse, attempt circumvention of Pitteway breakdown by trying spline code instead, which appears more numerically stable (see AR6502)") - - (COND - ((< 40 (/ SEMIMAJORRADIUS SEMIMINORRADIUS)) - (\DRAWELLIPSE.GENERIC DISPLAYSTREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS - ORIENTATION BRUSH DASHING) - (RETURN))) - -(* ;;; "This function is the implementation of the algorithm given in 'Algorithm for drawing ellipses or hyperbolae with a digital plotter' by Pitteway appearing in Computer Journal 10: (3) Nov 1967.0 The input parameters are used to determine the ellipse equation (1/8) Ayy+ (1/8) Bxx+ (1/4) Gxy+ (1/4) Ux+ (1/4) Vy= (1/4) K which specifies a translated version of the desired ellipse. This ellipse passes through the mesh point (0,0), the initial point of the algorithm. The power of 2 factors reflect an implementation convenience.") - - (GLOBALRESOURCE \BRUSHBBT - (PROG (DestinationBitMap LEFT RIGHTPLUS1 BOTTOM TOP BOTTOMMINUSBRUSH TOPMINUSBRUSH - LEFTMINUSBRUSH DESTINATIONBASE BRUSHBASE BRUSHHEIGHT BRUSHWIDTH - RASTERWIDTH BRUSHRASTERWIDTH BRUSHBM OPERATION HEIGHTMINUS1 - (BBT \BRUSHBBT) - (cosOrientation (COS ORIENTATION)) - (sinOrientation (SIN ORIENTATION)) - (SEMIMINORRADIUSSQUARED (ITIMES SEMIMINORRADIUS SEMIMINORRADIUS)) - (SEMIMAJORRADIUSSQUARED (ITIMES SEMIMAJORRADIUS SEMIMAJORRADIUS)) - (x 0) - (y 0) - (x2 1) - x1 y1 y2 k1 k2 k3 a b d w A B G U V K CX CY yOffset CYPlusOffset - CYMinusOffset NBITSRIGHTPLUS1 COLORBRUSHBASE COLOR NBITS - (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM)) - (USERFN (AND (LITATOM BRUSH) - BRUSH))) - - (* ;; "many of these variables are used by the macro for \CURVEPT that passes them to \BBTCURVEPT and .SETUP.FOR.\BBTCURVEPT. sets them up.") - - (COND - (USERFN (* ; - "if calling user fn, don't bother with set up and leave points in window coordinates.") - (SETQ CX CENTERX) - (SETQ CY CENTERY)) - (T (.SETUP.FOR.\BBTCURVEPT.) (* ; - "take into account the brush thickness.") - (SELECTQ NBITS - (1 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX (FOLDLO BRUSHWIDTH - 2)) - DISPLAYDATA))) - (4 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX - (FOLDLO (LRSH BRUSHWIDTH 2) - 2)) - DISPLAYDATA))) - (8 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX - (FOLDLO (LRSH BRUSHWIDTH 3) - 2)) - DISPLAYDATA))) - (SHOULDNT)) - (SETQ CY (\DSPTRANSFORMY (IDIFFERENCE CENTERY (FOLDLO BRUSHHEIGHT 2)) - DISPLAYDATA)) - - (* ;; "Move the window to top while interruptable, but verify that it is still there uninterruptably with drawing points") - - (\INSURETOPWDS DISPLAYSTREAM))) - (SETQ A (FPLUS (FTIMES SEMIMAJORRADIUSSQUARED cosOrientation cosOrientation) - (FTIMES SEMIMINORRADIUSSQUARED sinOrientation sinOrientation))) - (SETQ B (LSH (FIXR (FPLUS (FTIMES SEMIMINORRADIUSSQUARED cosOrientation - cosOrientation) - (FTIMES SEMIMAJORRADIUSSQUARED sinOrientation - sinOrientation))) - 3)) - (SETQ G (FTIMES cosOrientation sinOrientation (LSH (IDIFFERENCE - SEMIMINORRADIUSSQUARED - - SEMIMAJORRADIUSSQUARED - ) - 1))) - [SETQ yOffset (FIXR (FQUOTIENT (ITIMES SEMIMINORRADIUS SEMIMAJORRADIUS) - (SQRT A] - (SETQ CYPlusOffset (IPLUS CY yOffset)) - (SETQ CYMinusOffset (IDIFFERENCE CY yOffset)) - (SETQ U (LSH (FIXR (FTIMES A (LSH yOffset 1))) - 2)) - (SETQ V (LSH (FIXR (FTIMES G yOffset)) - 2)) - (SETQ K (LSH [FIXR (FDIFFERENCE (ITIMES SEMIMINORRADIUSSQUARED - SEMIMAJORRADIUSSQUARED) - (FTIMES A (ITIMES yOffset yOffset] - 2)) - (SETQ A (LSH (FIXR A) - 3)) - (SETQ G (LSH (FIXR G) - 2)) - - (* ;; "The algorithm is incremental and iterates through the octants of a cartesian plane. The octants are labeled from 1 through 8 beginning above the positive X axis and proceeding counterclockwise. Decisions in making the incremental steps are determined according to the error term d which is updated according to the curvature terms a and b. k1, k2, and k3 are used to correct the error and curvature terms at octant boundaries. The initial values of these terms depends on the octant in which drawing begins. The initial move steps (x1,y1) and (x2,y2) also depend on the starting octant.") - - [COND - [(ILESSP (ABS U) - (ABS V)) - (SETQ x1 0) - (COND - [(MINUSP V) (* ; "start in octant 2") - (SETQ y1 1) - (SETQ y2 1) - (SETQ k1 (IMINUS A)) - (SETQ k2 (IDIFFERENCE k1 G)) - (SETQ k3 (IDIFFERENCE k2 (IPLUS B G))) - (SETQ b (IPLUS U (RSH (IPLUS A G) - 1))) - (SETQ a (IMINUS (IPLUS b V))) - (SETQ d (IPLUS b (RSH B 3) - (RSH V 1) - (IMINUS K] - (T (* ; "start in octant 7") - (SETQ y1 -1) - (SETQ y2 -1) - (SETQ k1 A) - (SETQ k2 (IDIFFERENCE k1 G)) - (SETQ k3 (IPLUS k2 B (IMINUS G))) - (SETQ b (IPLUS U (RSH (IDIFFERENCE G A) - 1))) - (SETQ a (IDIFFERENCE V b)) - (SETQ d (IPLUS b K (IMINUS (IPLUS (RSH V 1) - (RSH B 3] - (T (SETQ x1 1) - (SETQ y1 0) - (COND - [(MINUSP V) (* ; "start in octant 1") - (SETQ y2 1) - (SETQ k1 B) - (SETQ k2 (IPLUS k1 G)) - (SETQ k3 (IPLUS k2 A G)) - [SETQ b (IMINUS (IPLUS V (RSH (IPLUS B G) - 1] - (SETQ a (IDIFFERENCE U b)) - (SETQ d (IPLUS b K (IMINUS (IPLUS (RSH A 3) - (RSH U 1] - (T (* ; "start in octant 8") - (SETQ y2 -1) - (SETQ k1 (IMINUS B)) - (SETQ k2 (IPLUS k1 G)) - (SETQ k3 (IPLUS k2 G (IMINUS A))) - (SETQ b (IPLUS V (RSH (IDIFFERENCE B G) - 1))) - (SETQ a (IDIFFERENCE U b)) - (SETQ d (IPLUS b (RSH A 3) - (IMINUS (IPLUS K (RSH U 1] - - (* ;; "The ellipse equation describes an ellipse of the desired size and ORIENTATION centered at (0,0) and then dropped yOffset mesh points so that it will pass through (0,0). Thus, the intended starting point is (CX, CY+yOffset) where (CX, CY) is the center of the desired ellipse. Drawing is accomplished with point relative steps. In each octant, the error term d is used to choose between move 1 (an axis move) and move 2 (a diagonal move).") - - MOVE - [COND - ((MINUSP d) (* ; "move 1") - (SETQ x (IPLUS x x1)) - (SETQ y (IPLUS y y1)) - (SETQ b (IDIFFERENCE b k1)) - (SETQ a (IPLUS a k2)) - (SETQ d (IPLUS b d))) - (T (* ; "move 2") - (SETQ x (IPLUS x x2)) - (SETQ y (IPLUS y y2)) - (SETQ b (IDIFFERENCE b k2)) - (SETQ a (IPLUS a k3)) - (SETQ d (IDIFFERENCE d a] - (COND - ((MINUSP x) - (MOVETO CENTERX CENTERY DISPLAYSTREAM) - (RETURN NIL))) - [COND - (USERFN (APPLY* USERFN (IPLUS CX x) - (IPLUS CYPlusOffset y) - DISPLAYSTREAM) - (APPLY* USERFN (IDIFFERENCE CX x) - (IDIFFERENCE CYMinusOffset y) - DISPLAYSTREAM)) - (T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVEPT (IPLUS CX x) - (IPLUS CYPlusOffset y)) - (\CURVEPT (IDIFFERENCE CX x) - (IDIFFERENCE CYMinusOffset y] - (AND (MINUSP b) - (GO SQUARE)) - DIAGONAL - (OR (MINUSP a) - (GO MOVE)) (* ; "diagonal octant change") - (SETQ x1 (IDIFFERENCE x2 x1)) - (SETQ y1 (IDIFFERENCE y2 y1)) - (SETQ w (IDIFFERENCE (LSH k2 1) - k3)) - (SETQ k1 (IDIFFERENCE w k1)) - (SETQ k2 (IDIFFERENCE k2 k3)) - (SETQ k3 (IMINUS k3)) - [SETQ b (IPLUS b a (IMINUS (RSH (ADD1 k2) - 1] - [SETQ d (IPLUS b (RSH (IPLUS k3 4) - 3) - (IMINUS d) - (IMINUS (RSH (ADD1 a) - 1] - (SETQ a (IDIFFERENCE (RSH (ADD1 w) - 1) - a)) - (OR (MINUSP b) - (GO MOVE)) - SQUARE - (* ; "square octant change") - [COND - ((EQ 0 x1) - (SETQ x2 (IMINUS x2))) - (T (SETQ y2 (IMINUS y2] - (SETQ w (IDIFFERENCE k2 k1)) - (SETQ k1 (IMINUS k1)) - (SETQ k2 (IPLUS w k1)) - (SETQ k3 (IDIFFERENCE (LSH w 2) - k3)) - (SETQ b (IDIFFERENCE (IMINUS b) - w)) - (SETQ d (IDIFFERENCE (IDIFFERENCE b a) - d)) - (SETQ a (IDIFFERENCE (IDIFFERENCE a w) - (LSH b 1))) - (GO DIAGONAL]) - -(\DRAWCURVE.DISPLAY - [LAMBDA (DISPLAYSTREAM KNOTS CLOSED BRUSH DASHING) (* ; "Edited 9-Jan-87 16:49 by rrb") - - (* ;; "draws a spline curve with a given brush.") - - (GLOBALRESOURCE \BRUSHBBT (PROG ((BBT \BRUSHBBT) - (DASHLST (\GOOD.DASHLST DASHING BRUSH))) - (SELECTQ (LENGTH KNOTS) - (0 (* ; - "No knots => empty curve rather than error?") - NIL) - (1 (* ; - "only one knot, put down a brush shape") - (OR (type? POSITION (CAR KNOTS)) - (ERROR "bad knot" (CAR KNOTS))) - (\DRAWPOINT.DISPLAY DISPLAYSTREAM (fetch XCOORD - of - (CAR KNOTS)) - (fetch YCOORD of (CAR KNOTS)) - BRUSH)) - (2 (OR (type? POSITION (CAR KNOTS)) - (ERROR "bad knot" (CAR KNOTS))) - (OR (type? POSITION (CADR KNOTS)) - (ERROR "bad knot" (CADR KNOTS))) - (\LINEWITHBRUSH (fetch XCOORD of (CAR KNOTS)) - (fetch YCOORD of (CAR KNOTS)) - (fetch XCOORD of (CADR KNOTS)) - (fetch YCOORD of (CADR KNOTS)) - BRUSH DASHLST DISPLAYSTREAM BBT)) - (\CURVE2 (PARAMETRICSPLINE KNOTS CLOSED) - BRUSH DASHLST BBT DISPLAYSTREAM)) - (RETURN DISPLAYSTREAM]) - -(\DRAWPOINT.DISPLAY - [LAMBDA (DISPLAYSTREAM X Y BRUSH OPERATION) (* rrb "17-Sep-86 17:51") - - (* ;; "draws a brush point at position X Y") - - (* ;; "this is used in 4, 8, and 24 bit per pixel bitmaps as well. For these, it may be should call BITMAPWIDTH instead of fetching.") - - (PROG ((BRUSHBM (\GETBRUSH BRUSH))) (* ; - "SUB1 is to put extra bit of even brush on the top or left.") - (RETURN (BITBLT BRUSHBM 0 0 DISPLAYSTREAM [IDIFFERENCE X (HALF (SUB1 (fetch - (BITMAP BITMAPWIDTH) - of BRUSHBM] - [IDIFFERENCE Y (HALF (SUB1 (fetch (BITMAP BITMAPHEIGHT) of BRUSHBM] - NIL NIL NIL (SELECTQ (OR OPERATION (DSPOPERATION NIL DISPLAYSTREAM)) - (REPLACE 'PAINT) - OPERATION]) - -(\DRAWPOLYGON.DISPLAY - [LAMBDA (STREAM POINTS CLOSED BRUSH DASHING) (* ; "Edited 13-Apr-88 14:14 by FS") - - (* ;; "Somewhat less generic version of drawpolygon that calls \drawline.display. Brush must be a brush (guaranteed in DRAWPOLYGON) other users must also ensure.") - - (* ;; "This is different than drawline.generic, because drawline.display will use width argument instead of bltting brushes around. That way you can get shades, dspoperation, eventually.") - - (PROG [COLOR (PTBRUSH (COND - ((EQ (fetch (BRUSH BRUSHSHAPE) of BRUSH) - 'ROUND) - BRUSH) - (T (create BRUSH using BRUSH BRUSHSHAPE _ 'ROUND] - (SETQ COLOR (fetch (BRUSH BRUSHCOLOR) of PTBRUSH)) - (for PTAIL on POINTS while (CDR PTAIL) do (\DRAWLINE.DISPLAY - STREAM - (fetch (POSITION XCOORD) - of (CAR PTAIL)) - (ffetch (POSITION YCOORD) - of (CAR PTAIL)) - (fetch (POSITION XCOORD) - of (CADR PTAIL)) - (ffetch (POSITION YCOORD) - of (CADR PTAIL)) - (fetch (BRUSH BRUSHSIZE) - of BRUSH) - NIL COLOR DASHING) - (* ; - "put a brush between lines so it looks better. It's not mitered this way but better than not.") - (\DRAWPOINT.DISPLAY - STREAM - (fetch (POSITION XCOORD) - of (CADR POINTS)) - (fetch (POSITION YCOORD) - of (CADR POINTS)) - PTBRUSH - 'NIL) - finally (COND - ((AND CLOSED (CDDR POINTS)) (* ; "draw the closing line.") - (\DRAWLINE.DISPLAY STREAM (fetch (POSITION XCOORD) - of (CAR PTAIL)) - (ffetch (POSITION YCOORD) of (CAR PTAIL)) - (fetch (POSITION XCOORD) of (CAR POINTS)) - (ffetch (POSITION YCOORD) of (CAR POINTS)) - (fetch (BRUSH BRUSHSIZE) of BRUSH) - NIL COLOR DASHING))) - (OR (NULL (CDR POINTS)) - (\DRAWPOINT.DISPLAY STREAM (fetch (POSITION XCOORD) - of (CAR POINTS)) - (fetch (POSITION YCOORD) of (CAR POINTS)) - PTBRUSH NIL]) - -(\LINEWITHBRUSH - [LAMBDA (X1 Y1 X2 Y2 BRUSH DASHLST DISPLAYSTREAM BBT OPERATION) - (* ; "Edited 29-Oct-87 17:40 by scp") - - (* ;; "draws a line with a brush on a guaranteed display-stream DISPLAYSTREAM") - - (DECLARE (LOCALVARS . T)) - (PROG (DestinationBitMap LEFT RIGHTPLUS1 TOP BOTTOM BRUSHWIDTH BRUSHHEIGHT LEFTMINUSBRUSH - BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE BRUSHBASE RASTERWIDTH - BRUSHRASTERWIDTH NBITSRIGHTPLUS1 HEIGHTMINUS1 COLOR COLORBRUSHBASE NBITS - HALFBRUSHWIDTH HALFBRUSHHEIGHT DX DY YINC CDL (DASHON T) - (DASHTAIL DASHLST) - (DASHCNT (CAR DASHLST)) - (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM)) - (USERFN (AND (LITATOM BRUSH) - BRUSH)) - (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM))) - - (* ;; "many of these variables are used by the macro for \CURVEPT that passes them to \BBTCURVEPT and .SETUP.FOR.\BBTCURVEPT. sets them up.") - (* ; - "move the display stream position before the coordinates are clobbered.") - (COND - ((NOT USERFN) - (.SETUP.FOR.\BBTCURVEPT.) - (SELECTQ NBITS - (1 (* ; - "SUB1 is so that the extra bit goes on the top and right as it is documented as doing for lines.") - (SETQ X1 (\DSPTRANSFORMX (IDIFFERENCE X1 (SETQ HALFBRUSHWIDTH - (FOLDLO (SUB1 BRUSHWIDTH) - 2))) - DISPLAYDATA))) - (4 (SETQ X1 (\DSPTRANSFORMX (IDIFFERENCE X1 (SETQ HALFBRUSHWIDTH - (FOLDLO (LRSH (SUB1 BRUSHWIDTH) - 2) - 2))) - DISPLAYDATA))) - (8 (SETQ X1 (\DSPTRANSFORMX (IDIFFERENCE X1 (SETQ HALFBRUSHWIDTH - (FOLDLO (LRSH (SUB1 BRUSHWIDTH) - 3) - 2))) - DISPLAYDATA))) - (SHOULDNT)) - (SETQ X2 (\DSPTRANSFORMX (IDIFFERENCE X2 HALFBRUSHWIDTH) - DISPLAYDATA)) - (SETQ Y1 (\DSPTRANSFORMY (IDIFFERENCE Y1 (SETQ HALFBRUSHHEIGHT (FOLDLO (SUB1 - BRUSHHEIGHT - ) - 2))) - DISPLAYDATA)) (* ; - "take into account the brush thickness.") - (SETQ Y2 (\DSPTRANSFORMY (IDIFFERENCE Y2 HALFBRUSHHEIGHT) - DISPLAYDATA)) - - (* ;; "Move the window to top while interruptable, but verify that it is still there uninterruptably with drawing points") - - (\INSURETOPWDS DISPLAYSTREAM))) (* ; - "arrange things so that dx is positive.") - (COND - ((IGREATERP X1 X2) (* ; "switch points") - (swap X1 X2) - (swap Y1 Y2))) - (SETQ DX (ADD1 (IDIFFERENCE X2 X1))) - [SETQ DY (ADD1 (COND - ((IGREATERP Y2 Y1) - (SETQ YINC 1) - (IDIFFERENCE Y2 Y1)) - (T (SETQ YINC -1) - (IDIFFERENCE Y1 Y2] - [SETQ CDL (HALF (COND - ((IGREATERP DX DY) (* ; - "set up the bucket so that the ends will be the same.") - (IREMAINDER DX DY)) - (T (IREMAINDER DY DX] - [COND - [USERFN (* ; - "if user function is being called, don't bother bringing window to top uninterruptably.") - (COND - ((IGEQ DX DY) (* ; "X is the fastest mover.") - (until (IGREATERP X1 X2) - do (* ; "main loop") - (COND - (DASHON (APPLY* USERFN X1 Y1 DISPLAYSTREAM))) - [COND - (DASHTAIL (* ; "do dashing.") - (COND - ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) - (SETQ DASHON (NOT DASHON)) - (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) - DASHLST)) - (SETQ DASHCNT (CAR DASHTAIL] - [COND - ((NOT (IGREATERP DX (add CDL DY))) - (add Y1 YINC) - (COND - ((COND - ((EQ YINC -1) - (ILESSP Y1 Y2)) - ((IGREATERP Y1 Y2))) - (RETURN))) - (SETQ CDL (IDIFFERENCE CDL DX] - (add X1 1))) - (T (* ; "Y is the fastest mover.") - (until (COND - ((EQ YINC -1) - (ILESSP Y1 Y2)) - ((IGREATERP Y1 Y2))) - do (* ; "main loop") - (COND - (DASHON (APPLY* USERFN X1 Y1 DISPLAYSTREAM))) - [COND - (DASHTAIL (* ; "do dashing.") - (COND - ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) - (SETQ DASHON (NOT DASHON)) - (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) - DASHLST)) - (SETQ DASHCNT (CAR DASHTAIL] - [COND - ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX] - (COND - ((IGREATERP (SETQ X1 (ADD1 X1)) - X2) - (RETURN))) - (SETQ CDL (IDIFFERENCE CDL DY] - (add Y1 YINC] - (T (* ; - "when we put the points down make it uninterruptable") - (.WHILE.TOP.DS. DISPLAYSTREAM - (COND - [(IGEQ DX DY) (* ; "X is the fastest mover.") - (until (IGREATERP X1 X2) - do (* ; "main loop") - (COND - (DASHON (\CURVEPT X1 Y1))) - [COND - (DASHTAIL (* ; "do dashing.") - (COND - ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) - (SETQ DASHON (NOT DASHON)) - (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) - DASHLST)) - (SETQ DASHCNT (CAR DASHTAIL] - [COND - ([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY] - (SETQ Y1 (IPLUS Y1 YINC)) - (COND - ((COND - ((EQ YINC -1) - (ILESSP Y1 Y2)) - ((IGREATERP Y1 Y2))) - (RETURN))) - (SETQ CDL (IDIFFERENCE CDL DX] - (SETQ X1 (ADD1 X1] - (T (* ; "Y is the fastest mover.") - (until (COND - ((EQ YINC -1) - (ILESSP Y1 Y2)) - ((IGREATERP Y1 Y2))) - do (* ; "main loop") - (COND - (DASHON (\CURVEPT X1 Y1))) - [COND - (DASHTAIL (* ; "do dashing.") - (COND - ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) - (SETQ DASHON (NOT DASHON)) - (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) - DASHLST)) - (SETQ DASHCNT (CAR DASHTAIL] - [COND - ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX] - (COND - ((IGREATERP (SETQ X1 (ADD1 X1)) - X2) - (RETURN))) - (SETQ CDL (IDIFFERENCE CDL DY] - (SETQ Y1 (IPLUS Y1 YINC] - (RETURN NIL]) -) -(DEFINEQ - -(LOADPOLY - [LAMBDA (POLY POLYPRIME A B C D) (* hdj "13-Mar-85 18:01") - (replace (POLYNOMIAL A) of POLY with (FQUOTIENT A 6.0)) - (replace (POLYNOMIAL B) of POLY with (FQUOTIENT B 2.0)) - (replace (POLYNOMIAL C) of POLY with C) - (replace (POLYNOMIAL D) of POLY with D) - (replace (POLYNOMIAL A) of POLYPRIME with (FQUOTIENT A 2.0)) - (replace (POLYNOMIAL B) of POLYPRIME with B) - (replace (POLYNOMIAL C) of POLYPRIME with C]) - -(PARAMETRICSPLINE - [LAMBDA (KNOTS CLOSEDFLG SPLINE) (* rmk%: "30-Nov-84 17:02") - - (* ;; "KNOTS is a non-NIL list of knots, CLOSEDFLG => closed curve") - - (PROG (DX DY DDX DDY DDDX DDDY %#KNOTS A BX BY X Y SX SY A C R D2X D2Y I) - [COND - (CLOSEDFLG (* ; "Wrap around") - (push KNOTS (CAR (LAST KNOTS] - (SETQ %#KNOTS (LENGTH KNOTS)) - (SETQ DX (ARRAY %#KNOTS 0 0.0)) - (SETQ DDX (ARRAY %#KNOTS 0 0.0)) - (SETQ DDDX (ARRAY %#KNOTS 0 0.0)) - (SETQ DY (ARRAY %#KNOTS 0 0.0)) - (SETQ DDY (ARRAY %#KNOTS 0 0.0)) - (SETQ DDDY (ARRAY %#KNOTS 0 0.0)) - (SETQ X (ARRAY %#KNOTS 0 0.0)) - (SETQ Y (ARRAY %#KNOTS 0 0.0)) - (for KNOT in KNOTS as I from 1 to %#KNOTS - do (OR (type? POSITION KNOT) - (ERROR "bad knot" KNOT)) - (SETA X I (CAR KNOT)) - (SETA Y I (CDR KNOT))) - (SETQ A (ARRAY %#KNOTS 0 0.0)) - (SETQ BX (ARRAY %#KNOTS 0 0.0)) - (SETQ BY (ARRAY %#KNOTS 0 0.0)) - [COND - (CLOSEDFLG (SETQ C (ARRAY %#KNOTS 0 0.0)) - (SETQ R (ARRAY %#KNOTS 0 0.0)) - (SETQ SX (ARRAY %#KNOTS 0 0.0)) - (SETQ SY (ARRAY %#KNOTS 0 0.0] - (SETA A 1 4.0) - [for I from 2 to (IDIFFERENCE %#KNOTS 2) - do (SETA A I (FDIFFERENCE 4.0 (FQUOTIENT 1.0 (ELT A (SUB1 I] - [COND - (CLOSEDFLG (SETA C 1 1.0) - (for I from 2 to (IDIFFERENCE %#KNOTS 2) - do (SETA C I (FMINUS (FQUOTIENT (ELT C (SUB1 I)) - (ELT A (SUB1 I] - [COND - ((IGEQ %#KNOTS 3) - (COND - [CLOSEDFLG [SETA BX 1 (FTIMES 6.0 (FPLUS (ELT X 2) - (FMINUS (FTIMES 2.0 (ELT X 1))) - (ELT X (SUB1 %#KNOTS] - [SETA BY 1 (FTIMES 6.0 (FPLUS (ELT Y 2) - (FMINUS (FTIMES 2.0 (ELT Y 1))) - (ELT Y (SUB1 %#KNOTS] - [for I from 2 to (IDIFFERENCE %#KNOTS 2) - do [SETA BX I (FDIFFERENCE [FTIMES 6.0 - (FPLUS (ELT X (ADD1 I)) - (FMINUS (FTIMES 2.0 - (ELT X I))) - (ELT X (SUB1 I] - (FQUOTIENT (ELT BX (SUB1 I)) - (ELT A (SUB1 I] - (SETA BY I (FDIFFERENCE [FTIMES 6.0 - (FPLUS (ELT Y (ADD1 I)) - (FMINUS (FTIMES 2.0 - (ELT Y I))) - (ELT Y (SUB1 I] - (FQUOTIENT (ELT BY (SUB1 I)) - (ELT A (SUB1 I] - (SETA R (SUB1 %#KNOTS) - 1.0) - (SETA SX (SUB1 %#KNOTS) - 0.0) - (SETA SY (SUB1 %#KNOTS) - 0.0) - (for I from (IDIFFERENCE %#KNOTS 2) to 1 by -1 - do [SETA R I (FMINUS (FQUOTIENT (FPLUS (ELT R (ADD1 I)) - (ELT C I)) - (ELT A I] - (SETA SX I (FQUOTIENT (FDIFFERENCE (ELT BX I) - (ELT SX (ADD1 I))) - (ELT A I))) - (SETA SY I (FQUOTIENT (FDIFFERENCE (ELT BY I) - (ELT SY (ADD1 I))) - (ELT A I] - (T [SETA BX 1 (FTIMES 6.0 (FPLUS (FDIFFERENCE (ELT X 3) - (FTIMES 2.0 (ELT X 2))) - (ELT X 1] - [SETA BY 1 (FTIMES 6.0 (FPLUS (FDIFFERENCE (ELT Y 3) - (FTIMES 2.0 (ELT Y 2))) - (ELT Y 1] - (for I from 2 to (IDIFFERENCE %#KNOTS 2) - do [SETA BX I (FDIFFERENCE (FTIMES - 6.0 - (FPLUS [FDIFFERENCE (ELT X (IPLUS I 2)) - (FTIMES 2 (ELT X (ADD1 I] - (ELT X I))) - (FQUOTIENT (ELT BX (SUB1 I)) - (ELT A (SUB1 I] - (SETA BY I (FDIFFERENCE (FTIMES 6.0 - (FPLUS [FDIFFERENCE - (ELT Y (IPLUS I 2)) - (FTIMES 2 (ELT Y (ADD1 I] - (ELT Y I))) - (FQUOTIENT (ELT BY (SUB1 I)) - (ELT A (SUB1 I] - [COND - (CLOSEDFLG [SETQ D2X (FPLUS (ELT X %#KNOTS) - [FMINUS (FTIMES 2.0 (ELT X (SUB1 %#KNOTS] - (ELT X (IDIFFERENCE %#KNOTS 2] - [SETQ D2Y (FPLUS (ELT Y %#KNOTS) - [FMINUS (FTIMES 2.0 (ELT Y (SUB1 %#KNOTS] - (ELT Y (IDIFFERENCE %#KNOTS 2] - (SETA DDX (SUB1 %#KNOTS) - (FQUOTIENT (FDIFFERENCE (FDIFFERENCE (FTIMES D2X 6.0) - (ELT SX 1)) - (ELT SX (IDIFFERENCE %#KNOTS 2))) - (FPLUS (ELT R 1) - (ELT R (IDIFFERENCE %#KNOTS 2)) - 4.0))) - (SETA DDY (SUB1 %#KNOTS) - (FQUOTIENT (FDIFFERENCE (FDIFFERENCE (FTIMES D2Y 6.0) - (ELT SY 1)) - (ELT SY (IDIFFERENCE %#KNOTS 2))) - (FPLUS (ELT R 1) - (ELT R (IDIFFERENCE %#KNOTS 2)) - 4.0))) - [for I from 1 to (IDIFFERENCE %#KNOTS 2) - do [SETA DDX I (FPLUS (ELT SX I) - (FTIMES (ELT R I) - (ELT DDX (SUB1 %#KNOTS] - (SETA DDY I (FPLUS (ELT SY I) - (FTIMES (ELT R I) - (ELT DDY (SUB1 %#KNOTS] - (SETA DDX %#KNOTS (ELT DDX 1)) - (SETA DDY %#KNOTS (ELT DDY 1))) - (T (* ; "COMPUTE SECOND DERIVATIVES.") - [SETA DDX 1 (SETA DDY 1 (SETA DDX %#KNOTS (SETA DDY %#KNOTS 0.0] - (for I from (SUB1 %#KNOTS) to 2 by -1 - do [SETA DDX I (FQUOTIENT (FDIFFERENCE (ELT BX (SUB1 I)) - (ELT DDX (ADD1 I))) - (ELT A (SUB1 I] - (SETA DDY I (FQUOTIENT (FDIFFERENCE (ELT BY (SUB1 I)) - (ELT DDY (ADD1 I))) - (ELT A (SUB1 I] - [for I from 1 to (SUB1 %#KNOTS) - do (* ; "COMPUTE 1ST & 3RD DERIVATIVES") - (SETA DX I (FDIFFERENCE (FDIFFERENCE (ELT X (ADD1 I)) - (ELT X I)) - (FQUOTIENT (FPLUS (FTIMES 2 (ELT DDX I)) - (ELT DDX (ADD1 I))) - 6.0))) - (SETA DY I (FDIFFERENCE (FDIFFERENCE (ELT Y (ADD1 I)) - (ELT Y I)) - (FQUOTIENT (FPLUS (FTIMES 2 (ELT DDY I)) - (ELT DDY (ADD1 I))) - 6.0))) - (SETA DDDX I (FDIFFERENCE (ELT DDX (ADD1 I)) - (ELT DDX I))) - (SETA DDDY I (FDIFFERENCE (ELT DDY (ADD1 I)) - (ELT DDY I] - (SETQ SPLINE - (create SPLINE - %#KNOTS _ %#KNOTS - SPLINEX _ X - SPLINEY _ Y - SPLINEDX _ DX - SPLINEDY _ DY - SPLINEDDX _ DDX - SPLINEDDY _ DDY - SPLINEDDDX _ DDDX - SPLINEDDDY _ DDDY)) - (RETURN SPLINE]) - -(\CURVE - [LAMBDA (X0 Y0 X1 Y1 DX DY DDX DDY DDDX DDDY N BRUSHBM DISPLAYDATA BBT ENDING USERFN DISPLAYSTREAM) - (* rrb "30-Apr-85 12:44") - (DECLARE (LOCALVARS . T)) - - (* ;; "Puts a spline segment down. Since it calls BitBlt1 directly, it must clip to both clipping region and the size of the destination bit map.") - - (PROG (OLDX X Y OLDY DELTAX DELTAY DELTA TX TY OOLDX OOLDY) - [COND - ((NEQ N 0) - [COND - (USERFN (* ; - "if there is a user fn, stay in his coordinates.") - (SETQ OLDX X0) - (SETQ OLDY Y0)) - (T - (* ;; "SUB1 on brush size is to cause the extra bit to be in the top left direction as is documented for lines.") - - (SETQ OLDX (\DSPTRANSFORMX (IDIFFERENCE X0 (LRSH (SUB1 BRUSHWIDTH) - 1)) - DISPLAYDATA)) - (SETQ OLDY (\DSPTRANSFORMY (IDIFFERENCE Y0 (LRSH (SUB1 BRUSHHEIGHT) - 1)) - DISPLAYDATA] (* ; "draw origin point") - (\CURVESMOOTH OLDX OLDY USERFN DISPLAYSTREAM) (* ; - "convert the derivatives to fractional representation.") - - (* ;; "\CONVERTTOFRACTION always returns a large number box. This uses 0.49 because 0.5 causes rounding up.") - - (SETQ X (\CONVERTTOFRACTION (FPLUS OLDX 0.49))) - (SETQ Y (\CONVERTTOFRACTION (FPLUS OLDY 0.49))) - (SETQ DX (\CONVERTTOFRACTION DX)) - (SETQ DY (\CONVERTTOFRACTION DY)) - (SETQ DDX (\CONVERTTOFRACTION DDX)) - (SETQ DDY (\CONVERTTOFRACTION DDY)) - (SETQ DDDX (\CONVERTTOFRACTION DDDX)) - (SETQ DDDY (\CONVERTTOFRACTION DDDY)) - [for I from 1 to N do (* ; - "uses \BOXIPLUS to save box and also set the new value of the variable.") - (\BOXIPLUS X DX) - (\BOXIPLUS DX DDX) - (\BOXIPLUS DDX DDDX) - (\BOXIPLUS Y DY) - (\BOXIPLUS DY DDY) - (\BOXIPLUS DDY DDDY) - (SETQ OOLDX OLDX) - (SETQ OOLDY OLDY) - (SETQ DELTAX (IDIFFERENCE (SETQ OLDX ( - \GETINTEGERPART - X)) - OOLDX)) - (SETQ DELTAY (IDIFFERENCE (SETQ OLDY ( - \GETINTEGERPART - Y)) - OOLDY)) - (SETQ DELTA (IMAX (IABS DELTAX) - (IABS DELTAY))) - (COND - ((EQ DELTA 1) - (\CURVESMOOTH OLDX OLDY USERFN DISPLAYSTREAM)) - ) - (COND - ((IGREATERP DELTA 1) - (SETQ DELTAX (\CONVERTTOFRACTION - (FQUOTIENT DELTAX DELTA))) - (SETQ DELTAY (\CONVERTTOFRACTION - (FQUOTIENT DELTAY DELTA))) - (SETQ TX (\CONVERTTOFRACTION OOLDX)) - (SETQ TY (\CONVERTTOFRACTION OOLDY)) - (for I from 0 to DELTA - do (\CURVESMOOTH (\GETINTEGERPART - TX) - (\GETINTEGERPART TY) - USERFN DISPLAYSTREAM) - (\BOXIPLUS TX DELTAX) - (\BOXIPLUS TY DELTAY] - (* ; "draw the end point") - (COND - (USERFN (\CURVESMOOTH X1 Y1 USERFN DISPLAYSTREAM)) - (T (\CURVESMOOTH (\DSPTRANSFORMX (IDIFFERENCE X1 (LRSH (SUB1 BRUSHWIDTH) - 1)) - DISPLAYDATA) - (\DSPTRANSFORMY (IDIFFERENCE Y1 (LRSH (SUB1 BRUSHHEIGHT) - 1)) - DISPLAYDATA) - NIL DISPLAYSTREAM))) - (AND DISPLAYSTREAM (MOVETO X1 Y1 DISPLAYSTREAM] - (COND - (ENDING (\CURVESMOOTH (IPLUS \CURX \CURX (IMINUS \OLDX)) - (IPLUS \CURY \CURY (IMINUS \OLDY)) - USERFN DISPLAYSTREAM) - (\CURVESMOOTH (IPLUS \CURX \CURX (IMINUS \OLDX)) - (IPLUS \CURY \CURY (IMINUS \OLDY)) - USERFN DISPLAYSTREAM))) - (RETURN NIL]) - -(\CURVE2 - [LAMBDA (SPLINE BRUSH DASHLST BBT DISPLAYSTREAM) (* jds "26-Nov-85 12:21") - -(* ;;; "Given a spline curve, represented as a set of derivatives for each segment, draw it on DISPLAYSTREAM using the brush BRUSH, and dashing it according to DASHLST. For speed, use the bitblt table BBT.") - - (DECLARE (SPECVARS . T)) - - (* ;; "DISPLAYSTREAM is guaranteed to be a display-stream. Should declare most of these variables local but currently have the \CURVE function between here and \CURVEBBT so can't") - - (PROG (BRUSHBM DestinationBitMap OPERATION BRUSHWIDTH BRUSHHEIGHT BRUSHBASE BRUSHRASTERWIDTH LEFT - RIGHTPLUS1 TOP BOTTOM DESTINATIONBASE LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH - RASTERWIDTH NBITSRIGHTPLUS1 HEIGHTMINUS1 COLOR COLORBRUSHBASE NBITS \CURX \CURY - \OLDX \OLDY \OLDERX \OLDERY LKNOT (DASHON T) - (DASHTAIL DASHLST) - (DASHCNT (CAR DASHLST)) - NPOINTS NSEGS POINTSPERSEG DX D2X D3X DY D2Y D3Y D1 D2 D3 X0 Y0 X1 Y1 DX DDX DDDX DY - DDY DDDY (XPOLY (create POLYNOMIAL)) - (X/PRIME/POLY (create POLYNOMIAL)) - (YPOLY (create POLYNOMIAL)) - (Y/PRIME/POLY (create POLYNOMIAL)) - (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM)) - (USERFN (AND (LITATOM BRUSH) - BRUSH))) - - (* ;; "many of these variables are used by the macro for \CURVEPT that passes them to \BBTCURVEPT and .SETUP.FOR.\BBTCURVEPT. sets them up.") - - [COND - (USERFN (* ; - "if calling user fn, don't bother with set up and leave points in window coordinates.") - (\CURVESTART (ELT (fetch (SPLINE SPLINEX) of SPLINE) - 1) - (ELT (fetch (SPLINE SPLINEY) of SPLINE) - 1))) - (T (.SETUP.FOR.\BBTCURVEPT.) (* ; - "Do it interruptably here to get set up, then uninterruptably when drawing points") - (\INSURETOPWDS DISPLAYSTREAM) (* ; - "curve pts will be kept in screen coordinates, start smoothing values there.") - (\CURVESTART (\DSPTRANSFORMX (IDIFFERENCE (ELT (fetch (SPLINE SPLINEX) - of SPLINE) - 1) - (LRSH (SUB1 BRUSHWIDTH) - 1)) - DISPLAYDATA) - (\DSPTRANSFORMY (IDIFFERENCE (ELT (fetch (SPLINE SPLINEY) of SPLINE) - 1) - (LRSH (SUB1 BRUSHHEIGHT) - 1)) - DISPLAYDATA] - [bind PERSEG for KNOT from 1 to (SUB1 (fetch %#KNOTS of SPLINE)) - when (PROGN - (* ;; - "Loop thru the segments of the spline curve, drawing each in turn.") - - (SETQ X0 (ELT (fetch (SPLINE SPLINEX) of SPLINE) - KNOT)) (* ; - "Set up X0,Y0 -- the starting point of this segment") - (SETQ Y0 (ELT (fetch (SPLINE SPLINEY) of SPLINE) - KNOT)) - (SETQ X1 (ELT (fetch (SPLINE SPLINEX) of SPLINE) - (ADD1 KNOT))) (* ; "And X1,Y1 -- the ending point") - (SETQ Y1 (ELT (fetch (SPLINE SPLINEY) of SPLINE) - (ADD1 KNOT))) - (SETQ DX (ELT (fetch (SPLINE SPLINEDX) of SPLINE) - KNOT)) (* ; - "And the initial derivatives -- first") - (SETQ DY (ELT (fetch (SPLINE SPLINEDY) of SPLINE) - KNOT)) - (SETQ DDX (ELT (fetch SPLINEDDX of SPLINE) - KNOT)) (* ; "Second") - (SETQ DDY (ELT (fetch SPLINEDDY of SPLINE) - KNOT)) - (SETQ DDDX (ELT (fetch SPLINEDDDX of SPLINE) - KNOT)) (* ; "And third.") - (SETQ DDDY (ELT (fetch SPLINEDDDY of SPLINE) - KNOT)) - (SETQ NPOINTS (FOLDLO (ITIMES (IMAX (IABS (IDIFFERENCE X1 X0)) - (IABS (IDIFFERENCE Y1 Y0))) - 3) - 2)) - - (* ;; "Establish an upper bound on the number of points we'll draw while painting this segment. We know that 3/2 the maximum DX or DY is the right amount.") - - (NOT (ZEROP NPOINTS))) - do - - (* ;; "NPOINTS can be zero if a knot is duplicated in the spline curve to produce a discontinuity. Skip over zero-length segments to avoid divide-by-zero trouble") - - (* ;; "To prevent round-off errors from accumulating, we'll draw this segment as runs of no more than 64 points each -- recomputing completely at the start of each run. This is a trade off of speed and accuracy.") - - [COND - ((ILEQ NPOINTS 64) (* ; - "Fewer than 64 points to draw. Do it in one run.") - (SETQ NSEGS 1) - (SETQ POINTSPERSEG NPOINTS)) - (T (* ; - "Figure out how many runs to do it in.") - (SETQ NSEGS (FOLDLO NPOINTS 64)) - (SETQ POINTSPERSEG 64) - (SETQ NPOINTS (UNFOLD NSEGS 64] - (SETQ D1 (FQUOTIENT 1.0 NPOINTS)) (* ; - "Set up ÿ&Eÿt, ÿ&Eÿt**2 and ÿ&Eÿt**3, for computing the next point.") - (SETQ D2 (FTIMES D1 D1)) - (SETQ D3 (FTIMES D2 D1)) - (SETQ D3X (FTIMES D3 DDDX)) - (SETQ D3Y (FTIMES D3 DDDY)) - (COND - [(EQ NSEGS 1) (* ; "Just one segment to draw.") - [SETQ DX (FPLUS (FTIMES D1 DX) - (FTIMES DDX D2 0.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 0.5) - (FTIMES D3 DDDY (CONSTANT (FQUOTIENT 1.0 6.0] - (SETQ D2Y (FPLUS (FTIMES D2 DDY) - (FTIMES D3 DDDY))) - (COND - (USERFN (* ; - "Draw this run of points, using the user's supplied function.") - (\CURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y NPOINTS BRUSHBM - DISPLAYDATA BBT NIL USERFN DISPLAYSTREAM)) - (T (* ; - "Draw this run of points, using the brush.") - (.WHILE.TOP.DS. DISPLAYSTREAM - (\CURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y NPOINTS BRUSHBM - DISPLAYDATA BBT NIL NIL DISPLAYSTREAM] - (T (* ; - "Have to do this segment in several runs.") - (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 - - (* ;; - "TT is the parameter, and runs from 0 to 1 as the curve segment runs from beginning to end.") - - (SETQ TT (FPLUS TT PERSEG)) - (SETQ X1 (POLYEVAL TT XPOLY 3)) - (SETQ Y1 (POLYEVAL TT YPOLY 3)) - (SETQ DX (FPLUS (FTIMES D1 DX) - (FTIMES D2 DDX 0.5) - D3XFACTOR)) - (SETQ D2X (FPLUS (FTIMES D2 DDX) - (FTIMES D3 DDDX))) - (SETQ DY (FPLUS (FTIMES D1 DY) - (FTIMES D2 DDY 0.5) - D3YFACTOR)) - (SETQ D2Y (FPLUS (FTIMES D2 DDY) - (FTIMES D3 DDDY))) - [COND - (USERFN (\CURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y 64 BRUSHBM - DISPLAYDATA BBT NIL USERFN DISPLAYSTREAM)) - (T (.WHILE.TOP.DS. DISPLAYSTREAM - (\CURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y 64 - BRUSHBM DISPLAYDATA BBT NIL NIL DISPLAYSTREAM] - (SETQ X0 X1) - (SETQ Y0 Y1) - (SETQ DDX (FPLUS DDX DDDX/PER/SEG)) - (SETQ DDY (FPLUS DDY DDDY/PER/SEG)) - (SETQ DX (POLYEVAL TT X/PRIME/POLY 2)) - (SETQ DY (POLYEVAL TT Y/PRIME/POLY 2] - - (* ;; "Draw the final point on the curve.") - - (COND - (USERFN (\CURVE 0 0 0 0 0 0 0 0 0 0 0 BRUSHBM DISPLAYDATA BBT T USERFN DISPLAYSTREAM - )) - (T (.WHILE.TOP.DS. DISPLAYSTREAM - (\CURVE 0 0 0 0 0 0 0 0 0 0 0 BRUSHBM DISPLAYDATA BBT T NIL DISPLAYSTREAM]) - -(\CURVEEND - [LAMBDA NIL (* rrb " 5-JAN-82 17:24") - - (* ;; "Put out the last two points, using \CURVEPT, since they were held back for smoothing.") - - (PROG ((X \CURX) - (Y \CURY) - (DX (IDIFFERENCE \CURX \OLDX)) - (DY (IDIFFERENCE \CURY \OLDY))) - (for I from 1 to 2 do (\CURVESMOOTH (SETQ X (IPLUS X DX)) - (SETQ Y (IPLUS Y DY]) - -(\CURVESLOPE - [LAMBDA (KNOTS ENDFLG) (* rrb "30-Nov-84 18:17") - - (* ;; "returns a CONS of DX DY that gives the slope of the curve thru KNOTS. If ENDFLG is NIL, it is at the beginning. If ENDFLG is T, it is at the last point.") - - (PROG (DX DY PARAMS (%#KNOTS (LENGTH KNOTS))) - (RETURN (SELECTQ %#KNOTS - ((0 1) (* ; "define slope as horizontal") - '(1 . 0)) - (2 [CONS (DIFFERENCE (fetch (POSITION XCOORD) of (CADR KNOTS)) - (fetch (POSITION XCOORD) of (CAR KNOTS))) - (DIFFERENCE (fetch (POSITION YCOORD) of (CADR KNOTS)) - (fetch (POSITION YCOORD) of (CAR KNOTS]) - (PROGN [SETQ PARAMS (COND - [ENDFLG (PARAMETRICSPLINE (REVERSE - (NLEFT KNOTS - (IMIN %#KNOTS 4] - (T (PARAMETRICSPLINE (COND - ((EQ %#KNOTS 3) - (LIST (CAR KNOTS) - (CADR KNOTS) - (CADDR KNOTS))) - (T (LIST (CAR KNOTS) - (CADR KNOTS) - (CADDR KNOTS) - (CADDDR KNOTS] - (SETQ DX (ELT (fetch (SPLINE SPLINEDX) of PARAMS) - 1)) - (SETQ DY (ELT (fetch (SPLINE SPLINEDY) of PARAMS) - 1)) - (if ENDFLG - then (CONS (MINUS DX) - (MINUS DY)) - else (CONS DX DY]) - -(\CURVESTART - [LAMBDA (X Y) (* jds "27-OCT-81 15:48") - - (* ;; "Set up the init vals for \OLDER* \OLD* \CUR*, for curve smoothing in \CURVEPT.") - - (SETQ \OLDERX X) - (SETQ \OLDX X) - (SETQ \CURX X) - (SETQ \OLDERY Y) - (SETQ \OLDY Y) - (SETQ \CURY Y]) - -(\FDIFS/FROM/DERIVS - [LAMBDA (DZ DDZ DDDZ RAD NSTEPS) (* rrb "12-MAY-81 10:59") - - (* ;; "the derivatives of the function, plus a scale factor (radius for drawing circles) See 'Spline Curve Techniques' , equations 2.18.") - - (PROG (S SS SSS) - (SETQ S (FQUOTIENT 1.0 NSTEPS)) - (SETQ SS (FTIMES S S)) - (SETQ SSS (FTIMES SS S)) - (SETQ S (FTIMES S DZ RAD)) - (SETQ SS (FTIMES SS DDZ RAD)) - (SETQ SSS (FTIMES SSS DDDZ RAD)) - (RETURN (LIST (FPLUS S (FQUOTIENT SS 2.0) - (FQUOTIENT SSS 6.0)) - (FPLUS SS SSS) - SSS]) -) -(DECLARE%: DONTCOPY -(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE - -(ARRAYRECORD POLYNOMIAL (A B C D) - (CREATE (ARRAY 4 'FLOATP)) - (SYSTEM)) - -(RECORD SPLINE (%#KNOTS SPLINEX SPLINEY SPLINEDX SPLINEDY SPLINEDDX SPLINEDDY SPLINEDDDX - SPLINEDDDY)) -) - -(* "END EXPORTED DEFINITIONS") - -) -(DECLARE%: DONTCOPY -(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE - -(PUTPROPS HALF MACRO ((X) - (LRSH X 1))) - -(PUTPROPS \FILLCIRCLEBLT MACRO (OPENLAMBDA (CX CY X Y) - (* ; - "calls bitblt twice to fill in one line of the circle.") - (\LINEBLT FCBBT (IDIFFERENCE CX X) - (IPLUS CY Y) - (IPLUS CX X) - DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP - GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS) - (\LINEBLT FCBBT (IDIFFERENCE CX X) - (IDIFFERENCE CY Y) - (IPLUS CX X) - DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP - GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS))) -) - -(* "END EXPORTED DEFINITIONS") - - -(DECLARE%: EVAL@COMPILE - -(PUTPROPS \CURVEPT MACRO [OPENLAMBDA (X Y) - (COND - ((OR (ILEQ X LEFTMINUSBRUSH) - (IGEQ X RIGHTPLUS1) - (ILEQ Y BOTTOMMINUSBRUSH) - (IGEQ Y TOP)) - NIL) - ((NULL BBT) - (\FBITMAPBIT DESTINATIONBASE X Y OPERATION HEIGHTMINUS1 - RASTERWIDTH)) - (T - (* ;; - "This should have been done in .SETUP.FOR.\BBTCURVEPT., under \GETBRUSHBBT.") - - (* ;; - "Its a bug here, because brushes can't use operation REPLACE.") - - (* ;; - "(\SETPBTFUNCTION BBT (ffetch DDSOURCETYPE of DISPLAYDATA) OPERATION)") - - (\BBTCURVEPT X Y BBT LEFT BRUSHWIDTH LEFTMINUSBRUSH - RIGHTPLUS1 NBITSRIGHTPLUS1 TOPMINUSBRUSH - DestinationBitMap BRUSHHEIGHT BOTTOMMINUSBRUSH TOP - BRUSHBASE DESTINATIONBASE RASTERWIDTH - BRUSHRASTERWIDTH COLORBRUSHBASE NBITS DISPLAYDATA]) - -(PUTPROPS .SETUP.FOR.\BBTCURVEPT. MACRO - [NIL (PROGN (SETQ BOTTOM (ffetch (\DISPLAYDATA DDClippingBottom) of DISPLAYDATA)) - (SETQ TOP (ffetch (\DISPLAYDATA DDClippingTop) of DISPLAYDATA)) - (SETQ RIGHTPLUS1 (ffetch (\DISPLAYDATA DDClippingRight) of DISPLAYDATA) - ) - (SETQ LEFT (ffetch (\DISPLAYDATA DDClippingLeft) of DISPLAYDATA)) - (SETQ DestinationBitMap (ffetch (\DISPLAYDATA DDDestination) of - DISPLAYDATA - )) - (SETQ OPERATION (OR OPERATION (ffetch (\DISPLAYDATA DDOPERATION) - of DISPLAYDATA))) - (SETQ NBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DestinationBitMap)) - [COND - [(NOT (EQ NBITS 1)) - (SETQ BRUSHBM (\GETCOLORBRUSH BRUSH (MAXIMUMCOLOR NBITS) - NBITS)) - [SETQ COLOR (COND - [(AND (LISTP BRUSH) - (CAR (LISTP (CDDR BRUSH] - ((DSPCOLOR NIL DISPLAYSTREAM)) - (T (MAXIMUMCOLOR NBITS] - [COND - ((EQ OPERATION 'ERASE) - (SETQ COLOR (OPPOSITECOLOR COLOR NBITS] - (SETQ COLORBRUSHBASE (fetch (BITMAP BITMAPBASE) - of (\GETCOLORBRUSH BRUSH COLOR NBITS] - (T (SETQ BRUSHBM (\GETBRUSH BRUSH] - (SETQ RASTERWIDTH (ffetch (BITMAP BITMAPRASTERWIDTH) of - DestinationBitMap - )) - (SETQ DESTINATIONBASE (ffetch (BITMAP BITMAPBASE) of DestinationBitMap) - ) - (SETQ BBT (\GETBRUSHBBT BRUSHBM DISPLAYDATA BBT)) - (SETQ BRUSHBASE (fetch (BITMAP BITMAPBASE) of BRUSHBM)) - (SETQ BRUSHRASTERWIDTH (ffetch (BITMAP BITMAPRASTERWIDTH) of BRUSHBM)) - [COND - ((NULL BBT) - (SETQ HEIGHTMINUS1 (SUB1 (ffetch (BITMAP BITMAPHEIGHT) of - DestinationBitMap - ))) - (COND - ((EQ (ffetch (\DISPLAYDATA DDOPERATION) of DISPLAYDATA) - 'INVERT) - (SETQ OPERATION 'INVERT] - (SETQ BRUSHWIDTH (ffetch (BITMAP BITMAPWIDTH) of BRUSHBM)) - (SETQ BRUSHHEIGHT (ffetch (BITMAP BITMAPHEIGHT) of BRUSHBM)) - (SETQ LEFTMINUSBRUSH (IDIFFERENCE LEFT BRUSHWIDTH)) - (SETQ BOTTOMMINUSBRUSH (IDIFFERENCE BOTTOM BRUSHHEIGHT)) - (SETQ TOPMINUSBRUSH (IDIFFERENCE TOP BRUSHHEIGHT)) - (SETQ NBITSRIGHTPLUS1 (ITIMES RIGHTPLUS1 NBITS)) - (SETQ BRUSHWIDTH (ITIMES BRUSHWIDTH NBITS]) - -(PUTPROPS \CIRCLEPTS MACRO (OPENLAMBDA (CX CY X Y) - (\CURVEPT (IPLUS CX X) - (IPLUS CY Y)) - (\CURVEPT (IDIFFERENCE CX X) - (IPLUS CY Y)) - (\CURVEPT (IPLUS CX X) - (IDIFFERENCE CY Y)) - (\CURVEPT (IDIFFERENCE CX X) - (IDIFFERENCE CY Y)))) - -(PUTPROPS \CURVESMOOTH MACRO (OPENLAMBDA (NEWX NEWY USERFN DISPLAYSTREAM) - (PROG [(DX (IABS (IDIFFERENCE NEWX \OLDX))) - (DY (IABS (IDIFFERENCE NEWY \OLDY] - (COND - ((OR (IGREATERP DX 1) - (IGREATERP DY 1)) - [COND - ((NEQ [IPLUS (ADD1 (IDIFFERENCE \OLDX \OLDERX)) - (ITIMES 3 (ADD1 (IDIFFERENCE \OLDY - \OLDERY] - 4) - [COND - (DASHON (COND - (USERFN (APPLY* USERFN \OLDX \OLDY - DISPLAYSTREAM)) - (T (.WHILE.TOP.DS. DISPLAYSTREAM - (\CURVEPT \OLDX \OLDY] - (COND - (DASHTAIL (COND - ((EQ 0 (SETQ DASHCNT - (SUB1 DASHCNT))) - (SETQ DASHON (NOT DASHON)) - (SETQ DASHTAIL - (OR (LISTP (CDR DASHTAIL)) - DASHLST)) - (SETQ DASHCNT (CAR DASHTAIL] - (SETQ \OLDERX \OLDX) - (SETQ \OLDERY \OLDY) - (SETQ \OLDX \CURX) - (SETQ \OLDY \CURY))) - (SETQ \CURX NEWX) - (SETQ \CURY NEWY)))) -) -) -(DEFINEQ - -(\FILLCIRCLE.DISPLAY - [LAMBDA (DISPLAYSTREAM CENTERX CENTERY RADIUS TEXTURE) (* kbr%: "24-Jan-86 19:12") - - (* ;; "Fill in area bounded by circle DRAWCIRCLE would draw.") - - (COND - ((OR (NOT (NUMBERP RADIUS)) - (ILESSP (SETQ RADIUS (FIXR RADIUS)) - 0)) - (\ILLEGAL.ARG RADIUS)) - (T (GLOBALRESOURCE \BRUSHBBT - (PROG (TOP BOTTOM RIGHT LEFT OPERATION DestinationBitMap DISPLAYDATA X Y D - DESTINATIONBASE RASTERWIDTH CX CY TEXTUREBM GRAYHEIGHT GRAYWIDTH GRAYBASE - NBITS FCBBT) - (SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DISPLAYSTREAM)) - (SETQ X 0) - (SETQ Y RADIUS) - (SETQ D (ITIMES 2 (IDIFFERENCE 1 RADIUS))) - (SETQ FCBBT \BRUSHBBT) - (SETQ LEFT (fetch (\DISPLAYDATA DDClippingLeft) of DISPLAYDATA)) - (SETQ BOTTOM (fetch (\DISPLAYDATA DDClippingBottom) of DISPLAYDATA)) - (SETQ TOP (SUB1 (fetch (\DISPLAYDATA DDClippingTop) of DISPLAYDATA))) - (SETQ RIGHT (SUB1 (fetch (\DISPLAYDATA DDClippingRight) of DISPLAYDATA - ))) - (SETQ OPERATION (fetch (\DISPLAYDATA DDOPERATION) of DISPLAYDATA)) - (SETQ DestinationBitMap (fetch (\DISPLAYDATA DDDestination) of - DISPLAYDATA - )) - (SETQ NBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DestinationBitMap)) - [SETQ TEXTUREBM (COND - ((BITMAPP TEXTURE)) - [(NOT (EQ NBITS 1))(* ; - "color case, default texture differently") - (COND - ((BITMAPP (COLORTEXTUREFROMCOLOR# - (COLORNUMBERP (OR TEXTURE - (DSPCOLOR NIL - DISPLAYSTREAM)) - NBITS T) - NBITS))) - [(AND (LISTP TEXTURE) - (BITMAPP (COLORTEXTUREFROMCOLOR# - (COLORNUMBERP (CADR TEXTURE) - NBITS) - NBITS] - (T (\ILLEGAL.ARG TEXTURE] - ((LISTP TEXTURE) (* ; - "either a color or a list of (texture color)") - (INSURE.B&W.TEXTURE TEXTURE)) - [(AND (NULL TEXTURE) - (BITMAPP (fetch (\DISPLAYDATA DDTexture) - of DISPLAYDATA] - ([OR (FIXP TEXTURE) - (AND (NULL TEXTURE) - (SETQ TEXTURE (fetch (\DISPLAYDATA DDTexture) - of DISPLAYDATA] - (* ; - "create bitmap for the texture. Could reuse a bitmap but for now this is good enough.") - (SETQ TEXTUREBM (BITMAPCREATE 16 4)) - (SETQ GRAYBASE (fetch (BITMAP BITMAPBASE) of - TEXTUREBM)) - (\PUTBASE GRAYBASE 0 (\SFReplicate (LOGAND (LRSH TEXTURE - 12) - 15))) - (\PUTBASE GRAYBASE 1 (\SFReplicate (LOGAND (LRSH TEXTURE 8 - ) - 15))) - (\PUTBASE GRAYBASE 2 (\SFReplicate (LOGAND (LRSH TEXTURE 4 - ) - 15))) - (\PUTBASE GRAYBASE 3 (\SFReplicate (LOGAND TEXTURE 15))) - TEXTUREBM) - (T (\ILLEGAL.ARG TEXTURE] - (SETQ GRAYBASE (fetch (BITMAP BITMAPBASE) of TEXTUREBM)) - (SETQ DESTINATIONBASE (fetch (BITMAP BITMAPBASE) of DestinationBitMap) - ) - (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of - DestinationBitMap - )) (* ; - "update as many fields in the brush bitblt table as possible from DS.") - (replace (PILOTBBT PBTFLAGS) of FCBBT with 0) - (replace (PILOTBBT PBTDESTBPL) of FCBBT with (UNFOLD RASTERWIDTH - BITSPERWORD)) - (* ; - "clear gray information. PBTSOURCEBPL is used for gray information too.") - (replace (PILOTBBT PBTSOURCEBPL) of FCBBT with 0) - (replace (PILOTBBT PBTUSEGRAY) of FCBBT with T) - [replace (PILOTBBT PBTGRAYWIDTHLESSONE) of FCBBT - with (SUB1 (SETQ GRAYWIDTH (IMIN (fetch (BITMAP BITMAPWIDTH) - of TEXTUREBM) - 16] - [replace (PILOTBBT PBTGRAYHEIGHTLESSONE) of FCBBT - with (SUB1 (SETQ GRAYHEIGHT (IMIN (fetch (BITMAP BITMAPHEIGHT) - of TEXTUREBM) - 16] - (replace (PILOTBBT PBTDISJOINT) of FCBBT with T) - (\SETPBTFUNCTION FCBBT 'TEXTURE OPERATION) - (replace (PILOTBBT PBTHEIGHT) of FCBBT with 1) - (* ; - "take into account the brush thickness.") - (SETQ CX (\DSPTRANSFORMX CENTERX DISPLAYDATA)) - (SETQ CY (\DSPTRANSFORMY CENTERY DISPLAYDATA)) - (* ; - "change Y TOP and BOTTOM to be in bitmap coordinates") - (SETQ CY (SUB1 (\SFInvert DestinationBitMap CY))) - (SETQ TOP (SUB1 (\SFInvert DestinationBitMap TOP))) - (SETQ BOTTOM (SUB1 (\SFInvert DestinationBitMap BOTTOM))) - (swap TOP BOTTOM) - (\INSURETOPWDS DISPLAYSTREAM) - - (* ;; "Move the window to top while interruptable, but verify that it is still there uninterruptably with drawing points") - - (COND - ((EQ RADIUS 0) (* ; - "put a single point down. Use \LINEBLT to get proper texture. NIL") - (.WHILE.TOP.DS. DISPLAYSTREAM - (\LINEBLT FCBBT CX CY CX DESTINATIONBASE RASTERWIDTH LEFT RIGHT - BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS)) - (RETURN))) - LP (* ; - "(UNFOLD x 2) is used instead of (ITIMES x 2)") - [COND - [(IGREATERP 0 D) - (SETQ X (ADD1 X)) - (COND - ((IGREATERP (UNFOLD (IPLUS D Y) - 2) - 1) - (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y) - 2) - 4))) - (T (SETQ D (IPLUS D (UNFOLD X 2) - 1)) (* ; "don't draw unless Y changes.") - (GO LP] - ((OR (EQ 0 D) - (IGREATERP X D)) - (SETQ X (ADD1 X)) - (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y) - 2) - 4))) - (T (SETQ D (IPLUS (IDIFFERENCE D (UNFOLD Y 2)) - 3] - (COND - ((EQ Y 0) (* ; - "draw the middle line differently to avoid duplication.") - (.WHILE.TOP.DS. DISPLAYSTREAM - (\LINEBLT FCBBT (IDIFFERENCE CX X) - CY - (IPLUS CX X) - DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH - GRAYHEIGHT GRAYBASE NBITS))) - (T (.WHILE.TOP.DS. DISPLAYSTREAM (\FILLCIRCLEBLT CX CY X Y)) - (SETQ Y (SUB1 Y)) - (GO LP))) - (MOVETO CENTERX CENTERY DISPLAYSTREAM) - (RETURN NIL]) - -(\LINEBLT - [LAMBDA (BBT X Y XRIGHT DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT - GRAYBASE NBITS) (* kbr%: "15-Feb-86 22:08") - - (* ;; "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 (PILOTBBT PBTDEST) of BBT with (\ADDBASE DESTINATIONBASE - (ITIMES RASTERWIDTH Y))) - [freplace (PILOTBBT PBTSOURCE) of BBT with (\ADDBASE GRAYBASE - (freplace (PILOTBBT - PBTGRAYOFFSET) - of BBT - with (MOD Y GRAYHEIGHT - ] - (SELECTQ NBITS - (1 (freplace (PILOTBBT PBTDESTBIT) of BBT with X) - (freplace (PILOTBBT PBTSOURCEBIT) of BBT with (MOD X GRAYWIDTH)) - (freplace (PILOTBBT PBTWIDTH) of BBT with (ADD1 (IDIFFERENCE XRIGHT X)))) - (4 (* ; - "color case, shift x values {which are in pixels} into bit values.") - (freplace (PILOTBBT PBTDESTBIT) of BBT with (SETQ X (LLSH X 2))) - (* ; - "if TEXTURE is not a multiple of nbits wide this is probably garbage.") - (freplace (PILOTBBT PBTSOURCEBIT) of BBT with (MOD X GRAYWIDTH)) - (freplace (PILOTBBT PBTWIDTH) of BBT with (IDIFFERENCE - (LLSH (ADD1 XRIGHT) - 2) - X))) - (8 (* ; - "color case, shift x values {which are in pixels} into bit values.") - (freplace (PILOTBBT PBTDESTBIT) of BBT with (SETQ X (LLSH X 3))) - (freplace (PILOTBBT PBTSOURCEBIT) of BBT with (MOD X GRAYWIDTH)) - (freplace (PILOTBBT PBTWIDTH) of BBT with (IDIFFERENCE - (LLSH (ADD1 XRIGHT) - 3) - X))) - (24 (* ; - "color case, shift x values {which are in pixels} into bit values.") - (freplace (PILOTBBT PBTDESTBIT) of BBT with (SETQ X (ITIMES 24 X))) - (freplace (PILOTBBT PBTSOURCEBIT) of BBT with (MOD X GRAYWIDTH)) - (freplace (PILOTBBT PBTWIDTH) of BBT with (IDIFFERENCE - (ITIMES 24 (ADD1 XRIGHT)) - X))) - (SHOULDNT)) - (\PILOTBITBLT BBT 0]) -) - - - -(* ; "making and copying bitmaps") - -(DEFINEQ - -(SCREENBITMAP - [LAMBDA (SCREEN) (* ; "Edited 20-Feb-87 14:57 by rrb") - - (* ;; "Return bitmap destination of SCREEN.") - - (COND - ((NULL SCREEN) - ScreenBitMap) - ((type? SCREEN SCREEN) - (fetch (SCREEN SCDESTINATION) of SCREEN)) - ((WINDOWP SCREEN) - (fetch (SCREEN SCDESTINATION) of (fetch (WINDOW SCREEN) of SCREEN))) - (T (\ILLEGAL.ARG SCREEN]) - -(BITMAPP - [LAMBDA (X) (* rrb "25-JUN-82 15:21") - (* ; "is x a bitmap?") - (AND (type? BITMAP X) - X]) - -(BITMAPHEIGHT - [LAMBDA (BITMAP) (* kbr%: " 8-Jul-85 16:01") - - (* ;; "returns the height in pixels of a bitmap.") - - (COND - ((type? BITMAP BITMAP) - (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) - ((type? WINDOW BITMAP) - (WINDOWPROP BITMAP 'HEIGHT)) - (T (\ILLEGAL.ARG BITMAP]) - -(BITSPERPIXEL - [LAMBDA (BITMAP) (* ; "Edited 15-Feb-94 16:10 by nilsson") - - (* ;; "returns the height in pixels of a bitmap.") - - (COND - ((type? BITMAP BITMAP) - (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)) - ((type? SCREEN BITMAP) - - (* ;; "Read the propper slots, not the implicit bitmap.") - - (OR (fetch (SCREEN SCDEPTH) of BITMAP) - (fetch (SCREEN SCBITSPERPIXEL) of BITMAP))) - ((type? WINDOW BITMAP) - (BITSPERPIXEL (fetch (WINDOW SCREEN) of BITMAP))) - ((ARRAYP BITMAP) (* ; - "Consider array to be a colormap.") - (SELECTQ (ARRAYSIZE BITMAP) - (256 8) - (16 4) - (LISPERROR "ILLEGAL ARG" BITMAP))) - (T (LISPERROR "ILLEGAL ARG" BITMAP]) -) -(* "FOLLOWING DEFINITIONS EXPORTED")(PUTDEF (QUOTE BITMAPS) (QUOTE FILEPKGCOMS) '[(COM - MACRO - (X (VARS . X]) -(PUTDEF (QUOTE CURSORS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (MAPC 'X 'PRINTCURSOR]) - -(* "END EXPORTED DEFINITIONS") - -(DECLARE%: EVAL@COMPILE -(* "FOLLOWING DEFINITIONS EXPORTED") -(ADDTOVAR GLOBALVARS SCREENHEIGHT SCREENWIDTH ScreenBitMap) - -(* "END EXPORTED DEFINITIONS") - -) - - - -(* ; "Display stream functions that are not needed in the primitive system") - -(DEFINEQ - -(DSPFILL - [LAMBDA (REGION TEXTURE OPERATION STREAM) (* kbr%: " 8-Jul-85 15:40") - - (* ;; "wipes a region of an imagestream with texture.") - - (* ;; "TEXTURE and OPERATION default to those of STREAM") - - (PROG (STRM) - (SETQ STRM (\OUTSTREAMARG STREAM)) - (OR REGION (SETQ REGION (DSPCLIPPINGREGION NIL STRM))) - (RETURN (BLTSHADE TEXTURE STRM (fetch (REGION LEFT) of REGION) - (fetch (REGION BOTTOM) of REGION) - (fetch (REGION WIDTH) of REGION) - (fetch (REGION HEIGHT) of REGION) - OPERATION]) - -(INVERTW - [LAMBDA (WIN SHADE) (* rrb "18-May-84 21:52") - - (* ;; "inverts a window and returns the window. Used in RESETFORMS.") - - (DSPFILL (DSPCLIPPINGREGION NIL WIN) - (OR SHADE BLACKSHADE) - 'INVERT WIN) - WIN]) -) -(DEFINEQ - -(\DSPCOLOR.DISPLAY - [LAMBDA (STREAM COLOR) (* ; "Edited 29-Jan-91 11:33 by matsuda") - - (* ;; "sets and returns a display stream's background color.") - - (PROG (DD COLORCELL DESTINATION BITSPERPIXEL) - (SETQ DD (\GETDISPLAYDATA STREAM)) - (SETQ COLORCELL (fetch (\DISPLAYDATA DDCOLOR) of DD)) - (SETQ DESTINATION (fetch (\DISPLAYDATA DDDestination) of DD)) - (SETQ BITSPERPIXEL (BITSPERPIXEL DESTINATION)) - (RETURN (COND - (COLOR (SETQ COLOR (COLORNUMBERP COLOR BITSPERPIXEL)) - (PROG1 (COND - (COLORCELL (PROG1 (CAR COLORCELL) - (RPLACA COLORCELL COLOR))) - (T (* ; "no color cell yet, make one.") - (replace (\DISPLAYDATA DDCOLOR) of DD - with (CONS COLOR 0)) - (MAXIMUMCOLOR BITSPERPIXEL))) - (\SFFixFont STREAM DD))) - (T (OR (CAR COLORCELL) - (MAXIMUMCOLOR BITSPERPIXEL]) - -(\DSPBACKCOLOR.DISPLAY - [LAMBDA (STREAM COLOR) (* kbr%: "25-Aug-85 18:15") - - (* ;; "sets and returns a display stream's foreground color.") - - (PROG (DD COLORCELL DESTINATION BITSPERPIXEL) - (SETQ DD (\GETDISPLAYDATA STREAM)) - (SETQ COLORCELL (fetch (\DISPLAYDATA DDCOLOR) of DD)) - (RETURN (COND - (COLOR (SETQ DESTINATION (fetch (\DISPLAYDATA DDDestination) of DD)) - (SETQ BITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of - DESTINATION - )) - (SETQ COLOR (COLORNUMBERP COLOR BITSPERPIXEL)) - (PROG1 (COND - (COLORCELL (PROG1 (CDR COLORCELL) - (RPLACD COLORCELL COLOR))) - (T (* ; "no color cell yet, make one.") - (replace (\DISPLAYDATA DDCOLOR) of DD - with (CONS (MAXIMUMCOLOR BITSPERPIXEL) - COLOR)) - 0)) - (\SFFixFont STREAM DD))) - (T (OR (CDR COLORCELL) - 0]) - -(DSPEOLFN - [LAMBDA (EOLFN DISPLAYSTREAM) (* rrb "18-May-84 21:44") - - (* ;; "sets the end of line function for a displaystream. EOLFN will be called every EOL with the argument of the display stream. If EOLFN is 'OFF, the eolfn is cleared.") - - (PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM))) - (RETURN (PROG1 (COND - ((fetch (\DISPLAYDATA DDEOLFN) of DD)) - (T 'OFF)) - [AND EOLFN (COND - [(LITATOM EOLFN) - (replace (\DISPLAYDATA DDEOLFN) of DD - with (COND - ((EQ EOLFN 'OFF) - NIL) - (T EOLFN] - (T (\ILLEGAL.ARG EOLFN])]) -) -(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE - -(RPAQQ BLACKSHADE 65535) - -(RPAQQ WHITESHADE 0) - - -(CONSTANTS (BLACKSHADE 65535) - (WHITESHADE 0)) -) - -(RPAQQ GRAYSHADE 43605) - -(ADDTOVAR GLOBALVARS GRAYSHADE) - -(* "END EXPORTED DEFINITIONS") - -(DECLARE%: EVAL@COMPILE - -(PUTPROPS DSPRUBOUTCHAR MACRO ((DS CHAR X Y TTBL) - (\DSPMOVELR DS CHAR X Y TTBL NIL T))) -) -(DEFINEQ - -(DSPCLEOL - [LAMBDA (DISPLAYSTREAM XPOS YPOS HEIGHT) (* lmm " 3-May-84 10:31") - (\CHECKCARET DISPLAYSTREAM) - (PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM DISPLAYSTREAM))) - (RETURN (BITBLT NIL NIL NIL DISPLAYSTREAM (OR (FIXP XPOS) - (SETQ XPOS (ffetch DDLeftMargin - of DD))) - [OR (FIXP YPOS) - (IDIFFERENCE (ffetch DDYPOSITION of DD) - (FONTPROP DISPLAYSTREAM 'DESCENT] - (IMAX 0 (IDIFFERENCE (ffetch DDRightMargin of DD) - XPOS)) - (OR (FIXP HEIGHT) - (IMINUS (ffetch DDLINEFEED of DD))) - 'TEXTURE - 'REPLACE]) - -(DSPRUBOUTCHAR - [LAMBDA (STREAM CHAR X Y TTBL) (* Pavel " 6-Oct-86 22:44") - (if (DISPLAYSTREAMP CHAR) - then - - (* ;; "Some older code may use the CHAR argument first.") - - (swap STREAM CHAR) - (SETQ TTBL X) - (SETQ X) - (SETQ Y)) - (\GETDISPLAYDATA STREAM STREAM) - (\DSPMOVELR STREAM CHAR X Y TTBL NIL T]) - -(\DSPMOVELR - [LAMBDA (DS CHAR X Y TTBL RIGHTWARDSFLG ERASEFLG) (* JonL " 7-May-84 02:47") - - (* ;; "Moves the cursor 'leftwards' (or 'rightwards' if RIGHTWARDSFLG is non-null) over any main character and control or meta indicators. Returns NIL if the move can't be determined, such as trying to move left when already at the left margin. Effaces (or 'Rubs out') any bits moved over if ERASEFLG is non-null.") - - ([LAMBDA (DD) - - (* ;; - "Must do the \GETDISPLAYDATA first, since it may reset DS when it coerces to a DISPLAYSTREAM") - - (PROG [(WIDTH (\STREAMCHARWIDTH (COND - ((CHARCODEP CHAR) - CHAR) - (T (CHARCODE M))) - DS TTBL)) - (DEFAULTPOS? (AND (NULL X) - (NULL Y] - (OR ERASEFLG DEFAULTPOS? (SHOULDNT)) (* ; - "CURSORLEFT and CURSORRIGHT commands aren't allowed to start from anywhere except current spot") - - (* ;; "Note that if CHAR is not specified and DS has a variable-pitch font, then the results may be somewhat random. Smart terminal drivers thus can work well only on fixed-pitch fonts.") - - (COND - ((NULL WIDTH) - (RETURN)) - ((EQ 0 WIDTH) (* ; "Ha, what an easy case") - (RETURN T))) - (OR (FIXP X) - (SETQ X (ffetch DDXPOSITION of DD))) - (OR (FIXP Y) - (SETQ Y (ffetch DDYPOSITION of DD))) - (COND - ([COND - (RIGHTWARDSFLG (IGREATERP (add X WIDTH) - (ffetch DDRightMargin of DD))) - (T (ILESSP (add X (IMINUS WIDTH)) - (ffetch DDLeftMargin of DD] - (* ; - "If we can't do the full backup, then return NIL to signal this fact") - (RETURN))) - (\CHECKCARET DS) (* ; - "Take down the caret, if there is one, just in case we are moving over it.") - [COND - (ERASEFLG (* ; "And do the erasure if requested") - ([LAMBDA (FONT) - (PROG ((YPRIME (IDIFFERENCE Y (FONTDESCENT FONT))) - (HEIGHT (FONTHEIGHT FONT))) - (COND - ((NOT DEFAULTPOS?) - (MOVETO X Y DS) (* ; - "Backup over the bits, and 'wipe' them out.") - )) - (BITBLT NIL 0 0 DS X YPRIME WIDTH HEIGHT 'TEXTURE 'REPLACE) - (* ; "wipe out some bits") - ] - (ffetch DDFONT of DD] - (DSPXPOSITION X DS) (* ; "Now do the move.") - (RETURN T] - (\GETDISPLAYDATA DS DS]) -) - - - -(* ; "for cursor") - - -(RPAQQ \DefaultCursor #*(16 16)H@@@L@@@N@@@O@@@OH@@OL@@ON@@O@@@MH@@IH@@@L@@@L@@@F@@@F@@@C@@@C@@) -(DEFINEQ - -(\CURSOR.DEFPRINT - [LAMBDA (CURSOR STREAM) (* ; "Edited 15-Sep-94 16:13 by sybalsky") - (COND - (*PRINT-ARRAY* (PRIN1 "#,(LET(image) (CURSORCREATE (SETQ image '" STREAM) - (PRIN4 (fetch (CURSOR CUIMAGE) of CURSOR) - STREAM) - (PRIN1 ") " STREAM) - (COND - ((EQ (fetch (CURSOR CUIMAGE) of CURSOR) - (fetch (CURSOR CUMASK) of CURSOR)) - (PRIN1 " image " STREAM)) - (T (PRIN1 " '" STREAM) - (PRIN4 (fetch (CURSOR CUMASK) of CURSOR) - STREAM))) - (PRIN1 " " STREAM) - (PRIN1 (fetch (CURSOR CUHOTSPOTX) of CURSOR) - STREAM) - (PRIN1 " " STREAM) - (PRIN1 (fetch (CURSOR CUHOTSPOTY) of CURSOR) - STREAM) - (PRIN1 " " STREAM) - (PRIN1 (fetch (CURSOR CUDATA) of CURSOR) - STREAM) - (PRIN1 "))" STREAM]) -) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(RPAQ? DEFAULTCURSOR (CURSORCREATE \DefaultCursor NIL 0 15)) - - -(COND - ((NULL \CURRENTCURSOR) - (SETQ \CURRENTCURSOR DEFAULTCURSOR))) - -(DEFPRINT 'CURSOR '\CURSOR.DEFPRINT) -) -(DECLARE%: DONTCOPY -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS DEFAULTCURSOR) -) -) - - - -(* ; "stuff to interpret colors as textures which is needed even in system that don't have color.") - -(DEFINEQ - -(TEXTUREOFCOLOR - [LAMBDA (COLOR NOERRORFLG) (* rrb "30-Oct-85 19:43") - - (* ;; "returns a texture to represent a color on a black and white display") - - (PROG ((RGB (INSURE.RGB.COLOR COLOR NOERRORFLG))) - (RETURN (COND - ((NULL RGB) - NIL) - ((AND (IGREATERP (fetch (RGB RED) of RGB) - 245) - (IGREATERP (fetch (RGB GREEN) of RGB) - 245) - (IGREATERP (fetch (RGB BLUE) of RGB) - 245)) (* ; "special case white") - BLACKSHADE16) - (T (PROG [(TEX (\PRIMARYTEXTURE 'RED (fetch (RGB RED) of RGB] - (BITBLT NIL NIL NIL TEX 0 0 16 16 'TEXTURE 'PAINT - (\PRIMARYTEXTURE 'BLUE (fetch (RGB BLUE) of RGB))) - (BITBLT NIL NIL NIL TEX 0 0 16 16 'TEXTURE 'PAINT - (\PRIMARYTEXTURE 'GREEN (fetch (RGB GREEN) of RGB))) - (RETURN TEX]) - -(\PRIMARYTEXTURE - [LAMBDA (PRIMARY LEVEL) (* rrb "30-Oct-85 19:25") - - (* ;; "returns the 16x16 texture for a primary color level.") - - (PROG [(TEXTURE (BITMAPCOPY (SELECTQ PRIMARY - (RED REDTEXTURE) - (BLUE BLUETEXTURE) - (GREEN GREENTEXTURE) - (\ILLEGAL.ARG PRIMARY] - (BITBLT (\LEVELTEXTURE LEVEL) - 0 0 TEXTURE 0 0 16 16 'INPUT 'ERASE) - (RETURN TEXTURE]) - -(\LEVELTEXTURE - [LAMBDA (LEVEL) (* rrb "20-Aug-85 16:42") - - (* ;; "returns a 16x16 texture which is merged so that only light bits on both go to light with a primary color pattern to get a level primary pattern.") - - (COND - ((ILESSP LEVEL 100) - BLACKSHADE16) - ((ILESSP LEVEL 150) - DARKGRAY16) - ((ILESSP LEVEL 200) - MEDIUMGRAY16) - ((ILESSP LEVEL 245) - LIGHTGRAY16) - (T WHITESHADE16]) - -(INSURE.B&W.TEXTURE - [LAMBDA (TEXTURE NOERRORFLG) (* rrb "30-Oct-85 19:47") - - (* ;; "coerces a TEXTURE argument to a 1 bit per pixel bitmap or small number") - - (SELECTQ (TYPENAME TEXTURE) - (LITATOM (* ; "includes NIL case") - (COND - (TEXTURE (* ; "should be a color name") - (TEXTUREOFCOLOR (INSURE.RGB.COLOR TEXTURE NOERRORFLG))) - (T WHITESHADE))) - ((SMALLP FIXP) - (LOGAND TEXTURE BLACKSHADE)) - (BITMAP TEXTURE) - (LISTP (* ; - "can be a list of (TEXTURE COLOR) or a list of levels rgb or hls.") - (COND - ((TEXTUREOFCOLOR TEXTURE T)) - ((CAR TEXTURE) - (INSURE.B&W.TEXTURE (CAR TEXTURE) - NOERRORFLG)) - ((CAR (LISTP (CDR TEXTURE))) - (TEXTUREOFCOLOR (CADR TEXTURE) - NOERRORFLG)) - (T (* ; "list of form (NIL NIL)") - WHITESHADE))) - (COND - ((NULL NOERRORFLG) - (\ILLEGAL.ARG TEXTURE]) - -(INSURE.RGB.COLOR - [LAMBDA (COLOR NOERRFLG) (* rrb "30-Oct-85 19:34") - (* ; - "returns the RGB triple for a color.") - (PROG (LEVELS) - (RETURN (COND - [(FIXP COLOR) (* ; - "don't know what to do with color numbers so error") - (COND - (NOERRFLG NIL) - (T (\ILLEGAL.ARG COLOR] - [(LITATOM COLOR) - (COND - ((SETQ LEVELS (\LOOKUPCOLORNAME COLOR)) - (* ; - "recursively look up color number") - (INSURE.RGB.COLOR (CDR LEVELS) - NOERRFLG)) - (NOERRFLG NIL) - (T (ERROR "Unknown color name" COLOR] - ((HLSP COLOR) (* ; "HLS form convert to RGB") - (HLSTORGB COLOR)) - ((RGBP COLOR) (* ; "check for RGB or HLS") - COLOR) - (NOERRFLG NIL) - (T (\ILLEGAL.ARG COLOR]) - -(\LOOKUPCOLORNAME - [LAMBDA (COLORNAME) (* rrb "13-DEC-82 13:14") - - (* ;; "looks up a prospective color name. Returns a list whose CAR is the name and whose CDR is a color spec.") - - (FASSOC COLORNAME COLORNAMES]) - -(RGBP - [LAMBDA (X) (* rrb "27-OCT-82 10:15") - (* ; - "return X if it is a red green blue triple.") - (PROG (TMP) - (RETURN (AND (LISTP X) - (SMALLP (SETQ TMP (CAR X))) - (IGREATERP TMP -1) - (IGREATERP 256 TMP) - (SMALLP (SETQ TMP (CADR X))) - (IGREATERP TMP -1) - (IGREATERP 256 TMP) - (SMALLP (SETQ TMP (CADDR X))) - (IGREATERP TMP -1) - (IGREATERP 256 TMP) - X]) - -(HLSP - [LAMBDA (X) (* rrb "31-Oct-85 10:51") - - (* ;; "return T if X is a hue lightness saturation triple.") - - (AND (NUMBERP (CAR (LISTP X))) - (IGREATERP (CAR X) - -1) - (IGREATERP 361 (CAR X)) - [FLOATP (CAR (LISTP (CDR X] - [FLOATP (CAR (LISTP (CDDR X] - X]) - -(HLSTORGB - [LAMBDA (HLS) (* rrb "30-Oct-85 19:59") - - (* ;; "converts from a hue saturation lightness triple into red green blue triple. HUE is in range 0 to 360, lightness and saturation are in the range 0 to 1.0") - - (* ;; "this algorithm was taken from siggraph vol 13 number 3 August 1979: Status report on graphics standards planning committee.") - - (PROG ((H (fetch (HLS HUE) of HLS)) - (L (fetch (HLS LIGHTNESS) of HLS)) - (S (fetch (HLS SATURATION) of HLS)) - Max Min) - [SETQ Max (COND - ((FGREATERP 0.5 L) - (FTIMES L (FPLUS 1.0 S))) - (T (FDIFFERENCE (FPLUS L S) - (FTIMES L S] - (SETQ Min (FDIFFERENCE (FTIMES L 2) - Max)) - (RETURN (create RGB - RED _ (\HLSVALUEFN Min Max H) - GREEN _ (\HLSVALUEFN Min Max (IDIFFERENCE H 120)) - BLUE _ (\HLSVALUEFN Min Max (IDIFFERENCE H 240]) - -(\HLSVALUEFN - [LAMBDA (MIN MAX HUE) (* rrb "25-OCT-82 10:47") - - (* ;; "internal value function for converting from HLS to RGB.") - - [COND - ((ILESSP HUE 0) - (SETQ HUE (IPLUS HUE 360] - (FIX (FTIMES (COND - ((ILESSP HUE 60) - (FPLUS MIN (FQUOTIENT (FTIMES (FDIFFERENCE MAX MIN) - HUE) - 60))) - ((ILESSP HUE 180) - MAX) - ((ILESSP HUE 240) - (FPLUS MIN (FQUOTIENT (FTIMES (FDIFFERENCE MAX MIN) - (FDIFFERENCE 240 HUE)) - 60))) - (T MIN)) - 255]) -) - -(RPAQQ COLORNAMES - ((WHITE 255 255 255) - (CYAN 0 255 255) - (MAGENTA 255 0 255) - (YELLOW 255 255 0) - (RED 255 0 0) - (GREEN 0 255 0) - (BLUE 0 0 255) - (BLACK 0 0 0))) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS COLORNAMES) -) -(DECLARE%: DONTCOPY -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS BLACKSHADE16 DARKGRAY16 MEDIUMGRAY16 LIGHTGRAY16 WHITESHADE16 REDTEXTURE GREENTEXTURE - BLUETEXTURE) -) -) - -(READVARS-FROM-STRINGS '(BLACKSHADE16 DARKGRAY16 MEDIUMGRAY16 LIGHTGRAY16 WHITESHADE16 REDTEXTURE - GREENTEXTURE BLUETEXTURE) - "({(READBITMAP)(16 16 -%"OOOO%" -%"OOOO%" -%"OOOO%" -%"OOOO%" -%"OOOO%" -%"OOOO%" -%"OOOO%" -%"OOOO%" -%"OOOO%" -%"OOOO%" -%"OOOO%" -%"OOOO%" -%"OOOO%" -%"OOOO%" -%"OOOO%" -%"OOOO%")} {(READBITMAP)(16 16 -%"NMGG%" -%"KGMM%" -%"MNKK%" -%"GKNN%" -%"MNKK%" -%"GKNM%" -%"NMGN%" -%"KGMG%" -%"NKKM%" -%"KNNK%" -%"GGMN%" -%"MMGG%" -%"GGKM%" -%"MJOG%" -%"NOEK%" -%"KMNN%")} {(READBITMAP)(16 16 -%"JJJJ%" -%"EEEE%" -%"JJJJ%" -%"EEEE%" -%"JJJJ%" -%"EEEE%" -%"JJJJ%" -%"EEEE%" -%"JJJJ%" -%"EEEE%" -%"JJJJ%" -%"EEEE%" -%"JJJJ%" -%"EEEE%" -%"JJJJ%" -%"EEEE%")} {(READBITMAP)(16 16 -%"HBDB%" -%"BHAA%" -%"DDHD%" -%"AABH%" -%"HHDA%" -%"BBAD%" -%"DDHB%" -%"AABH%" -%"HDAD%" -%"AADA%" -%"DHBH%" -%"BBHB%" -%"HHAD%" -%"ABDA%" -%"DDHH%" -%"BABB%")} {(READBITMAP)(16 16 -%"@@@@%" -%"@@@@%" -%"@@@@%" -%"@@@@%" -%"@@@@%" -%"@@@@%" -%"@@@@%" -%"@@@@%" -%"@@@@%" -%"@@@@%" -%"@@@@%" -%"@@@@%" -%"@@@@%" -%"@@@@%" -%"@@@@%" -%"@@@@%")} {(READBITMAP)(16 16 -%"LLLL%" -%"LLLL%" -%"LLLL%" -%"LLLL%" -%"LLLL%" -%"LLLL%" -%"LLLL%" -%"LLLL%" -%"LLLL%" -%"LLLL%" -%"LLLL%" -%"LLLL%" -%"LLLL%" -%"LLLL%" -%"LLLL%" -%"LLLL%")} {(READBITMAP)(16 16 -%"CLCL%" -%"O@O@%" -%"LCLC%" -%"@O@O%" -%"CLCL%" -%"O@O@%" -%"LCLC%" -%"@O@O%" -%"CLCL%" -%"O@O@%" -%"LCLC%" -%"@O@O%" -%"CLCL%" -%"O@O@%" -%"LCLC%" -%"@O@O%")} {(READBITMAP)(16 16 -%"LFGA%" -%"NCCH%" -%"GAIL%" -%"CHLN%" -%"ALFG%" -%"HNCC%" -%"LGAI%" -%"NCHL%" -%"GALF%" -%"CHNC%" -%"ILGA%" -%"LNCH%" -%"FGAL%" -%"CCHN%" -%"AILG%" -%"HLNC%")}) -") -(DECLARE%: DONTCOPY -(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE - -(RECORD HLS (HUE LIGHTNESS SATURATION)) - -(RECORD RGB (RED GREEN BLUE)) -) - -(* "END EXPORTED DEFINITIONS") - -) -(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - -(ADDTOVAR NLAMA ) - -(ADDTOVAR NLAML ) - -(ADDTOVAR LAMA UNIONREGIONS INTERSECTREGIONS) -) -(PUTPROPS ADISPLAY COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991 - 1993 1994 2021)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (12479 20536 (\BBTCURVEPT 12489 . 20534)) (20537 30595 (CREATETEXTUREFROMBITMAP 20547 . -22579) (PRINTBITMAP 22581 . 23910) (PRINT-BITMAPS-NICELY 23912 . 27929) (PRINTCURSOR 27931 . 28878) ( -\WRITEBITMAP 28880 . 30593)) (30638 33184 (\GETINTEGERPART 30648 . 32191) (\CONVERTTOFRACTION 32193 . -33182)) (33321 34207 (CURSORP 33331 . 33550) (CURSORBITMAP 33552 . 33598) (CreateCursorBitMap 33600 . -34205)) (38573 48435 (CARET 38583 . 40331) (\CARET.CREATE 40333 . 40511) (\CARET.DOWN 40513 . 41966) ( -\CARET.FLASH? 41968 . 43865) (\CARET.SHOW 43867 . 44623) (CARETRATE 44625 . 45283) (\CARET.FLASH.AGAIN - 45285 . 46560) (\CARET.FLASH.MULTIPLE 46562 . 47094) (\CARET.FLASH 47096 . 48433)) (48436 53536 ( -\MEDW.CARET.SHOW 48446 . 53534)) (53900 55731 (\AREAVISIBLE? 53910 . 54832) (\REGIONOVERLAPAREAP 54834 - . 55377) (\AREAINREGIONP 55379 . 55729)) (55780 71837 (CREATEREGION 55790 . 56126) (REGIONP 56128 . -56274) (INTERSECTREGIONS 56276 . 60099) (UNIONREGIONS 60101 . 63301) (REGIONSINTERSECTP 63303 . 63911) - (SUBREGIONP 63913 . 64558) (EXTENDREGION 64560 . 67780) (EXTENDREGIONBOTTOM 67782 . 68587) ( -EXTENDREGIONLEFT 68589 . 69292) (EXTENDREGIONRIGHT 69294 . 69931) (EXTENDREGIONTOP 69933 . 70559) ( -INSIDEP 70561 . 71329) (STRINGREGION 71331 . 71835)) (72082 78471 (\BRUSHBITMAP 72092 . 73816) ( -\GETBRUSH 73818 . 74129) (\GETBRUSHBBT 74131 . 76894) (\InitCurveBrushes 76896 . 78335) ( -\BrushFromWidth 78337 . 78469)) (78472 81537 (\MAKEBRUSH.DIAGONAL 78482 . 78762) ( -\MAKEBRUSH.HORIZONTAL 78764 . 79158) (\MAKEBRUSH.VERTICAL 79160 . 79472) (\MAKEBRUSH.SQUARE 79474 . -79751) (\MAKEBRUSH.ROUND 79753 . 81535)) (81538 82650 (INSTALLBRUSH 81548 . 82648)) (83051 87935 ( -\DRAWLINE.DISPLAY 83061 . 86650) (RELMOVETO 86652 . 87039) (MOVETOUPPERLEFT 87041 . 87933)) (87936 -111678 (\CLIPANDDRAWLINE 87946 . 94515) (\CLIPANDDRAWLINE1 94517 . 106387) (\CLIPCODE 106389 . 107763) - (\LEASTPTAT 107765 . 108363) (\GREATESTPTAT 108365 . 108993) (\DRAWLINE1 108995 . 110119) ( -\DRAWLINE.UFN 110121 . 111676)) (117836 164835 (\DRAWCIRCLE.DISPLAY 117846 . 126714) (\DRAWARC.DISPLAY - 126716 . 127006) (\DRAWARC.GENERIC 127008 . 127827) (\COMPUTE.ARC.POINTS 127829 . 130330) ( -\DRAWELLIPSE.DISPLAY 130332 . 145997) (\DRAWCURVE.DISPLAY 145999 . 148368) (\DRAWPOINT.DISPLAY 148370 - . 149455) (\DRAWPOLYGON.DISPLAY 149457 . 153399) (\LINEWITHBRUSH 153401 . 164833)) (164836 198066 ( -LOADPOLY 164846 . 165406) (PARAMETRICSPLINE 165408 . 175677) (\CURVE 175679 . 182223) (\CURVE2 182225 - . 194049) (\CURVEEND 194051 . 194549) (\CURVESLOPE 194551 . 197049) (\CURVESTART 197051 . 197375) ( -\FDIFS/FROM/DERIVS 197377 . 198064)) (208033 223185 (\FILLCIRCLE.DISPLAY 208043 . 219241) (\LINEBLT -219243 . 223183)) (223229 225285 (SCREENBITMAP 223239 . 223712) (BITMAPP 223714 . 223948) ( -BITMAPHEIGHT 223950 . 224326) (BITSPERPIXEL 224328 . 225283)) (225926 226919 (DSPFILL 225936 . 226619) - (INVERTW 226621 . 226917)) (226920 230721 (\DSPCOLOR.DISPLAY 226930 . 228223) (\DSPBACKCOLOR.DISPLAY -228225 . 229754) (DSPEOLFN 229756 . 230719)) (231162 235940 (DSPCLEOL 231172 . 232118) (DSPRUBOUTCHAR -232120 . 232558) (\DSPMOVELR 232560 . 235938)) (236070 237184 (\CURSOR.DEFPRINT 236080 . 237182)) ( -237596 246218 (TEXTUREOFCOLOR 237606 . 238868) (\PRIMARYTEXTURE 238870 . 239452) (\LEVELTEXTURE 239454 - . 239955) (INSURE.B&W.TEXTURE 239957 . 241350) (INSURE.RGB.COLOR 241352 . 242832) (\LOOKUPCOLORNAME -242834 . 243104) (RGBP 243106 . 243869) (HLSP 243871 . 244246) (HLSTORGB 244248 . 245388) (\HLSVALUEFN - 245390 . 246216))))) -STOP diff --git a/sources/ADISPLAY.LCOM b/sources/ADISPLAY.LCOM index 997d6bedd810af1e163589af0848b5122d74bffe..b01836efc417c0682410755f0705b1cfd9f7d359 100644 GIT binary patch delta 2154 zcmb7FOKcle6t!KeBq^~bj+KT$!^2Ig1QE+`ex9))^4K%>Og#3pJd=b-Mrn&9(j+A) zutBu)f^OK6MwA6&!$+b*DmGRY6s5CZ<1DgZ7w@}dk*ryiJHNyURH9zY+_~@0Ip?1H z{O0?I;Xj+ zTkS1MBoc8{zwrsc|JU0rj!*wDna`6o#Uq;IIDtm#oGO(IiZNpnG%&RwRShJ`no-fE zr5q_4JKKMazB7%|m8!C!k$GcA23P)N3Y|)`VjK-Tk1oiy)liFVU0Th4z*yi%?&e>m+vE9=D2m ztj{Wv=)t5_Y>?Q&#IR~h2@JP_PYLBfbeAI*iPp=<+g6!Gy2~Th8W}lm?~w>VY_HuT zF*`eI6&+?m*??|1Vxzj@=)nY70EIajE@zC0_(nAL$D41xaQ`PwMV_>tz3F2O4FxmT z?M9B;vDJ)Y`r_DY4>GQ2>VDr+-I>h&R^X8()fx0de_&@&m~ZU9q`sI8P3^?h&eip< z+L=&0lk43~Au>2`OExq`qTXyMORpDUG(|#nVZ>`N6X@w1LX}`PpO@_Hh~MBTXZWxTE4fo% zPv~I-rb=~{-SGMs4BG8;w|4%8O(9X=6*59%y`G#jMg87-HXWD}F^_6FU8_iCS*}Wr zMO`Z^NDwiqX}YcyBt0Qj3rJuw%4_ddk$`D8NC~1Buu0_pUsXjbs3uA=G%Aq=1&$0} zWZWV?#d-lJoUP_rx<|l*1@LX$HV9%<@9GqEaaWR`Z zD?J5b0Jd?8%Wz058}n5q;YtBZY)KV3wFLnqr79UPgA@Z*3rf{Q0?(p~q?IA!SX5Qu z_{~897EsMQjN#msP)g*^CU_C3{fdTN!VAgMjFWI$EM!ZFPx2l!Ckj3@2UB*LIcURY z=Gb%09Nj}?!*ci>4=XmnZeNRC!lrCFvEmkL=qBTswgvA)Arl$S9EE&c5St5m$nQ|dSJ2%gt09QjK-MV zyec8#Y@&(rVnF2JX;--E$?#ur_u{wTmH?h~S@J%4-}gT6^L_98`g3>a!{?!Qnm1e4 z4W(o&lB>u-u_*O$vz_7?js=#_GboP)3TCOr&RTb+)oehg4HU#*$jaKs|qJ_fJ%0_ByYw9k`B>$pi^Fk)iGZZ{sZ=UkTw|?B|pD#|+ zGzE?N1}=F~6v-BNDjEM5<^L#@$lltyHpwz^;P`AhhhTBJ-d<|9kF*s4jJ}Cr!?F4pwJgO#kv{wcwkB zd&J!Q9-eBXil~=IgDU!@A2qQTIanrWu=`7FkUN}FUmp-|rK~0h_tnT?FY+b~8jnV{ zzh%9?b~LOVQrh9I)no1OwsttPdMx7jQ9@sm#VbA-i_D@7f{ImBTnkW|2d`x4RmqfP zTbeg?QvrkoDC>`HKr9;oF2{ucr;;O1;6s2I@JMPO=h8)8EmmmLk|jq2j^)62kP%h! zz|-LQ73OtUE8257f=y?@Q!PuT{RG2tfkoMn?~IO+v3TRok>LlZo6ek#OA@B6&SU^^o?J6md4O91Ph2O`20Lw@<(*OVf diff --git a/sources/FILESETS b/sources/FILESETS index 3a7290e7..fcd8fe2e 100644 --- a/sources/FILESETS +++ b/sources/FILESETS @@ -1,10 +1,10 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "11-Sep-2022 20:08:31" {DSK}larry>medley>sources>FILESETS.;2 6394 +(FILECREATED "26-Feb-2023 11:25:24" {DSK}larry>il>medley>sources>FILESETS.;2 6410 :CHANGES-TO (VARS EXPORTFILES) - :PREVIOUS-DATE "17-Oct-2021 16:06:59" {DSK}larry>medley>sources>FILESETS.;1) + :PREVIOUS-DATE "11-Sep-2022 20:08:31" {DSK}larry>il>medley>sources>FILESETS.;1) (* ; " @@ -71,7 +71,7 @@ Copyright (c) 1981-1990, 1998, 2021 by Xerox Corporation. LLCHAR LLSTK PMAP LLGC ATBL FILEIO EXTERNALFORMAT LLARITH LLFLOAT FONT LLKEY LLDISPLAY ADISPLAY AINTERRUPT RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER IMAGEIO PROC XCCS PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS LLETHER PUP UFS - DTDECLARE)) + DTDECLARE BIGBITMAP)) (RPAQQ MAKEINITFILES (MAKEINIT MEM I-NEW)) diff --git a/sources/LOADUP-LISP b/sources/LOADUP-LISP index a6cacd14..a2f54a70 100644 --- a/sources/LOADUP-LISP +++ b/sources/LOADUP-LISP @@ -1,10 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) -(FILECREATED "12-Aug-2022 12:29:57" |{DSK}larry>medley>sources>LOADUP-LISP.;2| 5250 +(FILECREATED "27-Feb-2023 17:15:53" |{DSK}larry>il>medley>sources>LOADUP-LISP.;2| 5263 - :CHANGES-TO (VARS LOADUP-LISPCOMS) + :EDIT-BY "lmm" - :PREVIOUS-DATE "13-Jul-2022 14:10:00" |{DSK}larry>medley>sources>LOADUP-LISP.;1|) + :CHANGES-TO (FNS LOADUP-LISP) + + :PREVIOUS-DATE "12-Aug-2022 12:29:57" |{DSK}larry>il>medley>sources>LOADUP-LISP.;1|) (PRETTYCOMPRINT LOADUP-LISPCOMS) @@ -17,10 +19,9 @@ (DEFINEQ (LOADUP-LISP - (LAMBDA NIL (* \; "Edited 13-Jul-2022 14:09 by rmk") + (LAMBDA NIL (* \; "Edited 26-Feb-2023 12:17 by lmm") + (* \; "Edited 13-Jul-2022 14:09 by rmk") (* \; "Edited 4-Mar-2022 19:13 by larry") - (* \; "Edited 2-Mar-2022 16:31 by larry") - (* \; "Edited 28-Feb-2022 15:02 by larry") (* \; "Edited 29-Apr-2021 22:30 by rmk:") (SETQQ COMPILE.EXT LCOM) (MEDLEY-INIT-VARS) (* \; "should be set earlier") @@ -99,6 +100,10 @@ (LOADUP '(CMLSMARTARGS)) (LOADUP '(IMPLICIT-KEY-HASH CLOSURE-CACHE)) + (* |;;| " not sure what this depends on, so putting it here") + + (LOADUP '(BIGBITMAPS)) + (* |;;| "Already enabled, but this time fixes tables that weren't defined in the init") (PACKAGE-ENABLE) @@ -119,5 +124,5 @@ (GLOBALVARS MAKESYSFILENAME MEDLEY-INIT-VARS MEDLEYDIR SYSTEMINITVARS USERRECLST) ) (DECLARE\: DONTCOPY - (FILEMAP (NIL (631 5044 (LOADUP-LISP 641 . 5042))))) + (FILEMAP (NIL (654 5057 (LOADUP-LISP 664 . 5055))))) STOP diff --git a/sources/LOADUP-LISP.LCOM b/sources/LOADUP-LISP.LCOM index 79019e092fdbbe5b24c316425569692d12361ce8..8e01adf6921b2a5f9bc93bd2c7f74f25e296318e 100644 GIT binary patch delta 1058 zcmZ{i!D|yi6vjM(up9?~QZpqGWGEJ1$+1*L9WH(uNH?}zlrcJ~`(nwK6 zjP&MN8N7Qc2wucLpci`)!K>c9E8^XYFHPtK)IEHBy!V*jH#_gc%FmS-x2_YamAl&- z$q@r|TGI2SyrDuy-5K;B?Do1H80>)x%J8WZ)t=qBKj?SYd+q)GC+oXC@jY?zJQ-#| zC55R&^isZ9GKw#cRt^-e!JKBGd2STIaCdJAYPsooFg?Gzx~jsk(|*|PV0*fwpPXb8 zHLGOGuE*_=vzR+L^v}$HM@)`0nq&xhQZS&z9XHmj7AR`3-&dhzS6RKnBQ0(~rd*F; zDz12!SQ1WRdHH`=Z_j2S@g|WJ+sQ}shvB(1_#F)dOYMl8sn_CHQW4)$mk&&xfD^iw z<#8}`bbul6DisZDrCM}h=AZ=b+Q(8k>GPVcJ01S*Uz8M&~Q%fX{ zNF0$kB5_3Gh{O@ZIh(EzWCBALkt|#(@MJ&;ocRb$07!+*Ki4Kk%ayxE>E|0|VjGr=dL@dv~T3Vx!vD}K~#y$(8 zEEtrEx3gC$mTljQd=|zmtc)7@acS~ISTM1$WqTUmibED<6)+4c(&=j#z(8!q3Tw`0 z9p^AlCU$*}Hb+H}zH~<&=)H!7XwW>Tv h{j6L?{jCtx)rFC^7apU2U8tg}i!4FkcNXs^{s3615$yl~ delta 982 zcmZvZ&ubGw6vx@5Y3#NKJy?WN`&=j_=!TuyX`3vfPIjlwn%yMsZhu|W+OBOOO(ac_ zYNR(Wf(VN@@#3G*yIwqb(UW*8{snpyy!lLH2cefQ-+A-qeZIW;G4*lk)tv=Gb>7?7 zsX-|aYMF*bnFcv+v%U9dw;69iy9FBbpE_an+4Y_FUVNju(dir{ca@pLJgC}#?+uF- zEkdyWK_~ttvM1TXa2P2ZBe!Nj@l-E}WHGyEkWmWmkA@NrZY- z2Q|0CgAlwrca|Hv=Y|ct?uU7>8i81G>&v0;;6S9B`t4qGxF}{3!!isF)Uz1V$ymyn zghepHaRXsT^}rQ4QhB4KlQ7jAc^7Ps9(_(_l;k*l<rP2~#}n&7 zDFZt>&iHAwSV{_`uTu*w`8ql~&md>}Ug+~6;=vMrkU4i!8m=7+3=3 Date: Tue, 28 Feb 2023 06:50:17 -0800 Subject: [PATCH 2/3] remake ADISPLY --- sources/ADISPLAY | 4370 +++++++++++++++++++++++++++++++++++++++++ sources/ADISPLAY.LCOM | Bin 71761 -> 70835 bytes 2 files changed, 4370 insertions(+) diff --git a/sources/ADISPLAY b/sources/ADISPLAY index 5f25ddd2..2907ed81 100644 --- a/sources/ADISPLAY +++ b/sources/ADISPLAY @@ -1,3 +1,4373 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) + +(FILECREATED "28-Feb-2023 06:37:11" {DSK}larry>il>medley>sources>ADISPLAY.;2 238362 + + :EDIT-BY "lmm" + + :PREVIOUS-DATE "13-Jun-2021 14:03:35" {DSK}larry>il>medley>sources>ADISPLAY.;1) + + +(* ; " +Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation. +") + +(PRETTYCOMPRINT ADISPLAYCOMS) + +(RPAQQ ADISPLAYCOMS + [(COMS (* ; "COMPILE SUPPORT") + (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) + WINDOW))) + (P (MOVD? 'NILL 'BIGBITMAPP)) + (COMS (* ; "Interlisp-D dependent stuff.") + (EXPORT (RECORDS REGION BITMAP BITMAPWORD POSITION CURSOR MOUSEEVENT SCREENREGION + SCREENPOSITION)) + (SYSRECORDS PILOTBBT \DISPLAYDATA) + (CONSTANTS (BITSPERINTEGER 32)) + (FNS \BBTCURVEPT) + (FNS CREATETEXTUREFROMBITMAP PRINTBITMAP PRINT-BITMAPS-NICELY PRINTCURSOR \WRITEBITMAP) + (P (DEFPRINT 'BITMAP 'PRINT-BITMAPS-NICELY)) + (FNS \GETINTEGERPART \CONVERTTOFRACTION) + (CONSTANTS (INTEGERBITS 12))) + [COMS (* ; "cursor functions not on LLDISPLAY") + (FNS CURSORP CURSORBITMAP CreateCursorBitMap) + (EXPORT (MACROS CURSORBITMAP) + (CONSTANTS (HARDCURSORHEIGHT 16) + (HARDCURSORWIDTH 16)) + (DECLARE%: EVAL@COMPILE (ADDVARS (GLOBALVARS CursorBitMap] + (COMS * CARETCOMS) + (COMS (* ; "Region functions") + (FNS CREATEREGION REGIONP INTERSECTREGIONS UNIONREGIONS REGIONSINTERSECTP SUBREGIONP + EXTENDREGION EXTENDREGIONBOTTOM EXTENDREGIONLEFT EXTENDREGIONRIGHT EXTENDREGIONTOP + INSIDEP STRINGREGION)) + (COMS (* ; "line and spline drawing.") + (COMS (* ; "Brushes and brush initialization") + (GLOBALRESOURCES \BRUSHBBT) + (FNS \BRUSHBITMAP \GETBRUSH \GETBRUSHBBT \InitCurveBrushes \BrushFromWidth) + (FNS \MAKEBRUSH.DIAGONAL \MAKEBRUSH.HORIZONTAL \MAKEBRUSH.VERTICAL + \MAKEBRUSH.SQUARE \MAKEBRUSH.ROUND) + (FNS INSTALLBRUSH) + (VARS \BrushNames) + (INITVARS (KNOWN.BRUSHES NIL) + (\BrushAList NIL)) + (RECORDS BRUSHITEM) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\InitCurveBrushes))) + (DECLARE%: DONTCOPY (GLOBALVARS \BrushAList KNOWN.BRUSHES))) + (* ; "Lines") + (FNS \DRAWLINE.DISPLAY RELMOVETO MOVETOUPPERLEFT) + (FNS \CLIPANDDRAWLINE \CLIPANDDRAWLINE1 \CLIPCODE \LEASTPTAT \GREATESTPTAT \DRAWLINE1 + \DRAWLINE.UFN) + (DECLARE%: DONTCOPY (MACROS .DRAWLINEX. .DRAWLINEY.)) + (* ; "Curves") + (FNS \DRAWCIRCLE.DISPLAY \DRAWARC.DISPLAY \DRAWARC.GENERIC \COMPUTE.ARC.POINTS + \DRAWELLIPSE.DISPLAY \DRAWCURVE.DISPLAY \DRAWPOINT.DISPLAY \DRAWPOLYGON.DISPLAY + \LINEWITHBRUSH) + (FNS LOADPOLY PARAMETRICSPLINE \CURVE \CURVE2 \CURVEEND \CURVESLOPE \CURVESTART + \FDIFS/FROM/DERIVS) + (DECLARE%: DONTCOPY (* ; "Used by drawcurve") + (EXPORT (RECORDS POLYNOMIAL SPLINE))) + (DECLARE%: DONTCOPY (EXPORT (MACROS HALF \FILLCIRCLEBLT)) + (MACROS \CURVEPT .SETUP.FOR.\BBTCURVEPT. \CIRCLEPTS \CURVESMOOTH)) + (FNS \FILLCIRCLE.DISPLAY \LINEBLT)) + [COMS (* ; "making and copying bitmaps") + (FNS SCREENBITMAP BITMAPP BITMAPHEIGHT BITSPERPIXEL) + (EXPORT (FILEPKGCOMS BITMAPS CURSORS)) + (DECLARE%: EVAL@COMPILE (EXPORT (ADDVARS (GLOBALVARS SCREENHEIGHT SCREENWIDTH + ScreenBitMap] + [COMS (* ; + "Display stream functions that are not needed in the primitive system") + (FNS DSPFILL INVERTW) + (FNS \DSPCOLOR.DISPLAY \DSPBACKCOLOR.DISPLAY DSPEOLFN) + (EXPORT (CONSTANTS (BLACKSHADE 65535) + (WHITESHADE 0)) + (VARS (GRAYSHADE 43605)) + (ADDVARS (GLOBALVARS GRAYSHADE))) + (MACROS DSPRUBOUTCHAR) + (FNS DSPCLEOL DSPRUBOUTCHAR \DSPMOVELR) + (COMS (* ; "for cursor") + (BITMAPS \DefaultCursor) + (FNS \CURSOR.DEFPRINT) + [DECLARE%: DONTEVAL@LOAD DOCOPY (INITVARS (DEFAULTCURSOR (CURSORCREATE + \DefaultCursor + NIL 0 15))) + (P (COND ((NULL \CURRENTCURSOR) + (SETQ \CURRENTCURSOR DEFAULTCURSOR))) + (DEFPRINT 'CURSOR '\CURSOR.DEFPRINT] + (DECLARE%: DONTCOPY (GLOBALVARS DEFAULTCURSOR] + [COMS (* ; + "stuff to interpret colors as textures which is needed even in system that don't have color.") + (FNS TEXTUREOFCOLOR \PRIMARYTEXTURE \LEVELTEXTURE INSURE.B&W.TEXTURE INSURE.RGB.COLOR + \LOOKUPCOLORNAME RGBP HLSP HLSTORGB \HLSVALUEFN) + (VARS COLORNAMES) + (GLOBALVARS COLORNAMES) + (DECLARE%: DONTCOPY (GLOBALVARS BLACKSHADE16 DARKGRAY16 MEDIUMGRAY16 LIGHTGRAY16 + WHITESHADE16 REDTEXTURE GREENTEXTURE BLUETEXTURE)) + (UGLYVARS BLACKSHADE16 DARKGRAY16 MEDIUMGRAY16 LIGHTGRAY16 WHITESHADE16 REDTEXTURE + GREENTEXTURE BLUETEXTURE) + (DECLARE%: DONTCOPY (* ; "Used by drawcurve") + (EXPORT (RECORDS HLS RGB] + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) + (NLAML) + (LAMA UNIONREGIONS + INTERSECTREGIONS]) + + + +(* ; "COMPILE SUPPORT") + +(DECLARE%: EVAL@COMPILE DONTCOPY + +(FILESLOAD (LOADCOMP) + WINDOW) +) + +(MOVD? 'NILL 'BIGBITMAPP) + + + +(* ; "Interlisp-D dependent stuff.") + +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(RECORD REGION (LEFT BOTTOM WIDTH HEIGHT) + LEFT _ -16383 BOTTOM _ -16383 WIDTH _ 32767 HEIGHT _ 32767 + [ACCESSFNS ((TOP (IPLUS (fetch (REGION BOTTOM) of DATUM) + (fetch (REGION HEIGHT) of DATUM) + -1)) + (PTOP (IPLUS (fetch (REGION BOTTOM) of DATUM) + (fetch (REGION HEIGHT) of DATUM))) + (RIGHT (IPLUS (fetch (REGION LEFT) of DATUM) + (fetch (REGION WIDTH) of DATUM) + -1)) + (PRIGHT (IPLUS (fetch (REGION LEFT) of DATUM) + (fetch (REGION WIDTH) of DATUM] + [TYPE? (AND (EQLENGTH DATUM 4) + (EVERY DATUM (FUNCTION NUMBERP] + (SYSTEM)) + +(DATATYPE BITMAP ((BITMAPBASE POINTER) + (BITMAPRASTERWIDTH WORD) + (BITMAPHEIGHT WORD) + (BITMAPWIDTH WORD) + (BITMAPBITSPERPIXEL WORD)) + BITMAPBITSPERPIXEL _ 1 (BLOCKRECORD BITMAP ((BitMapHiLoc WORD) + (BitMapLoLoc WORD)) + (* ; "overlay initial pointer") + ) + (SYSTEM)) + +(BLOCKRECORD BITMAPWORD ((BITS WORD)) + (SYSTEM)) + +(RECORD POSITION (XCOORD . YCOORD) + [TYPE? (AND (LISTP DATUM) + (NUMBERP (CAR DATUM)) + (NUMBERP (CDR DATUM] + (SYSTEM)) + +(DATATYPE CURSOR (CUIMAGE CUMASK CUHOTSPOTX CUHOTSPOTY CUDATA) + [ACCESSFNS ((CUBITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) + of (fetch (CURSOR CUIMAGE) of DATUM] + (SYSTEM)) + +(RECORD MOUSEEVENT (MOUSEX MOUSEY MOUSEBUTTONS KEYBOARD MOUSETIME) + (SYSTEM)) + +(RECORD SCREENREGION (SCREEN . REGION) + (SUBRECORD REGION) + [TYPE? (AND (LISTP DATUM) + (type? SCREEN (CAR DATUM)) + (type? REGION (CDR DATUM] + (SYSTEM)) + +(RECORD SCREENPOSITION (SCREEN . POSITION) + (SUBRECORD POSITION) + [TYPE? (AND (LISTP DATUM) + (type? SCREEN (CAR DATUM)) + (type? POSITION (CDR DATUM] + (SYSTEM)) +) + +(/DECLAREDATATYPE 'BITMAP '(POINTER WORD WORD WORD WORD) + '((BITMAP 0 POINTER) + (BITMAP 2 (BITS . 15)) + (BITMAP 3 (BITS . 15)) + (BITMAP 4 (BITS . 15)) + (BITMAP 5 (BITS . 15))) + '6) + +(/DECLAREDATATYPE 'CURSOR '(POINTER POINTER POINTER POINTER POINTER) + '((CURSOR 0 POINTER) + (CURSOR 2 POINTER) + (CURSOR 4 POINTER) + (CURSOR 6 POINTER) + (CURSOR 8 POINTER)) + '10) + +(* "END EXPORTED DEFINITIONS") + +(ADDTOVAR SYSTEMRECLST + +(DATATYPE PILOTBBT ((PBTDESTLO WORD) + (PBTDESTHI WORD) + (PBTDESTBIT WORD) + (PBTDESTBPL SIGNEDWORD) + (PBTSOURCELO WORD) + (PBTSOURCEHI WORD) + (PBTSOURCEBIT WORD) + (PBTSOURCEBPL SIGNEDWORD) + (PBTWIDTH WORD) + (PBTHEIGHT WORD) + (PBTFLAGS WORD) + (NIL 5 WORD))) + +(DATATYPE \DISPLAYDATA + (DDXPOSITION DDYPOSITION DDXOFFSET DDYOFFSET DDDestination DDClippingRegion DDFONT + DDSlowPrintingCase DDWIDTHSCACHE DDOFFSETSCACHE DDCOLOR DDLINEFEED DDRightMargin + DDLeftMargin DDScroll DDOPERATION DDSOURCETYPE (DDClippingLeft WORD) + (DDClippingRight WORD) + (DDClippingBottom WORD) + (DDClippingTop WORD) + (NIL WORD) + (DDHELDFLG FLAG) + (XWINDOWHINT XPOINTER) + (DDPILOTBBT POINTER) + DDXSCALE DDYSCALE DDCHARIMAGEWIDTHS DDEOLFN DDPAGEFULLFN DDTexture DDMICAXPOS + DDMICAYPOS DDMICARIGHTMARGIN DDCHARSET (DDCHARSETASCENT WORD) + (DDCHARSETDESCENT WORD) + DDCHARHEIGHTDELTA + (DDSPACEWIDTH WORD))) +) +(DECLARE%: EVAL@COMPILE + +(RPAQQ BITSPERINTEGER 32) + + +(CONSTANTS (BITSPERINTEGER 32)) +) (DEFINEQ +(\BBTCURVEPT + [LAMBDA (X Y BBT LEFT BRUSHWIDTH LEFTMINUSBRUSH RIGHTPLUS1 NBITSRIGHTPLUS1 TOPMINUSBRUSH + DestinationBitMap BRUSHHEIGHT BOTTOMMINUSBRUSH TOP BRUSHBASE DESTINATIONBASE RASTERWIDTH + BRUSHRASTERWIDTH COLORBRUSHBASE NBITS DISPLAYDATA) + (* kbr%: "27-Aug-86 23:17") + + (* ;; "Called by \CURVEPT macro. Draws a brush point by bitblting BRUSHBM to point X,Y in DestinationBitMap. BBT is a BitBlt table where everything is already set except the source and destination addresses, width and height. In other words, only the easy stuff") + (* ; "set the width fields of the bbt") + [PROG (CLIPPEDTOP STY) + [COND + [(ILEQ Y TOPMINUSBRUSH) (* ; + "the top part of the brush is visible") + (SETQ CLIPPEDTOP (IPLUS Y BRUSHHEIGHT)) + (replace PBTSOURCE of BBT with BRUSHBASE) + (freplace 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] + (freplace PBTHEIGHT of BBT with (IDIFFERENCE (IMIN BRUSHHEIGHT (IDIFFERENCE Y + BOTTOMMINUSBRUSH + )) + STY] + (freplace 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") + [freplace PBTDESTBIT of BBT with (COND + ((EQ NBITS 4) + (LLSH LEFT 2)) + (T (LLSH LEFT 3] + (freplace PBTSOURCEBIT of BBT + with (IDIFFERENCE BRUSHWIDTH (freplace PBTWIDTH of BBT + with (COND + ((EQ NBITS 4) + (LLSH (IDIFFERENCE X + LEFTMINUSBRUSH) + 2)) + (T (LLSH (IDIFFERENCE X + LEFTMINUSBRUSH) + 3] + (T (* ; "left edge is visible") + [freplace PBTDESTBIT of BBT with (SETQ X (COND + ((EQ NBITS 4) + (LLSH X 2)) + (T (LLSH X 3] + (freplace PBTSOURCEBIT of BBT with 0) + (* ; + "set width to the amount that is visible") + (freplace PBTWIDTH of BBT with (IMIN BRUSHWIDTH (IDIFFERENCE + NBITSRIGHTPLUS1 X + ] + (* ; + "if color brush is used, the ground must be cleared before the brush is put in.") + (\SETPBTFUNCTION BBT (ffetch DDSOURCETYPE of DISPLAYDATA) + 'ERASE) + (\PILOTBITBLT BBT 0) (* ; + "reset the source to point to the color bitmap.") + [COND + ((ILEQ Y TOPMINUSBRUSH) (* ; + "the top part of the brush is visible") + (freplace PBTSOURCE of BBT with COLORBRUSHBASE)) + (T (* ; "only the bottom is visible") + (freplace PBTSOURCE of BBT with (\ADDBASE COLORBRUSHBASE (ITIMES BRUSHRASTERWIDTH + (IDIFFERENCE + Y TOPMINUSBRUSH] + (\SETPBTFUNCTION BBT (ffetch DDSOURCETYPE of DISPLAYDATA) + 'PAINT)) + (T (COND + [(ILESSP X LEFT) (* ; + "only the right part of the brush is visible") + (freplace PBTDESTBIT of BBT with LEFT) + (freplace PBTSOURCEBIT of BBT with (IDIFFERENCE BRUSHWIDTH (freplace PBTWIDTH + of BBT + with (IDIFFERENCE X + LEFTMINUSBRUSH + ] + (T (* ; "left edge is visible") + (freplace PBTDESTBIT of BBT with X) + (freplace PBTSOURCEBIT of BBT with 0) (* ; + "set width to the amount that is visible") + (freplace PBTWIDTH of BBT with (IMIN BRUSHWIDTH (IDIFFERENCE RIGHTPLUS1 X] + (\PILOTBITBLT BBT 0]) ) +(DEFINEQ + +(CREATETEXTUREFROMBITMAP + [LAMBDA (BITMAP) (* rrb "17-May-84 11:22") + + (* ;; "creates a texture object from the lower left corner of a bitmap") + + (OR (BITMAPP BITMAP) + (\ILLEGAL.ARG BITMAP)) + (PROG ((H (fetch BITMAPHEIGHT of BITMAP)) + (W (fetch BITMAPWIDTH of BITMAP)) + TEXTHEIGHT TEXTURE) + (COND + ((AND (OR (EQ W 2) + (EQ W 4)) + (OR (EQ H 2) + (EQ H 4))) (* ; + "small texture will match bitmap exactly so use integer representation.") + (SETQ TEXTURE 0) + [for X from 0 to 3 + do (for Y from 0 to 3 + do (COND + ([NOT (EQ 0 (BITMAPBIT BITMAP (IREMAINDER X W) + (IREMAINDER Y H] + (SETQ TEXTURE (LOGOR TEXTURE (\BITMASK (IPLUS (ITIMES (IDIFFERENCE + 3 Y) + 4) + X] + (RETURN TEXTURE)) + ((AND (EQ W 16) + (ILESSP H 17)) (* ; + "if it is already 16 by n n<=16, use it.") + (RETURN BITMAP)) + (T (* ; "make a 16 bit wide one.") + (SETQ TEXTURE (BITMAPCREATE 16 (IMIN H 16))) + (for X from 0 by W to 16 do (BITBLT BITMAP 0 0 TEXTURE X 0 W H 'INPUT 'REPLACE)) + (RETURN TEXTURE]) + +(PRINTBITMAP + [LAMBDA (BITMAP FILE) (* ; "Edited 1-Dec-86 16:24 by Pavel") + +(* ;;; "Writes a bitmap on a file such that READBITMAP will read it back in.") + + (DECLARE (LOCALVARS . T)) + (PROG ((BM BITMAP)) + (COND + ((type? BITMAP BITMAP)) + ([AND (LITATOM BITMAP) + (type? BITMAP (SETQ BM (EVALV BITMAP] (* ; + "Coerce litatoms for compatibility with original specification") + ) + (T (printout T "******** " BITMAP " is not a BITMAP." T) + (RETURN NIL))) + (printout FILE "(" .P2 (BITMAPWIDTH BM) + %, .P2 (BITMAPHEIGHT BM)) (* ; + "if the number of bits per pixel is not 1, write it out.") + (COND + ((NEQ (BITSPERPIXEL BM) + 1) + (SPACES 1 FILE) + (PRIN2 (BITSPERPIXEL BM) + FILE))) (* ; + "Enclose in list so that compile-copying works.") + (\WRITEBITMAP BM FILE) (* ; "Now write out contents.") + (PRIN1 ")" FILE]) + +(PRINT-BITMAPS-NICELY + [LAMBDA (BITMAP STREAM) (* ; "Edited 20-Mar-87 17:06 by jop") + +(* ;;; "The syntax for bitmaps is") + + (* ;; "#*(width height [bits-per-pixel])XXXXXX...") + +(* ;;; "where WIDTH and HEIGHT are the dimensions of the bitmap, BITS-PER-PIXEL can be omitted if it is equal to one, and the X's are single characters between @ and O (in ASCII), each representing four bits. There will be exactly (* (ceiling (* WIDTH BITS-PER-PIXEL) 16) 4) characters for each row of the bitmap and exactly HEIGHT rows. Note that there are no spaces allowed between the * and the (, between the ) and the first X, or anywhere inside the string of X's. Also, the character after the last X must not be of type OTHER.") + +(* ;;; "This function %"observes%" *print-length*: it truncates after printing *print-length* characters in the bitmap's representation.") + + (if (OR (NULL STREAM) + (NULL *PRINT-ARRAY*)) + then + (* ;; "Let it be printed in the normal way, with an address.") + + NIL + else + (* ;; "Print this bitmap in the preferred way.") + + (LET* ((WIDTH (BITMAPWIDTH BITMAP)) + (HEIGHT (BITMAPHEIGHT BITMAP)) + (BITS-PER-PIXEL (BITSPERPIXEL BITMAP)) + (BASE (fetch BITMAPBASE of BITMAP)) + (QUAD-CHARS-PER-ROW (FOLDHI (CL:* WIDTH BITS-PER-PIXEL) + 16)) + (CHARS-SO-FAR *PRINT-LENGTH*)) + (PRINTOUT STREAM "#*(" .P2 WIDTH " " .P2 HEIGHT) + (if (NEQ BITS-PER-PIXEL 1) + then (PRINTOUT STREAM " " .P2 BITS-PER-PIXEL)) + (PRINTOUT STREAM ")") + (PROG NIL + [CL:MACROLET [(ELIDE? NIL `(IF (AND CHARS-SO-FAR (EQ 0 (CL:DECF CHARS-SO-FAR)) + ) + THEN (PRINTOUT STREAM "...") + (GO OUT] + (CL:DOTIMES (ROW HEIGHT) + (CL:DOTIMES (QUAD QUAD-CHARS-PER-ROW) + (CL:WRITE-CHAR (CL:INT-CHAR (+ (LRSH (\GETBASEBYTE BASE 0) + 4) + (CL:CHAR-INT #\@))) + STREAM) + (ELIDE?) + (CL:WRITE-CHAR (CL:INT-CHAR (+ (LOGAND (\GETBASEBYTE BASE 0) + 15) + (CL:CHAR-INT #\@))) + STREAM) + (ELIDE?) + (CL:WRITE-CHAR (CL:INT-CHAR (+ (LRSH (\GETBASEBYTE BASE 1) + 4) + (CL:CHAR-INT #\@))) + STREAM) + (ELIDE?) + (CL:WRITE-CHAR (CL:INT-CHAR (+ (LOGAND (\GETBASEBYTE BASE 1) + 15) + (CL:CHAR-INT #\@))) + STREAM) + (ELIDE?) + (SETQ BASE (\ADDBASE BASE 1))))] + OUT (RETURN T]) + +(PRINTCURSOR + [LAMBDA (VAR) (* ; "Edited 2-Dec-86 14:15 by Pavel") + + (* ;; "Writes an expression that will define the cursor value of VAR") + + (PROG (CUR IMAGE MASK) + (COND + ([NOT (type? CURSOR (SETQ CUR (EVALV VAR 'PRINTCURSOR] + (printout T "******** " VAR " is not a CURSOR." T) + (RETURN NIL))) (* ; "write out defining form.") + (\CURSORBITSPERPIXEL CUR 1) + (SETQ IMAGE (fetch (CURSOR CUIMAGE) of CUR)) + (SETQ MASK (fetch (CURSOR CUMASK) of CUR)) + (PRINT `(RPAQ (\, VAR) + (CURSORCREATE ',IMAGE ',(AND (NOT (EQ IMAGE MASK)) + MASK) + ,(fetch (CURSOR CUHOTSPOTX) + of CUR) + ,(fetch (CURSOR CUHOTSPOTY) + of CUR)))]) + +(\WRITEBITMAP + [LAMBDA (BITMAP FILE) (* ; "Edited 1-Dec-86 16:24 by Pavel") + +(* ;;; "writes the contents of a bitmap onto the currently open output file.") + + (PROG (LIM (BASE (fetch BITMAPBASE of BITMAP)) + (OFD (GETSTREAM FILE 'OUTPUT)) + (W (fetch BITMAPRASTERWIDTH of BITMAP))) + (FRPTQ (fetch BITMAPHEIGHT of BITMAP) + (TERPRI FILE) + (\BOUT OFD (CHARCODE %")) + (SETQ LIM (\ADDBASE BASE W)) + (until (EQ BASE LIM) do (\BOUT OFD (IPLUS (SUB1 (CHARCODE A)) + (LRSH (\GETBASEBYTE BASE 0) + 4))) + (\BOUT OFD (IPLUS (SUB1 (CHARCODE A)) + (LOGAND (\GETBASEBYTE BASE 0) + 15))) + (\BOUT OFD (IPLUS (SUB1 (CHARCODE A)) + (LRSH (\GETBASEBYTE BASE 1) + 4))) + (\BOUT OFD (IPLUS (SUB1 (CHARCODE A)) + (LOGAND (\GETBASEBYTE BASE 1) + 15))) + (SETQ BASE (\ADDBASE BASE 1))) + (\BOUT OFD (CHARCODE %"]) +) + +(DEFPRINT 'BITMAP 'PRINT-BITMAPS-NICELY) +(DEFINEQ + +(\GETINTEGERPART + [LAMBDA (FRACT) (* JonL " 7-May-84 02:43") + + (* ;; "gets the integer part of a fixed point number. The integer part has INTEGERBITS worth of significant bits the leftmost of which is sign.") + + (PROG [HIPART (ROUNDER (COND + ([EQ 0 (LOGAND (fetch (FIXP HINUM) of FRACT) + (CONSTANT (LLSH 1 (IDIFFERENCE BITSPERWORD (ADD1 + INTEGERBITS + ] + 0) + (T 1] + + (* ;; "assumes that the number of significant bits --- INTEGERBITS --- is less than can fit in the high order of the two words allocated for the integer.") + + (RETURN (COND + ([IGREATERP [SETQ HIPART (LRSH (fetch (FIXP HINUM) of FRACT) + (CONSTANT (IDIFFERENCE BITSPERWORD INTEGERBITS] + (CONSTANT (EXPT 2 (SUB1 INTEGERBITS] + (* ; + "the sign bit is on, make it negative.") + (IDIFFERENCE (IDIFFERENCE HIPART (CONSTANT (EXPT 2 INTEGERBITS))) + ROUNDER)) + (T (IPLUS HIPART ROUNDER]) + +(\CONVERTTOFRACTION + [LAMBDA (FLOAT) (* rmk%: " 3-JUL-82 23:29") + + (* ;; "converts a floating point number into a fixed point number with INTEGERBITS worth of integer part. Always returns a large integer so that the box can be clobbered.") + + (PROG (RESULT BOX) + (RETURN (COND + ([SMALLP (SETQ RESULT (FIX (FTIMES FLOAT (CONSTANT (FLOAT (EXPT 2 + (IDIFFERENCE + BITSPERINTEGER + INTEGERBITS] + (* ; "clobber a created box.") + (PutUnboxed (SETQ BOX (CREATECELL \FIXP)) + RESULT) + BOX) + (T RESULT]) +) +(DECLARE%: EVAL@COMPILE + +(RPAQQ INTEGERBITS 12) + + +(CONSTANTS (INTEGERBITS 12)) +) + + + +(* ; "cursor functions not on LLDISPLAY") + +(DEFINEQ + +(CURSORP + [LAMBDA (X) (* kbr%: " 5-Jul-85 17:54") + (* ; "is X a cursor?") + (type? CURSOR 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 HARDCURSORHEIGHT 16) + +(RPAQQ HARDCURSORWIDTH 16) + + +(CONSTANTS (HARDCURSORHEIGHT 16) + (HARDCURSORWIDTH 16)) +) +(DECLARE%: EVAL@COMPILE + +(ADDTOVAR GLOBALVARS CursorBitMap) +) + +(* "END EXPORTED DEFINITIONS") + + +(RPAQQ CARETCOMS + ((BITMAPS \DefaultCaret) + (INITVARS (\CARET.UP NIL + + (* ;; "global. NIL if no caret showing, otherwise a CARET1 record with CURSOR, stream, x, y, and RATE (= off rate)") +) + (\CARET.DEFAULT NIL (* ; + "global = default caret to put up. An instance of CARET1 datatype") + ) + (\CARET.TIMER (SETUPTIMER 0) + (* ; "time for next caret action")) + (DEFAULTCARET (CURSORCREATE \DefaultCaret NIL 3 4)) + (DEFAULTCARETRATE 333 (* ; "default rate for flashing caret")) + (\CARET.ON.RATE DEFAULTCARETRATE) + (\CARET.OFF.RATE DEFAULTCARETRATE) + (\CARET.FORCED.OFF.RATE 0)) + (ADDVARS (\SYSTEMTIMERVARS \CARET.TIMER)) + (DECLARE%: DONTCOPY (RECORDS CARET1)) + (INITRECORDS CARET1) + (FNS CARET \CARET.CREATE \CARET.DOWN \CARET.FLASH? \CARET.SHOW CARETRATE \CARET.FLASH.AGAIN + \CARET.FLASH.MULTIPLE \CARET.FLASH) + (FNS \MEDW.CARET.SHOW) + (* ; "some declarations are on LLDISPLAY -- macro for \CHECKCARET and globalvar declaration for \CARET.UP") + (GLOBALVARS \CARET.DEFAULT \CARET.ON.RATE \CARET.OFF.RATE DEFAULTCARET \CARET.TIMER \CARET.UP + \CARET.FORCED.OFF.RATE) + (DECLARE%: DONTEVAL@LOAD DOCOPY (ADDVARS (TTYBACKGROUNDFNS \CARET.FLASH?))) + (FNS \AREAVISIBLE? \REGIONOVERLAPAREAP \AREAINREGIONP) + (P (CARET T)))) + +(RPAQQ \DefaultCaret #*(7 6)A@@@CH@@CH@@FL@@FL@@LF@@) + +(RPAQ? \CARET.UP NIL + (* ;; "global. NIL if no caret showing, otherwise a CARET1 record with CURSOR, stream, x, y, and RATE (= off rate)") +) + +(RPAQ? \CARET.DEFAULT NIL (* ; + "global = default caret to put up. An instance of CARET1 datatype") +) + +(RPAQ? \CARET.TIMER (SETUPTIMER 0) + (* ; "time for next caret action")) + +(RPAQ? DEFAULTCARET (CURSORCREATE \DefaultCaret NIL 3 4)) + +(RPAQ? DEFAULTCARETRATE 333 (* ; "default rate for flashing caret")) + +(RPAQ? \CARET.ON.RATE DEFAULTCARETRATE) + +(RPAQ? \CARET.OFF.RATE DEFAULTCARETRATE) + +(RPAQ? \CARET.FORCED.OFF.RATE 0) + +(ADDTOVAR \SYSTEMTIMERVARS \CARET.TIMER) +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RECORD CARET1 (* ; + "a record that describes a SHOWING caret") + (STREAM (* ; + "the stream the caret is showing in") + STREAMX (* ; + "the X position stream relative that it was shown at") + STREAMY (* ; + "the Y position stream relative that it was shown at") + CURSOR (* ; + "the cursor bitmap + x and y that this caret represents") + RATE (* ; "the 'down rate' for this caret, in ticks. After comes down (when \CARET.TIMER expires), \CARET.TIMER will be rescheduled to put something up. This is the rate to use") + (* ; + "NEXT for threading carets together") + . NEXT)) +) +) +(DEFINEQ + +(CARET + [LAMBDA (NEWCARET) (* kbr%: " 6-Jul-85 16:13") + (* ; + "changes the 'system default' caret") + (PROG1 (COND + (\CARET.DEFAULT (* ; + "merely stored as a 'cursor' record for simplicity") + (fetch (CARET1 CURSOR) of \CARET.DEFAULT)) + (T 'OFF)) + [COND + (NEWCARET (\CHECKCARET) + (CARETRATE (CARETRATE)) (* ; "make sure the caret rate is set") + (SETQ \CARET.DEFAULT (SELECTQ NEWCARET + (T (COND + ((EQ DEFAULTCARET 'OFF) + NIL) + ((CURSORP DEFAULTCARET) + (create CARET1 + CURSOR _ DEFAULTCARET)) + (T (ERROR "DEFAULTCARET is not a cursor" + DEFAULTCARET)))) + (OFF NIL) + (COND + ((CURSORP NEWCARET) + (create CARET1 + CURSOR _ NEWCARET)) + (T (LISPERROR "ILLEGAL ARG" NEWCARET])]) + +(\CARET.CREATE + [LAMBDA (CURSOR) (* jds "11-Jul-85 19:38") + (create CARET1 + CURSOR _ (OR CURSOR DEFAULTCARET]) + +(\CARET.DOWN + [LAMBDA (STREAM INTERVAL UNLESSOCCLUDED) (* lmm " 4-May-84 18:15") + + (* ;; "take caret down if it is up. If you take it down, reschedule to put it back up in INTERVAL (or 0) --- often called thru \CHECKCARET macro") + + (COND + (\CARET.UP (COND + ([OR (NULL STREAM) + (fetch (CARET1 NEXT) of \CARET.UP) + (EQ (fetch (CARET1 STREAM) of \CARET.UP) + (COND + ((type? WINDOW STREAM) + (fetch (WINDOW DSP) of STREAM)) + (T STREAM] + [while (UNINTERRUPTABLY + [COND + ((\CARET.SHOW \CARET.UP UNLESSOCCLUDED) + (* ; + "take caret down and set global state") + (replace (CARET1 STREAM) of \CARET.UP with NIL) + (SETQ \CARET.UP (fetch (CARET1 NEXT) of \CARET.UP])] + (SETUPTIMER (OR INTERVAL \CARET.FORCED.OFF.RATE) + \CARET.TIMER]) + +(\CARET.FLASH? + [LAMBDA (STREAM CARET ONRATE OFFRATE X Y) (* AJB "17-Jul-85 12:47") + +(* ;;; "Flashes the CARET at the ONRATE/OFFRATE at the X,Y position in the current TTY window. If CARET is NIL, uses \CARET.DEFAULT as the caret. Takes either a display stream or a textstream as the destination stream to flash the caret. The caret is not flashed on a shift-selection in a window") + + (COND + (\CARET.UP [COND + ((TIMEREXPIRED? \CARET.TIMER) + (\CARET.DOWN NIL (fetch (CARET1 RATE) of \CARET.UP) + (OR (KEYDOWNP 'LSHIFT) + (KEYDOWNP 'RSHIFT) + (KEYDOWNP 'COPY] + NIL) + ((AND (OR CARET (SETQ CARET \CARET.DEFAULT)) + (TIMEREXPIRED? \CARET.TIMER) + [OR [DISPLAYSTREAMP (OR STREAM (SETQ STREAM (TTYDISPLAYSTREAM] + (AND (IMAGESTREAMTYPEP STREAM 'TEXT) + (SETQ STREAM (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW) of (TEXTOBJ STREAM))) + 'DSP] + (\CARET.FLASH CARET STREAM OFFRATE (OR (KEYDOWNP 'LSHIFT) + (KEYDOWNP 'RSHIFT) + (KEYDOWNP 'COPY)) + X Y)) + + (* ;; "\CARET.DEFAULT is NIL if by default the caret is OFF --- the KEYDOWNP clause is a hack to detect whether we are doing a copy-select") + + (replace (CARET1 NEXT) of CARET with NIL) (* ; + "Since this function is displaying a new caret, destroy any chaining of multiple carets") + (SETUPTIMER (OR ONRATE \CARET.ON.RATE) + \CARET.TIMER) + T]) + +(\CARET.SHOW + [LAMBDA (CARET UNLESSOCCLUDED) (* ; "Edited 25-Feb-94 16:53 by sybalsky") + + (* ;; "GENERIC caret flasher.") + + (LET (DS) + (SETQ DS (fetch (CARET1 STREAM) of CARET)) + (WINDOWOP 'SCCARETFLASH (FETCH (WINDOW SCREEN) OF (FETCH (\DISPLAYDATA XWINDOWHINT) + OF (FETCH (STREAM IMAGEDATA) + OF DS))) + CARET UNLESSOCCLUDED]) + +(CARETRATE + [LAMBDA (ONRATE OFFRATE) (* lmm " 3-May-84 11:35") + + (* ;; "sets the default caret rate (s) to be ONRATE/OFFRATE in milliseconds") + + (PROG1 (COND + ((EQ \CARET.ON.RATE \CARET.OFF.RATE) + \CARET.ON.RATE) + (T (CONS \CARET.ON.RATE \CARET.OFF.RATE))) + [COND + ((OR ONRATE OFFRATE) + (SETUPTIMER 0 \CARET.TIMER) + (SETQ \CARET.ON.RATE (OR (FIXP ONRATE) + (FIX DEFAULTCARETRATE))) + (SETQ \CARET.OFF.RATE (OR (FIXP OFFRATE) + \CARET.ON.RATE])]) + +(\CARET.FLASH.AGAIN + [LAMBDA (CARET STREAM X Y) (* AJB "14-Aug-85 17:04") + (LET ((OCARET \CARET.UP)) + (COND + ([AND OCARET CARET (DISPLAYSTREAMP (OR STREAM (SETQ STREAM (TTYDISPLAYSTREAM] + (for (OC _ OCARET) by (fetch (CARET1 NEXT) of OC) + do (COND + [(NULL OC) + (RETURN (COND + ((\CARET.FLASH CARET STREAM (fetch (CARET1 RATE) of \CARET.UP) + (OR (KEYDOWNP 'LSHIFT) + (KEYDOWNP 'RSHIFT) + (KEYDOWNP 'COPY)) + X Y) (* ; "OK, showed this one") + (OR (EQ \CARET.UP CARET) + (SHOULDNT)) + (replace (CARET1 NEXT) of CARET with OCARET] + ((EQ OC CARET) (* ; "this CARET is already showing") + (RETURN]) + +(\CARET.FLASH.MULTIPLE + [LAMBDA (STREAMS CARETS ONRATE OFFRATE) (* AJB "14-Aug-85 17:10") + (* ; + "this is probably just a template for how to flash multiple carets") + (COND + ((\CARET.FLASH? (CAR STREAMS) + (CAR CARETS) + ONRATE OFFRATE) + (for STR in (CDR STREAMS) as CARET in (CDR CARETS) do (\CARET.FLASH.AGAIN CARET STR]) + +(\CARET.FLASH + [LAMBDA (CARET STREAM RATE UNLESSOCCLUDED X Y) (* kbr%: " 5-Jul-85 17:51") + (PROG (CURSOR ANSWER) + (SETQ CURSOR (fetch (CARET1 CURSOR) of CARET)) + (replace (CARET1 STREAM) of CARET with STREAM) + (replace (CARET1 STREAMX) of CARET with (IDIFFERENCE (OR X (DSPXPOSITION NIL STREAM)) + (fetch (CURSOR CUHOTSPOTX) of CURSOR))) + (replace (CARET1 STREAMY) of CARET with (IDIFFERENCE (OR Y (DSPYPOSITION NIL STREAM)) + (fetch (CURSOR CUHOTSPOTY) of CURSOR))) + (replace (CARET1 RATE) of CARET with (OR RATE \CARET.OFF.RATE)) + (UNINTERRUPTABLY + (COND + ((\CARET.SHOW CARET UNLESSOCCLUDED) + (SETQ \CARET.UP CARET) + (SETQ ANSWER T)))) + (RETURN ANSWER]) +) +(DEFINEQ + +(\MEDW.CARET.SHOW + [LAMBDA (SCREEN CARET UNLESSOCCLUDED) (* ; + "Edited 17-Jan-94 10:28 by sybalsky:mv:envos") + + (* ;; "MEDLEY-window-system specific version of \CARET.SHOW (vectored thru the screen). Flash the caret (by inverting its image). UNLESSOCCLUDED controls whether you bring the window to the top if the caret is under some other window.") + + (PROG (DS) + (SETQ DS (fetch (CARET1 STREAM) of CARET)) + (RETURN (PROG (DD CARETWIN CBMX CBMY CURSOR CARETBM CWX CWY CARETBMWIDTH CARETBMHEIGHT + CLIPREG CLIPVAR) + (SETQ DD (fetch (STREAM IMAGEDATA) of DS)) + (SETQ CARETWIN (WFROMDS DS)) + (SETQ CBMX 0) + (SETQ CBMY 0) + (SETQ CURSOR (fetch (CARET1 CURSOR) of CARET)) + (\CURSORBITSPERPIXEL CURSOR (BITSPERPIXEL (DSPDESTINATION NIL CARETWIN))) + (SETQ CARETBM (fetch (CURSOR CUIMAGE) of CURSOR)) + (SETQ CWX (fetch (CARET1 STREAMX) of CARET)) + (SETQ CWY (fetch (CARET1 STREAMY) of CARET)) + (SETQ CARETBMWIDTH (fetch (BITMAP BITMAPWIDTH) of CARETBM)) + (SETQ CARETBMHEIGHT (fetch (BITMAP BITMAPHEIGHT) of CARETBM)) + (* ; + "calculate how much to reduce the caret region by do to the clipping region of the window.") + (SETQ CLIPREG (fetch (\DISPLAYDATA DDClippingRegion) of DD)) + (COND + ((IGREATERP (SETQ CLIPVAR (fetch (REGION LEFT) of CLIPREG)) + CWX) + [SETQ CARETBMWIDTH (IDIFFERENCE CARETBMWIDTH (SETQ CBMX (IDIFFERENCE + CLIPVAR CWX] + (SETQ CWX CLIPVAR))) + (COND + ((IGREATERP CARETBMWIDTH (SETQ CLIPVAR (IDIFFERENCE + (IPLUS CLIPVAR (fetch (REGION + WIDTH) + of CLIPREG)) + CWX))) + (SETQ CARETBMWIDTH CLIPVAR))) + (COND + ((IGREATERP (SETQ CLIPVAR (fetch (REGION BOTTOM) of CLIPREG)) + CWY) + [SETQ CARETBMHEIGHT (IDIFFERENCE CARETBMHEIGHT (SETQ CBMY + (IDIFFERENCE CLIPVAR CWY] + (SETQ CWY CLIPVAR))) + (COND + ((IGREATERP CARETBMHEIGHT (SETQ CLIPVAR (IDIFFERENCE + (IPLUS CLIPVAR + (fetch (REGION HEIGHT) + of CLIPREG)) + CWY))) + (SETQ CARETBMHEIGHT CLIPVAR))) + + (* note the time of the next change. This must be done without creating boxes + because happens during keyboard wait.) + + (COND + ((OR (ILESSP CARETBMWIDTH 1) + (ILESSP CARETBMHEIGHT 1)) (* caret isn't within clipping region.) + (RETURN T))) (* convert the base of the caret + location to screen coordinates.) + (SETQ CWX (\DSPTRANSFORMX CWX DD)) + (SETQ CWY (\DSPTRANSFORMY CWY DD)) + + (* having only this section uninterruptable leaves open the possibility that the + window moves or the timer is wrong but these will only mess up the display and + are low frequency events.) + + (COND + [(AND (OPENWP CARETWIN) + (\AREAVISIBLE? CARETWIN CWX CWY (IPLUS CWX (SUB1 CARETBMWIDTH)) + (IPLUS CWY (SUB1 CARETBMHEIGHT] + (UNLESSOCCLUDED (RETURN)) + (T (TOTOPW CARETWIN))) + (BITBLT CARETBM CBMX CBMY (DSPDESTINATION NIL CARETWIN) + CWX CWY CARETBMWIDTH CARETBMHEIGHT 'INPUT 'INVERT) + (RETURN T]) +) + + + +(* ; +"some declarations are on LLDISPLAY -- macro for \CHECKCARET and globalvar declaration for \CARET.UP") + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \CARET.DEFAULT \CARET.ON.RATE \CARET.OFF.RATE DEFAULTCARET \CARET.TIMER \CARET.UP + \CARET.FORCED.OFF.RATE) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(ADDTOVAR TTYBACKGROUNDFNS \CARET.FLASH?) +) +(DEFINEQ + +(\AREAVISIBLE? + [LAMBDA (WIN LFT BTM RGHT TOP) (* kbr%: "18-Feb-86 18:05") + + (* ;; "is the area whose screen limits are LFT BTM RGHT and TOP eniretly visible within WIN,") + + (PROG (WPTR) + (SETQ WPTR (fetch (SCREEN SCTOPW) of (fetch (WINDOW SCREEN) of WIN))) + (COND + ((NOT (\AREAINREGIONP (fetch (WINDOW REG) of WIN) + LFT BTM RGHT TOP)) (* ; + "if the caret region isn't completely within the window, forget it.") + (RETURN))) + LP (COND + ((EQ WPTR WIN) + (RETURN T)) + ((\REGIONOVERLAPAREAP (fetch (WINDOW REG) of WPTR) + LFT BTM RGHT TOP) + (RETURN NIL)) + ((SETQ WPTR (fetch (WINDOW NEXTW) of WPTR)) + (GO LP]) + +(\REGIONOVERLAPAREAP + [LAMBDA (REG LFT BTM RGHT TOP) (* rrb "17-Feb-86 18:50") + + (* ;; + "is there any overlap between the region REG and the area defined by left bottom right and top?") + + (NOT (OR (IGREATERP (fetch (REGION LEFT) of REG) + RGHT) + (IGREATERP LFT (fetch (REGION RIGHT) of REG)) + (IGREATERP (fetch (REGION BOTTOM) of REG) + TOP) + (IGREATERP BTM (fetch (REGION TOP) of REG]) + +(\AREAINREGIONP + [LAMBDA (REGION LFT BTM RGHT TOP) (* rrb "14-OCT-83 15:32") + (AND (IGEQ LFT (fetch LEFT of REGION)) + (IGEQ BTM (fetch BOTTOM of REGION)) + (IGEQ (fetch PRIGHT of REGION) + RGHT) + (IGEQ (fetch PTOP of REGION) + TOP]) +) + +(CARET T) + + + +(* ; "Region functions") + +(DEFINEQ + +(CREATEREGION + [LAMBDA (LEFT BOTTOM WIDTH HEIGHT) (* rrb "17-JUN-83 08:56") + (* ; "creates a region structure.") + (create REGION + LEFT _ LEFT + BOTTOM _ BOTTOM + WIDTH _ WIDTH + HEIGHT _ HEIGHT]) + +(REGIONP + [LAMBDA (X) (* rrb "29-Jun-84 18:00") + (AND (type? REGION X) + X]) + +(INTERSECTREGIONS + [LAMBDA REGIONS (* kbr%: "24-Jan-86 18:30") + + (* ;; "returns the largest region that is contained in all of REGIONS") + + (COND + ((EQ REGIONS 0) + + (* ;; "this is documented as returning a very large region. This one covers the entire FIXP range so should work for many purposes. rrb") + + (create REGION + LEFT _ (SUB1 MIN.FIXP) + BOTTOM _ (SUB1 MIN.FIXP) + WIDTH _ (PLUS (TIMES 2 MAX.FIXP) + 4) + HEIGHT _ (PLUS (TIMES 2 MAX.FIXP) + 4))) + (T (PROG (REG LFT RGHT BTTM TP) + (SETQ REG (ARG REGIONS 1)) + (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 "30-Dec-85 17:07") + + (* ;; "returns the smallest region that encloses all of REGIONS") + + (COND + ((EQ 0 REGIONS) + NIL) + (T (PROG (REG LFT RGHT BTTM TP) + (SETQ REG (ARG REGIONS 1)) + (SETQ LFT (fetch (REGION LEFT) of REG)) + (SETQ RGHT (fetch (REGION PRIGHT) of REG)) + (SETQ BTTM (fetch (REGION BOTTOM) of REG)) + (SETQ TP (fetch (REGION PTOP) of REG)) + [for I from 2 thru REGIONS do (SETQ REG (ARG REGIONS I)) + [COND + ((LESSP (fetch (REGION LEFT) of REG) + LFT) + (SETQ LFT (fetch (REGION LEFT) of REG] + [COND + ((LESSP (fetch (REGION BOTTOM) of REG) + BTTM) + (SETQ BTTM (fetch (REGION BOTTOM) of REG] + [COND + ((GREATERP (fetch (REGION PRIGHT) of REG) + RGHT) + (SETQ RGHT (fetch (REGION PRIGHT) of REG] + (COND + ((GREATERP (fetch (REGION PTOP) of REG) + TP) + (SETQ TP (fetch (REGION PTOP) of REG] + (RETURN (create REGION + LEFT _ LFT + BOTTOM _ BTTM + WIDTH _ (DIFFERENCE RGHT LFT) + HEIGHT _ (DIFFERENCE 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 '(9 0 100 100) '(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 top") + (PROG ((OLDTOP (fetch (REGION TOP) of REG))) + [COND + ((ILESSP OLDTOP NEWTOP) + (replace (REGION HEIGHT) of REG with (IPLUS (fetch (REGION HEIGHT) of REG) + (IDIFFERENCE NEWTOP OLDTOP] + (RETURN REG]) + +(INSIDEP + [LAMBDA (REGION POSORX Y) (* rrb "18-May-84 21:04") + + (* ;; "returns T if the position X Y is inside the region REGION. If POSORX is a position, returns T if that position is inside of REGION") + + (COND + ((WINDOWP REGION) + (INSIDEP (DSPCLIPPINGREGION NIL REGION) + POSORX Y)) + (T (COND + ((AND (NUMBERP POSORX) + (NUMBERP Y)) + (INSIDE? REGION POSORX Y)) + ((POSITIONP POSORX) + (INSIDE? REGION (fetch (POSITION XCOORD) of POSORX) + (fetch (POSITION YCOORD) of POSORX))) + ((NUMBERP POSORX) + (\ILLEGAL.ARG Y)) + (T (\ILLEGAL.ARG POSORX]) + +(STRINGREGION + [LAMBDA (STR STREAM PRIN2FLG RDTBL) (* rmk%: "25-AUG-83 18:06") + + (* ;; "returns the region taken up by STR if it were printed at the current position of STREAM") + + (create REGION + LEFT _ (DSPXPOSITION NIL STREAM) + BOTTOM _ (IDIFFERENCE (DSPYPOSITION NIL STREAM) + (FONTPROP STREAM 'DESCENT)) + WIDTH _ (STRINGWIDTH STR STREAM PRIN2FLG RDTBL) + HEIGHT _ (FONTPROP STREAM 'HEIGHT]) +) + + + +(* ; "line and spline drawing.") + + + + +(* ; "Brushes and brush initialization") + +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +[PUTDEF '\BRUSHBBT 'RESOURCES '(NEW (create PILOTBBT] +) +) + +(/SETTOPVAL '\\BRUSHBBT.GLOBALRESOURCE NIL) +(DEFINEQ + +(\BRUSHBITMAP + [LAMBDA (BRUSHSHAPE BRUSHWIDTH) (* rrb " 9-Sep-86 16:30") + +(* ;;; "returns the bitmap for the brush of the shape and size. See comments on \InitCurveBrushes.") + + (DECLARE (GLOBALVARS \BrushAList)) + (LET [(BRUSHES&METHOD (CDR (OR (FASSOC BRUSHSHAPE \BrushAList) + (\ILLEGAL.ARG BRUSHSHAPE] + (COND + ((NOT (GREATERP BRUSHWIDTH 0)) + + (* ;; "if brush is 0 or negative, return an empty brush. Might want to error but this would require users to handle it.") + + (BITMAPCREATE 0 0)) + [(ILESSP BRUSHWIDTH 17) (* ; + "lowest 16 brushes are stored. FIX them so ELT works.") + (ELT (fetch (BRUSHITEM BRUSHARRAY) of BRUSHES&METHOD) + (COND + ((FIXP BRUSHWIDTH)) + ((GREATERP BRUSHWIDTH 1) + (FIXR BRUSHWIDTH)) + (T 1] + [(CDR (FASSOC BRUSHWIDTH (fetch (BRUSHITEM BRUSHCACHE) of BRUSHES&METHOD] + (T + (* ;; "cache the brush bitmap. This is done so that the brush creation methods don't have to be efficient.") + + (LET ((NEWBRUSHBM (APPLY* (fetch (BRUSHITEM CREATEMETHOD) of BRUSHES&METHOD) + BRUSHWIDTH))) + (replace (BRUSHITEM BRUSHCACHE) of BRUSHES&METHOD + with (CONS (CONS BRUSHWIDTH NEWBRUSHBM) + (fetch (BRUSHITEM BRUSHCACHE) of BRUSHES&METHOD))) + NEWBRUSHBM]) + +(\GETBRUSH + [LAMBDA (BRUSH) (* rrb " 9-Sep-86 16:30") + (COND + ((type? BITMAP BRUSH) + BRUSH) + [(LISTP BRUSH) + (\BRUSHBITMAP (CAR BRUSH) + (CAR (LISTP (CDR BRUSH] + (T (\BRUSHBITMAP 'ROUND (OR BRUSH 1]) + +(\GETBRUSHBBT + [LAMBDA (BRUSHBM DISPLAYDATA BBT) (* kbr%: "18-Aug-85 12:46") + + (* ;; "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 (BITMAP BITMAPHEIGHT) of BRUSHBM) + 1) + (EQ (ffetch (BITMAP 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 (PILOTBBT PBTDESTBPL) of BBT with (UNFOLD (fetch (BITMAP BITMAPRASTERWIDTH) + of (fetch (\DISPLAYDATA DDDestination + ) of DISPLAYDATA)) + BITSPERWORD)) + (freplace (PILOTBBT PBTSOURCEBPL) of BBT with (UNFOLD (ffetch (BITMAP BITMAPRASTERWIDTH) + of BRUSHBM) + BITSPERWORD)) + (freplace (PILOTBBT PBTFLAGS) of BBT with 0) + (freplace (PILOTBBT PBTDISJOINT) of BBT with T) + (\SETPBTFUNCTION BBT (ffetch (\DISPLAYDATA DDSOURCETYPE) of DISPLAYDATA) + (SELECTQ (ffetch (\DISPLAYDATA DDOPERATION) of DISPLAYDATA) + ((PAINT REPLACE) + 'PAINT) + ((INVERT ERASE) + 'ERASE) + (SHOULDNT))) + BBT]) + +(\InitCurveBrushes + [LAMBDA NIL (* ; "Edited 13-Oct-87 14:31 by jds") + + (* ;; "Set up the initial set of brush specs for curve drawing. \BrushAList is an association list from brush-shape-names to a spec which is an instance of the record BRUSHITEM.") + + (DECLARE (GLOBALVARS \BrushNames \BrushAList \SingleBitBitmap)) + (PROG (BARRAY CREATIONMETHOD) + (SETQ \SingleBitBitmap (BITMAPCREATE 1 1)) + (BITMAPBIT \SingleBitBitmap 0 0 1) + (for BRUSHNAME in \BrushNames do (SETQ BARRAY (ARRAY 16 'POINTER NIL 1)) + (SETQ CREATIONMETHOD (PACK* '\MAKEBRUSH. BRUSHNAME)) + (SETA BARRAY 1 \SingleBitBitmap) + (for SIZE from 2 to 16 + do (SETA BARRAY SIZE (APPLY* CREATIONMETHOD SIZE))) + (INSTALLBRUSH BRUSHNAME CREATIONMETHOD BARRAY]) + +(\BrushFromWidth + [LAMBDA (W) (* hdj " 5-Nov-84 16:47") + (LIST 'ROUND W]) +) +(DEFINEQ + +(\MAKEBRUSH.DIAGONAL + [LAMBDA (SIZE) (* kbr%: "18-Aug-85 12:51") + (PROG (BM) + (SETQ BM (BITMAPCREATE SIZE SIZE)) + (for X from 0 to (SUB1 SIZE) do (BITMAPBIT BM X X 1)) + (RETURN BM]) + +(\MAKEBRUSH.HORIZONTAL + [LAMBDA (SIZE) (* kbr%: "18-Aug-85 12:52") + +(* ;;; "create a brush that has a horizontal line across it halfway down") + + (PROG (BM) + (SETQ BM (BITMAPCREATE SIZE SIZE)) + (BITBLT NIL NIL NIL BM 0 (SUB1 (FOLDHI SIZE 2)) + NIL 1 'TEXTURE 'REPLACE BLACKSHADE) + (RETURN BM]) + +(\MAKEBRUSH.VERTICAL + [LAMBDA (SIZE) (* kbr%: "18-Aug-85 12:53") + (PROG (BM) + (SETQ BM (BITMAPCREATE SIZE SIZE)) + (BITBLT NIL NIL NIL BM (SUB1 (FOLDHI SIZE 2)) + 0 1 SIZE 'TEXTURE 'REPLACE BLACKSHADE) + (RETURN BM]) + +(\MAKEBRUSH.SQUARE + [LAMBDA (SIZE) (* kbr%: "18-Aug-85 13:07") + (PROG (BM) + (SETQ BM (BITMAPCREATE SIZE SIZE)) + (BITBLT NIL NIL NIL BM NIL NIL NIL NIL 'TEXTURE 'REPLACE BLACKSHADE) + (RETURN BM]) + +(\MAKEBRUSH.ROUND + [LAMBDA (SIZE) (* rrb "15-Sep-86 14:32") + (* ; + "special cased 8 so that it wouldn't have a width of 7. rrb") + (PROG (RADIUS BITMAP BASE) + (SETQ RADIUS (SUB1 (HALF SIZE))) + (SETQ BITMAP (BITMAPCREATE SIZE SIZE)) + (SETQ BASE (fetch (BITMAP BITMAPBASE) of BITMAP)) + (SELECTQ SIZE + (1 (\PUTBASE BASE 0 (MASK.1'S 15 1))) + (2 (\PUTBASE BASE 0 (MASK.1'S 14 2)) + (\PUTBASE BASE 1 (MASK.1'S 14 2))) + (3 (\PUTBASE BASE 0 (MASK.1'S 14 1)) + (\PUTBASE BASE 1 (MASK.1'S 13 3)) + (\PUTBASE BASE 2 (MASK.1'S 14 1))) + (4 (\PUTBASE BASE 0 (MASK.1'S 13 2)) + (\PUTBASE BASE 1 (MASK.1'S 12 4)) + (\PUTBASE BASE 2 (MASK.1'S 12 4)) + (\PUTBASE BASE 3 (MASK.1'S 13 2))) + (5 (\PUTBASE BASE 0 (MASK.1'S 13 1)) + (\PUTBASE BASE 1 (MASK.1'S 12 3)) + (\PUTBASE BASE 2 (MASK.1'S 11 5)) + (\PUTBASE BASE 3 (MASK.1'S 12 3)) + (\PUTBASE BASE 4 (MASK.1'S 13 1))) + (8 (\PUTBASE BASE 0 (MASK.1'S 10 4)) + (\PUTBASE BASE 1 (MASK.1'S 9 6)) + (\PUTBASE BASE 2 (MASK.1'S 8 8)) + (\PUTBASE BASE 3 (MASK.1'S 8 8)) + (\PUTBASE BASE 4 (MASK.1'S 8 8)) + (\PUTBASE BASE 5 (MASK.1'S 8 8)) + (\PUTBASE BASE 6 (MASK.1'S 9 6)) + (\PUTBASE BASE 7 (MASK.1'S 10 4))) + (FILLCIRCLE RADIUS RADIUS RADIUS BLACKSHADE (DSPCREATE BITMAP))) + (RETURN BITMAP]) +) +(DEFINEQ + +(INSTALLBRUSH + [LAMBDA (BRUSHNAME BRUSHFN BRUSHARRAY) (* kbr%: "18-Jan-86 15:27") + (DECLARE (GLOBALVARS \BrushAList)) + (PROG (OLDENTRY) + (SETQ OLDENTRY (FASSOC BRUSHNAME \BrushAList)) + (COND + (OLDENTRY (AND BRUSHARRAY (replace (BRUSHITEM BRUSHARRAY) of (CDR OLDENTRY) with + BRUSHARRAY + )) + (AND BRUSHFN (replace (BRUSHITEM CREATEMETHOD) of (CDR OLDENTRY) with BRUSHFN))) + (T [COND + ((AND BRUSHFN (NOT (ARRAYP BRUSHARRAY))) + (SETQ BRUSHARRAY (ARRAY 16 'POINTER NIL 1)) + (for X from 1 to 16 do (SETA BRUSHARRAY X (APPLY* BRUSHFN X] + (push \BrushAList (CONS BRUSHNAME (create BRUSHITEM + BRUSHARRAY _ BRUSHARRAY + CREATEMETHOD _ BRUSHFN))) + (push KNOWN.BRUSHES BRUSHNAME]) +) + +(RPAQQ \BrushNames (ROUND SQUARE DIAGONAL HORIZONTAL VERTICAL)) + +(RPAQ? KNOWN.BRUSHES NIL) + +(RPAQ? \BrushAList NIL) +(DECLARE%: EVAL@COMPILE + +(RECORD BRUSHITEM (BRUSHARRAY CREATEMETHOD . BRUSHCACHE)) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(\InitCurveBrushes) +) +(DECLARE%: DONTCOPY +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \BrushAList KNOWN.BRUSHES) +) +) + + + +(* ; "Lines") + +(DEFINEQ + +(\DRAWLINE.DISPLAY + [LAMBDA (DISPLAYSTREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING) + (* ; "Edited 13-Jun-2021 14:03 by rmk:") + + (* ;; "DISPLAYSTREAM is guaranteed to be a display-stream. Draws a line from x1,y1 to x2,y2 leaving the position at x2,y2") + + (* ;; "Added handling of brushes (I think, this is actually pretty tricky).") + + (DECLARE (LOCALVARS . T)) + (SELECTQ OPERATION + (NIL (ffetch DDOPERATION of (fetch IMAGEDATA of DISPLAYSTREAM))) + ((REPLACE PAINT INVERT ERASE) + OPERATION) + (\ILLEGAL.ARG OPERATION)) + (\INSURETOPWDS DISPLAYSTREAM) (* ; + "RMK: This was only in the no-dash case, oddly") + (IF (OR DASHING (BRUSHP WIDTH)) + THEN [LET ((BRUSH (INSURE.BRUSH WIDTH))) + (if COLOR + then (replace (BRUSH BRUSHCOLOR) of BRUSH with COLOR)) + (IF (BIGBITMAPP (ffetch DDDestination of (fetch IMAGEDATA of DISPLAYSTREAM))) + THEN (\DRAWLINE.BIGBM.DASH DISPLAYSTREAM X1 Y1 X2 Y2 BRUSH DASHING OPERATION) + ELSE (GLOBALRESOURCES \BRUSHBBT (\LINEWITHBRUSH X1 Y1 X2 Y2 BRUSH + (\GOOD.DASHLST DASHING BRUSH) + DISPLAYSTREAM \BRUSHBBT OPERATION] + ELSEIF (BIGBITMAPP (ffetch DDDestination of (fetch IMAGEDATA of DISPLAYSTREAM))) + THEN (\DRAWLINE.BIGBM.NODASH DISPLAYSTREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR) + ELSE (LET ((DD (fetch IMAGEDATA of DISPLAYSTREAM))) + (\CLIPANDDRAWLINE (\DSPTRANSFORMX (OR (FIXP X1) + (FIXR X1)) + DD) + (\DSPTRANSFORMY (OR (FIXP Y1) + (FIXR Y1)) + DD) + (\DSPTRANSFORMX (OR (FIXP X2) + (FIXR X2)) + DD) + (\DSPTRANSFORMY (OR (FIXP Y2) + (FIXR Y2)) + DD) + [COND + ((NULL WIDTH) + 1) + ((OR (FIXP WIDTH) + (FIXR WIDTH] + OPERATION + (ffetch DDDestination of DD) + (ffetch DDClippingLeft of DD) + (SUB1 (ffetch DDClippingRight of DD)) + (ffetch DDClippingBottom of DD) + (SUB1 (ffetch DDClippingTop of DD)) + DISPLAYSTREAM COLOR))) (* ; + "the generic case of MOVETO is used so that the hardcopy streams get handled as well.") + (MOVETO X2 Y2 DISPLAYSTREAM]) + +(RELMOVETO + [LAMBDA (DX DY STREAM) (* rmk%: "25-AUG-83 18:13") + (* ; "moves the position by a vector") + (DSPXPOSITION [IPLUS DX (DSPXPOSITION NIL (SETQ STREAM (\OUTSTREAMARG STREAM] + STREAM) + (DSPYPOSITION (IPLUS DY (DSPYPOSITION NIL STREAM)) + STREAM]) + +(MOVETOUPPERLEFT + [LAMBDA (STREAM REGION) (* hdj " 5-Jul-85 12:19") + + (* ;; "moves the current position to the upper left corner so that the first line of text will all appear.") + + (PROG [(ASCENT (FONTPROP (DSPFONT NIL STREAM) + 'ASCENT] + (COND + ((AND REGION (OR (type? REGION REGION) + (\ILLEGAL.ARG REGION))) + (MOVETO (fetch (REGION LEFT) of REGION) + (IDIFFERENCE (fetch (REGION PTOP) of REGION) + ASCENT) + STREAM)) + (T (MOVETO (DSPLEFTMARGIN NIL STREAM) + (IDIFFERENCE (fetch (REGION PTOP) of (DSPCLIPPINGREGION NIL STREAM)) + ASCENT) + STREAM))) + (RETURN STREAM]) +) +(DEFINEQ + +(\CLIPANDDRAWLINE + [LAMBDA (X1 Y1 X2 Y2 WIDTH OPERATION BITMAP LEFT RIGHT BOTTOM TOP DS COLOR) + (* ; "Edited 21-Aug-91 12:15 by jds") + + (* ;; "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 + ((NOT (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP) + 1)) (* ; + "make adjustments in case of color.") + (SETQ COLOR (COLORNUMBERP (OR COLOR (DSPCOLOR NIL DS)) + (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP))) + (* ; "(COND ((EQ OPERATION 'ERASE) ; treat erase as AND of background (SETQ COLOR (OPPOSITECOLOR COLOR (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)))))") + ) + (T (SETQ COLOR BLACKSHADE))) + (PROG NIL + (COND + [(EQ X1 X2) (* ; "special case of vertical line.") + [COND + ((IGREATERP WIDTH 2) + (COND + [(EQ Y1 Y2) + + (* ;; "special case. Since we don't know whether the guy is headed horizontally or vertically, put out a round brush This is a fairly infrequent case because I didn't get any bug reports on it in three years so efficiency is not a consideration.") + + (RETURN (.WHILE.TOP.DS. DS (\DRAWPOINT.DISPLAY (DSPDESTINATION NIL DS) + X1 Y1 (LIST 'ROUND WIDTH COLOR) + OPERATION] + (T (SETQ X1 (SETQ X2 (IDIFFERENCE X1 (LRSH (SUB1 WIDTH) + 1] + (PROG (MIN MAX) + (RETURN (COND + ([OR (IGREATERP X1 RIGHT) + (IGEQ LEFT (SETQ X2 (IPLUS X1 WIDTH))) + (IGREATERP (SETQ MIN (IMIN Y1 Y2)) + TOP) + (IGREATERP BOTTOM (SETQ MAX (IMAX Y1 Y2] + (* ; "outside clippingregion.") + NIL) + (T (.WHILE.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)) + '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) + '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) + (SETQ 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) + (SETQ 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) + (* JonL " 7-May-84 02:57") + + (* ;; "LEFT, RIGHT, BOTTOM, TOP are set to the boundaries of the clipping region") + + (* ;; "DS is passed so that window can be uninterruptably brought to top.") + + (PROG (DX DY YMOVEUP HALFDX HALFDY (BMRASTERWIDTH (fetch BITMAPRASTERWIDTH of BITMAP))) + (COND + ((IGREATERP X1 X2) (* ; + "switch points so DX is always positive.") + (SETQ HALFDX X1) + (SETQ X1 X2) + (SETQ X2 HALFDX) + (SETQ HALFDX Y1) + (SETQ Y1 Y2) + (SETQ Y2 HALFDX))) (* ; + "calculate differences and sign of Y movement.") + (SETQ HALFDX (LRSH (SETQ DX (IDIFFERENCE X2 X1)) + 1)) + (SETQ HALFDY (LRSH [SETQ DY (COND + ((IGREATERP Y2 Y1) + (SETQ YMOVEUP T) + (IDIFFERENCE Y2 Y1)) + (T (IDIFFERENCE Y1 Y2] + 1)) + (COND + ((AND (IGEQ X1 LEFT) + (IGEQ RIGHT X2) + [COND + (YMOVEUP (AND (IGEQ Y1 BOTTOM) + (IGEQ TOP Y2))) + (T (AND (IGEQ Y2 BOTTOM) + (IGEQ TOP Y1] + (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP) + 1)) (* ; + "line is completely visible, fast case.") + (.WHILE.TOP.DS. DS (\DRAWLINE1 X1 (SUB1 (\SFInvert BITMAP Y1)) + DX DY DX DY (COND + ((IGREATERP DX DY) + (* ; "X is the fastest mover.") + HALFDX) + (T (* ; "y is the fastest mover.") + HALFDY)) + (COND + (YMOVEUP (* ; + "y is moving in positive direction but bits are stored inversely") + (IMINUS BMRASTERWIDTH)) + (T BMRASTERWIDTH)) + OPERATION + (fetch BITMAPBASE of BITMAP) + BMRASTERWIDTH))) + (T + (PROG ((CX1 X1) + (CY1 Y1) + (CX2 X2) + (CY2 Y2) + (CA1 (\CLIPCODE X1 Y1 LEFT RIGHT TOP BOTTOM)) + (CA2 (\CLIPCODE X2 Y2 LEFT RIGHT TOP BOTTOM))) + (* ; + "save the original points for the clipping computation.") + (* ; + "determine the sectors in which the points fall.") + CLIPLP + [COND + ((NOT (EQ 0 (LOGAND CA1 CA2))) (* ; + "line is entirely out of clipping region") + (RETURN NIL)) + ((EQ 0 (IPLUS CA1 CA2)) (* ; "line is completely visible") + + (* ;; "\SFInvert has an off by one bug that everybody else in LLDISPLAY uses to save computation so SUB1 from what you would expect.") + (* ; "reuse the variable CA1") + (RETURN + (.WHILE.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 BMRASTERWIDTH)) + (T BMRASTERWIDTH)) + OPERATION + (fetch BITMAPBASE of BITMAP) + BMRASTERWIDTH)) + ((4 8) + (\DRAWCOLORLINE1 + CX1 + (SUB1 (\SFInvert BITMAP CY1)) + (IDIFFERENCE CX2 CX1) + (COND + (YMOVEUP (IDIFFERENCE CY2 CY1)) + (T (IDIFFERENCE CY1 CY2))) + DX DY (COND + ((IGREATERP DX DY) + (* ; "X is the fastest mover.") + (IREMAINDER (IPLUS (ITIMES DY (IDIFFERENCE CX1 X1)) + HALFDX) + DX)) + (T (* ; "y is the fastest mover.") + (IREMAINDER (IPLUS [ITIMES DX + (COND + (YMOVEUP (IDIFFERENCE + CY1 Y1)) + (T (IDIFFERENCE Y1 CY1] + HALFDY) + DY))) + (COND + (YMOVEUP (* ; + "y is moving in positive direction but bits are stored inversely") + (IMINUS BMRASTERWIDTH)) + (T BMRASTERWIDTH)) + OPERATION + (fetch BITMAPBASE of BITMAP) + BMRASTERWIDTH + (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP) + COLOR)) + (SHOULDNT] + [COND + ((NEQ CA1 0) + + (* ;; "now move point CX1 CY1 so that one of the coordinates is on one of the boundaries. Which boundary is done first was copied from BCPL.") + + (COND + ((IGREATERP CA1 7) (* ; "y1 less than bottom") + (* ; + "calculate the least X for which Y will be at bottom.") + [SETQ CX1 (IPLUS X1 (\LEASTPTAT DX DY (IDIFFERENCE BOTTOM Y1] + (SETQ CY1 BOTTOM)) + ((IGREATERP CA1 3) (* ; "y1 is greater than top") + [SETQ CX1 (IPLUS X1 (\LEASTPTAT DX DY (IDIFFERENCE Y1 TOP] + (SETQ CY1 TOP)) + (T (* ; "x1 is less than left") + [SETQ CY1 (COND + [YMOVEUP (IPLUS Y1 (\LEASTPTAT DY DX (IDIFFERENCE LEFT X1] + (T (IDIFFERENCE Y1 (\LEASTPTAT DY DX (IDIFFERENCE LEFT X1] + (SETQ CX1 LEFT))) + (SETQ CA1 (\CLIPCODE CX1 CY1 LEFT RIGHT TOP BOTTOM))) + (T (* ; + "now move point CX2 CY2 so that one of the coordinates is on one of the boundaries") + (COND + ((IGREATERP CA2 7) (* ; "y2 less than bottom") + [SETQ CX2 (IPLUS X1 (\GREATESTPTAT DX DY (IDIFFERENCE Y1 BOTTOM] + (SETQ CY2 BOTTOM)) + ((IGREATERP CA2 3) (* ; "y2 is greater than top") + [SETQ CX2 (IPLUS X1 (\GREATESTPTAT DX DY (IDIFFERENCE TOP Y1] + (SETQ CY2 TOP)) + (T (* ; "x2 is greater than right") + [SETQ CY2 (COND + [YMOVEUP (IPLUS Y1 (\GREATESTPTAT DY DX (IDIFFERENCE + RIGHT X1] + (T (IDIFFERENCE Y1 (\GREATESTPTAT DY DX (IDIFFERENCE + RIGHT X1] + (SETQ CX2 RIGHT))) + (SETQ CA2 (\CLIPCODE CX2 CY2 LEFT RIGHT TOP BOTTOM] + (GO CLIPLP]) + +(\CLIPCODE + [LAMBDA (X Y LEFT RIGHT TOP BOTTOM) (* rrb " 4-DEC-80 10:34") + + (* ;; "determines the sector code for a point wrt a region. Used to clip things quickly.") + + (* ;; "RIGHT and TOP are one past the region.") + + (COND + ((LESSP X LEFT) (* ; "falls to left of region") + (COND + ((GREATERP Y TOP) (* ; "left above") + 5) + ((LESSP Y BOTTOM) (* ; "left below") + 9) + (T (* ; "left inside") + 1))) + ((GREATERP X RIGHT) (* ; "right") + (COND + ((GREATERP Y TOP) (* ; "right above") + 6) + ((LESSP Y BOTTOM) (* ; "right below") + 10) + (T (* ; "right inside") + 2))) + ((GREATERP Y TOP) (* ; "inside top") + 4) + ((LESSP Y BOTTOM) (* ; "inside below") + 8) + (T (* ; "inside 0") + 0]) + +(\LEASTPTAT + [LAMBDA (DA DB THISB) (* rrb " 7-JAN-82 11:56") + + (* ;; "determines the smallest value in the dimension A that would give a B coordinate of THISB if a line were drawn from the point (0,0) with a slope of DA/DB.") + + (COND + ((IGREATERP DA DB) + (ADD1 (IQUOTIENT (IPLUS (IDIFFERENCE (ITIMES THISB DA) + (HALF DA)) + -1) + DB))) + (T (IQUOTIENT (IPLUS (ITIMES THISB DA) + (HALF DB)) + DB]) + +(\GREATESTPTAT + [LAMBDA (DA DB THISB) (* rrb " 7-JAN-82 14:24") + + (* ;; "determines the largest value in the dimension A that would give a B coordinate of THISB if a line were drawn from the point (0,0) with a slope of DA/DB.") + + (COND + ((IGREATERP DA DB) + (IQUOTIENT (IPLUS (IDIFFERENCE (ITIMES (ADD1 THISB) + DA) + (HALF DA)) + -1) + DB)) + (T (IQUOTIENT (IPLUS (ITIMES THISB DA) + (HALF DB)) + DB]) + +(\DRAWLINE1 + [LAMBDA (X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH) + (* mpl " 2-Jan-84 18:00") + + (* ;; "this was changed to interface with the opcode for line drawing. It probably be incorporated into the places it is called.") + + (* ;; "draws a line starting at X0,Y0 at a slope of DX/DY until reaching either XLIMIT or YLIMIT with an initial overflow bucket size of CDL in MODE. Arranged so that the clipping routines can determine what the exact location of the end point of the clipped line is wrt line drawing coordinates eg. amount in overflow bucket. XLIMIT and YLIMIT are the number of points to be moved in that direction.") + + (\DRAWLINE.UFN (\ADDBASE BITMAPBASE (IPLUS (ITIMES Y0 RASTERWIDTH) + (FOLDLO X0 BITSPERWORD))) + (LOGAND X0 15) + DX YINC DY (SELECTQ MODE + (INVERT 2) + (ERASE 1) + 0) + CDL + (ADD1 XLIMIT) + (ADD1 YLIMIT]) + +(\DRAWLINE.UFN + [LAMBDA (FIRSTADDR FIRSTBIT XDELTA YINCR YDELTA OPERATIONCODE INITIALBUCKET PIXELSINX PIXELSINY) + (* jds " 6-Jan-86 11:27") + + (* ;; "FIRSTADDR is the address of the word which contains the first point. FIRSTBIT is the address of the first bit in FIRSTADDR. XDELTA and YDELTA are how far the complete line has to move in X and Y respectively; both are positive quantities. YINCR is the amount the address should be incremented if the Y coordinate changes and can be either positive or negative. OPERATIONCODE is 0 for REPLACE, 1 for ERASE and 2 for INVERT. INITIALBUCKET is between 0 and the maximum of DX and DY and gives the starting amount of the bucket used to determine when to increment in the slower moving direction. PIXELSINX and PIXELSINY indicates how many pixels should be drawn in the X and Y direction.") + + (DECLARE (LOCALVARS . T)) + (PROG ((MASK (\BITMASK FIRSTBIT))) + (COND + [(IGEQ XDELTA YDELTA) (* ; "X is the fastest mover.") + (SELECTQ OPERATIONCODE + (0 (.DRAWLINEX. 'REPLACE/PAINT)) + (1 (.DRAWLINEX. 'ERASE)) + (.DRAWLINEX. 'INVERT] + (T (* ; "Y is the fastest mover.") + (SELECTQ OPERATIONCODE + (0 (.DRAWLINEY. 'REPLACE/PAINT)) + (1 (.DRAWLINEY. 'ERASE)) + (.DRAWLINEY. 'INVERT]) +) +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +(PUTPROPS .DRAWLINEX. MACRO [(MODE) + (bind (NY _ 0) for PT from 1 to PIXELSINX + do (* ; "main loop") + [replace (BITMAPWORD BITS) of FIRSTADDR + with (SELECTQ MODE + (INVERT (LOGXOR MASK (fetch (BITMAPWORD BITS) + of FIRSTADDR))) + (ERASE (LOGAND (LOGXOR MASK WORDMASK) + (fetch (BITMAPWORD BITS) of FIRSTADDR))) + (PROGN (* ; + "case is PAINT or REPLACE. Legality of OPERATION has been checked by \CLIPANDDRAWLINE1") + (LOGOR MASK (fetch (BITMAPWORD BITS) + of FIRSTADDR] + [COND + ([NOT (IGREATERP XDELTA (SETQ INITIALBUCKET (IPLUS + INITIALBUCKET + YDELTA] + (* ; "increment in the Y direction") + (COND + ((EQ (SETQ NY (ADD1 NY)) + PIXELSINY) + (RETURN))) + (SETQ INITIALBUCKET (IDIFFERENCE INITIALBUCKET XDELTA)) + (SETQ FIRSTADDR (\ADDBASE FIRSTADDR YINCR] + (SETQ MASK (LRSH MASK 1)) + (COND + ((EQ 0 MASK) (* ; "crossed word boundary") + (SETQ FIRSTADDR (\ADDBASE FIRSTADDR 1)) + (SETQ MASK 32768]) + +(PUTPROPS .DRAWLINEY. MACRO [(MODE) + (bind (NX _ 0) for PT from 1 to PIXELSINY + do (* ; "main loop") + [replace (BITMAPWORD BITS) of FIRSTADDR + with (SELECTQ MODE + (INVERT (LOGXOR MASK (fetch (BITMAPWORD BITS) + of FIRSTADDR))) + (ERASE (LOGAND (LOGXOR MASK WORDMASK) + (fetch (BITMAPWORD BITS) of FIRSTADDR))) + (PROGN (* ; + "case is PAINT or REPLACE. Legality of OPERATION has been checked by \CLIPANDDRAWLINE1") + (LOGOR MASK (fetch (BITMAPWORD BITS) + of FIRSTADDR] + [COND + ([NOT (IGREATERP YDELTA (SETQ INITIALBUCKET (IPLUS + INITIALBUCKET + XDELTA] + (COND + ((EQ (SETQ NX (ADD1 NX)) + PIXELSINX) + (RETURN))) + (SETQ INITIALBUCKET (IDIFFERENCE INITIALBUCKET YDELTA)) + (SETQ MASK (LRSH MASK 1)) + (COND + ((EQ 0 MASK) (* ; "crossed word boundary") + (SETQ FIRSTADDR (\ADDBASE FIRSTADDR 1)) + (SETQ MASK 32768] + (SETQ FIRSTADDR (\ADDBASE FIRSTADDR YINCR]) +) +) + + + +(* ; "Curves") + +(DEFINEQ + +(\DRAWCIRCLE.DISPLAY + [LAMBDA (DISPLAYSTREAM CENTERX CENTERY RADIUS BRUSH DASHING) + (* kbr%: "15-Feb-86 22:24") + + (* ;; + "\DRAWCIRCLE.DISPLAY extended for color. Color is specified by either BRUSH or the DSPCOLOR of DS.") + + (DECLARE (LOCALVARS . T)) + (COND + ((OR (NOT (NUMBERP RADIUS)) + (ILESSP (SETQ RADIUS (FIXR RADIUS)) + 0)) + (\ILLEGAL.ARG RADIUS)) + ((EQ RADIUS 0) (* ; "don't draw anything.") + NIL) + (DASHING (* ; + "draw it with the arc drawing code which does dashing. Slow but effective.") + + (* ;; "the CDR removes the first point to work around a bug in curve drawing when closed and first and last points the same. AR 4623.0") + + (DRAWCURVE (CDR (\COMPUTE.ARC.POINTS CENTERX CENTERY RADIUS 0 360)) + T BRUSH DASHING DISPLAYSTREAM)) + (T (GLOBALRESOURCE \BRUSHBBT + (PROG (X Y D DestinationBitMap LEFT RIGHTPLUS1 TOP BOTTOM BRUSHWIDTH BRUSHHEIGHT + LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE + BRUSHBASE RASTERWIDTH BRUSHRASTERWIDTH NBITSRIGHTPLUS1 OPERATION + HEIGHTMINUS1 CX CY BBT COLOR COLORBRUSHBASE NBITS DISPLAYDATA USERFN) + (SETQ X 0) + (SETQ Y RADIUS) + (SETQ D (ITIMES 2 (IDIFFERENCE 1 RADIUS))) + (SETQ BBT \BRUSHBBT) + (SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DISPLAYSTREAM)) + (SETQ USERFN (AND (LITATOM BRUSH) + BRUSH)) + + (* ;; "many of these variables are used by the macro for \CURVEPT that passes them to \BBTCURVEPT and .SETUP.FOR.\BBTCURVEPT. sets them up.") + + (COND + (USERFN (* ; + "if calling user fn, don't bother with set up and leave points in stream coordinates.") + (SETQ CX CENTERX) + (SETQ CY CENTERY)) + (T (.SETUP.FOR.\BBTCURVEPT.) + (SELECTQ NBITS + (1 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX (FOLDLO BRUSHWIDTH + 2)) + DISPLAYDATA))) + (4 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX + (FOLDLO (LRSH BRUSHWIDTH 2) + 2)) + DISPLAYDATA))) + (8 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX + (FOLDLO (LRSH BRUSHWIDTH 3) + 2)) + DISPLAYDATA))) + (24 (* ; "I doubt that this will be right.") + (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX + (FOLDLO (IQUOTIENT BRUSHWIDTH 24 + ) + 2)) + DISPLAYDATA))) + (SHOULDNT)) (* ; + "take into account the brush thickness.") + (SETQ CY (\DSPTRANSFORMY (IDIFFERENCE CENTERY (FOLDLO BRUSHHEIGHT 2)) + DISPLAYDATA)) + + (* ;; "Move the window to top while interruptable, but verify that it is still there uninterruptably with drawing points") + + (\INSURETOPWDS DISPLAYSTREAM))) + [COND + ((EQ RADIUS 1) (* ; "put a single brush down.") + (* ; + "draw the top and bottom most points.") + [COND + (USERFN (APPLY* USERFN CX CY DISPLAYSTREAM)) + (T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVEPT CX CY] + (RETURN)) + (T (* ; + "draw the top and bottom most points.") + (COND + (USERFN (APPLY* USERFN CX (IPLUS CY RADIUS) + DISPLAYSTREAM) + (APPLY* USERFN CX (IDIFFERENCE CY RADIUS) + DISPLAYSTREAM)) + (T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVEPT CX (IPLUS CY RADIUS)) + (\CURVEPT CX (IDIFFERENCE CY RADIUS] + LP (* ; + "(UNFOLD x 2) is used instead of (ITIMES x 2)") + [COND + [(IGREATERP 0 D) + (SETQ X (ADD1 X)) + (COND + ((IGREATERP (UNFOLD (IPLUS D Y) + 2) + 1) + (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y) + 2) + 4)) + (SETQ Y (SUB1 Y))) + (T (SETQ D (IPLUS D (UNFOLD X 2) + 1] + ((OR (EQ 0 D) + (IGREATERP X D)) + (SETQ X (ADD1 X)) + (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y) + 2) + 4)) + (SETQ Y (SUB1 Y))) + (T (SETQ D (IPLUS (IDIFFERENCE D (UNFOLD Y 2)) + 3)) + (SETQ Y (SUB1 Y] + (COND + [(EQ Y 0) + + (* ;; "left most and right most points are drawn specially so that they are not duplicated which leaves a hole in XOR mode.") + + (COND + (USERFN (APPLY* USERFN (IPLUS CX X) + CY DISPLAYSTREAM) + (APPLY* USERFN (IDIFFERENCE CX X) + CY DISPLAYSTREAM)) + (T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVEPT (IPLUS CX X) + CY) + (\CURVEPT (IDIFFERENCE CX X) + CY] + (T [COND + (USERFN (APPLY* USERFN (IPLUS CX X) + (IPLUS CY Y) + DISPLAYSTREAM) + (APPLY* USERFN (IDIFFERENCE CX X) + (IPLUS CY Y) + DISPLAYSTREAM) + (APPLY* USERFN (IPLUS CX X) + (IDIFFERENCE CY Y) + DISPLAYSTREAM) + (APPLY* USERFN (IDIFFERENCE CX X) + (IDIFFERENCE CY Y) + DISPLAYSTREAM)) + (T (.WHILE.TOP.DS. DISPLAYSTREAM (\CIRCLEPTS CX CY X Y] + (GO LP))) + (MOVETO CENTERX CENTERY DISPLAYSTREAM) + (RETURN NIL]) + +(\DRAWARC.DISPLAY + [LAMBDA (STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING) + (* ; "draws an arc on the display") + (\DRAWARC.GENERIC STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING]) + +(\DRAWARC.GENERIC + [LAMBDA (STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING) + (* rrb " 4-Oct-85 18:23") + (* ; "draws an arc by drawing a curve.") + (COND + ((AND (GREATERP 360 NDEGREES) + (LESSP -360 NDEGREES)) + (DRAWCURVE (\COMPUTE.ARC.POINTS CENTERX CENTERY RADIUS STARTANGLE NDEGREES) + NIL BRUSH DASHING STREAM)) + (T (* ; + "use circle drawing which could be faster") + (DRAWCIRCLE CENTERX CENTERY RADIUS BRUSH DASHING STREAM]) + +(\COMPUTE.ARC.POINTS + [LAMBDA (CENTERX CENTERY RADIUS STARTANGLE NDEGREES) (* DECLARATIONS%: FLOATING) + (* rrb "30-Oct-85 11:48") + + (* ;; "computes a list of knots that a spline goes through to make an arc") + + (PROG ((ANGLESIZE (COND + ((OR (GREATERP NDEGREES 360.0) + (GREATERP -360.0 NDEGREES)) + 360.0) + (T NDEGREES))) + ANGLEINCR) + + (* ;; "calculate an increment close to 10.0 that is exact but always have at least 5 knots and don't have more than a knot every 5 pts") + + [SETQ ANGLEINCR (FQUOTIENT ANGLESIZE + (IMIN (IMAX (ABS (FIX (FQUOTIENT ANGLESIZE 10.0))) + 5) + (PROGN (* ; + "don't have more than a knot every 5 pts") + (IMAX (ABS (FIX (QUOTIENT (TIMES RADIUS 6.3 + (QUOTIENT ANGLESIZE + 360.0)) + 4))) + 3] + + (* ;; "go from initial point to just past the last point. The just past (PLUS BETA (QUOTIENT ANGLEINCR 5.0)) picks up the case where the floating pt rounding error accumulates to be greater than the last point when it is very close to it.") + + (RETURN (for ANGLE from STARTANGLE to (PLUS STARTANGLE ANGLESIZE (QUOTIENT ANGLEINCR 5.0)) + by ANGLEINCR collect (create POSITION + XCOORD _ [FIXR (PLUS CENTERX (TIMES RADIUS + (COS ANGLE] + YCOORD _ (FIXR (PLUS CENTERY (TIMES RADIUS + (SIN ANGLE]) + +(\DRAWELLIPSE.DISPLAY + [LAMBDA (DISPLAYSTREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING) + (* ; "Edited 12-Apr-88 23:58 by FS") + (DECLARE (LOCALVARS . T)) + + (* ;; "Draws an ellipse. At ORIENTATION 0, the semimajor axis is horizontal, the semiminor axis vertical. Orientation is positive in the counterclockwise direction. The current location in the stream is left at the center of the ellipse.") + + (PROG ((CENTERX (FIXR CENTERX)) + (CENTERY (FIXR CENTERY)) + (SEMIMINORRADIUS (FIXR SEMIMINORRADIUS)) + (SEMIMAJORRADIUS (FIXR SEMIMAJORRADIUS))) + (COND + ((OR (EQ 0 SEMIMINORRADIUS) + (EQ 0 SEMIMAJORRADIUS)) + (MOVETO CENTERX CENTERY DISPLAYSTREAM) + (RETURN))) + (COND + ((ILESSP SEMIMINORRADIUS 1) + (\ILLEGAL.ARG SEMIMINORRADIUS)) + ((ILESSP SEMIMAJORRADIUS 1) + (\ILLEGAL.ARG SEMIMAJORRADIUS)) + ((OR (NULL ORIENTATION) + (EQ SEMIMINORRADIUS SEMIMAJORRADIUS)) + (SETQ ORIENTATION 0)) + ((NULL (NUMBERP ORIENTATION)) + (\ILLEGAL.ARG ORIENTATION))) + + (* ;; "If dashing, draw it with the curve drawing code which can do dashing") + + (COND + (DASHING (\DRAWELLIPSE.GENERIC DISPLAYSTREAM CENTERX CENTERY SEMIMINORRADIUS + SEMIMAJORRADIUS ORIENTATION BRUSH DASHING) + (RETURN))) + + (* ;; "If degenerate ellipse, attempt circumvention of Pitteway breakdown by trying spline code instead, which appears more numerically stable (see AR6502)") + + (COND + ((< 40 (/ SEMIMAJORRADIUS SEMIMINORRADIUS)) + (\DRAWELLIPSE.GENERIC DISPLAYSTREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS + ORIENTATION BRUSH DASHING) + (RETURN))) + +(* ;;; "This function is the implementation of the algorithm given in 'Algorithm for drawing ellipses or hyperbolae with a digital plotter' by Pitteway appearing in Computer Journal 10: (3) Nov 1967.0 The input parameters are used to determine the ellipse equation (1/8) Ayy+ (1/8) Bxx+ (1/4) Gxy+ (1/4) Ux+ (1/4) Vy= (1/4) K which specifies a translated version of the desired ellipse. This ellipse passes through the mesh point (0,0), the initial point of the algorithm. The power of 2 factors reflect an implementation convenience.") + + (GLOBALRESOURCE \BRUSHBBT + (PROG (DestinationBitMap LEFT RIGHTPLUS1 BOTTOM TOP BOTTOMMINUSBRUSH TOPMINUSBRUSH + LEFTMINUSBRUSH DESTINATIONBASE BRUSHBASE BRUSHHEIGHT BRUSHWIDTH + RASTERWIDTH BRUSHRASTERWIDTH BRUSHBM OPERATION HEIGHTMINUS1 + (BBT \BRUSHBBT) + (cosOrientation (COS ORIENTATION)) + (sinOrientation (SIN ORIENTATION)) + (SEMIMINORRADIUSSQUARED (ITIMES SEMIMINORRADIUS SEMIMINORRADIUS)) + (SEMIMAJORRADIUSSQUARED (ITIMES SEMIMAJORRADIUS SEMIMAJORRADIUS)) + (x 0) + (y 0) + (x2 1) + x1 y1 y2 k1 k2 k3 a b d w A B G U V K CX CY yOffset CYPlusOffset + CYMinusOffset NBITSRIGHTPLUS1 COLORBRUSHBASE COLOR NBITS + (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM)) + (USERFN (AND (LITATOM BRUSH) + BRUSH))) + + (* ;; "many of these variables are used by the macro for \CURVEPT that passes them to \BBTCURVEPT and .SETUP.FOR.\BBTCURVEPT. sets them up.") + + (COND + (USERFN (* ; + "if calling user fn, don't bother with set up and leave points in window coordinates.") + (SETQ CX CENTERX) + (SETQ CY CENTERY)) + (T (.SETUP.FOR.\BBTCURVEPT.) (* ; + "take into account the brush thickness.") + (SELECTQ NBITS + (1 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX (FOLDLO BRUSHWIDTH + 2)) + DISPLAYDATA))) + (4 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX + (FOLDLO (LRSH BRUSHWIDTH 2) + 2)) + DISPLAYDATA))) + (8 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX + (FOLDLO (LRSH BRUSHWIDTH 3) + 2)) + DISPLAYDATA))) + (SHOULDNT)) + (SETQ CY (\DSPTRANSFORMY (IDIFFERENCE CENTERY (FOLDLO BRUSHHEIGHT 2)) + DISPLAYDATA)) + + (* ;; "Move the window to top while interruptable, but verify that it is still there uninterruptably with drawing points") + + (\INSURETOPWDS DISPLAYSTREAM))) + (SETQ A (FPLUS (FTIMES SEMIMAJORRADIUSSQUARED cosOrientation cosOrientation) + (FTIMES SEMIMINORRADIUSSQUARED sinOrientation sinOrientation))) + (SETQ B (LSH (FIXR (FPLUS (FTIMES SEMIMINORRADIUSSQUARED cosOrientation + cosOrientation) + (FTIMES SEMIMAJORRADIUSSQUARED sinOrientation + sinOrientation))) + 3)) + (SETQ G (FTIMES cosOrientation sinOrientation (LSH (IDIFFERENCE + SEMIMINORRADIUSSQUARED + + SEMIMAJORRADIUSSQUARED + ) + 1))) + [SETQ yOffset (FIXR (FQUOTIENT (ITIMES SEMIMINORRADIUS SEMIMAJORRADIUS) + (SQRT A] + (SETQ CYPlusOffset (IPLUS CY yOffset)) + (SETQ CYMinusOffset (IDIFFERENCE CY yOffset)) + (SETQ U (LSH (FIXR (FTIMES A (LSH yOffset 1))) + 2)) + (SETQ V (LSH (FIXR (FTIMES G yOffset)) + 2)) + (SETQ K (LSH [FIXR (FDIFFERENCE (ITIMES SEMIMINORRADIUSSQUARED + SEMIMAJORRADIUSSQUARED) + (FTIMES A (ITIMES yOffset yOffset] + 2)) + (SETQ A (LSH (FIXR A) + 3)) + (SETQ G (LSH (FIXR G) + 2)) + + (* ;; "The algorithm is incremental and iterates through the octants of a cartesian plane. The octants are labeled from 1 through 8 beginning above the positive X axis and proceeding counterclockwise. Decisions in making the incremental steps are determined according to the error term d which is updated according to the curvature terms a and b. k1, k2, and k3 are used to correct the error and curvature terms at octant boundaries. The initial values of these terms depends on the octant in which drawing begins. The initial move steps (x1,y1) and (x2,y2) also depend on the starting octant.") + + [COND + [(ILESSP (ABS U) + (ABS V)) + (SETQ x1 0) + (COND + [(MINUSP V) (* ; "start in octant 2") + (SETQ y1 1) + (SETQ y2 1) + (SETQ k1 (IMINUS A)) + (SETQ k2 (IDIFFERENCE k1 G)) + (SETQ k3 (IDIFFERENCE k2 (IPLUS B G))) + (SETQ b (IPLUS U (RSH (IPLUS A G) + 1))) + (SETQ a (IMINUS (IPLUS b V))) + (SETQ d (IPLUS b (RSH B 3) + (RSH V 1) + (IMINUS K] + (T (* ; "start in octant 7") + (SETQ y1 -1) + (SETQ y2 -1) + (SETQ k1 A) + (SETQ k2 (IDIFFERENCE k1 G)) + (SETQ k3 (IPLUS k2 B (IMINUS G))) + (SETQ b (IPLUS U (RSH (IDIFFERENCE G A) + 1))) + (SETQ a (IDIFFERENCE V b)) + (SETQ d (IPLUS b K (IMINUS (IPLUS (RSH V 1) + (RSH B 3] + (T (SETQ x1 1) + (SETQ y1 0) + (COND + [(MINUSP V) (* ; "start in octant 1") + (SETQ y2 1) + (SETQ k1 B) + (SETQ k2 (IPLUS k1 G)) + (SETQ k3 (IPLUS k2 A G)) + [SETQ b (IMINUS (IPLUS V (RSH (IPLUS B G) + 1] + (SETQ a (IDIFFERENCE U b)) + (SETQ d (IPLUS b K (IMINUS (IPLUS (RSH A 3) + (RSH U 1] + (T (* ; "start in octant 8") + (SETQ y2 -1) + (SETQ k1 (IMINUS B)) + (SETQ k2 (IPLUS k1 G)) + (SETQ k3 (IPLUS k2 G (IMINUS A))) + (SETQ b (IPLUS V (RSH (IDIFFERENCE B G) + 1))) + (SETQ a (IDIFFERENCE U b)) + (SETQ d (IPLUS b (RSH A 3) + (IMINUS (IPLUS K (RSH U 1] + + (* ;; "The ellipse equation describes an ellipse of the desired size and ORIENTATION centered at (0,0) and then dropped yOffset mesh points so that it will pass through (0,0). Thus, the intended starting point is (CX, CY+yOffset) where (CX, CY) is the center of the desired ellipse. Drawing is accomplished with point relative steps. In each octant, the error term d is used to choose between move 1 (an axis move) and move 2 (a diagonal move).") + + MOVE + [COND + ((MINUSP d) (* ; "move 1") + (SETQ x (IPLUS x x1)) + (SETQ y (IPLUS y y1)) + (SETQ b (IDIFFERENCE b k1)) + (SETQ a (IPLUS a k2)) + (SETQ d (IPLUS b d))) + (T (* ; "move 2") + (SETQ x (IPLUS x x2)) + (SETQ y (IPLUS y y2)) + (SETQ b (IDIFFERENCE b k2)) + (SETQ a (IPLUS a k3)) + (SETQ d (IDIFFERENCE d a] + (COND + ((MINUSP x) + (MOVETO CENTERX CENTERY DISPLAYSTREAM) + (RETURN NIL))) + [COND + (USERFN (APPLY* USERFN (IPLUS CX x) + (IPLUS CYPlusOffset y) + DISPLAYSTREAM) + (APPLY* USERFN (IDIFFERENCE CX x) + (IDIFFERENCE CYMinusOffset y) + DISPLAYSTREAM)) + (T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVEPT (IPLUS CX x) + (IPLUS CYPlusOffset y)) + (\CURVEPT (IDIFFERENCE CX x) + (IDIFFERENCE CYMinusOffset y] + (AND (MINUSP b) + (GO SQUARE)) + DIAGONAL + (OR (MINUSP a) + (GO MOVE)) (* ; "diagonal octant change") + (SETQ x1 (IDIFFERENCE x2 x1)) + (SETQ y1 (IDIFFERENCE y2 y1)) + (SETQ w (IDIFFERENCE (LSH k2 1) + k3)) + (SETQ k1 (IDIFFERENCE w k1)) + (SETQ k2 (IDIFFERENCE k2 k3)) + (SETQ k3 (IMINUS k3)) + [SETQ b (IPLUS b a (IMINUS (RSH (ADD1 k2) + 1] + [SETQ d (IPLUS b (RSH (IPLUS k3 4) + 3) + (IMINUS d) + (IMINUS (RSH (ADD1 a) + 1] + (SETQ a (IDIFFERENCE (RSH (ADD1 w) + 1) + a)) + (OR (MINUSP b) + (GO MOVE)) + SQUARE + (* ; "square octant change") + [COND + ((EQ 0 x1) + (SETQ x2 (IMINUS x2))) + (T (SETQ y2 (IMINUS y2] + (SETQ w (IDIFFERENCE k2 k1)) + (SETQ k1 (IMINUS k1)) + (SETQ k2 (IPLUS w k1)) + (SETQ k3 (IDIFFERENCE (LSH w 2) + k3)) + (SETQ b (IDIFFERENCE (IMINUS b) + w)) + (SETQ d (IDIFFERENCE (IDIFFERENCE b a) + d)) + (SETQ a (IDIFFERENCE (IDIFFERENCE a w) + (LSH b 1))) + (GO DIAGONAL]) + +(\DRAWCURVE.DISPLAY + [LAMBDA (DISPLAYSTREAM KNOTS CLOSED BRUSH DASHING) (* ; "Edited 9-Jan-87 16:49 by rrb") + + (* ;; "draws a spline curve with a given brush.") + + (GLOBALRESOURCE \BRUSHBBT (PROG ((BBT \BRUSHBBT) + (DASHLST (\GOOD.DASHLST DASHING BRUSH))) + (SELECTQ (LENGTH KNOTS) + (0 (* ; + "No knots => empty curve rather than error?") + NIL) + (1 (* ; + "only one knot, put down a brush shape") + (OR (type? POSITION (CAR KNOTS)) + (ERROR "bad knot" (CAR KNOTS))) + (\DRAWPOINT.DISPLAY DISPLAYSTREAM (fetch XCOORD + of (CAR KNOTS)) + (fetch YCOORD of (CAR KNOTS)) + BRUSH)) + (2 (OR (type? POSITION (CAR KNOTS)) + (ERROR "bad knot" (CAR KNOTS))) + (OR (type? POSITION (CADR KNOTS)) + (ERROR "bad knot" (CADR KNOTS))) + (\LINEWITHBRUSH (fetch XCOORD of (CAR KNOTS)) + (fetch YCOORD of (CAR KNOTS)) + (fetch XCOORD of (CADR KNOTS)) + (fetch YCOORD of (CADR KNOTS)) + BRUSH DASHLST DISPLAYSTREAM BBT)) + (\CURVE2 (PARAMETRICSPLINE KNOTS CLOSED) + BRUSH DASHLST BBT DISPLAYSTREAM)) + (RETURN DISPLAYSTREAM]) + +(\DRAWPOINT.DISPLAY + [LAMBDA (DISPLAYSTREAM X Y BRUSH OPERATION) (* rrb "17-Sep-86 17:51") + + (* ;; "draws a brush point at position X Y") + + (* ;; "this is used in 4, 8, and 24 bit per pixel bitmaps as well. For these, it may be should call BITMAPWIDTH instead of fetching.") + + (PROG ((BRUSHBM (\GETBRUSH BRUSH))) (* ; + "SUB1 is to put extra bit of even brush on the top or left.") + (RETURN (BITBLT BRUSHBM 0 0 DISPLAYSTREAM [IDIFFERENCE X (HALF (SUB1 (fetch (BITMAP + BITMAPWIDTH + ) + of BRUSHBM] + [IDIFFERENCE Y (HALF (SUB1 (fetch (BITMAP BITMAPHEIGHT) of BRUSHBM] + NIL NIL NIL (SELECTQ (OR OPERATION (DSPOPERATION NIL DISPLAYSTREAM)) + (REPLACE 'PAINT) + OPERATION]) + +(\DRAWPOLYGON.DISPLAY + [LAMBDA (STREAM POINTS CLOSED BRUSH DASHING) (* ; "Edited 13-Apr-88 14:14 by FS") + + (* ;; "Somewhat less generic version of drawpolygon that calls \drawline.display. Brush must be a brush (guaranteed in DRAWPOLYGON) other users must also ensure.") + + (* ;; "This is different than drawline.generic, because drawline.display will use width argument instead of bltting brushes around. That way you can get shades, dspoperation, eventually.") + + (PROG [COLOR (PTBRUSH (COND + ((EQ (fetch (BRUSH BRUSHSHAPE) of BRUSH) + 'ROUND) + BRUSH) + (T (create BRUSH using BRUSH BRUSHSHAPE _ 'ROUND] + (SETQ COLOR (fetch (BRUSH BRUSHCOLOR) of PTBRUSH)) + (for PTAIL on POINTS while (CDR PTAIL) do (\DRAWLINE.DISPLAY STREAM (fetch (POSITION XCOORD + ) + of (CAR PTAIL)) + (ffetch (POSITION YCOORD) + of (CAR PTAIL)) + (fetch (POSITION XCOORD) + of (CADR PTAIL)) + (ffetch (POSITION YCOORD) + of (CADR PTAIL)) + (fetch (BRUSH BRUSHSIZE) of BRUSH) + NIL COLOR DASHING) + (* ; + "put a brush between lines so it looks better. It's not mitered this way but better than not.") + (\DRAWPOINT.DISPLAY STREAM (fetch (POSITION + XCOORD) + of (CADR POINTS)) + (fetch (POSITION YCOORD) + of (CADR POINTS)) + PTBRUSH + 'NIL) + finally (COND + ((AND CLOSED (CDDR POINTS)) (* ; "draw the closing line.") + (\DRAWLINE.DISPLAY STREAM (fetch (POSITION XCOORD) of (CAR PTAIL)) + (ffetch (POSITION YCOORD) of (CAR PTAIL)) + (fetch (POSITION XCOORD) of (CAR POINTS)) + (ffetch (POSITION YCOORD) of (CAR POINTS)) + (fetch (BRUSH BRUSHSIZE) of BRUSH) + NIL COLOR DASHING))) + (OR (NULL (CDR POINTS)) + (\DRAWPOINT.DISPLAY STREAM (fetch (POSITION XCOORD) of (CAR POINTS)) + (fetch (POSITION YCOORD) of (CAR POINTS)) + PTBRUSH NIL]) + +(\LINEWITHBRUSH + [LAMBDA (X1 Y1 X2 Y2 BRUSH DASHLST DISPLAYSTREAM BBT OPERATION) + (* ; "Edited 29-Oct-87 17:40 by scp") + + (* ;; "draws a line with a brush on a guaranteed display-stream DISPLAYSTREAM") + + (DECLARE (LOCALVARS . T)) + (PROG (DestinationBitMap LEFT RIGHTPLUS1 TOP BOTTOM BRUSHWIDTH BRUSHHEIGHT LEFTMINUSBRUSH + BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE BRUSHBASE RASTERWIDTH + BRUSHRASTERWIDTH NBITSRIGHTPLUS1 HEIGHTMINUS1 COLOR COLORBRUSHBASE NBITS + HALFBRUSHWIDTH HALFBRUSHHEIGHT DX DY YINC CDL (DASHON T) + (DASHTAIL DASHLST) + (DASHCNT (CAR DASHLST)) + (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM)) + (USERFN (AND (LITATOM BRUSH) + BRUSH)) + (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM))) + + (* ;; "many of these variables are used by the macro for \CURVEPT that passes them to \BBTCURVEPT and .SETUP.FOR.\BBTCURVEPT. sets them up.") + (* ; + "move the display stream position before the coordinates are clobbered.") + (COND + ((NOT USERFN) + (.SETUP.FOR.\BBTCURVEPT.) + (SELECTQ NBITS + (1 (* ; + "SUB1 is so that the extra bit goes on the top and right as it is documented as doing for lines.") + (SETQ X1 (\DSPTRANSFORMX (IDIFFERENCE X1 (SETQ HALFBRUSHWIDTH + (FOLDLO (SUB1 BRUSHWIDTH) + 2))) + DISPLAYDATA))) + (4 (SETQ X1 (\DSPTRANSFORMX (IDIFFERENCE X1 (SETQ HALFBRUSHWIDTH + (FOLDLO (LRSH (SUB1 BRUSHWIDTH) + 2) + 2))) + DISPLAYDATA))) + (8 (SETQ X1 (\DSPTRANSFORMX (IDIFFERENCE X1 (SETQ HALFBRUSHWIDTH + (FOLDLO (LRSH (SUB1 BRUSHWIDTH) + 3) + 2))) + DISPLAYDATA))) + (SHOULDNT)) + (SETQ X2 (\DSPTRANSFORMX (IDIFFERENCE X2 HALFBRUSHWIDTH) + DISPLAYDATA)) + (SETQ Y1 (\DSPTRANSFORMY (IDIFFERENCE Y1 (SETQ HALFBRUSHHEIGHT (FOLDLO (SUB1 + BRUSHHEIGHT + ) + 2))) + DISPLAYDATA)) (* ; + "take into account the brush thickness.") + (SETQ Y2 (\DSPTRANSFORMY (IDIFFERENCE Y2 HALFBRUSHHEIGHT) + DISPLAYDATA)) + + (* ;; "Move the window to top while interruptable, but verify that it is still there uninterruptably with drawing points") + + (\INSURETOPWDS DISPLAYSTREAM))) (* ; + "arrange things so that dx is positive.") + (COND + ((IGREATERP X1 X2) (* ; "switch points") + (swap X1 X2) + (swap Y1 Y2))) + (SETQ DX (ADD1 (IDIFFERENCE X2 X1))) + [SETQ DY (ADD1 (COND + ((IGREATERP Y2 Y1) + (SETQ YINC 1) + (IDIFFERENCE Y2 Y1)) + (T (SETQ YINC -1) + (IDIFFERENCE Y1 Y2] + [SETQ CDL (HALF (COND + ((IGREATERP DX DY) (* ; + "set up the bucket so that the ends will be the same.") + (IREMAINDER DX DY)) + (T (IREMAINDER DY DX] + [COND + [USERFN (* ; + "if user function is being called, don't bother bringing window to top uninterruptably.") + (COND + ((IGEQ DX DY) (* ; "X is the fastest mover.") + (until (IGREATERP X1 X2) + do (* ; "main loop") + (COND + (DASHON (APPLY* USERFN X1 Y1 DISPLAYSTREAM))) + [COND + (DASHTAIL (* ; "do dashing.") + (COND + ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) + (SETQ DASHON (NOT DASHON)) + (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) + DASHLST)) + (SETQ DASHCNT (CAR DASHTAIL] + [COND + ((NOT (IGREATERP DX (add CDL DY))) + (add Y1 YINC) + (COND + ((COND + ((EQ YINC -1) + (ILESSP Y1 Y2)) + ((IGREATERP Y1 Y2))) + (RETURN))) + (SETQ CDL (IDIFFERENCE CDL DX] + (add X1 1))) + (T (* ; "Y is the fastest mover.") + (until (COND + ((EQ YINC -1) + (ILESSP Y1 Y2)) + ((IGREATERP Y1 Y2))) + do (* ; "main loop") + (COND + (DASHON (APPLY* USERFN X1 Y1 DISPLAYSTREAM))) + [COND + (DASHTAIL (* ; "do dashing.") + (COND + ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) + (SETQ DASHON (NOT DASHON)) + (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) + DASHLST)) + (SETQ DASHCNT (CAR DASHTAIL] + [COND + ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX] + (COND + ((IGREATERP (SETQ X1 (ADD1 X1)) + X2) + (RETURN))) + (SETQ CDL (IDIFFERENCE CDL DY] + (add Y1 YINC] + (T (* ; + "when we put the points down make it uninterruptable") + (.WHILE.TOP.DS. DISPLAYSTREAM + (COND + [(IGEQ DX DY) (* ; "X is the fastest mover.") + (until (IGREATERP X1 X2) + do (* ; "main loop") + (COND + (DASHON (\CURVEPT X1 Y1))) + [COND + (DASHTAIL (* ; "do dashing.") + (COND + ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) + (SETQ DASHON (NOT DASHON)) + (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) + DASHLST)) + (SETQ DASHCNT (CAR DASHTAIL] + [COND + ([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY] + (SETQ Y1 (IPLUS Y1 YINC)) + (COND + ((COND + ((EQ YINC -1) + (ILESSP Y1 Y2)) + ((IGREATERP Y1 Y2))) + (RETURN))) + (SETQ CDL (IDIFFERENCE CDL DX] + (SETQ X1 (ADD1 X1] + (T (* ; "Y is the fastest mover.") + (until (COND + ((EQ YINC -1) + (ILESSP Y1 Y2)) + ((IGREATERP Y1 Y2))) + do (* ; "main loop") + (COND + (DASHON (\CURVEPT X1 Y1))) + [COND + (DASHTAIL (* ; "do dashing.") + (COND + ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) + (SETQ DASHON (NOT DASHON)) + (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) + DASHLST)) + (SETQ DASHCNT (CAR DASHTAIL] + [COND + ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX] + (COND + ((IGREATERP (SETQ X1 (ADD1 X1)) + X2) + (RETURN))) + (SETQ CDL (IDIFFERENCE CDL DY] + (SETQ Y1 (IPLUS Y1 YINC] + (RETURN NIL]) +) +(DEFINEQ + +(LOADPOLY + [LAMBDA (POLY POLYPRIME A B C D) (* hdj "13-Mar-85 18:01") + (replace (POLYNOMIAL A) of POLY with (FQUOTIENT A 6.0)) + (replace (POLYNOMIAL B) of POLY with (FQUOTIENT B 2.0)) + (replace (POLYNOMIAL C) of POLY with C) + (replace (POLYNOMIAL D) of POLY with D) + (replace (POLYNOMIAL A) of POLYPRIME with (FQUOTIENT A 2.0)) + (replace (POLYNOMIAL B) of POLYPRIME with B) + (replace (POLYNOMIAL C) of POLYPRIME with C]) + +(PARAMETRICSPLINE + [LAMBDA (KNOTS CLOSEDFLG SPLINE) (* rmk%: "30-Nov-84 17:02") + + (* ;; "KNOTS is a non-NIL list of knots, CLOSEDFLG => closed curve") + + (PROG (DX DY DDX DDY DDDX DDDY %#KNOTS A BX BY X Y SX SY A C R D2X D2Y I) + [COND + (CLOSEDFLG (* ; "Wrap around") + (push KNOTS (CAR (LAST KNOTS] + (SETQ %#KNOTS (LENGTH KNOTS)) + (SETQ DX (ARRAY %#KNOTS 0 0.0)) + (SETQ DDX (ARRAY %#KNOTS 0 0.0)) + (SETQ DDDX (ARRAY %#KNOTS 0 0.0)) + (SETQ DY (ARRAY %#KNOTS 0 0.0)) + (SETQ DDY (ARRAY %#KNOTS 0 0.0)) + (SETQ DDDY (ARRAY %#KNOTS 0 0.0)) + (SETQ X (ARRAY %#KNOTS 0 0.0)) + (SETQ Y (ARRAY %#KNOTS 0 0.0)) + (for KNOT in KNOTS as I from 1 to %#KNOTS do (OR (type? POSITION KNOT) + (ERROR "bad knot" KNOT)) + (SETA X I (CAR KNOT)) + (SETA Y I (CDR KNOT))) + (SETQ A (ARRAY %#KNOTS 0 0.0)) + (SETQ BX (ARRAY %#KNOTS 0 0.0)) + (SETQ BY (ARRAY %#KNOTS 0 0.0)) + [COND + (CLOSEDFLG (SETQ C (ARRAY %#KNOTS 0 0.0)) + (SETQ R (ARRAY %#KNOTS 0 0.0)) + (SETQ SX (ARRAY %#KNOTS 0 0.0)) + (SETQ SY (ARRAY %#KNOTS 0 0.0] + (SETA A 1 4.0) + [for I from 2 to (IDIFFERENCE %#KNOTS 2) + do (SETA A I (FDIFFERENCE 4.0 (FQUOTIENT 1.0 (ELT A (SUB1 I] + [COND + (CLOSEDFLG (SETA C 1 1.0) + (for I from 2 to (IDIFFERENCE %#KNOTS 2) + do (SETA C I (FMINUS (FQUOTIENT (ELT C (SUB1 I)) + (ELT A (SUB1 I] + [COND + ((IGEQ %#KNOTS 3) + (COND + [CLOSEDFLG [SETA BX 1 (FTIMES 6.0 (FPLUS (ELT X 2) + (FMINUS (FTIMES 2.0 (ELT X 1))) + (ELT X (SUB1 %#KNOTS] + [SETA BY 1 (FTIMES 6.0 (FPLUS (ELT Y 2) + (FMINUS (FTIMES 2.0 (ELT Y 1))) + (ELT Y (SUB1 %#KNOTS] + [for I from 2 to (IDIFFERENCE %#KNOTS 2) + do [SETA BX I (FDIFFERENCE [FTIMES 6.0 + (FPLUS (ELT X (ADD1 I)) + (FMINUS (FTIMES 2.0 + (ELT X I))) + (ELT X (SUB1 I] + (FQUOTIENT (ELT BX (SUB1 I)) + (ELT A (SUB1 I] + (SETA BY I (FDIFFERENCE [FTIMES 6.0 + (FPLUS (ELT Y (ADD1 I)) + (FMINUS (FTIMES 2.0 + (ELT Y I))) + (ELT Y (SUB1 I] + (FQUOTIENT (ELT BY (SUB1 I)) + (ELT A (SUB1 I] + (SETA R (SUB1 %#KNOTS) + 1.0) + (SETA SX (SUB1 %#KNOTS) + 0.0) + (SETA SY (SUB1 %#KNOTS) + 0.0) + (for I from (IDIFFERENCE %#KNOTS 2) to 1 by -1 + do [SETA R I (FMINUS (FQUOTIENT (FPLUS (ELT R (ADD1 I)) + (ELT C I)) + (ELT A I] + (SETA SX I (FQUOTIENT (FDIFFERENCE (ELT BX I) + (ELT SX (ADD1 I))) + (ELT A I))) + (SETA SY I (FQUOTIENT (FDIFFERENCE (ELT BY I) + (ELT SY (ADD1 I))) + (ELT A I] + (T [SETA BX 1 (FTIMES 6.0 (FPLUS (FDIFFERENCE (ELT X 3) + (FTIMES 2.0 (ELT X 2))) + (ELT X 1] + [SETA BY 1 (FTIMES 6.0 (FPLUS (FDIFFERENCE (ELT Y 3) + (FTIMES 2.0 (ELT Y 2))) + (ELT Y 1] + (for I from 2 to (IDIFFERENCE %#KNOTS 2) + do [SETA BX I (FDIFFERENCE (FTIMES 6.0 + (FPLUS [FDIFFERENCE + (ELT X (IPLUS I 2)) + (FTIMES 2 (ELT X (ADD1 I] + (ELT X I))) + (FQUOTIENT (ELT BX (SUB1 I)) + (ELT A (SUB1 I] + (SETA BY I (FDIFFERENCE (FTIMES 6.0 + (FPLUS [FDIFFERENCE + (ELT Y (IPLUS I 2)) + (FTIMES 2 (ELT Y (ADD1 I] + (ELT Y I))) + (FQUOTIENT (ELT BY (SUB1 I)) + (ELT A (SUB1 I] + [COND + (CLOSEDFLG [SETQ D2X (FPLUS (ELT X %#KNOTS) + [FMINUS (FTIMES 2.0 (ELT X (SUB1 %#KNOTS] + (ELT X (IDIFFERENCE %#KNOTS 2] + [SETQ D2Y (FPLUS (ELT Y %#KNOTS) + [FMINUS (FTIMES 2.0 (ELT Y (SUB1 %#KNOTS] + (ELT Y (IDIFFERENCE %#KNOTS 2] + (SETA DDX (SUB1 %#KNOTS) + (FQUOTIENT (FDIFFERENCE (FDIFFERENCE (FTIMES D2X 6.0) + (ELT SX 1)) + (ELT SX (IDIFFERENCE %#KNOTS 2))) + (FPLUS (ELT R 1) + (ELT R (IDIFFERENCE %#KNOTS 2)) + 4.0))) + (SETA DDY (SUB1 %#KNOTS) + (FQUOTIENT (FDIFFERENCE (FDIFFERENCE (FTIMES D2Y 6.0) + (ELT SY 1)) + (ELT SY (IDIFFERENCE %#KNOTS 2))) + (FPLUS (ELT R 1) + (ELT R (IDIFFERENCE %#KNOTS 2)) + 4.0))) + [for I from 1 to (IDIFFERENCE %#KNOTS 2) + do [SETA DDX I (FPLUS (ELT SX I) + (FTIMES (ELT R I) + (ELT DDX (SUB1 %#KNOTS] + (SETA DDY I (FPLUS (ELT SY I) + (FTIMES (ELT R I) + (ELT DDY (SUB1 %#KNOTS] + (SETA DDX %#KNOTS (ELT DDX 1)) + (SETA DDY %#KNOTS (ELT DDY 1))) + (T (* ; "COMPUTE SECOND DERIVATIVES.") + [SETA DDX 1 (SETA DDY 1 (SETA DDX %#KNOTS (SETA DDY %#KNOTS 0.0] + (for I from (SUB1 %#KNOTS) to 2 by -1 + do [SETA DDX I (FQUOTIENT (FDIFFERENCE (ELT BX (SUB1 I)) + (ELT DDX (ADD1 I))) + (ELT A (SUB1 I] + (SETA DDY I (FQUOTIENT (FDIFFERENCE (ELT BY (SUB1 I)) + (ELT DDY (ADD1 I))) + (ELT A (SUB1 I] + [for I from 1 to (SUB1 %#KNOTS) + do (* ; "COMPUTE 1ST & 3RD DERIVATIVES") + (SETA DX I (FDIFFERENCE (FDIFFERENCE (ELT X (ADD1 I)) + (ELT X I)) + (FQUOTIENT (FPLUS (FTIMES 2 (ELT DDX I)) + (ELT DDX (ADD1 I))) + 6.0))) + (SETA DY I (FDIFFERENCE (FDIFFERENCE (ELT Y (ADD1 I)) + (ELT Y I)) + (FQUOTIENT (FPLUS (FTIMES 2 (ELT DDY I)) + (ELT DDY (ADD1 I))) + 6.0))) + (SETA DDDX I (FDIFFERENCE (ELT DDX (ADD1 I)) + (ELT DDX I))) + (SETA DDDY I (FDIFFERENCE (ELT DDY (ADD1 I)) + (ELT DDY I] + (SETQ SPLINE + (create SPLINE + %#KNOTS _ %#KNOTS + SPLINEX _ X + SPLINEY _ Y + SPLINEDX _ DX + SPLINEDY _ DY + SPLINEDDX _ DDX + SPLINEDDY _ DDY + SPLINEDDDX _ DDDX + SPLINEDDDY _ DDDY)) + (RETURN SPLINE]) + +(\CURVE + [LAMBDA (X0 Y0 X1 Y1 DX DY DDX DDY DDDX DDDY N BRUSHBM DISPLAYDATA BBT ENDING USERFN DISPLAYSTREAM) + (* rrb "30-Apr-85 12:44") + (DECLARE (LOCALVARS . T)) + + (* ;; "Puts a spline segment down. Since it calls BitBlt1 directly, it must clip to both clipping region and the size of the destination bit map.") + + (PROG (OLDX X Y OLDY DELTAX DELTAY DELTA TX TY OOLDX OOLDY) + [COND + ((NEQ N 0) + [COND + (USERFN (* ; + "if there is a user fn, stay in his coordinates.") + (SETQ OLDX X0) + (SETQ OLDY Y0)) + (T + (* ;; "SUB1 on brush size is to cause the extra bit to be in the top left direction as is documented for lines.") + + (SETQ OLDX (\DSPTRANSFORMX (IDIFFERENCE X0 (LRSH (SUB1 BRUSHWIDTH) + 1)) + DISPLAYDATA)) + (SETQ OLDY (\DSPTRANSFORMY (IDIFFERENCE Y0 (LRSH (SUB1 BRUSHHEIGHT) + 1)) + DISPLAYDATA] (* ; "draw origin point") + (\CURVESMOOTH OLDX OLDY USERFN DISPLAYSTREAM) (* ; + "convert the derivatives to fractional representation.") + + (* ;; "\CONVERTTOFRACTION always returns a large number box. This uses 0.49 because 0.5 causes rounding up.") + + (SETQ X (\CONVERTTOFRACTION (FPLUS OLDX 0.49))) + (SETQ Y (\CONVERTTOFRACTION (FPLUS OLDY 0.49))) + (SETQ DX (\CONVERTTOFRACTION DX)) + (SETQ DY (\CONVERTTOFRACTION DY)) + (SETQ DDX (\CONVERTTOFRACTION DDX)) + (SETQ DDY (\CONVERTTOFRACTION DDY)) + (SETQ DDDX (\CONVERTTOFRACTION DDDX)) + (SETQ DDDY (\CONVERTTOFRACTION DDDY)) + [for I from 1 to N do (* ; + "uses \BOXIPLUS to save box and also set the new value of the variable.") + (\BOXIPLUS X DX) + (\BOXIPLUS DX DDX) + (\BOXIPLUS DDX DDDX) + (\BOXIPLUS Y DY) + (\BOXIPLUS DY DDY) + (\BOXIPLUS DDY DDDY) + (SETQ OOLDX OLDX) + (SETQ OOLDY OLDY) + (SETQ DELTAX (IDIFFERENCE (SETQ OLDX (\GETINTEGERPART X)) + OOLDX)) + (SETQ DELTAY (IDIFFERENCE (SETQ OLDY (\GETINTEGERPART Y)) + OOLDY)) + (SETQ DELTA (IMAX (IABS DELTAX) + (IABS DELTAY))) + (COND + ((EQ DELTA 1) + (\CURVESMOOTH OLDX OLDY USERFN DISPLAYSTREAM))) + (COND + ((IGREATERP DELTA 1) + (SETQ DELTAX (\CONVERTTOFRACTION (FQUOTIENT DELTAX DELTA))) + (SETQ DELTAY (\CONVERTTOFRACTION (FQUOTIENT DELTAY DELTA))) + (SETQ TX (\CONVERTTOFRACTION OOLDX)) + (SETQ TY (\CONVERTTOFRACTION OOLDY)) + (for I from 0 to DELTA do (\CURVESMOOTH (\GETINTEGERPART + TX) + (\GETINTEGERPART TY) + USERFN DISPLAYSTREAM) + (\BOXIPLUS TX DELTAX) + (\BOXIPLUS TY DELTAY] + (* ; "draw the end point") + (COND + (USERFN (\CURVESMOOTH X1 Y1 USERFN DISPLAYSTREAM)) + (T (\CURVESMOOTH (\DSPTRANSFORMX (IDIFFERENCE X1 (LRSH (SUB1 BRUSHWIDTH) + 1)) + DISPLAYDATA) + (\DSPTRANSFORMY (IDIFFERENCE Y1 (LRSH (SUB1 BRUSHHEIGHT) + 1)) + DISPLAYDATA) + NIL DISPLAYSTREAM))) + (AND DISPLAYSTREAM (MOVETO X1 Y1 DISPLAYSTREAM] + (COND + (ENDING (\CURVESMOOTH (IPLUS \CURX \CURX (IMINUS \OLDX)) + (IPLUS \CURY \CURY (IMINUS \OLDY)) + USERFN DISPLAYSTREAM) + (\CURVESMOOTH (IPLUS \CURX \CURX (IMINUS \OLDX)) + (IPLUS \CURY \CURY (IMINUS \OLDY)) + USERFN DISPLAYSTREAM))) + (RETURN NIL]) + +(\CURVE2 + [LAMBDA (SPLINE BRUSH DASHLST BBT DISPLAYSTREAM) (* jds "26-Nov-85 12:21") + +(* ;;; "Given a spline curve, represented as a set of derivatives for each segment, draw it on DISPLAYSTREAM using the brush BRUSH, and dashing it according to DASHLST. For speed, use the bitblt table BBT.") + + (DECLARE (SPECVARS . T)) + + (* ;; "DISPLAYSTREAM is guaranteed to be a display-stream. Should declare most of these variables local but currently have the \CURVE function between here and \CURVEBBT so can't") + + (PROG (BRUSHBM DestinationBitMap OPERATION BRUSHWIDTH BRUSHHEIGHT BRUSHBASE BRUSHRASTERWIDTH LEFT + RIGHTPLUS1 TOP BOTTOM DESTINATIONBASE LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH + RASTERWIDTH NBITSRIGHTPLUS1 HEIGHTMINUS1 COLOR COLORBRUSHBASE NBITS \CURX \CURY + \OLDX \OLDY \OLDERX \OLDERY LKNOT (DASHON T) + (DASHTAIL DASHLST) + (DASHCNT (CAR DASHLST)) + NPOINTS NSEGS POINTSPERSEG DX D2X D3X DY D2Y D3Y D1 D2 D3 X0 Y0 X1 Y1 DX DDX DDDX DY + DDY DDDY (XPOLY (create POLYNOMIAL)) + (X/PRIME/POLY (create POLYNOMIAL)) + (YPOLY (create POLYNOMIAL)) + (Y/PRIME/POLY (create POLYNOMIAL)) + (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM)) + (USERFN (AND (LITATOM BRUSH) + BRUSH))) + + (* ;; "many of these variables are used by the macro for \CURVEPT that passes them to \BBTCURVEPT and .SETUP.FOR.\BBTCURVEPT. sets them up.") + + [COND + (USERFN (* ; + "if calling user fn, don't bother with set up and leave points in window coordinates.") + (\CURVESTART (ELT (fetch (SPLINE SPLINEX) of SPLINE) + 1) + (ELT (fetch (SPLINE SPLINEY) of SPLINE) + 1))) + (T (.SETUP.FOR.\BBTCURVEPT.) (* ; + "Do it interruptably here to get set up, then uninterruptably when drawing points") + (\INSURETOPWDS DISPLAYSTREAM) (* ; + "curve pts will be kept in screen coordinates, start smoothing values there.") + (\CURVESTART (\DSPTRANSFORMX (IDIFFERENCE (ELT (fetch (SPLINE SPLINEX) of SPLINE) + 1) + (LRSH (SUB1 BRUSHWIDTH) + 1)) + DISPLAYDATA) + (\DSPTRANSFORMY (IDIFFERENCE (ELT (fetch (SPLINE SPLINEY) of SPLINE) + 1) + (LRSH (SUB1 BRUSHHEIGHT) + 1)) + DISPLAYDATA] + [bind PERSEG for KNOT from 1 to (SUB1 (fetch %#KNOTS of SPLINE)) + when (PROGN + (* ;; "Loop thru the segments of the spline curve, drawing each in turn.") + + (SETQ X0 (ELT (fetch (SPLINE SPLINEX) of SPLINE) + KNOT)) (* ; + "Set up X0,Y0 -- the starting point of this segment") + (SETQ Y0 (ELT (fetch (SPLINE SPLINEY) of SPLINE) + KNOT)) + (SETQ X1 (ELT (fetch (SPLINE SPLINEX) of SPLINE) + (ADD1 KNOT))) (* ; "And X1,Y1 -- the ending point") + (SETQ Y1 (ELT (fetch (SPLINE SPLINEY) of SPLINE) + (ADD1 KNOT))) + (SETQ DX (ELT (fetch (SPLINE SPLINEDX) of SPLINE) + KNOT)) (* ; + "And the initial derivatives -- first") + (SETQ DY (ELT (fetch (SPLINE SPLINEDY) of SPLINE) + KNOT)) + (SETQ DDX (ELT (fetch SPLINEDDX of SPLINE) + KNOT)) (* ; "Second") + (SETQ DDY (ELT (fetch SPLINEDDY of SPLINE) + KNOT)) + (SETQ DDDX (ELT (fetch SPLINEDDDX of SPLINE) + KNOT)) (* ; "And third.") + (SETQ DDDY (ELT (fetch SPLINEDDDY of SPLINE) + KNOT)) + (SETQ NPOINTS (FOLDLO (ITIMES (IMAX (IABS (IDIFFERENCE X1 X0)) + (IABS (IDIFFERENCE Y1 Y0))) + 3) + 2)) + + (* ;; "Establish an upper bound on the number of points we'll draw while painting this segment. We know that 3/2 the maximum DX or DY is the right amount.") + + (NOT (ZEROP NPOINTS))) + do + (* ;; "NPOINTS can be zero if a knot is duplicated in the spline curve to produce a discontinuity. Skip over zero-length segments to avoid divide-by-zero trouble") + + (* ;; "To prevent round-off errors from accumulating, we'll draw this segment as runs of no more than 64 points each -- recomputing completely at the start of each run. This is a trade off of speed and accuracy.") + + [COND + ((ILEQ NPOINTS 64) (* ; + "Fewer than 64 points to draw. Do it in one run.") + (SETQ NSEGS 1) + (SETQ POINTSPERSEG NPOINTS)) + (T (* ; + "Figure out how many runs to do it in.") + (SETQ NSEGS (FOLDLO NPOINTS 64)) + (SETQ POINTSPERSEG 64) + (SETQ NPOINTS (UNFOLD NSEGS 64] + (SETQ D1 (FQUOTIENT 1.0 NPOINTS)) (* ; + "Set up ÿ&Eÿt, ÿ&Eÿt**2 and ÿ&Eÿt**3, for computing the next point.") + (SETQ D2 (FTIMES D1 D1)) + (SETQ D3 (FTIMES D2 D1)) + (SETQ D3X (FTIMES D3 DDDX)) + (SETQ D3Y (FTIMES D3 DDDY)) + (COND + [(EQ NSEGS 1) (* ; "Just one segment to draw.") + [SETQ DX (FPLUS (FTIMES D1 DX) + (FTIMES DDX D2 0.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 0.5) + (FTIMES D3 DDDY (CONSTANT (FQUOTIENT 1.0 6.0] + (SETQ D2Y (FPLUS (FTIMES D2 DDY) + (FTIMES D3 DDDY))) + (COND + (USERFN (* ; + "Draw this run of points, using the user's supplied function.") + (\CURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y NPOINTS BRUSHBM DISPLAYDATA + BBT NIL USERFN DISPLAYSTREAM)) + (T (* ; + "Draw this run of points, using the brush.") + (.WHILE.TOP.DS. DISPLAYSTREAM + (\CURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y NPOINTS BRUSHBM + DISPLAYDATA BBT NIL NIL DISPLAYSTREAM] + (T (* ; + "Have to do this segment in several runs.") + (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 + (* ;; + "TT is the parameter, and runs from 0 to 1 as the curve segment runs from beginning to end.") + + (SETQ TT (FPLUS TT PERSEG)) + (SETQ X1 (POLYEVAL TT XPOLY 3)) + (SETQ Y1 (POLYEVAL TT YPOLY 3)) + (SETQ DX (FPLUS (FTIMES D1 DX) + (FTIMES D2 DDX 0.5) + D3XFACTOR)) + (SETQ D2X (FPLUS (FTIMES D2 DDX) + (FTIMES D3 DDDX))) + (SETQ DY (FPLUS (FTIMES D1 DY) + (FTIMES D2 DDY 0.5) + D3YFACTOR)) + (SETQ D2Y (FPLUS (FTIMES D2 DDY) + (FTIMES D3 DDDY))) + [COND + (USERFN (\CURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y 64 BRUSHBM + DISPLAYDATA BBT NIL USERFN DISPLAYSTREAM)) + (T (.WHILE.TOP.DS. DISPLAYSTREAM + (\CURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y 64 BRUSHBM + DISPLAYDATA BBT NIL NIL DISPLAYSTREAM] + (SETQ X0 X1) + (SETQ Y0 Y1) + (SETQ DDX (FPLUS DDX DDDX/PER/SEG)) + (SETQ DDY (FPLUS DDY DDDY/PER/SEG)) + (SETQ DX (POLYEVAL TT X/PRIME/POLY 2)) + (SETQ DY (POLYEVAL TT Y/PRIME/POLY 2] + + (* ;; "Draw the final point on the curve.") + + (COND + (USERFN (\CURVE 0 0 0 0 0 0 0 0 0 0 0 BRUSHBM DISPLAYDATA BBT T USERFN DISPLAYSTREAM)) + (T (.WHILE.TOP.DS. DISPLAYSTREAM + (\CURVE 0 0 0 0 0 0 0 0 0 0 0 BRUSHBM DISPLAYDATA BBT T NIL DISPLAYSTREAM]) + +(\CURVEEND + [LAMBDA NIL (* rrb " 5-JAN-82 17:24") + + (* ;; "Put out the last two points, using \CURVEPT, since they were held back for smoothing.") + + (PROG ((X \CURX) + (Y \CURY) + (DX (IDIFFERENCE \CURX \OLDX)) + (DY (IDIFFERENCE \CURY \OLDY))) + (for I from 1 to 2 do (\CURVESMOOTH (SETQ X (IPLUS X DX)) + (SETQ Y (IPLUS Y DY]) + +(\CURVESLOPE + [LAMBDA (KNOTS ENDFLG) (* rrb "30-Nov-84 18:17") + + (* ;; "returns a CONS of DX DY that gives the slope of the curve thru KNOTS. If ENDFLG is NIL, it is at the beginning. If ENDFLG is T, it is at the last point.") + + (PROG (DX DY PARAMS (%#KNOTS (LENGTH KNOTS))) + (RETURN (SELECTQ %#KNOTS + ((0 1) (* ; "define slope as horizontal") + '(1 . 0)) + (2 [CONS (DIFFERENCE (fetch (POSITION XCOORD) of (CADR KNOTS)) + (fetch (POSITION XCOORD) of (CAR KNOTS))) + (DIFFERENCE (fetch (POSITION YCOORD) of (CADR KNOTS)) + (fetch (POSITION YCOORD) of (CAR KNOTS]) + (PROGN [SETQ PARAMS (COND + [ENDFLG (PARAMETRICSPLINE (REVERSE (NLEFT KNOTS + (IMIN %#KNOTS + 4] + (T (PARAMETRICSPLINE (COND + ((EQ %#KNOTS 3) + (LIST (CAR KNOTS) + (CADR KNOTS) + (CADDR KNOTS))) + (T (LIST (CAR KNOTS) + (CADR KNOTS) + (CADDR KNOTS) + (CADDDR KNOTS] + (SETQ DX (ELT (fetch (SPLINE SPLINEDX) of PARAMS) + 1)) + (SETQ DY (ELT (fetch (SPLINE SPLINEDY) of PARAMS) + 1)) + (if ENDFLG + then (CONS (MINUS DX) + (MINUS DY)) + else (CONS DX DY]) + +(\CURVESTART + [LAMBDA (X Y) (* jds "27-OCT-81 15:48") + + (* ;; "Set up the init vals for \OLDER* \OLD* \CUR*, for curve smoothing in \CURVEPT.") + + (SETQ \OLDERX X) + (SETQ \OLDX X) + (SETQ \CURX X) + (SETQ \OLDERY Y) + (SETQ \OLDY Y) + (SETQ \CURY Y]) + +(\FDIFS/FROM/DERIVS + [LAMBDA (DZ DDZ DDDZ RAD NSTEPS) (* rrb "12-MAY-81 10:59") + + (* ;; "the derivatives of the function, plus a scale factor (radius for drawing circles) See 'Spline Curve Techniques' , equations 2.18.") + + (PROG (S SS SSS) + (SETQ S (FQUOTIENT 1.0 NSTEPS)) + (SETQ SS (FTIMES S S)) + (SETQ SSS (FTIMES SS S)) + (SETQ S (FTIMES S DZ RAD)) + (SETQ SS (FTIMES SS DDZ RAD)) + (SETQ SSS (FTIMES SSS DDDZ RAD)) + (RETURN (LIST (FPLUS S (FQUOTIENT SS 2.0) + (FQUOTIENT SSS 6.0)) + (FPLUS SS SSS) + SSS]) +) +(DECLARE%: DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(ARRAYRECORD POLYNOMIAL (A B C D) + (CREATE (ARRAY 4 'FLOATP)) + (SYSTEM)) + +(RECORD SPLINE (%#KNOTS SPLINEX SPLINEY SPLINEDX SPLINEDY SPLINEDDX SPLINEDDY SPLINEDDDX SPLINEDDDY)) +) + +(* "END EXPORTED DEFINITIONS") + +) +(DECLARE%: DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(PUTPROPS HALF MACRO ((X) + (LRSH X 1))) + +(PUTPROPS \FILLCIRCLEBLT MACRO (OPENLAMBDA (CX CY X Y) (* ; + "calls bitblt twice to fill in one line of the circle.") + (\LINEBLT FCBBT (IDIFFERENCE CX X) + (IPLUS CY Y) + (IPLUS CX X) + DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH + GRAYHEIGHT GRAYBASE NBITS) + (\LINEBLT FCBBT (IDIFFERENCE CX X) + (IDIFFERENCE CY Y) + (IPLUS CX X) + DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH + GRAYHEIGHT GRAYBASE NBITS))) +) + +(* "END EXPORTED DEFINITIONS") + + +(DECLARE%: EVAL@COMPILE + +(PUTPROPS \CURVEPT MACRO [OPENLAMBDA (X Y) + (COND + ((OR (ILEQ X LEFTMINUSBRUSH) + (IGEQ X RIGHTPLUS1) + (ILEQ Y BOTTOMMINUSBRUSH) + (IGEQ Y TOP)) + NIL) + ((NULL BBT) + (\FBITMAPBIT DESTINATIONBASE X Y OPERATION HEIGHTMINUS1 RASTERWIDTH)) + (T + (* ;; + "This should have been done in .SETUP.FOR.\BBTCURVEPT., under \GETBRUSHBBT.") + + (* ;; "Its a bug here, because brushes can't use operation REPLACE.") + + (* ;; + "(\SETPBTFUNCTION BBT (ffetch DDSOURCETYPE of DISPLAYDATA) OPERATION)") + + (\BBTCURVEPT X Y BBT LEFT BRUSHWIDTH LEFTMINUSBRUSH RIGHTPLUS1 + NBITSRIGHTPLUS1 TOPMINUSBRUSH DestinationBitMap BRUSHHEIGHT + BOTTOMMINUSBRUSH TOP BRUSHBASE DESTINATIONBASE RASTERWIDTH + BRUSHRASTERWIDTH COLORBRUSHBASE NBITS DISPLAYDATA]) + +(PUTPROPS .SETUP.FOR.\BBTCURVEPT. MACRO [NIL (PROGN (SETQ BOTTOM (ffetch (\DISPLAYDATA + DDClippingBottom) + of DISPLAYDATA)) + (SETQ TOP (ffetch (\DISPLAYDATA DDClippingTop) + of DISPLAYDATA)) + (SETQ RIGHTPLUS1 (ffetch (\DISPLAYDATA + DDClippingRight) + of DISPLAYDATA)) + (SETQ LEFT (ffetch (\DISPLAYDATA DDClippingLeft) + of DISPLAYDATA)) + (SETQ DestinationBitMap (ffetch (\DISPLAYDATA + DDDestination) + of DISPLAYDATA)) + (SETQ OPERATION (OR OPERATION (ffetch + (\DISPLAYDATA + DDOPERATION) + of DISPLAYDATA)) + ) + (SETQ NBITS (fetch (BITMAP BITMAPBITSPERPIXEL) + of DestinationBitMap)) + [COND + [(NOT (EQ NBITS 1)) + (SETQ BRUSHBM (\GETCOLORBRUSH BRUSH + (MAXIMUMCOLOR NBITS) + NBITS)) + [SETQ COLOR + (COND + [(AND (LISTP BRUSH) + (CAR (LISTP (CDDR BRUSH] + ((DSPCOLOR NIL DISPLAYSTREAM)) + (T (MAXIMUMCOLOR NBITS] + [COND + ((EQ OPERATION 'ERASE) + (SETQ COLOR (OPPOSITECOLOR COLOR NBITS] + (SETQ COLORBRUSHBASE + (fetch (BITMAP BITMAPBASE) + of (\GETCOLORBRUSH BRUSH COLOR NBITS] + (T (SETQ BRUSHBM (\GETBRUSH BRUSH] + (SETQ RASTERWIDTH (ffetch (BITMAP + BITMAPRASTERWIDTH + ) of + DestinationBitMap + )) + (SETQ DESTINATIONBASE (ffetch (BITMAP BITMAPBASE) + of DestinationBitMap)) + (SETQ BBT (\GETBRUSHBBT BRUSHBM DISPLAYDATA BBT)) + (SETQ BRUSHBASE (fetch (BITMAP BITMAPBASE) + of BRUSHBM)) + (SETQ BRUSHRASTERWIDTH (ffetch (BITMAP + BITMAPRASTERWIDTH + ) + of BRUSHBM)) + [COND + ((NULL BBT) + (SETQ HEIGHTMINUS1 (SUB1 (ffetch (BITMAP + + BITMAPHEIGHT + ) + of + DestinationBitMap + ))) + (COND + ((EQ (ffetch (\DISPLAYDATA DDOPERATION) + of DISPLAYDATA) + 'INVERT) + (SETQ OPERATION 'INVERT] + (SETQ BRUSHWIDTH (ffetch (BITMAP BITMAPWIDTH) + of BRUSHBM)) + (SETQ BRUSHHEIGHT (ffetch (BITMAP BITMAPHEIGHT) + of BRUSHBM)) + (SETQ LEFTMINUSBRUSH (IDIFFERENCE LEFT BRUSHWIDTH + )) + (SETQ BOTTOMMINUSBRUSH (IDIFFERENCE BOTTOM + BRUSHHEIGHT)) + (SETQ TOPMINUSBRUSH (IDIFFERENCE TOP BRUSHHEIGHT) + ) + (SETQ NBITSRIGHTPLUS1 (ITIMES RIGHTPLUS1 NBITS)) + (SETQ BRUSHWIDTH (ITIMES BRUSHWIDTH NBITS]) + +(PUTPROPS \CIRCLEPTS MACRO (OPENLAMBDA (CX CY X Y) + (\CURVEPT (IPLUS CX X) + (IPLUS CY Y)) + (\CURVEPT (IDIFFERENCE CX X) + (IPLUS CY Y)) + (\CURVEPT (IPLUS CX X) + (IDIFFERENCE CY Y)) + (\CURVEPT (IDIFFERENCE CX X) + (IDIFFERENCE CY Y)))) + +(PUTPROPS \CURVESMOOTH MACRO (OPENLAMBDA (NEWX NEWY USERFN DISPLAYSTREAM) + (PROG [(DX (IABS (IDIFFERENCE NEWX \OLDX))) + (DY (IABS (IDIFFERENCE NEWY \OLDY] + (COND + ((OR (IGREATERP DX 1) + (IGREATERP DY 1)) + [COND + ((NEQ [IPLUS (ADD1 (IDIFFERENCE \OLDX \OLDERX)) + (ITIMES 3 (ADD1 (IDIFFERENCE \OLDY \OLDERY] + 4) + [COND + (DASHON (COND + (USERFN (APPLY* USERFN \OLDX \OLDY + DISPLAYSTREAM)) + (T (.WHILE.TOP.DS. DISPLAYSTREAM + (\CURVEPT \OLDX \OLDY] + (COND + (DASHTAIL (COND + ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) + (SETQ DASHON (NOT DASHON)) + (SETQ DASHTAIL + (OR (LISTP (CDR DASHTAIL)) + DASHLST)) + (SETQ DASHCNT (CAR DASHTAIL] + (SETQ \OLDERX \OLDX) + (SETQ \OLDERY \OLDY) + (SETQ \OLDX \CURX) + (SETQ \OLDY \CURY))) + (SETQ \CURX NEWX) + (SETQ \CURY NEWY)))) +) +) +(DEFINEQ + +(\FILLCIRCLE.DISPLAY + [LAMBDA (DISPLAYSTREAM CENTERX CENTERY RADIUS TEXTURE) (* kbr%: "24-Jan-86 19:12") + + (* ;; "Fill in area bounded by circle DRAWCIRCLE would draw.") + + (COND + ((OR (NOT (NUMBERP RADIUS)) + (ILESSP (SETQ RADIUS (FIXR RADIUS)) + 0)) + (\ILLEGAL.ARG RADIUS)) + (T (GLOBALRESOURCE \BRUSHBBT + (PROG (TOP BOTTOM RIGHT LEFT OPERATION DestinationBitMap DISPLAYDATA X Y D + DESTINATIONBASE RASTERWIDTH CX CY TEXTUREBM GRAYHEIGHT GRAYWIDTH GRAYBASE + NBITS FCBBT) + (SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DISPLAYSTREAM)) + (SETQ X 0) + (SETQ Y RADIUS) + (SETQ D (ITIMES 2 (IDIFFERENCE 1 RADIUS))) + (SETQ FCBBT \BRUSHBBT) + (SETQ LEFT (fetch (\DISPLAYDATA DDClippingLeft) of DISPLAYDATA)) + (SETQ BOTTOM (fetch (\DISPLAYDATA DDClippingBottom) of DISPLAYDATA)) + (SETQ TOP (SUB1 (fetch (\DISPLAYDATA DDClippingTop) of DISPLAYDATA))) + (SETQ RIGHT (SUB1 (fetch (\DISPLAYDATA DDClippingRight) of DISPLAYDATA))) + (SETQ OPERATION (fetch (\DISPLAYDATA DDOPERATION) of DISPLAYDATA)) + (SETQ DestinationBitMap (fetch (\DISPLAYDATA DDDestination) of DISPLAYDATA)) + (SETQ NBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DestinationBitMap)) + [SETQ TEXTUREBM (COND + ((BITMAPP TEXTURE)) + [(NOT (EQ NBITS 1))(* ; + "color case, default texture differently") + (COND + ((BITMAPP (COLORTEXTUREFROMCOLOR# + (COLORNUMBERP (OR TEXTURE (DSPCOLOR NIL + DISPLAYSTREAM + )) + NBITS T) + NBITS))) + [(AND (LISTP TEXTURE) + (BITMAPP (COLORTEXTUREFROMCOLOR# + (COLORNUMBERP (CADR TEXTURE) + NBITS) + NBITS] + (T (\ILLEGAL.ARG TEXTURE] + ((LISTP TEXTURE) (* ; + "either a color or a list of (texture color)") + (INSURE.B&W.TEXTURE TEXTURE)) + [(AND (NULL TEXTURE) + (BITMAPP (fetch (\DISPLAYDATA DDTexture) of + DISPLAYDATA + ] + ([OR (FIXP TEXTURE) + (AND (NULL TEXTURE) + (SETQ TEXTURE (fetch (\DISPLAYDATA DDTexture) + of DISPLAYDATA] + (* ; + "create bitmap for the texture. Could reuse a bitmap but for now this is good enough.") + (SETQ TEXTUREBM (BITMAPCREATE 16 4)) + (SETQ GRAYBASE (fetch (BITMAP BITMAPBASE) of TEXTUREBM)) + (\PUTBASE GRAYBASE 0 (\SFReplicate (LOGAND (LRSH TEXTURE + 12) + 15))) + (\PUTBASE GRAYBASE 1 (\SFReplicate (LOGAND (LRSH TEXTURE 8 + ) + 15))) + (\PUTBASE GRAYBASE 2 (\SFReplicate (LOGAND (LRSH TEXTURE 4 + ) + 15))) + (\PUTBASE GRAYBASE 3 (\SFReplicate (LOGAND TEXTURE 15))) + TEXTUREBM) + (T (\ILLEGAL.ARG TEXTURE] + (SETQ GRAYBASE (fetch (BITMAP BITMAPBASE) of TEXTUREBM)) + (SETQ DESTINATIONBASE (fetch (BITMAP BITMAPBASE) of DestinationBitMap)) + (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of DestinationBitMap)) + (* ; + "update as many fields in the brush bitblt table as possible from DS.") + (replace (PILOTBBT PBTFLAGS) of FCBBT with 0) + (replace (PILOTBBT PBTDESTBPL) of FCBBT with (UNFOLD RASTERWIDTH BITSPERWORD)) + (* ; + "clear gray information. PBTSOURCEBPL is used for gray information too.") + (replace (PILOTBBT PBTSOURCEBPL) of FCBBT with 0) + (replace (PILOTBBT PBTUSEGRAY) of FCBBT with T) + [replace (PILOTBBT PBTGRAYWIDTHLESSONE) of FCBBT + with (SUB1 (SETQ GRAYWIDTH (IMIN (fetch (BITMAP BITMAPWIDTH) of TEXTUREBM) + 16] + [replace (PILOTBBT PBTGRAYHEIGHTLESSONE) of FCBBT + with (SUB1 (SETQ GRAYHEIGHT (IMIN (fetch (BITMAP BITMAPHEIGHT) of TEXTUREBM + ) + 16] + (replace (PILOTBBT PBTDISJOINT) of FCBBT with T) + (\SETPBTFUNCTION FCBBT 'TEXTURE OPERATION) + (replace (PILOTBBT PBTHEIGHT) of FCBBT with 1) + (* ; + "take into account the brush thickness.") + (SETQ CX (\DSPTRANSFORMX CENTERX DISPLAYDATA)) + (SETQ CY (\DSPTRANSFORMY CENTERY DISPLAYDATA)) + (* ; + "change Y TOP and BOTTOM to be in bitmap coordinates") + (SETQ CY (SUB1 (\SFInvert DestinationBitMap CY))) + (SETQ TOP (SUB1 (\SFInvert DestinationBitMap TOP))) + (SETQ BOTTOM (SUB1 (\SFInvert DestinationBitMap BOTTOM))) + (swap TOP BOTTOM) + (\INSURETOPWDS DISPLAYSTREAM) + + (* ;; "Move the window to top while interruptable, but verify that it is still there uninterruptably with drawing points") + + (COND + ((EQ RADIUS 0) (* ; + "put a single point down. Use \LINEBLT to get proper texture. NIL") + (.WHILE.TOP.DS. DISPLAYSTREAM + (\LINEBLT FCBBT CX CY CX DESTINATIONBASE RASTERWIDTH LEFT RIGHT + BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS)) + (RETURN))) + LP (* ; + "(UNFOLD x 2) is used instead of (ITIMES x 2)") + [COND + [(IGREATERP 0 D) + (SETQ X (ADD1 X)) + (COND + ((IGREATERP (UNFOLD (IPLUS D Y) + 2) + 1) + (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y) + 2) + 4))) + (T (SETQ D (IPLUS D (UNFOLD X 2) + 1)) (* ; "don't draw unless Y changes.") + (GO LP] + ((OR (EQ 0 D) + (IGREATERP X D)) + (SETQ X (ADD1 X)) + (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y) + 2) + 4))) + (T (SETQ D (IPLUS (IDIFFERENCE D (UNFOLD Y 2)) + 3] + (COND + ((EQ Y 0) (* ; + "draw the middle line differently to avoid duplication.") + (.WHILE.TOP.DS. DISPLAYSTREAM + (\LINEBLT FCBBT (IDIFFERENCE CX X) + CY + (IPLUS CX X) + DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH + GRAYHEIGHT GRAYBASE NBITS))) + (T (.WHILE.TOP.DS. DISPLAYSTREAM (\FILLCIRCLEBLT CX CY X Y)) + (SETQ Y (SUB1 Y)) + (GO LP))) + (MOVETO CENTERX CENTERY DISPLAYSTREAM) + (RETURN NIL]) + +(\LINEBLT + [LAMBDA (BBT X Y XRIGHT DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT + GRAYBASE NBITS) (* kbr%: "15-Feb-86 22:08") + + (* ;; "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 (PILOTBBT PBTDEST) of BBT with (\ADDBASE DESTINATIONBASE (ITIMES RASTERWIDTH Y))) + [freplace (PILOTBBT PBTSOURCE) of BBT with (\ADDBASE GRAYBASE (freplace (PILOTBBT + PBTGRAYOFFSET + ) + of BBT + with (MOD Y GRAYHEIGHT] + (SELECTQ NBITS + (1 (freplace (PILOTBBT PBTDESTBIT) of BBT with X) + (freplace (PILOTBBT PBTSOURCEBIT) of BBT with (MOD X GRAYWIDTH)) + (freplace (PILOTBBT PBTWIDTH) of BBT with (ADD1 (IDIFFERENCE XRIGHT X)))) + (4 (* ; + "color case, shift x values {which are in pixels} into bit values.") + (freplace (PILOTBBT PBTDESTBIT) of BBT with (SETQ X (LLSH X 2))) + (* ; + "if TEXTURE is not a multiple of nbits wide this is probably garbage.") + (freplace (PILOTBBT PBTSOURCEBIT) of BBT with (MOD X GRAYWIDTH)) + (freplace (PILOTBBT PBTWIDTH) of BBT with (IDIFFERENCE (LLSH (ADD1 XRIGHT) + 2) + X))) + (8 (* ; + "color case, shift x values {which are in pixels} into bit values.") + (freplace (PILOTBBT PBTDESTBIT) of BBT with (SETQ X (LLSH X 3))) + (freplace (PILOTBBT PBTSOURCEBIT) of BBT with (MOD X GRAYWIDTH)) + (freplace (PILOTBBT PBTWIDTH) of BBT with (IDIFFERENCE (LLSH (ADD1 XRIGHT) + 3) + X))) + (24 (* ; + "color case, shift x values {which are in pixels} into bit values.") + (freplace (PILOTBBT PBTDESTBIT) of BBT with (SETQ X (ITIMES 24 X))) + (freplace (PILOTBBT PBTSOURCEBIT) of BBT with (MOD X GRAYWIDTH)) + (freplace (PILOTBBT PBTWIDTH) of BBT with (IDIFFERENCE (ITIMES 24 (ADD1 XRIGHT)) + X))) + (SHOULDNT)) + (\PILOTBITBLT BBT 0]) +) + + + +(* ; "making and copying bitmaps") + +(DEFINEQ + +(SCREENBITMAP + [LAMBDA (SCREEN) (* ; "Edited 20-Feb-87 14:57 by rrb") + + (* ;; "Return bitmap destination of SCREEN.") + + (COND + ((NULL SCREEN) + ScreenBitMap) + ((type? SCREEN SCREEN) + (fetch (SCREEN SCDESTINATION) of SCREEN)) + ((WINDOWP SCREEN) + (fetch (SCREEN SCDESTINATION) of (fetch (WINDOW SCREEN) of SCREEN))) + (T (\ILLEGAL.ARG SCREEN]) + +(BITMAPP + [LAMBDA (X) (* rrb "25-JUN-82 15:21") + (* ; "is x a bitmap?") + (AND (type? BITMAP X) + X]) + +(BITMAPHEIGHT + [LAMBDA (BITMAP) (* kbr%: " 8-Jul-85 16:01") + + (* ;; "returns the height in pixels of a bitmap.") + + (COND + ((type? BITMAP BITMAP) + (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) + ((type? WINDOW BITMAP) + (WINDOWPROP BITMAP 'HEIGHT)) + (T (\ILLEGAL.ARG BITMAP]) + +(BITSPERPIXEL + [LAMBDA (BITMAP) (* ; "Edited 15-Feb-94 16:10 by nilsson") + + (* ;; "returns the height in pixels of a bitmap.") + + (COND + ((type? BITMAP BITMAP) + (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)) + ((type? SCREEN BITMAP) + + (* ;; "Read the propper slots, not the implicit bitmap.") + + (OR (fetch (SCREEN SCDEPTH) of BITMAP) + (fetch (SCREEN SCBITSPERPIXEL) of BITMAP))) + ((type? WINDOW BITMAP) + (BITSPERPIXEL (fetch (WINDOW SCREEN) of BITMAP))) + ((ARRAYP BITMAP) (* ; "Consider array to be a colormap.") + (SELECTQ (ARRAYSIZE BITMAP) + (256 8) + (16 4) + (LISPERROR "ILLEGAL ARG" BITMAP))) + (T (LISPERROR "ILLEGAL ARG" BITMAP]) +) +(* "FOLLOWING DEFINITIONS EXPORTED")(PUTDEF (QUOTE BITMAPS) (QUOTE FILEPKGCOMS) '[(COM + MACRO + (X (VARS . X]) +(PUTDEF (QUOTE CURSORS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (MAPC 'X 'PRINTCURSOR]) + +(* "END EXPORTED DEFINITIONS") + +(DECLARE%: EVAL@COMPILE +(* "FOLLOWING DEFINITIONS EXPORTED") +(ADDTOVAR GLOBALVARS SCREENHEIGHT SCREENWIDTH ScreenBitMap) + +(* "END EXPORTED DEFINITIONS") + +) + + + +(* ; "Display stream functions that are not needed in the primitive system") + +(DEFINEQ + +(DSPFILL + [LAMBDA (REGION TEXTURE OPERATION STREAM) (* kbr%: " 8-Jul-85 15:40") + + (* ;; "wipes a region of an imagestream with texture.") + + (* ;; "TEXTURE and OPERATION default to those of STREAM") + + (PROG (STRM) + (SETQ STRM (\OUTSTREAMARG STREAM)) + (OR REGION (SETQ REGION (DSPCLIPPINGREGION NIL STRM))) + (RETURN (BLTSHADE TEXTURE STRM (fetch (REGION LEFT) of REGION) + (fetch (REGION BOTTOM) of REGION) + (fetch (REGION WIDTH) of REGION) + (fetch (REGION HEIGHT) of REGION) + OPERATION]) + +(INVERTW + [LAMBDA (WIN SHADE) (* rrb "18-May-84 21:52") + + (* ;; "inverts a window and returns the window. Used in RESETFORMS.") + + (DSPFILL (DSPCLIPPINGREGION NIL WIN) + (OR SHADE BLACKSHADE) + 'INVERT WIN) + WIN]) +) +(DEFINEQ + +(\DSPCOLOR.DISPLAY + [LAMBDA (STREAM COLOR) (* ; "Edited 29-Jan-91 11:33 by matsuda") + + (* ;; "sets and returns a display stream's background color.") + + (PROG (DD COLORCELL DESTINATION BITSPERPIXEL) + (SETQ DD (\GETDISPLAYDATA STREAM)) + (SETQ COLORCELL (fetch (\DISPLAYDATA DDCOLOR) of DD)) + (SETQ DESTINATION (fetch (\DISPLAYDATA DDDestination) of DD)) + (SETQ BITSPERPIXEL (BITSPERPIXEL DESTINATION)) + (RETURN (COND + (COLOR (SETQ COLOR (COLORNUMBERP COLOR BITSPERPIXEL)) + (PROG1 (COND + (COLORCELL (PROG1 (CAR COLORCELL) + (RPLACA COLORCELL COLOR))) + (T (* ; "no color cell yet, make one.") + (replace (\DISPLAYDATA DDCOLOR) of DD + with (CONS COLOR 0)) + (MAXIMUMCOLOR BITSPERPIXEL))) + (\SFFixFont STREAM DD))) + (T (OR (CAR COLORCELL) + (MAXIMUMCOLOR BITSPERPIXEL]) + +(\DSPBACKCOLOR.DISPLAY + [LAMBDA (STREAM COLOR) (* kbr%: "25-Aug-85 18:15") + + (* ;; "sets and returns a display stream's foreground color.") + + (PROG (DD COLORCELL DESTINATION BITSPERPIXEL) + (SETQ DD (\GETDISPLAYDATA STREAM)) + (SETQ COLORCELL (fetch (\DISPLAYDATA DDCOLOR) of DD)) + (RETURN (COND + (COLOR (SETQ DESTINATION (fetch (\DISPLAYDATA DDDestination) of DD)) + (SETQ BITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTINATION)) + (SETQ COLOR (COLORNUMBERP COLOR BITSPERPIXEL)) + (PROG1 (COND + (COLORCELL (PROG1 (CDR COLORCELL) + (RPLACD COLORCELL COLOR))) + (T (* ; "no color cell yet, make one.") + (replace (\DISPLAYDATA DDCOLOR) of DD + with (CONS (MAXIMUMCOLOR BITSPERPIXEL) + COLOR)) + 0)) + (\SFFixFont STREAM DD))) + (T (OR (CDR COLORCELL) + 0]) + +(DSPEOLFN + [LAMBDA (EOLFN DISPLAYSTREAM) (* rrb "18-May-84 21:44") + + (* ;; "sets the end of line function for a displaystream. EOLFN will be called every EOL with the argument of the display stream. If EOLFN is 'OFF, the eolfn is cleared.") + + (PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM))) + (RETURN (PROG1 (COND + ((fetch (\DISPLAYDATA DDEOLFN) of DD)) + (T 'OFF)) + [AND EOLFN (COND + [(LITATOM EOLFN) + (replace (\DISPLAYDATA DDEOLFN) of DD + with (COND + ((EQ EOLFN 'OFF) + NIL) + (T EOLFN] + (T (\ILLEGAL.ARG EOLFN])]) +) +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(RPAQQ BLACKSHADE 65535) + +(RPAQQ WHITESHADE 0) + + +(CONSTANTS (BLACKSHADE 65535) + (WHITESHADE 0)) +) + +(RPAQQ GRAYSHADE 43605) + +(ADDTOVAR GLOBALVARS GRAYSHADE) + +(* "END EXPORTED DEFINITIONS") + +(DECLARE%: EVAL@COMPILE + +(PUTPROPS DSPRUBOUTCHAR MACRO ((DS CHAR X Y TTBL) + (\DSPMOVELR DS CHAR X Y TTBL NIL T))) +) +(DEFINEQ + +(DSPCLEOL + [LAMBDA (DISPLAYSTREAM XPOS YPOS HEIGHT) (* lmm " 3-May-84 10:31") + (\CHECKCARET DISPLAYSTREAM) + (PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM DISPLAYSTREAM))) + (RETURN (BITBLT NIL NIL NIL DISPLAYSTREAM (OR (FIXP XPOS) + (SETQ XPOS (ffetch DDLeftMargin of DD))) + [OR (FIXP YPOS) + (IDIFFERENCE (ffetch DDYPOSITION of DD) + (FONTPROP DISPLAYSTREAM 'DESCENT] + (IMAX 0 (IDIFFERENCE (ffetch DDRightMargin of DD) + XPOS)) + (OR (FIXP HEIGHT) + (IMINUS (ffetch DDLINEFEED of DD))) + 'TEXTURE + 'REPLACE]) + +(DSPRUBOUTCHAR + [LAMBDA (STREAM CHAR X Y TTBL) (* Pavel " 6-Oct-86 22:44") + (if (DISPLAYSTREAMP CHAR) + then + (* ;; "Some older code may use the CHAR argument first.") + + (swap STREAM CHAR) + (SETQ TTBL X) + (SETQ X) + (SETQ Y)) + (\GETDISPLAYDATA STREAM STREAM) + (\DSPMOVELR STREAM CHAR X Y TTBL NIL T]) + +(\DSPMOVELR + [LAMBDA (DS CHAR X Y TTBL RIGHTWARDSFLG ERASEFLG) (* JonL " 7-May-84 02:47") + + (* ;; "Moves the cursor 'leftwards' (or 'rightwards' if RIGHTWARDSFLG is non-null) over any main character and control or meta indicators. Returns NIL if the move can't be determined, such as trying to move left when already at the left margin. Effaces (or 'Rubs out') any bits moved over if ERASEFLG is non-null.") + + ([LAMBDA (DD) + + (* ;; + "Must do the \GETDISPLAYDATA first, since it may reset DS when it coerces to a DISPLAYSTREAM") + + (PROG [(WIDTH (\STREAMCHARWIDTH (COND + ((CHARCODEP CHAR) + CHAR) + (T (CHARCODE M))) + DS TTBL)) + (DEFAULTPOS? (AND (NULL X) + (NULL Y] + (OR ERASEFLG DEFAULTPOS? (SHOULDNT)) (* ; + "CURSORLEFT and CURSORRIGHT commands aren't allowed to start from anywhere except current spot") + + (* ;; "Note that if CHAR is not specified and DS has a variable-pitch font, then the results may be somewhat random. Smart terminal drivers thus can work well only on fixed-pitch fonts.") + + (COND + ((NULL WIDTH) + (RETURN)) + ((EQ 0 WIDTH) (* ; "Ha, what an easy case") + (RETURN T))) + (OR (FIXP X) + (SETQ X (ffetch DDXPOSITION of DD))) + (OR (FIXP Y) + (SETQ Y (ffetch DDYPOSITION of DD))) + (COND + ([COND + (RIGHTWARDSFLG (IGREATERP (add X WIDTH) + (ffetch DDRightMargin of DD))) + (T (ILESSP (add X (IMINUS WIDTH)) + (ffetch DDLeftMargin of DD] (* ; + "If we can't do the full backup, then return NIL to signal this fact") + (RETURN))) + (\CHECKCARET DS) (* ; + "Take down the caret, if there is one, just in case we are moving over it.") + [COND + (ERASEFLG (* ; "And do the erasure if requested") + ([LAMBDA (FONT) + (PROG ((YPRIME (IDIFFERENCE Y (FONTDESCENT FONT))) + (HEIGHT (FONTHEIGHT FONT))) + (COND + ((NOT DEFAULTPOS?) + (MOVETO X Y DS) (* ; + "Backup over the bits, and 'wipe' them out.") + )) + (BITBLT NIL 0 0 DS X YPRIME WIDTH HEIGHT 'TEXTURE 'REPLACE) + (* ; "wipe out some bits") + ] + (ffetch DDFONT of DD] + (DSPXPOSITION X DS) (* ; "Now do the move.") + (RETURN T] + (\GETDISPLAYDATA DS DS]) +) + + + +(* ; "for cursor") + + +(RPAQQ \DefaultCursor #*(16 16)H@@@L@@@N@@@O@@@OH@@OL@@ON@@O@@@MH@@IH@@@L@@@L@@@F@@@F@@@C@@@C@@) +(DEFINEQ + +(\CURSOR.DEFPRINT + [LAMBDA (CURSOR STREAM) (* ; "Edited 15-Sep-94 16:13 by sybalsky") + (COND + (*PRINT-ARRAY* (PRIN1 "#,(LET(image) (CURSORCREATE (SETQ image '" STREAM) + (PRIN4 (fetch (CURSOR CUIMAGE) of CURSOR) + STREAM) + (PRIN1 ") " STREAM) + (COND + ((EQ (fetch (CURSOR CUIMAGE) of CURSOR) + (fetch (CURSOR CUMASK) of CURSOR)) + (PRIN1 " image " STREAM)) + (T (PRIN1 " '" STREAM) + (PRIN4 (fetch (CURSOR CUMASK) of CURSOR) + STREAM))) + (PRIN1 " " STREAM) + (PRIN1 (fetch (CURSOR CUHOTSPOTX) of CURSOR) + STREAM) + (PRIN1 " " STREAM) + (PRIN1 (fetch (CURSOR CUHOTSPOTY) of CURSOR) + STREAM) + (PRIN1 " " STREAM) + (PRIN1 (fetch (CURSOR CUDATA) of CURSOR) + STREAM) + (PRIN1 "))" STREAM]) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(RPAQ? DEFAULTCURSOR (CURSORCREATE \DefaultCursor NIL 0 15)) + + +(COND + ((NULL \CURRENTCURSOR) + (SETQ \CURRENTCURSOR DEFAULTCURSOR))) + +(DEFPRINT 'CURSOR '\CURSOR.DEFPRINT) +) +(DECLARE%: DONTCOPY +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS DEFAULTCURSOR) +) +) + + + +(* ; "stuff to interpret colors as textures which is needed even in system that don't have color.") + +(DEFINEQ + +(TEXTUREOFCOLOR + [LAMBDA (COLOR NOERRORFLG) (* rrb "30-Oct-85 19:43") + + (* ;; "returns a texture to represent a color on a black and white display") + + (PROG ((RGB (INSURE.RGB.COLOR COLOR NOERRORFLG))) + (RETURN (COND + ((NULL RGB) + NIL) + ((AND (IGREATERP (fetch (RGB RED) of RGB) + 245) + (IGREATERP (fetch (RGB GREEN) of RGB) + 245) + (IGREATERP (fetch (RGB BLUE) of RGB) + 245)) (* ; "special case white") + BLACKSHADE16) + (T (PROG [(TEX (\PRIMARYTEXTURE 'RED (fetch (RGB RED) of RGB] + (BITBLT NIL NIL NIL TEX 0 0 16 16 'TEXTURE 'PAINT + (\PRIMARYTEXTURE 'BLUE (fetch (RGB BLUE) of RGB))) + (BITBLT NIL NIL NIL TEX 0 0 16 16 'TEXTURE 'PAINT + (\PRIMARYTEXTURE 'GREEN (fetch (RGB GREEN) of RGB))) + (RETURN TEX]) + +(\PRIMARYTEXTURE + [LAMBDA (PRIMARY LEVEL) (* rrb "30-Oct-85 19:25") + + (* ;; "returns the 16x16 texture for a primary color level.") + + (PROG [(TEXTURE (BITMAPCOPY (SELECTQ PRIMARY + (RED REDTEXTURE) + (BLUE BLUETEXTURE) + (GREEN GREENTEXTURE) + (\ILLEGAL.ARG PRIMARY] + (BITBLT (\LEVELTEXTURE LEVEL) + 0 0 TEXTURE 0 0 16 16 'INPUT 'ERASE) + (RETURN TEXTURE]) + +(\LEVELTEXTURE + [LAMBDA (LEVEL) (* rrb "20-Aug-85 16:42") + + (* ;; "returns a 16x16 texture which is merged so that only light bits on both go to light with a primary color pattern to get a level primary pattern.") + + (COND + ((ILESSP LEVEL 100) + BLACKSHADE16) + ((ILESSP LEVEL 150) + DARKGRAY16) + ((ILESSP LEVEL 200) + MEDIUMGRAY16) + ((ILESSP LEVEL 245) + LIGHTGRAY16) + (T WHITESHADE16]) + +(INSURE.B&W.TEXTURE + [LAMBDA (TEXTURE NOERRORFLG) (* rrb "30-Oct-85 19:47") + + (* ;; "coerces a TEXTURE argument to a 1 bit per pixel bitmap or small number") + + (SELECTQ (TYPENAME TEXTURE) + (LITATOM (* ; "includes NIL case") + (COND + (TEXTURE (* ; "should be a color name") + (TEXTUREOFCOLOR (INSURE.RGB.COLOR TEXTURE NOERRORFLG))) + (T WHITESHADE))) + ((SMALLP FIXP) + (LOGAND TEXTURE BLACKSHADE)) + (BITMAP TEXTURE) + (LISTP (* ; + "can be a list of (TEXTURE COLOR) or a list of levels rgb or hls.") + (COND + ((TEXTUREOFCOLOR TEXTURE T)) + ((CAR TEXTURE) + (INSURE.B&W.TEXTURE (CAR TEXTURE) + NOERRORFLG)) + ((CAR (LISTP (CDR TEXTURE))) + (TEXTUREOFCOLOR (CADR TEXTURE) + NOERRORFLG)) + (T (* ; "list of form (NIL NIL)") + WHITESHADE))) + (COND + ((NULL NOERRORFLG) + (\ILLEGAL.ARG TEXTURE]) + +(INSURE.RGB.COLOR + [LAMBDA (COLOR NOERRFLG) (* rrb "30-Oct-85 19:34") + (* ; + "returns the RGB triple for a color.") + (PROG (LEVELS) + (RETURN (COND + [(FIXP COLOR) (* ; + "don't know what to do with color numbers so error") + (COND + (NOERRFLG NIL) + (T (\ILLEGAL.ARG COLOR] + [(LITATOM COLOR) + (COND + ((SETQ LEVELS (\LOOKUPCOLORNAME COLOR)) + (* ; "recursively look up color number") + (INSURE.RGB.COLOR (CDR LEVELS) + NOERRFLG)) + (NOERRFLG NIL) + (T (ERROR "Unknown color name" COLOR] + ((HLSP COLOR) (* ; "HLS form convert to RGB") + (HLSTORGB COLOR)) + ((RGBP COLOR) (* ; "check for RGB or HLS") + COLOR) + (NOERRFLG NIL) + (T (\ILLEGAL.ARG COLOR]) + +(\LOOKUPCOLORNAME + [LAMBDA (COLORNAME) (* rrb "13-DEC-82 13:14") + + (* ;; "looks up a prospective color name. Returns a list whose CAR is the name and whose CDR is a color spec.") + + (FASSOC COLORNAME COLORNAMES]) + +(RGBP + [LAMBDA (X) (* rrb "27-OCT-82 10:15") + (* ; + "return X if it is a red green blue triple.") + (PROG (TMP) + (RETURN (AND (LISTP X) + (SMALLP (SETQ TMP (CAR X))) + (IGREATERP TMP -1) + (IGREATERP 256 TMP) + (SMALLP (SETQ TMP (CADR X))) + (IGREATERP TMP -1) + (IGREATERP 256 TMP) + (SMALLP (SETQ TMP (CADDR X))) + (IGREATERP TMP -1) + (IGREATERP 256 TMP) + X]) + +(HLSP + [LAMBDA (X) (* rrb "31-Oct-85 10:51") + + (* ;; "return T if X is a hue lightness saturation triple.") + + (AND (NUMBERP (CAR (LISTP X))) + (IGREATERP (CAR X) + -1) + (IGREATERP 361 (CAR X)) + [FLOATP (CAR (LISTP (CDR X] + [FLOATP (CAR (LISTP (CDDR X] + X]) + +(HLSTORGB + [LAMBDA (HLS) (* rrb "30-Oct-85 19:59") + + (* ;; "converts from a hue saturation lightness triple into red green blue triple. HUE is in range 0 to 360, lightness and saturation are in the range 0 to 1.0") + + (* ;; "this algorithm was taken from siggraph vol 13 number 3 August 1979: Status report on graphics standards planning committee.") + + (PROG ((H (fetch (HLS HUE) of HLS)) + (L (fetch (HLS LIGHTNESS) of HLS)) + (S (fetch (HLS SATURATION) of HLS)) + Max Min) + [SETQ Max (COND + ((FGREATERP 0.5 L) + (FTIMES L (FPLUS 1.0 S))) + (T (FDIFFERENCE (FPLUS L S) + (FTIMES L S] + (SETQ Min (FDIFFERENCE (FTIMES L 2) + Max)) + (RETURN (create RGB + RED _ (\HLSVALUEFN Min Max H) + GREEN _ (\HLSVALUEFN Min Max (IDIFFERENCE H 120)) + BLUE _ (\HLSVALUEFN Min Max (IDIFFERENCE H 240]) + +(\HLSVALUEFN + [LAMBDA (MIN MAX HUE) (* rrb "25-OCT-82 10:47") + + (* ;; "internal value function for converting from HLS to RGB.") + + [COND + ((ILESSP HUE 0) + (SETQ HUE (IPLUS HUE 360] + (FIX (FTIMES (COND + ((ILESSP HUE 60) + (FPLUS MIN (FQUOTIENT (FTIMES (FDIFFERENCE MAX MIN) + HUE) + 60))) + ((ILESSP HUE 180) + MAX) + ((ILESSP HUE 240) + (FPLUS MIN (FQUOTIENT (FTIMES (FDIFFERENCE MAX MIN) + (FDIFFERENCE 240 HUE)) + 60))) + (T MIN)) + 255]) +) + +(RPAQQ COLORNAMES + ((WHITE 255 255 255) + (CYAN 0 255 255) + (MAGENTA 255 0 255) + (YELLOW 255 255 0) + (RED 255 0 0) + (GREEN 0 255 0) + (BLUE 0 0 255) + (BLACK 0 0 0))) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS COLORNAMES) +) +(DECLARE%: DONTCOPY +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS BLACKSHADE16 DARKGRAY16 MEDIUMGRAY16 LIGHTGRAY16 WHITESHADE16 REDTEXTURE GREENTEXTURE + BLUETEXTURE) +) +) + +(READVARS-FROM-STRINGS '(BLACKSHADE16 DARKGRAY16 MEDIUMGRAY16 LIGHTGRAY16 WHITESHADE16 REDTEXTURE + GREENTEXTURE BLUETEXTURE) + "({(READBITMAP)(16 16 +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%")} {(READBITMAP)(16 16 +%"NMGG%" +%"KGMM%" +%"MNKK%" +%"GKNN%" +%"MNKK%" +%"GKNM%" +%"NMGN%" +%"KGMG%" +%"NKKM%" +%"KNNK%" +%"GGMN%" +%"MMGG%" +%"GGKM%" +%"MJOG%" +%"NOEK%" +%"KMNN%")} {(READBITMAP)(16 16 +%"JJJJ%" +%"EEEE%" +%"JJJJ%" +%"EEEE%" +%"JJJJ%" +%"EEEE%" +%"JJJJ%" +%"EEEE%" +%"JJJJ%" +%"EEEE%" +%"JJJJ%" +%"EEEE%" +%"JJJJ%" +%"EEEE%" +%"JJJJ%" +%"EEEE%")} {(READBITMAP)(16 16 +%"HBDB%" +%"BHAA%" +%"DDHD%" +%"AABH%" +%"HHDA%" +%"BBAD%" +%"DDHB%" +%"AABH%" +%"HDAD%" +%"AADA%" +%"DHBH%" +%"BBHB%" +%"HHAD%" +%"ABDA%" +%"DDHH%" +%"BABB%")} {(READBITMAP)(16 16 +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%")} {(READBITMAP)(16 16 +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%")} {(READBITMAP)(16 16 +%"CLCL%" +%"O@O@%" +%"LCLC%" +%"@O@O%" +%"CLCL%" +%"O@O@%" +%"LCLC%" +%"@O@O%" +%"CLCL%" +%"O@O@%" +%"LCLC%" +%"@O@O%" +%"CLCL%" +%"O@O@%" +%"LCLC%" +%"@O@O%")} {(READBITMAP)(16 16 +%"LFGA%" +%"NCCH%" +%"GAIL%" +%"CHLN%" +%"ALFG%" +%"HNCC%" +%"LGAI%" +%"NCHL%" +%"GALF%" +%"CHNC%" +%"ILGA%" +%"LNCH%" +%"FGAL%" +%"CCHN%" +%"AILG%" +%"HLNC%")}) +") +(DECLARE%: DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(RECORD HLS (HUE LIGHTNESS SATURATION)) + +(RECORD RGB (RED GREEN BLUE)) +) + +(* "END EXPORTED DEFINITIONS") + +) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA ) + +(ADDTOVAR NLAML ) + +(ADDTOVAR LAMA UNIONREGIONS INTERSECTREGIONS) +) +(PUTPROPS ADISPLAY COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991 + 1993 1994 2021)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (12017 19378 (\BBTCURVEPT 12027 . 19376)) (19379 29195 (CREATETEXTUREFROMBITMAP 19389 . +21319) (PRINTBITMAP 21321 . 22672) (PRINT-BITMAPS-NICELY 22674 . 26525) (PRINTCURSOR 26527 . 27560) ( +\WRITEBITMAP 27562 . 29193)) (29238 31786 (\GETINTEGERPART 29248 . 30793) (\CONVERTTOFRACTION 30795 . +31784)) (31923 32795 (CURSORP 31933 . 32152) (CURSORBITMAP 32154 . 32200) (CreateCursorBitMap 32202 . +32793)) (37157 46200 (CARET 37167 . 38927) (\CARET.CREATE 38929 . 39107) (\CARET.DOWN 39109 . 40461) ( +\CARET.FLASH? 40463 . 42277) (\CARET.SHOW 42279 . 42848) (CARETRATE 42850 . 43508) (\CARET.FLASH.AGAIN + 43510 . 44676) (\CARET.FLASH.MULTIPLE 44678 . 45201) (\CARET.FLASH 45203 . 46198)) (46201 51273 ( +\MEDW.CARET.SHOW 46211 . 51271)) (51637 53472 (\AREAVISIBLE? 51647 . 52571) (\REGIONOVERLAPAREAP 52573 + . 53118) (\AREAINREGIONP 53120 . 53470)) (53521 65997 (CREATEREGION 53531 . 53867) (REGIONP 53869 . +54015) (INTERSECTREGIONS 54017 . 56787) (UNIONREGIONS 56789 . 58940) (REGIONSINTERSECTP 58942 . 59550) + (SUBREGIONP 59552 . 60197) (EXTENDREGION 60199 . 62356) (EXTENDREGIONBOTTOM 62358 . 63000) ( +EXTENDREGIONLEFT 63002 . 63621) (EXTENDREGIONRIGHT 63623 . 64176) (EXTENDREGIONTOP 64178 . 64719) ( +INSIDEP 64721 . 65489) (STRINGREGION 65491 . 65995)) (66242 71516 (\BRUSHBITMAP 66252 . 67969) ( +\GETBRUSH 67971 . 68282) (\GETBRUSHBBT 68284 . 70312) (\InitCurveBrushes 70314 . 71380) ( +\BrushFromWidth 71382 . 71514)) (71517 74584 (\MAKEBRUSH.DIAGONAL 71527 . 71807) ( +\MAKEBRUSH.HORIZONTAL 71809 . 72203) (\MAKEBRUSH.VERTICAL 72205 . 72517) (\MAKEBRUSH.SQUARE 72519 . +72796) (\MAKEBRUSH.ROUND 72798 . 74582)) (74585 75750 (INSTALLBRUSH 74595 . 75748)) (76151 80623 ( +\DRAWLINE.DISPLAY 76161 . 79338) (RELMOVETO 79340 . 79727) (MOVETOUPPERLEFT 79729 . 80621)) (80624 +104109 (\CLIPANDDRAWLINE 80634 . 87080) (\CLIPANDDRAWLINE1 87082 . 98830) (\CLIPCODE 98832 . 100206) ( +\LEASTPTAT 100208 . 100806) (\GREATESTPTAT 100808 . 101436) (\DRAWLINE1 101438 . 102554) ( +\DRAWLINE.UFN 102556 . 104107)) (108639 154686 (\DRAWCIRCLE.DISPLAY 108649 . 117462) (\DRAWARC.DISPLAY + 117464 . 117754) (\DRAWARC.GENERIC 117756 . 118509) (\COMPUTE.ARC.POINTS 118511 . 120776) ( +\DRAWELLIPSE.DISPLAY 120778 . 136447) (\DRAWCURVE.DISPLAY 136449 . 138738) (\DRAWPOINT.DISPLAY 138740 + . 139936) (\DRAWPOLYGON.DISPLAY 139938 . 143466) (\LINEWITHBRUSH 143468 . 154684)) (154687 186379 ( +LOADPOLY 154697 . 155257) (PARAMETRICSPLINE 155259 . 165456) (\CURVE 165458 . 171060) (\CURVE2 171062 + . 182393) (\CURVEEND 182395 . 182877) (\CURVESLOPE 182879 . 185362) (\CURVESTART 185364 . 185688) ( +\FDIFS/FROM/DERIVS 185690 . 186377)) (198908 213244 (\FILLCIRCLE.DISPLAY 198918 . 209666) (\LINEBLT +209668 . 213242)) (213288 215288 (SCREENBITMAP 213298 . 213775) (BITMAPP 213777 . 214011) ( +BITMAPHEIGHT 214013 . 214389) (BITSPERPIXEL 214391 . 215286)) (215929 216922 (DSPFILL 215939 . 216622) + (INVERTW 216624 . 216920)) (216923 220566 (\DSPCOLOR.DISPLAY 216933 . 218230) (\DSPBACKCOLOR.DISPLAY +218232 . 219611) (DSPEOLFN 219613 . 220564)) (220999 225653 (DSPCLEOL 221009 . 221885) (DSPRUBOUTCHAR +221887 . 222319) (\DSPMOVELR 222321 . 225651)) (225783 226901 (\CURSOR.DEFPRINT 225793 . 226899)) ( +227313 235887 (TEXTUREOFCOLOR 227323 . 228585) (\PRIMARYTEXTURE 228587 . 229169) (\LEVELTEXTURE 229171 + . 229672) (INSURE.B&W.TEXTURE 229674 . 231069) (INSURE.RGB.COLOR 231071 . 232499) (\LOOKUPCOLORNAME +232501 . 232771) (RGBP 232773 . 233538) (HLSP 233540 . 233915) (HLSTORGB 233917 . 235057) (\HLSVALUEFN + 235059 . 235885))))) +STOP diff --git a/sources/ADISPLAY.LCOM b/sources/ADISPLAY.LCOM index b01836efc417c0682410755f0705b1cfd9f7d359..efa56474dbb06db048027cf31ecdb64bb1db7503 100644 GIT binary patch delta 11866 zcmbtad2|%VnOBd*C42tOAKXWoA`nxfN|m=hQnY$KGqK8#ddrofH!X!@PYG^b!6|`bzTxX`>U#+LnAq4 zpXZP1uIj3_b^@^!OT8UyZnY#fEhoduFc`*Q^(7!kw|0m^-eap`k`xxopb~E5%{vYf4RBacwvn z3k4D(e=-!rpgaz|jj~)Lh~&IbKTi=A)lhXsYzzgX$@=ESV5(=`x*D-Do(L_Bnw=f> zK~NEEWVOEa=JoV7WKq@{CACrY)G!)?oGNk1g+eiD8u3(7acy03>irSF5YX-$^)=ou z9lcYiD6Ul{u{oM-^T$P>eN$IVem2I3p+fPJGEEiZqE}3q7OuKDy)lxysrZs(Tyd?I zo`~@`j+-kKryd+vOIJ8ivH}0~<7?5iaJ-jxeYdohElQ4+t{z?79*t3s$TxpfPOfow zx_F0Zh_a*^93F=r9uyANt;P&U9m8F>v$dn>K82UbCfb*+%}v zRrc)+-PG=~3dTqI?O59Dnt}hNu50nGvLpsWVSi^V8Sp1UNj`PIYXAdwx>KCPMHOwm z9&u?hlxS-(!@)XH`27f>VC3}$`0eT|IL>ay(AL4id;1EWS@`zv`+l zeb+DN8&m$@ulj7IuUGT>#HE3l8JI7Lnue`pd)*L@`8!%fO;W|B^Fxc<{cWM7+1}aK z97>3)M;WG5l81IGUQCa+cXTE~R+KAi<*bZklIKCf1>&fF<{0Qi>eP2fGCp? zVn>ovQ8l=Sj+SURiCabN9sE@B>0*pORp>honyToY9O0?#9>T#2xoay@hE3ag;q1Je z9T_VQrWwM5HakPsgErW_z*-oLLh}nc z*hTOk8fn!mcVw)z;14ZMq0|%)QBU)Jlb_8R&efba-o`vl8}&3tyQ7z$KQ=$s$~{f* zJ>4)RO5q+hKWnvJuKupFe$&OKnl3u`WOw_euG0Rll76$)EHg{e&I%Ox>N&Hg^mk3_ zH>dE~Q|RojivDi1;!;<2e^*t%S#3@-t6utm+%`$-HATv{qf6}j>lFpH3iJ#T?TiK6 zldzhMu5lZcsfy*>sH_fSj$UKvKvm7NHt4>x+@t4iuVE{*Y~(AmtYoxDMo=BBBQSnj zeRM25NRvGVxu&9$?fk=~V+1!@Jb7<6AdQ)F1r12LxupkH2uzOW9^JswsCSsFw;mC&#V?)cjS zMyfYq0H$Rqa3__fka|enD3oG^oXb3MdoF<2&pcn}ye`sj?1h`^0Qd{FbFkF`TydL2 zC>RqyRNTbE?EX4tS_7$?uzfSZzIishlK1?OIfniwX2t`l^3_c&VkahT=i$0PQo1L^ z#vItduTG~BDcRoQaP&q>s`~jtr=`=Q`JnP9e{&$%5-AOj8(o0k{(46F&>VJ|denZ} z!d7XDhR5;sqm^`Ud0)Yy)$Fc+|Cy$h94cf;SM)R5p>U*x(H>vW-&gQY_8>Swa?n`X z+j4qz%c+`{Q`5W8wVayKa%yJxxh9Ms$H)hQO;^yH(t=tQhSz2;M8FnRcn$>jXx!f( z3?}?mEZU9;gb0hUg+MOL{6_I9_6?@8M~a7qwgkd4JUyG*i@6QW(MWS!L%SKI=s=Mb z>|=y)5gff2UW2Y+MUySfiB61=bvW~gX$BkUgjh!su>!sz&5BKq5u^SihZvk12M!IK zlHutU*&X0D#hYf*j9bADQP;&_M?44!5pDM;qh`BE{bMv13q|~~27e*~)m3Rou`vZQ z0l%mqJP+=mAZXAC;FQ4~YNb!)fJ9V)itJlBU-G?cCOHg#@hHT(s=QFvJhV3m`Pk#A zL$x_Z2o5Fu9dsY?iVH&t>eI!zKMLnAdoreD*i*^EYxe`$dquM|8Sk_~xO?8G)E8j; z%=RQ+K9GpUlWEvLwdphR&c3nPQ9CVXKVH3pBvFru=dLTal8c;MwIxpVLXN_*Vu#+1eji5^;U9t*_v4 zq>Og#><@g6HuwB3TDLT>7+uBJ{DfR+t_I;UKM0THgqv12gK+bbNGT^=LOXW$H(#Fc z`oM~5(}Udu2PRWnqNWrnjg&=Pk%~ywxUtkW`o1V6p9VGy50D#zR|+f1*5J$_4QY7> zB8vt^jzfBNsx?D1$j#9(G21bm6s#K%F|wn zh({_HY2YA3O;usV8EUGcNNUXq2@@UJ31Xe2@UWF{X)#a5v@{kb} zA7)mPVf* zg}I-!Q7Ar*4Oa}EEO^=tD7a~btIC5&!h)SFGkG$LmnDUKbEQjQ6DkpG?0kH1K)euX z707!>nH9kL^MXm?EhR76+r+3cLOPOhyUp=6PpU1@6|CY159-p6sczqm@zX!c@==4%!1^oTS+9Eu$_@6Lj^tK;qC z(^VpS&q-5UBB$fk*+IXHpO}D9=(B?l?1l#)Mlbc^f}c`|y(vk>fzr{V$%jUWVOTV| zaI}16ojB%?T2V^t>~hTd%v^P_)LdjPY3eC7SB)>}EBemjW7gUObF7|&V{M3KttZE= z6J^gcnACqg^}W&83i=A4Cf`{!t#Wl&334V(sUI{Y_3ENG1mP!S`;zIETe>Qc5)B>l z_L37q<+r=$bj=;+;l8DJJ1YJ+XH9cX-=E$?`s7imPwiDa3U;TtnR>~Ep*X@W%7%kG zn9k&mke~;-Q)C~UW{!vSX+wRe4+@j7#IoU=hD>X)ua~`8-$rTxPc)8H_If>eE9%tu zY=)vg4d(kD|i7U>;-g=*Ew4Ea8#gs7%Cva z8$Rd$Cba4YSywf%>cdjI$PENtuj(jpr#`&#r|D#U$C?;?)rL>piKi742e^d86%M14J^;6K~ScK<>FqL@kt|_Uv!jOHKL!_3}+Pgm$9H{(2 z;6a%xMUH%Z(EHrBq2>ZnV<_Y`Bo8@y&zX^U0hGt6rnku`=Y(-@xF=@ zyQ1{@)-{m!joVh?|MhLF@$V(`al~^U`JS+dmNhycUpO3wmRM%nOp`+N0o-LhXPou` zCeU;mStAOgRy3GwL9YQ=bi++s)~sK)WzB~5{B(ybduSs0;8X^bLcMf~CZ_Xn zG*C=7<89IQ&JLbpqe~afI3&aJXf(ZIODGy?NwPsmHbo$|TviRA7z?409Tt6($lfVI zhsR^&i-$%|IQ|b}fzvrq;vAUl9GL4o-xzVN9oW`4rh`o0-X(OBH=eALYppwgss9?8 za?okrV%-)IdkP~{04fT8*Hw*jsrA@_25T1u+9KDYAClACWnnj2@Te^On7r`BjD}~e zZL1Aozr?0jTL-KMt#4W1whmhRtf#E)*1uZcwf0*NSlg^8tR2=Pr1xP%*h>b!UrpY6 zxJUSy%zNZIfsiL2(Js%>tghPO7@7)Jz5+wPdNj>Y?T!**fOvQ4!cnq*NBHs#NnOft z3<=-=N(>$OK4(ZT4Vy6SuBN`fI3rV##cU<|W9sF(3U{>($JOD-z7khGkEg}d|M)23 zN91RZFA)M%g{D?875cB$UGc8Oa0@Se;wvp&_9S0;B3bq1WMKih|H;xW}y z;!|IVl{cSCvodpM$K{#m=~_P=6R+(2N=)3jE6v0kyT%pD2FnBy(!6k=ISw76Di)`(3MX})`p^8MMh4ZHxOBXhlaoF4S3qz*FreV z1-w`io;p8S0DRAXEm`*s9jNJaPpW!p-5^JFGR42y7r_b95V_0j%rP5$_}MBwv(0A) z#86%cq3D_nMM8;HEr25VVPNclp&r9_Xl~W?A8!(DXjP&x5)Y<$#u{*cI4`T~X&^R}`D*6`4Q1 zIy7V39(N&9F0|YZgJ&-)4cR%8R&d;!6*Pc&KHJbKvV0FswXy7`y>4h9HiKao>`EGh zs}NWkyQor51x%H|6>y0|@ew&vQAkrqG!;ch#AZ|!9ms-197RW7WFsKOLklN%nL$C3 zl1?j9JUU0^imK3>9&#IGO`MK`jK`)!lfpC|cHW+*Ba^50RyeQ|$iikz^z=Emk}mrw z5*geh$+XBPAy4Lb%>XjvtDr=g#lBuFp5|8e$~2#;KxL5DMsWYS3rF9;9h`&;FJhBW zaom`O&osTukWi?a0XL)mi2|Yn>WIr+q;HIb4<%Pl!2qtY2^cx>+mKkgi^W-yA ziwc3M$h3RiNNPsD9xF=y+fP3g1V1^_ccFBl*}8H>;SP4Vw5_i&LiQd=;so{c1K)D5 zaf;2>4&*$K0e1&EVtRr+p4uXuCuIkh3*R6&AN-N~U!3Cnp`(;TCrj@uH}6Kozq{|x zC(F&!15>vho>;N}8(%`yN7f%!9SXzqlf2X|v$_h-d;qHP*7kd2+m>xEucBHw)O)EK zt-_7NHrsPi+n~NnqCPj>g$i>HISoaeJTD-_h?ngtpQi#S=RZ>6_tTVQx^ z#nfBjd^*#TSRkuZBpS!;l_libIV(%U)K4VINEJQzj{?m@P*SBkT&hzNnYZ__G`tYU z1N7lU54^HJk?=3Zc^ORv)AyR;ql!JAef_|Xw!kjD!wMI2)Nj64F#%2@Gg^VWNY9k0 z2PwtJE?Hgk`Fvc%nO&35j_quQuED!&&@m5gAQW~Zqw*j%pxQxyUdRM#*q}BlI}-96 zxF?ys`}~~pV&oNkE^;GLrk|drDvwVPYVG7j!4B9beaIdWH-=;=Upq0^Jxn$O*^`VIo7S7EvIy-1af>Jo6#uF9V;Tw|HVB2%k8UT~Lv<6`&*Fl9vZ8mg+ zXEun$Y=Lyzg^yww7dVlAVr&gboLs2;tSW2Px$d()g;upyi<@`P_7ox05yn~~vYYo- zUxyDwtZQ+&)&#p;$?Y@*?53K-^O{RMUuN)7&&>)oCNinkF zT3Kumr8<<5<(G0k!Z`TSu1w}E(_~phh~b$tSE9`?k9F{h!`3adlry5crYLp)E0YS{ zbxv`z6^2u5$rf^2$#bVRk3VD9m{ZQ5?LOO8)88jNNPMRi_fDrcb?E5(PCtNZ#2^AQ zex9mbYfi!BDgB@$o;}}zNB|X8V09H z5c7~#C6qeyRz+=uA~2LH;YHG~WelQk3?)wsfRSJPnHIcM)Y$h`jFXrgctuhMIB^%D zDx**@R*3Q=JrplQy@noal;r4?1nYnEHMc|2;I`ZpgN!%mhkEv#8F;)i;-ZfcI#Z9m zKGMNUSi65YhMrpNe@kI)^5I*zqIuoh25;_oyOw3J)@kIRbux|KAZ*hP#EX}I``w2B1Nx382><{9 delta 12888 zcmbtbdw5jUwa>`}2uQ*tnS>A!P9o7nA)eQqnW0?CWM(oMGMO_@CLB;O1cJN*D2i_# zYG3NtuLZVZMXN&9tG1se4D_MG)V6xDmaE)rE40@ZY_<05y|4mpHHTvqoai%9=aZVC!(*2E$!3Vx+C+Vp+F+!Plkegi!>37w_e(&@{-%_ z_DcMsK#xBb4)rfgYW%deW&T7z@3)u;Xnp-`|Gzi3xATkQiO{l$HqgH?2)ZR?CC?(o z*TPTRefvVro&FIgI=CwK-xZHmRJFBNrT0zx35W9fDOZ~1m#6IK8mii4f$xeW`}}d< zXT7vnvD>Hm(DV<#t!F=(8gj@!iPcPVaZ>t%X}>M6s%lg0K4?0#Y5`Z34py}h@h#Qc z@cUME8>%MH@KDud&NgE_w#m7nvMLsd5;N@Q&J8ZJzvYOTzRc&rQ zFp%ii675Fgdum$iF(@C{vHiMj+q*Vi-#2uP`Q=A7_hf0Nm(?~HJk;HcVSigUAHUOG zmtl&czz0L!{()#R;7^2-X4loOaWuHRK5cSW+0Zv4@GFy{L|=#29c<^hjxw%n^6E1D z9b9ERrqcVN_y(g;jz4as(|8}5^n-Ucjql#HbMvP0!xxWKnw3-XD(mf*=h>C4d1gbZ z?5NSyB<#3ztn8W2!;|7`%8ZKig3k42_?t#Qhv@6BPUFL5s(7WAGYYSittmTngTFIi zkMIe2smwAnr_q;^ygq(qAgTp=1=32qldw9vqyGLLUi5hQm62HgKq90^VnI#kMOERG zq2)=fYbh_fB|g&UhyEs^@qNh^@lc!>Wgl;;uvv{NN#c`{zEC2xJRV7ef=hT`cAON5 z#z3{O0oF?LVQ7;VE!L4B#h1KTDznNU$4efC?~W{w^O8!FFc`PK$QS`rNcM(S^e2tZ zqEb{N`ec4(s-TewI@#GN9^)OxCCiCP9Exj?W+@o&@fHzxqfY^8SuLuN3?f}5>;cF~ zv`Ly{WJef?8;WbquD=Isuqf!A)`l*;U-Sx+#QwSITIh7=?0!?H@1K1D#YJ=OpGVus z>S(NIhd=C(#IpU_**Q{5%Gds~$IH30iq)iPHC$Pbp?-IF8jm~uhbJZ0l$%O>eNPR? zMGkN6^c!tI#jap2b1zLrh(P&@(Jz*@iL!^sBnP6wSkh3OeExY^D$*^;MwGH^PjVD6 zp#s5sA=!co6AG>&;J;qx{hY*O-mB&wm+3 zU#nymx3%7!?aRhnZ_O31yD*w7{L_WOY$08DQ5!eOFo~?QZ850b-gYMYm0jI_d#>>N z_SWM!_8Cv~WL$Uf8|BLh#W6SOeMEo-j=Y zt@Ok0Yd9xbi1|#hxt=pz)gJFElje|jeM-cx?}v*H#Y_j--_AQ8uj0z4hMiA^4D~)R z#(mw;>%*Gym{-$W-eZ1x?t9_ty-Ul>!_|$M&SBFe3$IlE5F4f}y(;7H3Ivyiol6bl z-5KdVJhRhoGk4UzVJ2Fo$}*z|4GTY>KEHd|dTX*?p0%EPGTomyc&RdeGozYCr)Kx` z-d8GDnx%>(QRDN`-eawUwVB>y^9Nm-KCZ9)$e=T$Iq#1RYp%2DxtZRmt1{E8)gEun z^rke|@%eQ<#7bG+821~^X^=QISe?;ohht}VXJT6QslkTKCavLY`iNEy61z8jUUN}x zW2V;_S#uIW^RKAz*E`&I_M4fyx)x^kfRF>O2)XT(S9XnLk`E02z_EKNbYqP8o2U_xfO(BhhFm?2mT%6Jg$~h~&=`yjPUW7Z1>hQRB&i&z?{u z+>_)z@CAL^vJjB73P)}GoKTCEp198Xe9YH>Z-&npUWPk%fJFcgXTlMyY(D*}N41QvQE+0&I60H9I? znsO>{&N6Wp*0f+p5Qr<WfVl#)Ktv{z>*z`u zyg)?sj3aFE!bye_{{9f}^~h+pER;y{UO>G#@B-f4u-cZ{^@@Nx7QjO|;^#dC=JG34 zABHZdAl#N;ky4E*hP(QBRZy*w-9E29vKy;zj_k%X?2+9{(a3J{{P}dHTs-&{6Rq+xx|pJny;)JnP%M)n8A7oclCcbSuVSglwD$QUOFrnD zRZ(dOPLh3W){fZ$(L;WeSQ1syCP+BQWP|XHwIZS?mXn&5Nt7X4i z5)b|~T-_Nwxu)Vn>UYdP9Dr#HToE>m+V{e>RIxu3xRPw#(;q|bsm`@m*PA2%nHbsU z4{kp7_Ng_K*OX^!gbKe&^rs+-0VkUSb`E!8z^*I8P8tCoohtTcy8d4SKI~uHe135A z_`&l#;q61+;p(t6TpM<}n&jPHY>2D@LMUBqfZT2myEahgD*2#@ zZgyf-gH9GIOHPJ~&5@I_C5r5sEMUjYi z*cqU=F@Lz0o==4gr+#eGX4-rY*6>sGIR`J*=hEhLv4 zPHsXMF8qIYNx#~&gX2WzUwUKeJ7sVb6qrI~16mNy0&aF?*vNMEC*ugS;lc5}uttQ^ z6x4XgC>Peynr5kzt6v!nA$T`PdL%3s6)&>N0y)3zXBE~nzbJc1vr{U1W#dQ{cGJl6 z1+=J^Ajc{4Zh^dsmH89lnDez#_LZouOyd+OzpRufuSCu-5N)(1Bo)X@a*MRQh_0CWy+=T6bx+DDmiUa0Hmy1a%Z;6 z$|@TQxg4^a_K&NP9P0!+>n4SsC1HnJB#>*hUqz3^E$V*XSk-9chy zHQ#r!I}^7}Mk=^Mair(;50#K|G<&j7c1#CvzmS*$IHeX&$4TlH8*V@tVU>sUP5uN^pne82_+=N@Yy2uDG3&jB! zWddON6;QLn3Xxn&UJKC&gpj9kJ^-0wEA69%Rgu1nfEdWY6rxY9Dim{|$YM!DsgTuyIQ!MAsUs5Ejr>Uqlu^v9@Tn+g zS@0oaSHyvj3{epSKH$}&W?n_0U5zOeE{qC~lcTS~F%)%FJ!1O8K^O8rw7j(0Qj&s< zD-3E7HUhDTi2x-9Uf+U%*p0H)K!y*p8pyzHb^{UM*`y%CH(L!v%++onzyX^L1X-~g z&?!nJR&M}**rS}O5aAfdhU&|GB0XmN40K{->GMM!N<B(fq8FG2^5vgh`qSxBQtUJ!?oYY8N{u_?>enh6qxsgvWgRw^zgc8 z?L=bZ`Y0^oiT|i)x2%5}HgL+~C6090hVhD~n+KgpHRwBGzV0kEdg;iP%^dd*JG^x( zcLSThZ55|Nsb}`61eNkO4dTqA3UY!uH3yz6wI#Bsrq679nwyLOLzQWb8no={W9Fuk zBC5?>eM&OYJ`j~`govYs>dz-(JlbvP?_Yy-j(^ z`W;*F`?(z*_&vDe4g7xThIX^Xp&PbvGl^FV?O9LLfq8Fw05Yw3zuA%g!%f}g+_%~8 zTQ6WMZf%}s|Ggk@xSP*iy{OM^yz1N{h}kwP&^*&KNJXsA0$AAIH%5|qG- zN71^SpMK&q^U7*!#;a?_&#xI@P;+`w*tKbV&)C#8>=`!5EoVb}8Ws1BCeboMtioUXgo@IUf?ar`aR>=68Hc-?PEX zjS2>ZCVf=DSHDZYM?a`PsXwgm)xWHNMSn)$rSH+7&>z+Jv8wyL+}D`!XcJp~-w5|- zcKp7pxV>z_UghI?x^S@V96UX}_fzq-`u-eGl~ZDykv`!5#C~wU%Duq;=l<@G=S&!s z&cWH;U;9*?EqTD?Y&K&L%ytGeSb)LKu@BA*&jpM3vZD{kAJ1I(V9z<2`^>&i#oXC_ zme?x0*6z#%#<(Y0^ua5*ZqlumS)^NK;~NI!gNbtt|H}tI)$sQ|WXtBghtB78Hu>vI zKVBGD4X!>1H~YT+skn(hY;*J2!~Gx6$H?H;bMWDR0^NgXHlkow07B!SS9&+dnTOvi7KyU7 zC8M|j(27S<;8LtuK$0a`Wy}jNz|nd0k_e*ajYzJqn2<=x^_-D6=Ovc1hLD5;{+X-2 zgtqer5si6fr-dYI32+xZ6uTA;B6^TtDB=d7hamn;kAehH!5}gM@Z3y9EMZAsSrFLn z1Fj{d!;3Ol4u^1FkPL-GiMSt0cM&uus1y{|{Ftjk6nyrJSG8&Yxbdmn=Vd1zotg5H zXU-FYmty;@6ug*l(cFxDevu43@OwqgR7!9c@v2fRP*_*N1Hyx!`f}NPAn!~ir1Y8} zYvA0(szdP^ygL-238M_vq^ImN11XuDcHSK5KqNN@#Jk1JNs_>R`Ph8GOQ@QW(lEqm zU>})KkO^*Nh|k78vS4OAjXa`^=!X&^4nZ`YvjxgAmEarPH}M*;Z2q{ zGPy?n5)#IQWsQ}=;Rj`J9U{iS za~32I-6$pQWBWt(3-bW2eR`4)XfYR?X|G@bS`*mLqI1Rx$l`ODc z`w-eagcu{3hXiM(eXReWiw%xevbRR(ald9Cj;`TSZ1vdVjbE}ksX0`PASIyFiMM|t}rT9CWuNEI{huCE>Dn% zLV%s+S_Ivw<`2fT=n5EXs8qJ(5Mg^>U)3lH#5Q!4_z=j(=VmED07aHn6htxo-k~oT z(Xj{C6MJZeN->J1QzFiODEXlpIS?E`g6+~BAmTzP?@uKBD{u+Q4LfhYD?S`gJW*er zA1@!Xn%A zodaFad+ccs^xcgY2-bKJ5mgBtm?-^u=*FE=SVj~nAd1AXr^0Ud?!|Rg2-r*_9z)>{`$SPDOOC$e)(e4Mc}?5x`W{}qRd=~hPVw! z3PaD;ad5DE>aT$J$&dfwMY8eVfD!)T4nw|C?dFl}w*o-uj=_^1ULxCNjD~Bc`=>Xv z$?zEQvGp%)pYe08MVov2~=BvD}8F<0{huoDKv&ev0_ z2&Pjp?zm>j3ph&7BQGFTTTEV1eC)HwT&|Kd6nrpg5O6t+gH4fcmE;I|ar#h1&#S0x z{Mh@HAjB~=JNrs~H6ZShMsz37NtCY_|vOQdaXZu3dPrc zX5Gweee*pOt52H$BEYtsJcMG)Df2dHy7$yO)LHz6dFwU(_%BjaZhdPhey@28SO3$e z-;$}y^(%8cHu9@CQ4F5e&EXz7y%NO_PWPGI^qpy>)>pqRnx7wh`%k>JtpRvj2DWbA zy6wiT{Mv0J+qUythqkP1!5)9+*Pc4#KLqFqH|FmP^_znG>#x`4GUMxh)151%e{;0K gwia+U Date: Wed, 1 Mar 2023 07:53:44 -0800 Subject: [PATCH 3/3] once more --- sources/ADISPLAY | 266 +++++++++++++++++++++++++++++------------- sources/ADISPLAY.LCOM | Bin 70835 -> 71906 bytes sources/FILESETS | 8 +- 3 files changed, 188 insertions(+), 86 deletions(-) diff --git a/sources/ADISPLAY b/sources/ADISPLAY index 2907ed81..28b9736e 100644 --- a/sources/ADISPLAY +++ b/sources/ADISPLAY @@ -1,10 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "28-Feb-2023 06:37:11" {DSK}larry>il>medley>sources>ADISPLAY.;2 238362 +(FILECREATED " 1-Mar-2023 07:49:03" {DSK}larry>il>medley>sources>ADISPLAY.;2 245335 :EDIT-BY "lmm" - :PREVIOUS-DATE "13-Jun-2021 14:03:35" {DSK}larry>il>medley>sources>ADISPLAY.;1) + :CHANGES-TO (FNS \DRAWLINE.DISPLAY) + + :PREVIOUS-DATE "28-Feb-2023 06:37:11" {DSK}larry>il>medley>sources>ADISPLAY.;1) (* ; " @@ -1470,56 +1472,154 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation (\DRAWLINE.DISPLAY [LAMBDA (DISPLAYSTREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING) - (* ; "Edited 13-Jun-2021 14:03 by rmk:") + (* ; "Edited 1-Mar-2023 07:42 by lmm") + (* ; "Edited 29-Jan-91 14:59 by matsuda") (* ;; "DISPLAYSTREAM is guaranteed to be a display-stream. Draws a line from x1,y1 to x2,y2 leaving the position at x2,y2") (* ;; "Added handling of brushes (I think, this is actually pretty tricky).") - (DECLARE (LOCALVARS . T)) - (SELECTQ OPERATION - (NIL (ffetch DDOPERATION of (fetch IMAGEDATA of DISPLAYSTREAM))) - ((REPLACE PAINT INVERT ERASE) - OPERATION) - (\ILLEGAL.ARG OPERATION)) - (\INSURETOPWDS DISPLAYSTREAM) (* ; - "RMK: This was only in the no-dash case, oddly") - (IF (OR DASHING (BRUSHP WIDTH)) - THEN [LET ((BRUSH (INSURE.BRUSH WIDTH))) - (if COLOR - then (replace (BRUSH BRUSHCOLOR) of BRUSH with COLOR)) - (IF (BIGBITMAPP (ffetch DDDestination of (fetch IMAGEDATA of DISPLAYSTREAM))) - THEN (\DRAWLINE.BIGBM.DASH DISPLAYSTREAM X1 Y1 X2 Y2 BRUSH DASHING OPERATION) - ELSE (GLOBALRESOURCES \BRUSHBBT (\LINEWITHBRUSH X1 Y1 X2 Y2 BRUSH - (\GOOD.DASHLST DASHING BRUSH) - DISPLAYSTREAM \BRUSHBBT OPERATION] - ELSEIF (BIGBITMAPP (ffetch DDDestination of (fetch IMAGEDATA of DISPLAYSTREAM))) - THEN (\DRAWLINE.BIGBM.NODASH DISPLAYSTREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR) - ELSE (LET ((DD (fetch IMAGEDATA of DISPLAYSTREAM))) - (\CLIPANDDRAWLINE (\DSPTRANSFORMX (OR (FIXP X1) - (FIXR X1)) - DD) - (\DSPTRANSFORMY (OR (FIXP Y1) - (FIXR Y1)) - DD) - (\DSPTRANSFORMX (OR (FIXP X2) - (FIXR X2)) - DD) - (\DSPTRANSFORMY (OR (FIXP Y2) - (FIXR Y2)) - DD) - [COND - ((NULL WIDTH) - 1) - ((OR (FIXP WIDTH) - (FIXR WIDTH] - OPERATION - (ffetch DDDestination of DD) - (ffetch DDClippingLeft of DD) - (SUB1 (ffetch DDClippingRight of DD)) - (ffetch DDClippingBottom of DD) - (SUB1 (ffetch DDClippingTop of DD)) - DISPLAYSTREAM COLOR))) (* ; + (DECLARE (LOCALVARS . T) + (GLOBALVARS \SCREENBITMAPS)) + [COND + [(OR DASHING (BRUSHP WIDTH)) + (GLOBALRESOURCE + \BRUSHBBT + (LET ((BBT \BRUSHBBT) + (BRUSH (INSURE.BRUSH WIDTH))) + (if COLOR + then (replace (BRUSH BRUSHCOLOR) of BRUSH with COLOR)) + (IF [NOT (type? BIGBM (ffetch DDDestination of (fetch IMAGEDATA of DISPLAYSTREAM] + THEN (\LINEWITHBRUSH X1 Y1 X2 Y2 BRUSH (\GOOD.DASHLST DASHING BRUSH) + DISPLAYSTREAM BBT (SELECTQ OPERATION + (NIL (ffetch DDOPERATION + of (fetch IMAGEDATA of DISPLAYSTREAM))) + ((REPLACE PAINT INVERT ERASE) + OPERATION) + (\ILLEGAL.ARG OPERATION))) + ELSE (PROG ((DD (fetch IMAGEDATA of DISPLAYSTREAM)) + BITMAP BIGBMLIST HEIGHT BOTTOM BM YY1 YY2 ClippingTop ClippingBottom CTop + CBottom) + (SETQ BITMAP (ffetch DDDestination of DD)) + (SETQ BIGBMLIST (fetch (BIGBM BIGBMLIST) of BITMAP)) + (SETQ HEIGHT (BITMAPHEIGHT BITMAP)) + (SETQ ClippingTop (ffetch DDClippingTop of DD)) + (SETQ ClippingBottom (ffetch DDClippingBottom of DD)) + (SETQ BM (GetNewFragment BIGBMLIST)) + (while (AND BM (IGREATERP HEIGHT ClippingBottom)) + do (SETQ BOTTOM (IDIFFERENCE HEIGHT (BITMAPHEIGHT BM))) + [SETQ CTop (COND + ((IGREATERP ClippingTop HEIGHT) + (IDIFFERENCE HEIGHT BOTTOM)) + (T (IDIFFERENCE ClippingTop BOTTOM] + (if (IGEQ CTop 0) + then [SETQ CBottom (COND + ((ILESSP ClippingBottom BOTTOM) + 0) + (T (IDIFFERENCE ClippingBottom BOTTOM] + (replace DDDestination of DD with BM) + (replace DDClippingTop of DD with CTop) + (replace DDClippingBottom of DD with CBottom) + (\LINEWITHBRUSH X1 (IDIFFERENCE Y1 BOTTOM) + X2 + (IDIFFERENCE Y2 BOTTOM) + BRUSH + (\GOOD.DASHLST DASHING BRUSH) + DISPLAYSTREAM BBT + (SELECTQ OPERATION + (NIL (ffetch DDOPERATION + of (fetch IMAGEDATA of DISPLAYSTREAM))) + ((REPLACE PAINT INVERT ERASE) + OPERATION) + (\ILLEGAL.ARG OPERATION))) + (SETQ BM (GetNewFragment BIGBMLIST)) + (SETQ HEIGHT BOTTOM))) + (freplace DDDestination of DD with BITMAP) + (freplace DDClippingTop of DD with ClippingTop) + (freplace DDClippingBottom of DD with ClippingBottom] + (T (PROG ((DD (fetch IMAGEDATA of DISPLAYSTREAM)) + BITMAP) + (\INSURETOPWDS DISPLAYSTREAM) (* ; "bring the window to the top") + (SETQ BITMAP (ffetch DDDestination of DD)) + (COND + ((NOT (type? BIGBM BITMAP)) + (\CLIPANDDRAWLINE (\DSPTRANSFORMX (OR (FIXP X1) + (FIXR X1)) + DD) + (\DSPTRANSFORMY (OR (FIXP Y1) + (FIXR Y1)) + DD) + (\DSPTRANSFORMX (OR (FIXP X2) + (FIXR X2)) + DD) + (\DSPTRANSFORMY (OR (FIXP Y2) + (FIXR Y2)) + DD) + [COND + ((NULL WIDTH) + 1) + ((OR (FIXP WIDTH) + (FIXR WIDTH] + (SELECTQ OPERATION + (NIL (ffetch DDOPERATION of DD)) + ((REPLACE PAINT INVERT ERASE) + OPERATION) + (\ILLEGAL.ARG OPERATION)) + BITMAP + (ffetch DDClippingLeft of DD) + (SUB1 (ffetch DDClippingRight of DD)) + (ffetch DDClippingBottom of DD) + (SUB1 (ffetch DDClippingTop of DD)) + DISPLAYSTREAM COLOR)) + (T (PROG ((BIGBMLIST (fetch (BIGBM BIGBMLIST) of BITMAP)) + (HEIGHT (BITMAPHEIGHT BITMAP)) + BOTTOM BM CTop CBottom (ClippingTop (ffetch DDClippingTop of DD)) + (ClippingBottom (ffetch DDClippingBottom of DD)) + (YY1 (\DSPTRANSFORMY (OR (FIXP Y1) + (FIXR Y1)) + DD)) + (YY2 (\DSPTRANSFORMY (OR (FIXP Y2) + (FIXR Y2)) + DD))) + (SETQ BM (GetNewFragment BIGBMLIST)) + (while (AND BM (IGREATERP HEIGHT ClippingBottom)) + do (SETQ BOTTOM (IDIFFERENCE HEIGHT (BITMAPHEIGHT BM))) + [SETQ CTop (COND + ((IGREATERP ClippingTop HEIGHT) + (IDIFFERENCE HEIGHT BOTTOM)) + (T (IDIFFERENCE ClippingTop BOTTOM] + (COND + ((IGEQ CTop 0) + [SETQ CBottom (COND + ((ILESSP ClippingBottom BOTTOM) + 0) + (T (IDIFFERENCE ClippingBottom BOTTOM] + (\CLIPANDDRAWLINE (\DSPTRANSFORMX (OR (FIXP X1) + (FIXR X1)) + DD) + (IDIFFERENCE YY1 BOTTOM) + (\DSPTRANSFORMX (OR (FIXP X2) + (FIXR X2)) + DD) + (IDIFFERENCE YY2 BOTTOM) + [COND + ((NULL WIDTH) + 1) + ((OR (FIXP WIDTH) + (FIXR WIDTH] + (SELECTQ OPERATION + (NIL (ffetch DDOPERATION of DD)) + ((REPLACE PAINT INVERT ERASE) + OPERATION) + (\ILLEGAL.ARG OPERATION)) + BM + (ffetch DDClippingLeft of DD) + (SUB1 (ffetch DDClippingRight of DD)) + CBottom + (SUB1 CTop) + DISPLAYSTREAM COLOR))) + (SETQ BM (GetNewFragment BIGBMLIST)) + (SETQ HEIGHT BOTTOM] (* ;  "the generic case of MOVETO is used so that the hardcopy streams get handled as well.") (MOVETO X2 Y2 DISPLAYSTREAM]) @@ -4334,40 +4434,40 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation (PUTPROPS ADISPLAY COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991 1993 1994 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (12017 19378 (\BBTCURVEPT 12027 . 19376)) (19379 29195 (CREATETEXTUREFROMBITMAP 19389 . -21319) (PRINTBITMAP 21321 . 22672) (PRINT-BITMAPS-NICELY 22674 . 26525) (PRINTCURSOR 26527 . 27560) ( -\WRITEBITMAP 27562 . 29193)) (29238 31786 (\GETINTEGERPART 29248 . 30793) (\CONVERTTOFRACTION 30795 . -31784)) (31923 32795 (CURSORP 31933 . 32152) (CURSORBITMAP 32154 . 32200) (CreateCursorBitMap 32202 . -32793)) (37157 46200 (CARET 37167 . 38927) (\CARET.CREATE 38929 . 39107) (\CARET.DOWN 39109 . 40461) ( -\CARET.FLASH? 40463 . 42277) (\CARET.SHOW 42279 . 42848) (CARETRATE 42850 . 43508) (\CARET.FLASH.AGAIN - 43510 . 44676) (\CARET.FLASH.MULTIPLE 44678 . 45201) (\CARET.FLASH 45203 . 46198)) (46201 51273 ( -\MEDW.CARET.SHOW 46211 . 51271)) (51637 53472 (\AREAVISIBLE? 51647 . 52571) (\REGIONOVERLAPAREAP 52573 - . 53118) (\AREAINREGIONP 53120 . 53470)) (53521 65997 (CREATEREGION 53531 . 53867) (REGIONP 53869 . -54015) (INTERSECTREGIONS 54017 . 56787) (UNIONREGIONS 56789 . 58940) (REGIONSINTERSECTP 58942 . 59550) - (SUBREGIONP 59552 . 60197) (EXTENDREGION 60199 . 62356) (EXTENDREGIONBOTTOM 62358 . 63000) ( -EXTENDREGIONLEFT 63002 . 63621) (EXTENDREGIONRIGHT 63623 . 64176) (EXTENDREGIONTOP 64178 . 64719) ( -INSIDEP 64721 . 65489) (STRINGREGION 65491 . 65995)) (66242 71516 (\BRUSHBITMAP 66252 . 67969) ( -\GETBRUSH 67971 . 68282) (\GETBRUSHBBT 68284 . 70312) (\InitCurveBrushes 70314 . 71380) ( -\BrushFromWidth 71382 . 71514)) (71517 74584 (\MAKEBRUSH.DIAGONAL 71527 . 71807) ( -\MAKEBRUSH.HORIZONTAL 71809 . 72203) (\MAKEBRUSH.VERTICAL 72205 . 72517) (\MAKEBRUSH.SQUARE 72519 . -72796) (\MAKEBRUSH.ROUND 72798 . 74582)) (74585 75750 (INSTALLBRUSH 74595 . 75748)) (76151 80623 ( -\DRAWLINE.DISPLAY 76161 . 79338) (RELMOVETO 79340 . 79727) (MOVETOUPPERLEFT 79729 . 80621)) (80624 -104109 (\CLIPANDDRAWLINE 80634 . 87080) (\CLIPANDDRAWLINE1 87082 . 98830) (\CLIPCODE 98832 . 100206) ( -\LEASTPTAT 100208 . 100806) (\GREATESTPTAT 100808 . 101436) (\DRAWLINE1 101438 . 102554) ( -\DRAWLINE.UFN 102556 . 104107)) (108639 154686 (\DRAWCIRCLE.DISPLAY 108649 . 117462) (\DRAWARC.DISPLAY - 117464 . 117754) (\DRAWARC.GENERIC 117756 . 118509) (\COMPUTE.ARC.POINTS 118511 . 120776) ( -\DRAWELLIPSE.DISPLAY 120778 . 136447) (\DRAWCURVE.DISPLAY 136449 . 138738) (\DRAWPOINT.DISPLAY 138740 - . 139936) (\DRAWPOLYGON.DISPLAY 139938 . 143466) (\LINEWITHBRUSH 143468 . 154684)) (154687 186379 ( -LOADPOLY 154697 . 155257) (PARAMETRICSPLINE 155259 . 165456) (\CURVE 165458 . 171060) (\CURVE2 171062 - . 182393) (\CURVEEND 182395 . 182877) (\CURVESLOPE 182879 . 185362) (\CURVESTART 185364 . 185688) ( -\FDIFS/FROM/DERIVS 185690 . 186377)) (198908 213244 (\FILLCIRCLE.DISPLAY 198918 . 209666) (\LINEBLT -209668 . 213242)) (213288 215288 (SCREENBITMAP 213298 . 213775) (BITMAPP 213777 . 214011) ( -BITMAPHEIGHT 214013 . 214389) (BITSPERPIXEL 214391 . 215286)) (215929 216922 (DSPFILL 215939 . 216622) - (INVERTW 216624 . 216920)) (216923 220566 (\DSPCOLOR.DISPLAY 216933 . 218230) (\DSPBACKCOLOR.DISPLAY -218232 . 219611) (DSPEOLFN 219613 . 220564)) (220999 225653 (DSPCLEOL 221009 . 221885) (DSPRUBOUTCHAR -221887 . 222319) (\DSPMOVELR 222321 . 225651)) (225783 226901 (\CURSOR.DEFPRINT 225793 . 226899)) ( -227313 235887 (TEXTUREOFCOLOR 227323 . 228585) (\PRIMARYTEXTURE 228587 . 229169) (\LEVELTEXTURE 229171 - . 229672) (INSURE.B&W.TEXTURE 229674 . 231069) (INSURE.RGB.COLOR 231071 . 232499) (\LOOKUPCOLORNAME -232501 . 232771) (RGBP 232773 . 233538) (HLSP 233540 . 233915) (HLSTORGB 233917 . 235057) (\HLSVALUEFN - 235059 . 235885))))) + (FILEMAP (NIL (12060 19421 (\BBTCURVEPT 12070 . 19419)) (19422 29238 (CREATETEXTUREFROMBITMAP 19432 . +21362) (PRINTBITMAP 21364 . 22715) (PRINT-BITMAPS-NICELY 22717 . 26568) (PRINTCURSOR 26570 . 27603) ( +\WRITEBITMAP 27605 . 29236)) (29281 31829 (\GETINTEGERPART 29291 . 30836) (\CONVERTTOFRACTION 30838 . +31827)) (31966 32838 (CURSORP 31976 . 32195) (CURSORBITMAP 32197 . 32243) (CreateCursorBitMap 32245 . +32836)) (37200 46243 (CARET 37210 . 38970) (\CARET.CREATE 38972 . 39150) (\CARET.DOWN 39152 . 40504) ( +\CARET.FLASH? 40506 . 42320) (\CARET.SHOW 42322 . 42891) (CARETRATE 42893 . 43551) (\CARET.FLASH.AGAIN + 43553 . 44719) (\CARET.FLASH.MULTIPLE 44721 . 45244) (\CARET.FLASH 45246 . 46241)) (46244 51316 ( +\MEDW.CARET.SHOW 46254 . 51314)) (51680 53515 (\AREAVISIBLE? 51690 . 52614) (\REGIONOVERLAPAREAP 52616 + . 53161) (\AREAINREGIONP 53163 . 53513)) (53564 66040 (CREATEREGION 53574 . 53910) (REGIONP 53912 . +54058) (INTERSECTREGIONS 54060 . 56830) (UNIONREGIONS 56832 . 58983) (REGIONSINTERSECTP 58985 . 59593) + (SUBREGIONP 59595 . 60240) (EXTENDREGION 60242 . 62399) (EXTENDREGIONBOTTOM 62401 . 63043) ( +EXTENDREGIONLEFT 63045 . 63664) (EXTENDREGIONRIGHT 63666 . 64219) (EXTENDREGIONTOP 64221 . 64762) ( +INSIDEP 64764 . 65532) (STRINGREGION 65534 . 66038)) (66285 71559 (\BRUSHBITMAP 66295 . 68012) ( +\GETBRUSH 68014 . 68325) (\GETBRUSHBBT 68327 . 70355) (\InitCurveBrushes 70357 . 71423) ( +\BrushFromWidth 71425 . 71557)) (71560 74627 (\MAKEBRUSH.DIAGONAL 71570 . 71850) ( +\MAKEBRUSH.HORIZONTAL 71852 . 72246) (\MAKEBRUSH.VERTICAL 72248 . 72560) (\MAKEBRUSH.SQUARE 72562 . +72839) (\MAKEBRUSH.ROUND 72841 . 74625)) (74628 75793 (INSTALLBRUSH 74638 . 75791)) (76194 87596 ( +\DRAWLINE.DISPLAY 76204 . 86311) (RELMOVETO 86313 . 86700) (MOVETOUPPERLEFT 86702 . 87594)) (87597 +111082 (\CLIPANDDRAWLINE 87607 . 94053) (\CLIPANDDRAWLINE1 94055 . 105803) (\CLIPCODE 105805 . 107179) + (\LEASTPTAT 107181 . 107779) (\GREATESTPTAT 107781 . 108409) (\DRAWLINE1 108411 . 109527) ( +\DRAWLINE.UFN 109529 . 111080)) (115612 161659 (\DRAWCIRCLE.DISPLAY 115622 . 124435) (\DRAWARC.DISPLAY + 124437 . 124727) (\DRAWARC.GENERIC 124729 . 125482) (\COMPUTE.ARC.POINTS 125484 . 127749) ( +\DRAWELLIPSE.DISPLAY 127751 . 143420) (\DRAWCURVE.DISPLAY 143422 . 145711) (\DRAWPOINT.DISPLAY 145713 + . 146909) (\DRAWPOLYGON.DISPLAY 146911 . 150439) (\LINEWITHBRUSH 150441 . 161657)) (161660 193352 ( +LOADPOLY 161670 . 162230) (PARAMETRICSPLINE 162232 . 172429) (\CURVE 172431 . 178033) (\CURVE2 178035 + . 189366) (\CURVEEND 189368 . 189850) (\CURVESLOPE 189852 . 192335) (\CURVESTART 192337 . 192661) ( +\FDIFS/FROM/DERIVS 192663 . 193350)) (205881 220217 (\FILLCIRCLE.DISPLAY 205891 . 216639) (\LINEBLT +216641 . 220215)) (220261 222261 (SCREENBITMAP 220271 . 220748) (BITMAPP 220750 . 220984) ( +BITMAPHEIGHT 220986 . 221362) (BITSPERPIXEL 221364 . 222259)) (222902 223895 (DSPFILL 222912 . 223595) + (INVERTW 223597 . 223893)) (223896 227539 (\DSPCOLOR.DISPLAY 223906 . 225203) (\DSPBACKCOLOR.DISPLAY +225205 . 226584) (DSPEOLFN 226586 . 227537)) (227972 232626 (DSPCLEOL 227982 . 228858) (DSPRUBOUTCHAR +228860 . 229292) (\DSPMOVELR 229294 . 232624)) (232756 233874 (\CURSOR.DEFPRINT 232766 . 233872)) ( +234286 242860 (TEXTUREOFCOLOR 234296 . 235558) (\PRIMARYTEXTURE 235560 . 236142) (\LEVELTEXTURE 236144 + . 236645) (INSURE.B&W.TEXTURE 236647 . 238042) (INSURE.RGB.COLOR 238044 . 239472) (\LOOKUPCOLORNAME +239474 . 239744) (RGBP 239746 . 240511) (HLSP 240513 . 240888) (HLSTORGB 240890 . 242030) (\HLSVALUEFN + 242032 . 242858))))) STOP diff --git a/sources/ADISPLAY.LCOM b/sources/ADISPLAY.LCOM index efa56474dbb06db048027cf31ecdb64bb1db7503..f3094c84a4146e70aa76126b9e9bc8e545e7ad7f 100644 GIT binary patch delta 2116 zcmb7FO>Y}j6pc+3(v(;e$4XKP$-^X4g0MB;A66G0d&V;pkLOvQNkSx}G>xOCNmEdP z6`)zr4Lj0^vOsJQ3o0Z?u(D`TI*V=`iR|Mo8w4xz3(B1jr?#n(>c#lZefOPn?zvBI znhyv6I2`0Yy z+nWuvv9*5Z=H^FpIaF6_@``C#YF07qswuCcTX#^pv}Bry?t;l?vuV^={}}d;q`Ma) zd_KJ}GG8)GwOCW-D~_t5^b5s(N^T&Uau~C?2IBiD(X=}@;OGxQB)d@?0ueTK8?i%cLBZfI2C;I=0Hw0H39P5=L&=9{GkM6Msc?ne;(68+!zO7{XSqruZVz!A>a-fQKP z;d=Nscx(pCPs**iwWL>W&90@qN~{t;UL!nAd}B3m>byDamCe+!SH{WHIe4Z{XUFwG z$@pRHPfWN0M0+ja;bg-)-}5Y-Xs=Cp+j!!r~K@cR}Ppl;RA-@gpV4A zQ>U|F0TdP$c=Q;N=rZEnm+$|gsl=1RXYX{d#>Qg#>w$00$*p`~dhq(jgM4V4elon; z2!?b2aNuW8ZZPPFU`3A%JS#Nz|CTiO=vDn>`k+_X|IWqGTWP)Z_D)-G&FZbWopxSJ zjKV4M=Ua`yjgYD}2Q`I$>Y+2`dCCoU44sXYE-%IwkTTE17SYK59?8J-OwP2e1lNmkc@@ z4$pe&rA@)fjw^Tqr@B44Xo~pl@Y%w^yhKT;UNnuWY$yV;=(e3J)VF5+MSjj4~t(&%kXpZa^Pl;?_f@AuDDHgc8TM?kO z9$4_pu7|&{$^|)#nT2ABRB9Re3eAj)sHVBaddJ{VShbEm8s(`9r};jsPh}h-6T-)R95a rWF&*4$O{=1N&7f664}|zcMONFBRrbjk6lZ}g#EvMpJ{$}O*s1(@j@p9 delta 1017 zcmZWnUu)A)6mPpBU1ejl;x-s~h!3tpYjbatwsEi|%}shWYeJH)4)QQ(hZFb52L)l1 zf)74B3i|}2_#&HS4?gvIpFrOP@dM0n;Jr!4s@|9L>dJQ*K+8h_Whj%r17 zbEAmL2t!#`a80SmhtEh)zI2PCBGnaK7hvP@-p=#w+g*6N3xe6UZ9pTuQmG_B_tA^Z zE(oLkIKP5~LT=HdHfeZ73y8r;|J1H3qA0+=;XinN_@=M~2-mQTKp_SViuxMlgzcRj z0TkCGtJG=xMT6;pAmZZvm%Drf5yXm8#tN1W_wNp}nM}0@CLjoXR+F@J8mwrpUx4(h zOgc4Tp61jmDfW&FPq;ZB2xbE26Y$yW#-8^RoH10_xj7%?x6~X*-olX@N37|OBtl>I zVmmXFwx*7H%}mCcnj6N2&dO)mn3PvFy&5mg^r8s+??Kt%+0S!v>8=VsW}-} zp|hNoKS`Z#MQC{ZP3=ZATuR>W&6E*^Syk- zP_J^%bZQY-F|0VNBya%B6$l$Pb+wjZcv{D%Edm%zVA6*kU{Q<#s-pz3)F_0cN&;{h z!i&_BPAz?<)N%~XZvqk#a0mO1p60qBR%Hlzg$@mxy4PkDQLaL0IgU}{8MYsQh-?4p zMQS4Z^+b(})iKbP-}Xo;R;o!50T-$ggn<({ZpZLJmcj5{qeuLJwzPmcEvVEXq_#~g z%`R!4#f}w=tP6wsuC1-HQ_}#|c@v|KDogsyA@i|E8MqF9z%G6TP#Ir9k+m6yy4U}; zJe#TE{*UE_ISIkR_?Sy=C(!jESaZp(19s064;pM`iHgLQl?+iqKs?RoKf{JzC0+oi Z0larry>il>medley>sources>FILESETS.;2 6410 +(FILECREATED " 1-Mar-2023 07:49:03" {DSK}larry>il>medley>sources>FILESETS.;2 6433 + + :EDIT-BY "lmm" :CHANGES-TO (VARS EXPORTFILES) - :PREVIOUS-DATE "11-Sep-2022 20:08:31" {DSK}larry>il>medley>sources>FILESETS.;1) + :PREVIOUS-DATE "26-Feb-2023 11:25:24" {DSK}larry>il>medley>sources>FILESETS.;1) (* ; " @@ -71,7 +73,7 @@ Copyright (c) 1981-1990, 1998, 2021 by Xerox Corporation. LLCHAR LLSTK PMAP LLGC ATBL FILEIO EXTERNALFORMAT LLARITH LLFLOAT FONT LLKEY LLDISPLAY ADISPLAY AINTERRUPT RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER IMAGEIO PROC XCCS PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS LLETHER PUP UFS - DTDECLARE BIGBITMAP)) + DTDECLARE BIGBITMAPS)) (RPAQQ MAKEINITFILES (MAKEINIT MEM I-NEW))