(FILECREATED " 4-Oct-85 12:24:53" {ERIS}<LISPCORE>LIBRARY>LLCOLOR.;34 97043
changes to: (FNS \GETCOLORFONT)
previous date: "19-Jul-85 13:07:47" {ERIS}<LISPCORE>LIBRARY>LLCOLOR.;33)
(* Copyright (c) 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT LLCOLORCOMS)
(RPAQQ LLCOLORCOMS ((FNS COLORDISPLAY SCREENON? COLORMAPBITS COLORMAPENTRY SETCOLORMAPENTRY
\CreateColorScreenBitMap \GENERIC.COLORLEVEL SCREENCOLORMAP MAXIMUMCOLOR
COLORSCREENBITMAP \COLORDISPLAYBITS COLORNUMBERBITSPERPIXEL)
(FNS \STARTCOLOR \STOPCOLOR \SETSCREENCOLORMAP COLORLEVEL ROTATECOLORMAP
\GENERIC.ROTATECOLORMAP)
(MACROS COLORMAPENTRY)
(FNS COLORMAPCREATE REPEAT.TO.AT.LEAST.N COLORMAPOF COLORMAPP COLORMAPCOPY COLORNUMBERP
\LOOKUPCOLORNAME HLSP RGBP COLORFROMRGBLEVELS \POSSIBLECOLOR INTENSITIESFROMCOLORMAP
SETCOLORINTENSITY)
(FNS \GENERICCOLORLEVEL \GENERICROTATECOLORMAP)
(FNS \INSUREBITSPERPIXEL \FAST8BIT \MAP4 \MAP8)
(FNS \GETCOLORBRUSH \DDSETCOLORFONT \GETCOLORFONT \GETCOLORCSINFO \COLORFONTLOOKUP
\COLORFONTSTORE)
(FNS CHANGECURSORSCREEN \SETCOLORCURSORBM \TAKEDOWNCOLORCURSOR \IFCOLORDS\TAKEDOWNCOLORCURSOR
\PUTUPCOLORCURSOR \COLORCURSORDOWN)
(FNS \PIXELBLT.UFN)
(GLOBALVARS \COLORCURSOR \COLORSCREENBITMAPBASE \COLORCURSORWIDTH \CURSORSAV \COLORCURSORDOWN
\EMPTYCURSOR \ColorCursorBBT \COLORSCREENRASTERWIDTH \COLORCURSORRASTERWIDTH
\COLORSCREENWIDTHINBITS \COLORCURSORBASE \COLORCURSORWIDTH \COLORCURSORHEIGHT
\COLORFONTCACHE)
(INITVARS (\COLORCURSOR)
(\CURSORSAV)
(\COLORFONTCACHE))
(CURSORS \EMPTYCURSOR \DEFAULTCOLORCURSOR)
(FNS \DRAWCOLORLINE1 \DRAW4BPPCOLORLINE \DRAW8BPPCOLORLINE)
(DECLARE: DONTCOPY DOEVAL@COMPILE (MACROS .DRAW4BPPLINEX. .DRAW8BPPLINEX .DRAW8BPPLINEY
.DRAW4BPPLINEY.))
(DECLARE: DONTCOPY DOEVAL@COMPILE (MACROS \BITADDRESSOFPIXEL COLORNUMBERBITSPERPIXEL))
(FNS \BWTOCOLORBLT \8BITLINEBLT \4BITLINEBLT COLORFILL COLORBACKGROUND COLORFILLAREA
COLORTEXTUREFROMCOLOR# \BITMAPWORD)
(FNS COLORIZEBITMAP)
(RECORDS 4BITCOLORMAP 8BITCOLORMAP RGB HLS)
(DECLARE: DONTCOPY (RECORDS NIBBLES ONEOFFSETBITACCESS TWOOFFSETBITACCESS THREEOFFSETBTACCESS
2BITNIBBLES ODD2BITNIBBLES)
(CONSTANTS (\ColorScreenAddr 268)
(\ColorMapAddr 270)
(REDMASK 2048)
(GREENMASK 1024)
(BLUEMASK 512)
(COLORSOFFSETINMAP 2)
(INTENSITYSIZE 3)
(REDOFFSET 0)
(GREENOFFSET 1)
(BLUEOFFSET 2)
(\MaxBitsPerPixel 4)
(\MaxBitMapWidth 65535)
(\MaxBitMapHeight 65535)
(\MaxBitMapWords 131066)))
(* this should be in each device init)
(VARS (COLORSCREENWIDTH 640)
(COLORSCREENHEIGHT 480))
(CONSTANTS (MaxBitsPerPixel 8)
(PagesPerSegment 256)
(BITSPERWORD 16)
(ExtraColorDisplayPages 2))
(INITVARS (\SystemColorMap)
(\COLORDISPLAYBITS)
(ColorScreenBitMap)
(LastSystemColorMap)
(\DefaultColorMap)
(\COLORDISPLAYBITSPERPIXEL 4))
(VARS \DEFAULTCOLORINTENSITIES COLORNAMES
[\DEFAULT8BITCOLORINTENSITIES (for RED from 83 to 255 by 43 join
(for GREEN from 80 to 255 by 35 join
(for BLUE from 80 to 255 by 25 collect
(LIST RED GREEN BLUE]
(\NULLINTENSITIES (for COLOR from 0 to 255 collect (LIST 0 0 0)))
(WHOLECOLORDISPLAY (create REGION LEFT ← 0 BOTTOM ← 0 WIDTH ← COLORSCREENWIDTH HEIGHT ←
COLORSCREENHEIGHT)))
(GLOBALVARS \COLORDISPLAYBITS \COLORDISPLAYBITSPERPIXEL ColorScreenBitMap \SystemColorMap
LastSystemColorMap WHOLECOLORDISPLAY \COLORCURSOR)
(RECORDS BRUSH)))
(DEFINEQ
(COLORDISPLAY
[LAMBDA (COLORMAPIFON BITSPERPIXEL CLEARSCREENFLG DISPLAY)
(* hdj "19-Jun-85 16:30")
(* turns the color display on and off)
(LET ((DISPLAYDEV (\CoerceToDisplayDevice DISPLAY)))
(PROG1 (SCREENCOLORMAP NIL DISPLAYDEV) (* return whether on not it is on.)
(COND
(COLORMAPIFON (SETQ BITSPERPIXEL (\INSUREBITSPERPIXEL BITSPERPIXEL))
[COND
[(SCREENON? DISPLAYDEV) (* its currently on.)
(COND
((EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of (COLORSCREENBITMAP))
BITSPERPIXEL) (* now on at same size; don%'t do anything)
NIL)
(T (* to turn it on with a different size%, turn it off
first.)
(COLORDISPLAY NIL)
(COLORDISPLAY COLORMAPIFON BITSPERPIXEL DISPLAYDEV]
(T (* turn it on)
(\CreateColorScreenBitMap BITSPERPIXEL DISPLAYDEV)
(PROG (COLORBITS (CBITMAP (COLORSCREENBITMAP)))
(SETQ COLORBITS (fetch (BITMAP BITMAPBASE) of CBITMAP))
(* do type check before going uninterruptable)
[SETQ COLORMAPIFON (COLORMAPOF (COND
((EQ COLORMAPIFON T)
LastSystemColorMap)
(T COLORMAPIFON]
(UNINTERRUPTABLY
(\LOCKPAGES COLORBITS
(IPLUS (FOLDHI (ITIMES (fetch
BITMAPRASTERWIDTH
of CBITMAP)
(fetch BITMAPHEIGHT
of CBITMAP))
WordsPerPage)
ExtraColorDisplayPages))
(\STARTCOLOR COLORMAPIFON COLORBITS BITSPERPIXEL
DISPLAYDEV))]
(AND CLEARSCREENFLG (COLORBACKGROUND 0)))
((SCREENON? DISPLAYDEV) (* The color display is on%, turn it off.)
(AND CLEARSCREENFLG (COLORBACKGROUND 0)) (* move cursor back if it is now on color screen.)
(AND \COLORCURSORBM (CHANGECURSORSCREEN (SCREENBITMAP)))
(PROG ((CBITMAP (COLORSCREENBITMAP)))
(UNINTERRUPTABLY
(\STOPCOLOR DISPLAYDEV)
(SETQ LastSystemColorMap (SCREENCOLORMAP NIL DISPLAYDEV))
(\UNLOCKPAGES (fetch (BITMAP BITMAPBASE) of CBITMAP)
(FOLDHI (ITIMES (fetch BITMAPRASTERWIDTH of CBITMAP)
(fetch BITMAPHEIGHT of CBITMAP))
WordsPerPage)))])
(SCREENON?
[LAMBDA (DISPLAY) (* hdj "19-Jun-85 16:26")
(fetch (DISPLAYSTATE RUNNING?) of (fetch (FDEV DEVICEINFO) of DISPLAY])
(COLORMAPBITS
[LAMBDA (COLORMAP?) (* hdj "19-Jun-85 15:36")
(COND
((type? 4BITCOLORMAP COLORMAP?)
4)
((type? 8BITCOLORMAP COLORMAP?)
8)
(T (\ILLEGAL.ARG COLORMAP?])
(COLORMAPENTRY
[LAMBDA (COLORMAP ENTRY) (* hdj "18-Jun-85 18:47")
(ELT COLORMAP ENTRY])
(SETCOLORMAPENTRY
[LAMBDA (COLORMAP ENTRY RGB) (* hdj "20-Jun-85 12:22")
(SETA COLORMAP ENTRY RGB])
(\CreateColorScreenBitMap
[LAMBDA (BITSPP DISPLAY) (* hdj "15-Feb-85 17:31")
(* creates and locks the pages for the color display
bit map and returns a BITMAP descriptor for it.)
(PROG [[WIDTH (fetch (REGION WIDTH) of (fetch (WSDATA WSREGION) of (fetch (FDEV WINDOWDATA)
of DISPLAY]
(HEIGHT (fetch (REGION HEIGHT) of (fetch (WSDATA WSREGION) of (fetch (FDEV WINDOWDATA)
of DISPLAY]
(COND
((type? BITMAP ColorScreenBitMap) (* reuse the same BITMAP ptr so that it will stay EQ to
the one in user datastructures.)
(replace (WSDATA WSDESTINATION) of (fetch (FDEV WINDOWDATA) of DISPLAY) with
ColorScreenBitMap)
(replace BITMAPBASE of ColorScreenBitMap with (\COLORDISPLAYBITS BITSPP WIDTH HEIGHT))
(replace BITMAPWIDTH of ColorScreenBitMap with (ITIMES WIDTH BITSPP))
(replace BITMAPRASTERWIDTH of ColorScreenBitMap with (FOLDHI (ITIMES WIDTH BITSPP)
BITSPERWORD))
(replace BITMAPHEIGHT of ColorScreenBitMap with HEIGHT)
(replace (BITMAP BITMAPBITSPERPIXEL) of ColorScreenBitMap with BITSPP)
ColorScreenBitMap)
(T (PROG1 (SETQ ColorScreenBitMap (create BITMAP
BITMAPBASE ←(\COLORDISPLAYBITS BITSPP WIDTH
HEIGHT)
BITMAPRASTERWIDTH ←(FOLDHI (ITIMES WIDTH BITSPP)
BITSPERWORD)
BITMAPWIDTH ←(ITIMES WIDTH BITSPP)
BITMAPHEIGHT ← HEIGHT
BITMAPBITSPERPIXEL ← BITSPP))
(replace (WSDATA WSDESTINATION) of (fetch (FDEV WINDOWDATA) of DISPLAY)
with ColorScreenBitMap])
(\GENERIC.COLORLEVEL
[LAMBDA (COLORMAP COLOR# PRIMARYCOLOR NEWLEVEL) (* hdj "20-Jun-85 12:25")
(LET* [(REALCOLOR (COLORNUMBERP COLOR#))
(ENTRY (OR (COLORMAPENTRY COLORMAP REALCOLOR)
(SETCOLORMAPENTRY COLORMAP REALCOLOR (LIST 0 0 0]
(PROG1 (SELECTQ PRIMARYCOLOR
(RED (fetch (RGB RED) of ENTRY))
(GREEN (fetch (RGB GREEN) of ENTRY))
(BLUE (fetch (RGB BLUE) of ENTRY))
(\ILLEGAL.ARG PRIMARYCOLOR))
(if NEWLEVEL
then (LET ((REALNEWLEVEL (LOGAND NEWLEVEL 255)))
(SELECTQ PRIMARYCOLOR
(RED (replace (RGB RED) of ENTRY with REALNEWLEVEL))
(GREEN (replace (RGB GREEN) of ENTRY with REALNEWLEVEL))
(BLUE (replace (RGB BLUE) of ENTRY with REALNEWLEVEL))
(\ILLEGAL.ARG PRIMARYCOLOR])
(SCREENCOLORMAP
[LAMBDA (NEWCOLORMAP DISPLAY) (* hdj "19-Jun-85 15:54")
(* sets NEWCOLORMAP as the colormap for the display. If NIL%, returns the current value. May have to unlock the old
colormap and lock the new one.)
(LET ((DEVICE (\CoerceToDisplayDevice DISPLAY)))
(PROG1 (fetch (WSDATA WSCOLORMAP) of (fetch (FDEV WINDOWDATA) of DEVICE))
(AND NEWCOLORMAP (SETQ NEWCOLORMAP (COLORMAPOF NEWCOLORMAP))
(\SETSCREENCOLORMAP NEWCOLORMAP DISPLAY])
(MAXIMUMCOLOR
[LAMBDA (COLORMAP) (* rrb "21-SEP-82 09:19")
(* returns the largest color number in COLORMAP or in
the screen colormap. If COLORMAP is not given, the
color display must be on.)
(SELECTQ (COND
(COLORMAP (COLORMAPBITS COLORMAP))
(T \COLORDISPLAYBITSPERPIXEL))
(4 15)
(8 255)
(SHOULDNT])
(COLORSCREENBITMAP
[LAMBDA NIL (* rrb "22-OCT-82 14:01")
(* returns the color screen bitmap)
ColorScreenBitMap])
(\COLORDISPLAYBITS
[LAMBDA (BITSPP WIDTH HEIGHT) (* hdj "11-Mar-85 21:12")
(* returns a pointer to the bits that the color board
needs.)
(DECLARE (GLOBALVARS COLORSCREENWIDTH COLORSCREENHEIGHT \COLORDISPLAYBITS \COLORDISPLAYSIZE
\COLORDISPLAYBITSPERPIXEL))
(UNINTERRUPTABLY
(LET* ((SWIDTH (OR WIDTH COLORSCREENWIDTH))
(SHEIGHT (OR HEIGHT COLORSCREENHEIGHT))
(NPAGES (IPLUS (FOLDHI (ITIMES (FOLDHI (ITIMES SWIDTH BITSPP)
BITSPERWORD)
SHEIGHT)
WORDSPERPAGE)
ExtraColorDisplayPages)))
[if (NOT \COLORDISPLAYBITS)
then (* must allocate something)
(* \ALLOCBLOCK can't hack bitmaps of the size of the
1132 color screen)
(SETQ \COLORDISPLAYBITS (if (IGREATERP (UNFOLD NPAGES CELLSPERPAGE)
\MaxArrayNCells)
then (OR (\ALLOCPAGEBLOCK NPAGES)
(ERROR "No room for color screen of size"
NPAGES))
else (\ALLOCBLOCK (UNFOLD NPAGES CELLSPERPAGE)
NIL NIL CELLSPERPAGE]
(SETQ \COLORDISPLAYBITSPERPIXEL BITSPP)
\COLORDISPLAYBITS))])
(COLORNUMBERBITSPERPIXEL
[LAMBDA NIL (* rrb "27-OCT-82 17:25")
(* returns the number of bits per pixel that the color
screen is running at.)
\COLORDISPLAYBITSPERPIXEL])
)
(DEFINEQ
(\STARTCOLOR
[LAMBDA (COLORMAP PTRTOBITS BITSPP DISPLAY) (* hdj " 3-Feb-85 14:01")
(WSOP (QUOTE STARTCOLOR)
(\CoerceToDisplayDevice DISPLAY)
COLORMAP PTRTOBITS BITSPP])
(\STOPCOLOR
[LAMBDA (DISPLAY) (* hdj " 3-Feb-85 14:01")
(WSOP (QUOTE STOPCOLOR)
(\CoerceToDisplayDevice DISPLAY])
(\SETSCREENCOLORMAP
[LAMBDA (COLORMAP DISPLAY) (* hdj "19-Jun-85 00:17")
(OR (type? 4BITCOLORMAP COLORMAP)
(type? 8BITCOLORMAP COLORMAP)
(\ILLEGAL.ARG COLORMAP))
(LET ((DEVICE (\CoerceToDisplayDevice DISPLAY)))
(replace (WSDATA WSCOLORMAP) of (fetch (FDEV WINDOWDATA) of DEVICE) with COLORMAP)
(WSOP (QUOTE SETSCREENCOLORMAP)
DEVICE COLORMAP])
(COLORLEVEL
[LAMBDA (DISPLAY/COLORMAP COLOR# PRIMARYCOLOR NEWLEVEL) (* hdj "19-Jun-85 17:49")
(if (type? FDEV DISPLAY/COLORMAP)
then (WSOP (QUOTE COLORLEVEL)
(\CoerceToDisplayDevice DISPLAY/COLORMAP)
COLOR# PRIMARYCOLOR NEWLEVEL)
else (OR (type? 4BITCOLORMAP DISPLAY/COLORMAP)
(type? 8BITCOLORMAP DISPLAY/COLORMAP)
(\ILLEGAL.ARG DISPLAY/COLORMAP))
(* * arg is colormap)
(PROG1 (\GENERIC.COLORLEVEL DISPLAY/COLORMAP COLOR# PRIMARYCOLOR NEWLEVEL)
(LET ((DEFAULTCOLORDISPLAY (\CoerceToDisplayDevice NIL)))
(if (EQ DISPLAY/COLORMAP (fetch (WSDATA WSCOLORMAP) of (fetch (FDEV WINDOWDATA)
of DEFAULTCOLORDISPLAY))
)
then (\SETSCREENCOLORMAP DISPLAY/COLORMAP DEFAULTCOLORDISPLAY])
(ROTATECOLORMAP
[LAMBDA (COLORMAP STARTCOLOR THRUCOLOR DISPLAY) (* hdj " 3-Feb-85 14:06")
(WSOP (QUOTE ROTATECOLORMAP)
(\CoerceToDisplayDevice DISPLAY)
COLORMAP STARTCOLOR THRUCOLOR])
(\GENERIC.ROTATECOLORMAP
[LAMBDA (COLORMAP STARTCOLOR THRUCOLOR) (* hdj "20-Jun-85 18:53")
(OR (EQ STARTCOLOR THRUCOLOR)
(COND
[(OR (type? 4BITCOLORMAP COLORMAP)
(type? 8BITCOLORMAP COLORMAP))
(LET* ((SCRATCH (if (type? 4BITCOLORMAP COLORMAP)
then (create 4BITCOLORMAP)
else (create 8BITCOLORMAP)))
(LENGTH (if (type? 4BITCOLORMAP COLORMAP)
then 16
else 256))
[CUTPOINT (if (ILESSP STARTCOLOR THRUCOLOR)
then (IDIFFERENCE THRUCOLOR STARTCOLOR)
else (IPLUS LENGTH (IDIFFERENCE THRUCOLOR STARTCOLOR]
(COPY1LENGTH (IDIFFERENCE LENGTH CUTPOINT))
(COPY2LENGTH CUTPOINT))
(for ELT from 0 to (SUB1 (IDIFFERENCE LENGTH CUTPOINT)) do (SETCOLORMAPENTRY
SCRATCH
(IPLUS CUTPOINT ELT)
(COLORMAPENTRY COLORMAP
ELT)))
(for ELT from 0 TO (SUB1 CUTPOINT) do (SETCOLORMAPENTRY SCRATCH
(IPLUS ELT (IDIFFERENCE LENGTH
CUTPOINT))
(COLORMAPENTRY COLORMAP ELT)))
(for ELT from 0 to (SUB1 LENGTH) do (SETCOLORMAPENTRY COLORMAP ELT (COLORMAPENTRY
SCRATCH ELT]
(T (\ILLEGAL.ARG COLORMAP])
)
(DECLARE: EVAL@COMPILE
(PUTPROPS COLORMAPENTRY MACRO (= . ELT))
)
(DEFINEQ
(COLORMAPCREATE
[LAMBDA (INTENSITIES BITSPERPIXEL) (* hdj "20-Jun-85 17:50")
(* creates a color map. Starts with a reasonable color
set. COLORMAPS must be on multiple of 16 word
boundaries for D0 hardware.)
(DECLARE (GLOBALVARS \NULLINTENSITIES))
(SELECTQ (OR BITSPERPIXEL \COLORDISPLAYBITSPERPIXEL)
(4 (LET [(CMAP (create 4BITCOLORMAP))
(REALINTENSITIES (COND
((NULL INTENSITIES)
\DEFAULTCOLORINTENSITIES)
((LISTP INTENSITIES)
(REPEAT.TO.AT.LEAST.N INTENSITIES 16))
(T (\ILLEGAL.ARG INTENSITIES]
(for I from 0 to 15 as COLORS in REALINTENSITIES do (SETCOLORINTENSITY CMAP I
COLORS))
CMAP))
(8 (LET [(CMAP (create 8BITCOLORMAP))
(REALINTENSITIES (COND
((NULL INTENSITIES)
(APPEND \DEFAULTCOLORINTENSITIES \DEFAULT8BITCOLORINTENSITIES)
)
((LISTP INTENSITIES)
(REPEAT.TO.AT.LEAST.N INTENSITIES 256))
(T (\ILLEGAL.ARG INTENSITIES]
(* make the lowest 16 colors the same as in the 4 bit
case)
(for I from 0 to 255 as COLORS in REALINTENSITIES do (SETCOLORINTENSITY CMAP I
COLORS))
CMAP))
(\ILLEGAL.ARG BITSPERPIXEL])
(REPEAT.TO.AT.LEAST.N
[LAMBDA (LIST N) (* hdj "20-Jun-85 17:46")
(bind (TOTALLENGTH ←(LENGTH LIST))
(LENGTH ←(LENGTH LIST))
(NEWLIST ← LIST) until (IGEQ TOTALLENGTH N)
do (SETQ NEWLIST (APPEND NEWLIST LIST))
(add TOTALLENGTH LENGTH)
finally (RETURN NEWLIST])
(COLORMAPOF
[LAMBDA (NEWCM BITSPERPIXEL) (* edited: " 8-SEP-82 12:07")
(SETQ BITSPERPIXEL (OR BITSPERPIXEL \COLORDISPLAYBITSPERPIXEL))
(COND
[(COLORMAPP NEWCM)
(COND
((EQ BITSPERPIXEL (COLORMAPBITS NEWCM))
NEWCM)
(T (COLORMAPCOPY NEWCM BITSPERPIXEL]
((EQ NEWCM T)
(COLORMAPCREATE NIL BITSPERPIXEL))
(T (COLORMAPCREATE NEWCM BITSPERPIXEL])
(COLORMAPP
[LAMBDA (COLORMAP? BITSPERPIXEL) (* hdj "19-Jun-85 15:36")
(* returns COLORMAP? if it is a colormap.)
(AND (OR (AND (OR (NULL BITSPERPIXEL)
(EQ BITSPERPIXEL 4))
(type? 4BITCOLORMAP COLORMAP?))
(AND (OR (NULL BITSPERPIXEL)
(EQ BITSPERPIXEL 8))
(type? 8BITCOLORMAP COLORMAP?)))
COLORMAP?])
(COLORMAPCOPY
[LAMBDA (COLORMAP BITSPERPIXEL) (* rrb "21-OCT-82 18:32")
(* makes a copy of a color map If COLORMAP is not a color map, it returns a new color map with default values.
If the colormaps are different sizes, the first 16 entries will be the same and the rest will be black)
(COLORMAPCREATE (AND (COLORMAPP COLORMAP BITSPERPIXEL)
(INTENSITIESFROMCOLORMAP COLORMAP))
BITSPERPIXEL])
(COLORNUMBERP
[LAMBDA (COLOR# BITSPERPIXEL NOERRFLG) (* rrb "13-DEC-82 13:14")
(* returns the color number from a color.)
(PROG (LEVELS)
(AND (COND
[(FIXP COLOR#)
(RETURN (COND
((AND (IGEQ COLOR# 0)
(ILESSP COLOR# (EXPT 2 (OR BITSPERPIXEL \COLORDISPLAYBITSPERPIXEL))
)
COLOR#))
(NOERRFLG NIL)
(T (\ILLEGAL.ARG COLOR#]
[(LITATOM COLOR#)
(RETURN (COND
((SETQ LEVELS (\LOOKUPCOLORNAME COLOR#))
(* recursively look up color number)
(COLORNUMBERP (CDR LEVELS)
BITSPERPIXEL NOERRFLG))
(NOERRFLG NIL)
(T (ERROR "Unknown color name" COLOR#]
((HLSP COLOR#) (* HLS form convert to RGB)
(SETQ LEVELS (HLSTORGB COLOR#)))
((RGBP COLOR#) (* check for RGB or HLS)
(SETQ LEVELS COLOR#))
(NOERRFLG NIL)
(T (\ILLEGAL.ARG COLOR#)))
(RETURN (COND
((COLORFROMRGBLEVELS LEVELS))
(NOERRFLG NIL)
(T (ERROR COLOR# "not available in color map"])
(\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])
(HLSP
[LAMBDA (X) (* rrb "27-OCT-82 10:10")
(* return T if X is a hue lightness saturation triple.)
(AND (LISTP X)
(IGREATERP (CAR X)
-1)
(IGREATERP 361 (CAR X))
(FLOATP (CADR X))
(FLOATP (CADDR X))
X])
(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])
(COLORFROMRGBLEVELS
[LAMBDA (LEVELS) (* rrb "27-OCT-82 10:35")
(* looks in the colormap for a color that has the RGB
levels of LEVELS)
(BIND (CM ←(SCREENCOLORMAP)) for I from 0 to (MAXIMUMCOLOR)
thereis (AND (EQ (COLORLEVEL CM I (QUOTE RED))
(fetch (RGB RED) of LEVELS))
(EQ (COLORLEVEL CM I (QUOTE GREEN))
(fetch (RGB GREEN) of LEVELS))
(EQ (COLORLEVEL CM I (QUOTE BLUE))
(fetch (RGB BLUE) of LEVELS])
(\POSSIBLECOLOR
[LAMBDA (COLOR?) (* rrb "22-FEB-83 11:38")
(* could COLOR? be a color indicator. True if it is a number in the right range or a LITATOM that could be a name.)
(PROG ((MAXIMUMCOLOR 255))
(RETURN (SELECTQ (TYPENAME COLOR?)
(LITATOM COLOR?)
(SMALLP (AND (IGEQ COLOR? 0)
(ILEQ COLOR? MAXIMUMCOLOR)
COLOR?))
(LISTP (OR (RGBP COLOR?)
(HLSP COLOR?)))
NIL])
(INTENSITIESFROMCOLORMAP
[LAMBDA (CM) (* hdj "19-Jun-85 16:07")
(* returns the intensity levels of the primary colors
from a colormap. This list can be passed into
COLORMAPCREATE to get an equivalent colormap.)
(OR CM (SETQ CM (SCREENCOLORMAP)))
(for I from 0 to (SUB1 (EXPT 2 (COLORMAPBITS CM))) collect (COLORMAPENTRY CM I])
(SETCOLORINTENSITY
[LAMBDA (COLORMAP COLOR# INTENSITIES) (* hdj "26-Jun-85 11:48")
(* sets the intensity levels of a color number in a
color map. Does not return the previous setting.)
(PROG ((RGB INTENSITIES))
LP (COND
[(NULL RGB)
(SETQ RGB (QUOTE (0 0 0]
((RGBP RGB))
((HLSP RGB)
(SETQ RGB (HLSTORGB RGB)))
((SETQ RGB (CDR (\LOOKUPCOLORNAME RGB)))
(GO LP))
(T (\ILLEGAL.ARG RGB)))
(SETCOLORMAPENTRY COLORMAP COLOR# RGB])
)
(DEFINEQ
(\GENERICCOLORLEVEL
[LAMBDA (COLORMAP COLOR# PRIMARYCOLOR NEWLEVEL) (* bas: "25-APR-82 23:13")
(* returns the value of the intensity for color gun
PRIMARYCOLOR {RED, GREEN or BLUE} in COLOR#)
(SETQ COLOR# (COLORNUMBERP COLOR#))
(PROG1 (IDIFFERENCE 255 (LOGAND [\GETBASE (\DTEST COLORMAP (QUOTE COLORMAPP))
(IPLUS COLORSOFFSETINMAP (ITIMES COLOR# INTENSITYSIZE)
(SELECTQ PRIMARYCOLOR
(RED REDOFFSET)
(GREEN GREENOFFSET)
(BLUE BLUEOFFSET)
(\ILLEGAL.ARG PRIMARYCOLOR]
255)) (* if a new level is given, set it)
(COND
(NEWLEVEL (COND
((AND (SMALLP NEWLEVEL)
(IGEQ NEWLEVEL 0)
(ILEQ NEWLEVEL 255)))
(T (\ILLEGAL.ARG NEWLEVEL)))
(\PUTBASE COLORMAP (IPLUS COLORSOFFSETINMAP (ITIMES COLOR# INTENSITYSIZE)
(SELECTQ PRIMARYCOLOR
(RED REDOFFSET)
(GREEN GREENOFFSET)
BLUEOFFSET))
(LOGOR (LLSH COLOR# 12)
(SELECTQ PRIMARYCOLOR
(RED REDMASK)
(GREEN GREENMASK)
BLUEMASK)
(IDIFFERENCE 255 NEWLEVEL])
(\GENERICROTATECOLORMAP
[LAMBDA (COLORMAP STARTCOLOR THRUCOLOR) (* bas: "25-APR-82 12:38")
(* rotates the colors STARTCOLOR through THRUCOLOR in
the color map)
(OR (COLORMAPP COLORMAP)
(SETQ COLORMAP (SCREENCOLORMAP)))
(SETQ STARTCOLOR (COLORNUMBERP (OR STARTCOLOR 0)))
(SETQ THRUCOLOR (COLORNUMBERP (OR THRUCOLOR 15)))
[COND
((IGREATERP STARTCOLOR THRUCOLOR)
(SETQ STARTCOLOR (PROG1 THRUCOLOR (SETQ THRUCOLOR STARTCOLOR]
(PROG (LRED LBLUE LGREEN COLORADDR) (* save the last color)
[PROGN [SETQ LRED (\GETBASE COLORMAP (IPLUS COLORSOFFSETINMAP REDOFFSET (ITIMES
INTENSITYSIZE
THRUCOLOR]
[SETQ LBLUE (\GETBASE COLORMAP (IPLUS COLORSOFFSETINMAP BLUEOFFSET (ITIMES
INTENSITYSIZE
THRUCOLOR]
(SETQ LGREEN (\GETBASE COLORMAP (IPLUS COLORSOFFSETINMAP GREENOFFSET
(ITIMES INTENSITYSIZE THRUCOLOR]
(* move most of the colors up)
[for I from (SUB1 (IPLUS COLORSOFFSETINMAP (ITIMES INTENSITYSIZE THRUCOLOR)))
to (IPLUS COLORSOFFSETINMAP (ITIMES INTENSITYSIZE STARTCOLOR)) by -1
do (* IPLUS of constant quanity increments the color
address by one color number.)
(\PUTBASE (\ADDBASE COLORMAP (IPLUS I INTENSITYSIZE))
0
(IPLUS (\GETBASE (\ADDBASE COLORMAP I)
0)
(CONSTANT (LLSH 1 12]
[PROGN (* put the last color in the first.
LOGAND mask sets the color address which is stored in
the leftmost 4 bits to)
(\PUTBASE COLORMAP (IPLUS COLORSOFFSETINMAP REDOFFSET (ITIMES STARTCOLOR
INTENSITYSIZE))
(LOGOR (SETQ COLORADDR (LLSH STARTCOLOR 12))
(LOGAND (CONSTANT (SUB1 (EXPT 2 12)))
LRED)))
(\PUTBASE COLORMAP (IPLUS COLORSOFFSETINMAP BLUEOFFSET (ITIMES STARTCOLOR
INTENSITYSIZE))
(LOGOR COLORADDR (LOGAND (CONSTANT (SUB1 (EXPT 2 12)))
LBLUE)))
(\PUTBASE COLORMAP (IPLUS COLORSOFFSETINMAP GREENOFFSET (ITIMES STARTCOLOR
INTENSITYSIZE))
(LOGOR COLORADDR (LOGAND (CONSTANT (SUB1 (EXPT 2 12)))
LGREEN]
(RETURN COLORMAP])
)
(DEFINEQ
(\INSUREBITSPERPIXEL
(LAMBDA (NBITS) (* kbr: "16-May-85 19:19")
(* determines if NBITS is a legal color bits per
pixel.)
(SELECTQ NBITS
(NIL (* default to previous value or 4)
(OR \COLORDISPLAYBITSPERPIXEL 4))
(4 (* 4 is legal on both machines.)
4)
(8 8)
(\ILLEGAL.ARG NBITS))))
(\FAST8BIT
[LAMBDA (A B N MAP) (* edited: "10-SEP-82 16:14")
(bind AW (I ← 0) for J from 0
do (SETQ AW (\ADDBASE A J))
(OR (IGREATERP N I)
(RETURN))
(\PUTBASE B I (ELT MAP (fetch EN1 of AW)))
(OR (IGREATERP N (add I 1))
(RETURN))
(\PUTBASE B I (ELT MAP (fetch EN2 of AW)))
(OR (IGREATERP N (add I 1))
(RETURN))
(\PUTBASE B I (ELT MAP (fetch EN3 of AW)))
(OR (IGREATERP N (add I 1))
(RETURN))
(\PUTBASE B I (ELT MAP (fetch EN4 of AW)))
(OR (IGREATERP N (add I 1))
(RETURN))
(\PUTBASE B I (ELT MAP (fetch EN5 of AW)))
(OR (IGREATERP N (add I 1))
(RETURN))
(\PUTBASE B I (ELT MAP (fetch EN6 of AW)))
(OR (IGREATERP N (add I 1))
(RETURN))
(\PUTBASE B I (ELT MAP (fetch EN7 of AW)))
(OR (IGREATERP N (add I 1))
(RETURN))
(\PUTBASE B I (ELT MAP (fetch EN8 of AW)))
(add I 1])
(\MAP4
[LAMBDA (0C 1C) (* edited: "10-SEP-82 15:50")
(SETQ 0C (COND
(0C (COLORNUMBERP 0C 4))
(T 0))) (* Mask out but 4 bits)
(SETQ 1C (COND
(1C (COLORNUMBERP 1C 4))
(T 15)))
(PROG ((MAP (ARRAY 16 (QUOTE SMALLPOSP)
0 0)))
[for I from 0 to 15 do (SETA MAP I (for J from 0 to 3
sum (LLSH (COND
((ZEROP (LOGAND I (LLSH 1 J)))
0C)
(T 1C))
(ITIMES J 4]
(RETURN MAP])
(\MAP8
[LAMBDA (0C 1C) (* edited: "10-SEP-82 15:50")
(* returns an array of words that contain the destination bitmap should contain if a black and white bitmap is blown
up to an 8 bit per pixel bitmap.)
(SETQ 0C (COND
(0C (COLORNUMBERP 0C 8))
(T 0))) (* make sure color numbers are given.)
(SETQ 1C (COND
(1C (COLORNUMBERP 1C 8))
(T 255)))
(PROG ((MAP (ARRAY 4 (QUOTE SMALLPOSP)
0 0)))
[for I from 0 to 3 do (SETA MAP I (LOGOR (COND
((ZEROP (LOGAND I 1))
0C)
(T 1C))
(LLSH (COND
((ZEROP (LOGAND I 2))
0C)
(T 1C))
8]
(RETURN MAP])
)
(DEFINEQ
(\GETCOLORBRUSH
[LAMBDA (BRUSH COLOR NBITS) (* rrb "21-DEC-82 20:46")
(* produces a colorbitmap that is 1's where ever the
brush bitmap would be 1)
(COND
((AND (BITMAPP BRUSH)
(EQ (FETCH (BITMAP BITMAPBITSPERPIXEL) OF BRUSH)
NBITS))
BRUSH)
(T (COLORIZEBITMAP [COND
((LISTP BRUSH)
(\BRUSHBITMAP (FETCH (BRUSH BRUSHSHAPE) OF BRUSH)
(FETCH (BRUSH BRUSHSIZE) OF BRUSH)))
(T (\BRUSHBITMAP (QUOTE ROUND)
(OR BRUSH 1]
0 COLOR NBITS])
(\DDSETCOLORFONT
[LAMBDA (DISPLAYSTREAM) (* rrb " 7-SEP-83 15:05")
(* sets up the color font in a display stream)
(PROG (FONT (DD (\GETDISPLAYDATA DISPLAYSTREAM)))
[SETQ FONT (\GETCOLORFONT (fetch (\DISPLAYDATA DDFONT) of DD)
(DSPCOLOR NIL DISPLAYSTREAM)
(DSPBACKCOLOR NIL DISPLAYSTREAM)
(fetch (BITMAP BITMAPBITSPERPIXEL) of (fetch (\DISPLAYDATA
DDDestination)
of DD]
(replace (\DISPLAYDATA DDFONT) of DD with FONT) (* some of this is duplicated from \SFFixFont)
(replace PBTSOURCEBPL of (ffetch (\DISPLAYDATA DDPILOTBBT) of DD)
with (UNFOLD (fetch BITMAPRASTERWIDTH of (fetch CHARACTERBITMAP of FONT))
BITSPERWORD)) (* the cached offsets field is used to mark that the
color font has been computed)
(replace (\DISPLAYDATA DDOFFSETSCACHE) of DD with (fetch (ARRAYP BASE)
of (fetch \SFOffsets of FONT)))
(* call \SFFixY to set up the source in the PBT)
(\SFFixY DD])
(\GETCOLORFONT
[LAMBDA (BWFONT FORECOLOR BACKCOLOR NBITS) (* hdj " 4-Oct-85 09:42")
(* makes a font descriptor that has a character bitmap
that is colorized.)
(OR (\COLORFONTLOOKUP BWFONT FORECOLOR BACKCOLOR NBITS)
(LET* ((COLOREDFD (create FONTDESCRIPTOR using BWFONT))
(CSARRAY (ARRAY 256))
(CSINFO (\GETCHARSETINFO 0 COLOREDFD NIL)))
(* use the character bitmap of the black and white font which must be looked up because the one in the display
stream may have been colorized to a different color.)
(SETA CSARRAY 1 (create CHARSETINFO using CSINFO
(*)
CHARSETBITMAP ←(COLORIZEBITMAP
(fetch (CHARSETINFO CHARSETBITMAP)
of CSINFO)
(COLORNUMBERP BACKCOLOR)
(COLORNUMBERP FORECOLOR)
NBITS)))
(replace (FONTDESCRIPTOR FONTCHARSETVECTOR) of COLOREDFD
with (fetch (ARRAYP BASE) of CSARRAY))
(\COLORFONTSTORE COLOREDFD BWFONT FORECOLOR BACKCOLOR NBITS])
(\GETCOLORCSINFO
[LAMBDA (BWFONT FORECOLOR BACKCOLOR NBITS CHARSET) (* hdj "19-Jul-85 12:45")
(* Fill in the colorized bits from BWFONT into the
color font, if need be, then return the CSINFO for
CHARSET.)
(LET* ((FONT (\GETCOLORFONT BWFONT FORECOLOR BACKCOLOR NBITS))
(CSVECTOR (fetch FONTCHARSETVECTOR of FONT))
(CSINFO (\GETBASEPTR CSVECTOR (ITIMES CHARSET 2)))
BWCSINFO)
(COND
(CSINFO)
(T (* Have to create a new CSINFO)
(SETQ BWCSINFO (\GETCHARSETINFO CHARSET BWFONT))
(SETQ CSINFO (CREATE CHARSETINFO USING BWCSINFO CHARSETBITMAP←(COLORIZEBITMAP
(fetch (CHARSETINFO CHARSETBITMAP)
of BWCSINFO)
(COLORNUMBERP BACKCOLOR)
(COLORNUMBERP FORECOLOR)
NBITS)))
(\RPLPTR CSVECTOR (ITIMES CHARSET 2)
CSINFO)
CSINFO])
(\COLORFONTLOOKUP
[LAMBDA (BWFONT FORECOLOR BACKCOLOR NBITS) (* rrb "16-DEC-82 12:04")
(* looks in the color font cache to see if this font
has been colorized yet.)
(CDR (FASSOC NBITS (CDR (FASSOC BACKCOLOR (CDR (FASSOC FORECOLOR (CDR (FASSOC BWFONT
\COLORFONTCACHE])
(\COLORFONTSTORE
[LAMBDA (COLORIZEDFONT BWFONT FORECOLOR BACKCOLOR NBITS) (* rrb "16-DEC-82 12:10")
(* puts a color font into the cache of colored fonts.)
[PROG (X Y)
(COND
((NULL (SETQ X (FASSOC BWFONT \COLORFONTCACHE)))
(SETQ \COLORFONTCACHE (CONS [LIST BWFONT (LIST FORECOLOR (LIST BACKCOLOR
(CONS NBITS
COLORIZEDFONT]
\COLORFONTCACHE)))
[[NULL (SETQ Y (FASSOC FORECOLOR (CDR X]
(NCONC1 X (LIST FORECOLOR (LIST BACKCOLOR (CONS NBITS COLORIZEDFONT]
[[NULL (SETQ X (FASSOC BACKCOLOR (CDR Y]
(NCONC1 Y (LIST BACKCOLOR (CONS NBITS COLORIZEDFONT]
([NULL (SETQ Y (FASSOC NBITS (CDR X]
(NCONC1 X (CONS NBITS COLORIZEDFONT)))
((EQ (CDR Y)
COLORIZEDFONT))
(T (RPLACD Y COLORIZEDFONT]
COLORIZEDFONT])
)
(DEFINEQ
(CHANGECURSORSCREEN
[LAMBDA (NEWSCREEN) (* rrb "26-DEC-82 14:36")
(* moves the cursor onto the screen NEWSCREEN.)
(* for now support only the black and white and a color
screen.)
(PROG1 (COND
(\COLORCURSORBM (COLORSCREENBITMAP))
(T (SCREENBITMAP)))
(COND
[(EQ NEWSCREEN (SCREENBITMAP)) (* move to black and white.)
(COND
(\COLORCURSORBM (* now on color.)
(* take down current color cursor.)
(UNINTERRUPTABLY
(\TAKEDOWNCOLORCURSOR)
(* restore saved regular cursor.)
(SETQ \COLORCURSORBM NIL)
(* set flag that indicates that the color cursor is operating but currently down for a screen change to false.
This prevents SETCURSOR from bringing the cursor back up.)
(SETQ \COLORCURSORDOWN NIL)
(SETCURSOR (create CURSOR
CURSORBITMAP ← \COLORCURSOR
CURSORHOTSPOTX ← \MOUSEHOTSPOTX
CURSORHOTSPOTY ← \MOUSEHOTSPOTY)))
(\SETCURSORPOSITION LASTMOUSEX LASTMOUSEY]
[(EQ NEWSCREEN (COLORSCREENBITMAP)) (* move to color.)
(COND
((AND (COLORDISPLAYP)
(NULL \COLORCURSORBM)) (* now on black and white.)
(* move cursor to the corresponding spot on the color screen. This is necessary because the hardware tracks from the
upper left but we want the area of the b&w display that corresponds to the color to be the lower left.)
[\SETCURSORPOSITION (IMIN LASTMOUSEX (CONSTANT (SUB1 COLORSCREENWIDTH)))
(IMIN (CONSTANT (SUB1 SCREENHEIGHT))
(IPLUS LASTMOUSEY (CONSTANT (IDIFFERENCE SCREENHEIGHT
COLORSCREENHEIGHT]
(\SETCOLORCURSORBM (fetch (CURSOR CURSORBITMAP) of (CURSOR \EMPTYCURSOR]
(NEWSCREEN (\ILLEGAL.ARG NEWSCREEN])
(\SETCOLORCURSORBM
[LAMBDA (CURSORBM) (* rrb "13-Dec-83 10:46")
(* sets the global variables that are used in tracking the color cursor. \COLORCURSORBM is the one which indicates
whether the cursor is on the color or bw screen; non-NIL indicates color. It is the bitmap of the colorized cursor
bitmap image.)
(* this should only be called with the colorcursor
taken down.)
(PROG ((COLORSBM (COLORSCREENBITMAP))
NBITS CURSORCOLORBM)
(SETQ NBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of COLORSBM))
(SETQ CURSORCOLORBM (COLORIZEBITMAP CURSORBM 0 (MAXIMUMCOLOR \SystemColorMap)
NBITS))
(COND
((NOT (type? PILOTBBT \ColorCursorBBT)) (* make sure cursor flashing bit blt table is set up.)
(SETQ \ColorCursorBBT (create PILOTBBT))
(replace (PILOTBBT PBTFLAGS) of \ColorCursorBBT with 0)
(replace (PILOTBBT PBTUSEGRAY) of \ColorCursorBBT with NIL)
(replace (PILOTBBT PBTDISJOINT) of \ColorCursorBBT with T)
(replace (PILOTBBT PBTOPERATION) of \ColorCursorBBT with 3)
(replace (PILOTBBT PBTSOURCETYPE) of \ColorCursorBBT with 0)))
(UNINTERRUPTABLY
(replace (PILOTBBT PBTDESTBPL) of \ColorCursorBBT with (UNFOLD (SETQ
\COLORSCREENRASTERWIDTH
(fetch (BITMAP
BITMAPRASTERWIDTH)
of COLORSBM))
BITSPERWORD))
(replace (PILOTBBT PBTSOURCEBPL) of \ColorCursorBBT
with (UNFOLD (SETQ \COLORCURSORRASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH)
of CURSORCOLORBM))
BITSPERWORD)) (* keep a pointer to the base of the line that the
cursor is on.)
(SETQ.NOREF \COLORSCREENCURSORLINEBASE (\ADDBASE (fetch (BITMAP BITMAPBASE)
of COLORSBM)
(ITIMES (SETQ \COLORSCREENCURSORLINE
(\GETBASE \EM.CURSORY 0))
\COLORSCREENRASTERWIDTH)))
(SETQ \COLORSCREENWIDTHINBITS (fetch (BITMAP BITMAPWIDTH) of COLORSBM))
(SETQ \COLORCURSORBASE (fetch (BITMAP BITMAPBASE) of CURSORCOLORBM))
(SETQ \COLORCURSORWIDTH (fetch (BITMAP BITMAPWIDTH) of CURSORCOLORBM))
(SETQ \COLORCURSORHEIGHT (fetch (BITMAP BITMAPHEIGHT) of CURSORCOLORBM))
(SETQ \COLORCURSOR CURSORBM)
(* \COLORCURSORDOWN is used to disable the color cursor tracking by the key handler even though \COLORCURSORBM is
non-NIL. It is set to T here so that if the keyboard handler runs between the time \COLORCURSORBM is set and
\PUTUPCOLORCURSOR completes, the cursor won't be displayed.)
(SETQ \COLORCURSORDOWN T)
(SETQ \COLORCURSORBM CURSORCOLORBM)
(\PUTUPCOLORCURSOR))])
(\TAKEDOWNCOLORCURSOR
[LAMBDA NIL (* rrb "11-NOV-82 19:06")
(COND
((AND \COLORCURSORBM (NULL \COLORCURSORDOWN)) (* take down the color cursor.)
(* set flag first so that keyboard handler will stop
moving cursor image before we remove it.)
(SETQ \COLORCURSORDOWN T)
(.TAKE.DOWN.COLOR.CURSOR])
(\IFCOLORDS\TAKEDOWNCOLORCURSOR
[LAMBDA (DS) (* rrb " 7-SEP-83 15:09")
(* if DS is onto the color display, this takes down the
color cursor)
(AND (EQ (fetch (\DISPLAYDATA DDDestination) of (\GETDISPLAYDATA DS))
(COLORSCREENBITMAP))
(\TAKEDOWNCOLORCURSOR])
(\PUTUPCOLORCURSOR
[LAMBDA NIL (* rrb "16-NOV-82 12:12")
(* put up the color cursor image. Must be done without 60 cycle interrupts so that position of cursor doesn't get
changed before the flag gets set to indicate tracking.)
(* turns off keyboard interrupts {and everything else for that matter} with code cobbled from WITHOUT-INTERRUPTS.
Didn't use WITHOUT-INTERRUPTS because is cause flash on the b&w display taking the display down.)
(* this should always be called in an UNINTERRUPTABLE
context.)
(\PUTBASE \EM.DISPINTERRUPT 0 (PROG1 (\GETBASE \EM.DISPINTERRUPT 0)
(\PUTBASE \EM.DISPINTERRUPT 0 0)
(\SHOWCOLORCURSOR (\GETBASE \EM.CURSORX 0)
(\GETBASE \EM.CURSORY 0))
(SETQ \COLORCURSORDOWN NIL])
(\COLORCURSORDOWN
[LAMBDA (DS) (* rrb " 7-SEP-83 15:09")
(* if this DS is onto the colorscreen, it takes the
cursor down.)
(AND (NULL \COLORCURSORDOWN)
(EQ (fetch (\DISPLAYDATA DDDestination) of (\GETDISPLAYDATA DS))
(COLORSCREENBITMAP))
(\TAKEDOWNCOLORCURSOR])
)
(DEFINEQ
(\PIXELBLT.UFN
[LAMBDA (COLORTABLEBASE SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTBITMAP DESTINATIONLEFT
DESTINATIONBOTTOM WIDTH DUMMY HEIGHT)
(* hdj " 3-Jul-85 14:39")
(DECLARE (LOCALVARS . T))
[PROG ((SOURCEBITMAPBASE (fetch (BITMAP BITMAPBASE) of SOURCEBITMAP))
(DESTBITMAPBASE (fetch (BITMAP BITMAPBASE) of DESTBITMAP))
PXHEIGHTCOUNTER PXWIDTHCOUNTER BMSTMPREG BMDTMPREG BMSRCOFFSET BMDSTOFFSET COLRTBENTRY
COLRNBLENTRY BMSRCORIOFFSET BMDSTORIOFFSET BMRSWOFSRC BMRSWOFDST BMDTMPREGNBL BMSTMPREGNBL
PXWIDTHMAX PXHEIGHTMAX XOFSRCMOD4 XOFDSTMOD4 XDSTOFFSETIMOD2 YDSTOFFSETIMOD2
XOFDSTIMOD4MAX PXWORDOFFSET)
(SETQ PXHEIGHTMAX (SUB1 HEIGHT))
(SETQ PXWIDTHMAX (SUB1 WIDTH))
(SETQ BMRSWOFSRC (fetch BITMAPRASTERWIDTH of SOURCEBITMAP))
(SETQ BMRSWOFDST (fetch BITMAPRASTERWIDTH of DESTBITMAP))
(SETQ BMSRCORIOFFSET (IPLUS (ITIMES (IDIFFERENCE (fetch BITMAPHEIGHT of SOURCEBITMAP)
(ADD1 SOURCEBOTTOM))
BMRSWOFSRC)
(FOLDLO SOURCELEFT 4)))
(* CALCULATE INITIAL OFFSET OF SOURCE MEMORY LOCATION)
(SETQ BMDSTORIOFFSET (IPLUS (ITIMES (IDIFFERENCE (fetch BITMAPHEIGHT of DESTBITMAP)
(ADD1 DESTINATIONBOTTOM))
BMRSWOFDST)
(FOLDLO DESTINATIONLEFT 4)))
(* CALCULATE INITIAL OFFSET OF DESTINATION MEMORY
LOCATION)
(* DO BLOCK TRANSFER ONE LINE AT A TIME)
(for PXHEIGHTCOUNTER from 0 to PXHEIGHTMAX
do (SETQ BMSRCOFFSET (IDIFFERENCE BMSRCORIOFFSET (ITIMES PXHEIGHTCOUNTER BMRSWOFSRC)))
(* CALCULATE SOURCE OFFSET)
(SETQ BMDSTOFFSET (IDIFFERENCE BMDSTORIOFFSET (ITIMES PXHEIGHTCOUNTER BMRSWOFDST)))
(* CALCULATE DESTINATION OFFSET)
(SETQ BMSTMPREG (\GETBASE SOURCEBITMAPBASE BMSRCOFFSET))
(* FETCH FIRST WORD OF A LINE OF SOURCE)
(SETQ BMDTMPREG (\GETBASE DESTBITMAPBASE BMDSTOFFSET))
(* FETCH FIRST WORD OF A LINE OF DESTINATION)
(SETQ XOFSRCMOD4 (IMOD SOURCELEFT 4))
(SETQ BMSTMPREG (ROT BMSTMPREG (SELECTQ XOFSRCMOD4
(0 8)
(1 12)
(2 0)
4)
16)) (* ALIGN SOURCE NYBBLE VALUE)
(SETQ XOFDSTMOD4 (IMOD DESTINATIONLEFT 4))
(SETQ BMDTMPREG (ROT BMDTMPREG (SELECTQ XOFDSTMOD4
(0 4)
(1 8)
(2 12)
0)
16)) (* ALIGN DESTINATION NYBBLE VALUE)
[for PXWIDTHCOUNTER from 0 to PXWIDTHMAX
do (SETQ BMDTMPREGNBL (LOGAND BMDTMPREG 15))
(* MASK OFF UNWANTED BITS)
(SETQ BMSTMPREGNBL (LOGAND BMSTMPREG 240))
(SETQ COLRTBENTRY (\GETBASE COLORTABLEBASE (LOGOR BMSTMPREGNBL BMDTMPREGNBL)))
(* GET A COLOR TABLE ENTRY)
(SETQ XDSTOFFSETIMOD2 (IMOD (IPLUS DESTINATIONLEFT PXWIDTHCOUNTER)
2))
(SETQ YDSTOFFSETIMOD2 (IMOD (IPLUS DESTINATIONBOTTOM PXHEIGHTCOUNTER)
2))
(SETQ COLRNBLENTRY (LOGAND (ROT COLRTBENTRY (SELECTQ
YDSTOFFSETIMOD2
(0 (SELECTQ XDSTOFFSETIMOD2
(0 4)
8))
(SELECTQ XDSTOFFSETIMOD2
(0 12)
0))
16)
15)) (* SELECT WHICH NYBBLE)
(SETQ BMDTMPREG (LOGOR (LOGAND BMDTMPREG 65520)
COLRNBLENTRY))
(* INSTALL NYBBLE AT DESTINATION WORD)
(SETQ PXWORDOFFSET (IDIFFERENCE (FOLDLO (IPLUS DESTINATIONLEFT PXWIDTHCOUNTER)
4)
(FOLDLO DESTINATIONLEFT 4)))
(COND
((EQ (IMOD (IPLUS DESTINATIONLEFT PXWIDTHCOUNTER)
4)
3)
(\PUTBASE DESTBITMAPBASE (IPLUS BMDSTOFFSET PXWORDOFFSET)
BMDTMPREG) (* IF LAST NYBBLE WRITE THAT WORD)
[COND
((NEQ PXWIDTHCOUNTER PXWIDTHMAX)
(SETQ BMDTMPREG (\GETBASE DESTBITMAPBASE (IPLUS BMDSTOFFSET
(ADD1 PXWORDOFFSET]
(* AND FETCH THE NEXT WORD OF DESTINATION)
))
(SETQ BMDTMPREG (ROT BMDTMPREG 4 16))
(if (EQ (IMOD (IPLUS SOURCELEFT PXWIDTHCOUNTER)
4)
3)
then [SETQ BMSTMPREG (\GETBASE SOURCEBITMAPBASE
(IPLUS BMSRCOFFSET
(ADD1 (IDIFFERENCE
(FOLDLO (IPLUS SOURCELEFT
PXWIDTHCOUNTER)
4)
(FOLDLO SOURCELEFT 4]
(* IF LAST NYBBLE FETCH THE NEXT WORD OF SOURCE)
(SETQ BMSTMPREG (ROT BMSTMPREG 8 16))
else (SETQ BMSTMPREG (ROT BMSTMPREG 4 16]
(SETQ XOFDSTIMOD4MAX (IMOD (IPLUS DESTINATIONLEFT PXWIDTHMAX)
4))
(SETQ BMDTMPREG (ROT BMDTMPREG (SELECTQ XOFDSTIMOD4MAX
(0 8)
(1 4)
(2 0)
12)
16)) (* ALIGN THE LAST WORD OF DESTINATION)
(if (NEQ XOFDSTIMOD4MAX 3)
then (\PUTBASE DESTBITMAPBASE (IPLUS BMDSTOFFSET (IDIFFERENCE
(FOLDLO (IPLUS DESTINATIONLEFT PXWIDTHMAX)
4)
(FOLDLO DESTINATIONLEFT 4)))
BMDTMPREG]
0])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \COLORCURSOR \COLORSCREENBITMAPBASE \COLORCURSORWIDTH \CURSORSAV \COLORCURSORDOWN
\EMPTYCURSOR \ColorCursorBBT \COLORSCREENRASTERWIDTH \COLORCURSORRASTERWIDTH
\COLORSCREENWIDTHINBITS \COLORCURSORBASE \COLORCURSORWIDTH \COLORCURSORHEIGHT
\COLORFONTCACHE)
)
(RPAQ? \COLORCURSOR )
(RPAQ? \CURSORSAV )
(RPAQ? \COLORFONTCACHE )
(RPAQ \EMPTYCURSOR (CURSORCREATE (READBITMAP) 0 15))
(16 16
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@")(RPAQ \DEFAULTCOLORCURSOR (CURSORCREATE (READBITMAP) 0 15))
(16 16
"OOH@"
"OO@@"
"ON@@"
"ON@@"
"OO@@"
"OOH@"
"OOL@"
"OON@"
"LOO@"
"HGOH"
"@COL"
"@AON"
"@@OO"
"@@GN"
"@@CL"
"@@AH")(DEFINEQ
(\DRAWCOLORLINE1
[LAMBDA (X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH NBITS COLOR)
(* rrb "10-OCT-82 12:33")
(DECLARE (LOCALVARS . T))
(COND
((EQ NBITS 4)
(\DRAW4BPPCOLORLINE X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH COLOR))
(T (\DRAW8BPPCOLORLINE X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH COLOR])
(\DRAW4BPPCOLORLINE
[LAMBDA (X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH COLOR)
(* rrb "10-OCT-82 12:33")
(DECLARE (LOCALVARS . T))
(* draws a color line starting at X0,Y0 at a slope of DX/DY until reaching either XLIMIT or YLIMIT with an initial
overflow bucket size of CDL in MODE. Arranged so that the clipping routines can determine what the exact location of
the end point of the clipped line is wrt line drawing coordinates eg. amount in overflow bucket.
XLIMIT and YLIMIT are the number of points to be moved in that direction.)
(PROG (MAPPTR MASK COLORMASK (COLORMASKORG (LLSH COLOR 12))
WORDOFFSET)
(* keep word offset from bitmapbase so that the YINC can be negative or positive. Used to use \ADDBASE directly but
negative case was not in micro code and ran much slower.)
[SETQ WORDOFFSET (IPLUS (ITIMES Y0 RASTERWIDTH)
(FOLDLO X0 (CONSTANT (LRSH BITSPERWORD 2]
(SETQ MAPPTR (\ADDBASE BITMAPBASE WORDOFFSET))
(SETQ MASK (\4BITMASK X0))
(SETQ COLORMASK (LLSH COLOR (LLSH (IDIFFERENCE 3 (LOGAND X0 3))
2)))
(SETQ X0 0)
(SETQ Y0 0)
(COND
[(IGEQ DX DY) (* X is the fastest mover.)
(SELECTQ MODE
(INVERT (.DRAW4BPPLINEX. (QUOTE INVERT)))
(.DRAW4BPPLINEX. (QUOTE REPLACE/PAINT]
(T (* Y is the fastest mover.)
(SELECTQ MODE
(INVERT (.DRAW4BPPLINEY. (QUOTE INVERT)))
(.DRAW4BPPLINEY. (QUOTE REPLACE/PAINT])
(\DRAW8BPPCOLORLINE
[LAMBDA (X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH COLOR)
(* rrb "15-OCT-82 14:14")
(DECLARE (LOCALVARS . T))
(* draws a color line starting at X0,Y0 at a slope of DX/DY until reaching either XLIMIT or YLIMIT with an initial
overflow bucket size of CDL in MODE. Arranged so that the clipping routines can determine what the exact location of
the end point of the clipped line is wrt line drawing coordinates eg. amount in overflow bucket.
XLIMIT and YLIMIT are the number of points to be moved in that direction.)
(PROG (MAPPTR STARTBYTE WORDOFFSET)
(* keep word offset from bitmapbase so that the YINC can be negative or positive. Used to use \ADDBASE directly but
negative case was not in micro code and ran much slower.)
[SETQ WORDOFFSET (IPLUS (ITIMES Y0 RASTERWIDTH)
(FOLDLO X0 (CONSTANT (LRSH BITSPERWORD 3]
(SETQ MAPPTR (\ADDBASE BITMAPBASE WORDOFFSET))
(SETQ STARTBYTE (LOGAND X0 1))
(SETQ X0 0)
(SETQ Y0 0)
(COND
[(IGEQ DX DY) (* X is the fastest mover.)
(SELECTQ MODE
(INVERT (.DRAW8BPPLINEX (QUOTE INVERT)))
(.DRAW8BPPLINEX (QUOTE REPLACE/PAINT]
(T (* Y is the fastest mover.)
(SELECTQ MODE
(INVERT (.DRAW8BPPLINEY (QUOTE INVERT)))
(.DRAW8BPPLINEY (QUOTE REPLACE/PAINT])
)
(DECLARE: DONTCOPY DOEVAL@COMPILE
(DECLARE: EVAL@COMPILE
[PUTPROPS .DRAW4BPPLINEX. MACRO ((MODE)
(until (IGREATERP X0 XLIMIT)
do
(* main loop)
[replace (BITMAPWORD BITS)
of MAPPTR with (SELECTQ MODE (INVERT (LOGXOR COLORMASK
(fetch (BITMAPWORD BITS)
of MAPPTR)))
(PROGN (* case of ERASE was change to PAINT of
background color.)
(* case is PAINT or REPLACE. Legality of
OPERATION has been checked by
\CLIPANDDRAWLINE1)
(LOGOR COLORMASK
(LOGAND (LOGXOR MASK WORDMASK)
(fetch (BITMAPWORD BITS)
of MAPPTR]
[COND ([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY]
(COND ((IGREATERP (SETQ Y0 (ADD1 Y0))
YLIMIT)
(RETURN)))
(SETQ CDL (IDIFFERENCE CDL DX))
(SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET YINC]
[COND [(ZEROP (SETQ MASK (LRSH MASK 4)))
(* crossed word boundary)
[SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (ADD1 WORDOFFSET]
(SETQ COLORMASK COLORMASKORG)
(SETQ MASK (CONSTANT (\4BITMASK 0]
(T (SETQ COLORMASK (LRSH COLORMASK 4]
(SETQ X0 (ADD1 X0]
[PUTPROPS .DRAW8BPPLINEX MACRO ((MODE)
(PROG NIL (COND ((EQ STARTBYTE 1)
(GO 1LP)))
0LP
(* main loop)
(\PUTBASEBYTE MAPPTR 0 (SELECTQ MODE (INVERT (LOGXOR COLOR (\GETBASEBYTE MAPPTR 0)))
(PROGN (* case of ERASE was change to PAINT of
background color.)
(* case is PAINT or REPLACE. Legality of
OPERATION has been checked by
\CLIPANDDRAWLINE1)
COLOR)))
[COND ([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY]
(COND ((IGREATERP (SETQ Y0 (ADD1 Y0))
YLIMIT)
(RETURN)))
(SETQ CDL (IDIFFERENCE CDL DX))
(SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET YINC]
(COND ((IGREATERP (SETQ X0 (ADD1 X0))
XLIMIT)
(RETURN)))
1LP
(\PUTBASEBYTE MAPPTR 1 (SELECTQ MODE (INVERT (LOGXOR COLOR (\GETBASEBYTE MAPPTR 1)))
(PROGN (* case of ERASE was change to PAINT of
background color.)
(* case is PAINT or REPLACE. Legality of
OPERATION has been checked by
\CLIPANDDRAWLINE1)
COLOR)))
[COND ([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY]
(COND ((IGREATERP (SETQ Y0 (ADD1 Y0))
YLIMIT)
(RETURN)))
(SETQ CDL (IDIFFERENCE CDL DX))
(SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET YINC]
(COND ((IGREATERP (SETQ X0 (ADD1 X0))
XLIMIT)
(RETURN)))
[SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (ADD1 WORDOFFSET]
(GO 0LP]
[PUTPROPS .DRAW8BPPLINEY MACRO ((MODE)
(PROG NIL (COND ((EQ STARTBYTE 1)
(GO 1LP)))
0LP
(* main loop)
(\PUTBASEBYTE MAPPTR 0 (SELECTQ MODE (INVERT (LOGXOR COLOR (\GETBASEBYTE MAPPTR 0)))
(PROGN (* case of ERASE was change to PAINT of
background color.)
(* case is PAINT or REPLACE. Legality of
OPERATION has been checked by
\CLIPANDDRAWLINE1)
COLOR)))
(COND ((IGREATERP (SETQ Y0 (ADD1 Y0))
YLIMIT)
(RETURN)))
[SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET YINC]
(COND ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX]
(* moved enough in Y to move a point in X)
(COND ((IGREATERP (SETQ X0 (ADD1 X0))
XLIMIT)
(RETURN)))
(SETQ CDL (IDIFFERENCE CDL DY))
(GO 1LP)))
(GO 0LP)
1LP
(\PUTBASEBYTE MAPPTR 1 (SELECTQ MODE (INVERT (LOGXOR COLOR (\GETBASEBYTE MAPPTR 1)))
(PROGN (* case of ERASE was change to PAINT of
background color.)
(* case is PAINT or REPLACE. Legality of
OPERATION has been checked by
\CLIPANDDRAWLINE1)
COLOR)))
(COND ((IGREATERP (SETQ Y0 (ADD1 Y0))
YLIMIT)
(RETURN)))
[SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET YINC]
(COND ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX]
(* moved enough in Y to move a point in X)
(COND ((IGREATERP (SETQ X0 (ADD1 X0))
XLIMIT)
(RETURN)))
(SETQ CDL (IDIFFERENCE CDL DY))
[SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (ADD1 WORDOFFSET]
(GO 0LP)))
(GO 1LP]
[PUTPROPS .DRAW4BPPLINEY. MACRO ((MODE)
(until (IGREATERP Y0 YLIMIT)
do
(* main loop)
[replace (BITMAPWORD BITS)
of MAPPTR with (SELECTQ MODE (INVERT (LOGXOR COLORMASK
(fetch (BITMAPWORD BITS)
of MAPPTR)))
(PROGN (* case is PAINT or REPLACE. Legality of
OPERATION has been checked by
\CLIPANDDRAWLINE1)
(LOGOR COLORMASK
(LOGAND (LOGXOR MASK WORDMASK)
(fetch (BITMAPWORD BITS)
of MAPPTR]
[COND ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX]
(COND ((IGREATERP (SETQ X0 (ADD1 X0))
XLIMIT)
(RETURN)))
(SETQ CDL (IDIFFERENCE CDL DY))
(COND [(ZEROP (SETQ MASK (LRSH MASK 4)))
(* crossed word boundary)
[SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (ADD1 WORDOFFSET]
(SETQ COLORMASK COLORMASKORG)
(SETQ MASK (CONSTANT (\4BITMASK 0]
(T (SETQ COLORMASK (LRSH COLORMASK 4]
[SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET YINC]
(SETQ Y0 (ADD1 Y0]
)
)
(DECLARE: DONTCOPY DOEVAL@COMPILE
(DECLARE: EVAL@COMPILE
[PUTPROPS \BITADDRESSOFPIXEL MACRO (OPENLAMBDA (BITSPERPIXEL PIXEL)
(COND ((EQ BITSPERPIXEL 4)
(LLSH PIXEL 2))
(T (LLSH PIXEL 3]
(PUTPROPS COLORNUMBERBITSPERPIXEL MACRO (NIL (DECLARE (GLOBALVARS \COLORDISPLAYBITSPERPIXEL))
\COLORDISPLAYBITSPERPIXEL))
)
)
(DEFINEQ
(\BWTOCOLORBLT
[LAMBDA (SOURCEBWBM SLEFT SBOTTOM DESTCOLORBM DLEFT DBOTTOM WIDTH HEIGHT 0COLOR 1COLOR DESTNBITS)
(* rrb "21-DEC-82 21:26")
(* blits from a black and white bitmap into a color bitmap which has DESTNBITS bits per pixel.
DESTCOLORBM is a pointer to the color bitmap.)
(* assumes all datatypes and bounds have been checked)
(SELECTQ DESTNBITS
[4 (PROG ((MAP (fetch (ARRAYP BASE) of (\MAP4 0COLOR 1COLOR)))
(SRCBASE (fetch BITMAPBASE of SOURCEBWBM))
(SRCHEIGHT (fetch BITMAPHEIGHT of SOURCEBWBM))
(SRCRW (fetch BITMAPRASTERWIDTH of SOURCEBWBM))
(SRCWRD (FOLDLO SLEFT BITSPERWORD))
(SRCOFFSET (MOD SLEFT BITSPERWORD))
(DESBASE (fetch BITMAPBASE of DESTCOLORBM))
(DESHEIGHT (fetch BITMAPHEIGHT of DESTCOLORBM))
(DESRW (fetch BITMAPRASTERWIDTH of DESTCOLORBM))
(DESWRD (FOLDLO DLEFT 4))
(DESOFF (MOD DLEFT 4))
(NBITS 4)
DESALIGNLEFT SCR) (* DESTCOLORBM is used to allow one bit per pixel
bitblt operations on the bitmap.)
[COND
((NEQ 0 DESOFF) (* save the left bits of the destination bitmap so it
can be word aligned.)
(SETQ SCR (BITMAPCREATE 4 HEIGHT 4))
(BITBLT DESTCOLORBM (SETQ DESALIGNLEFT (LLSH DESWRD 2))
DBOTTOM SCR 0 0 DESOFF HEIGHT (QUOTE INPUT)
(QUOTE REPLACE]
(for LINECOUNTER from 1 to HEIGHT
do
(* linecounter goes from 1 to height because bitmaps are stored internally with top first so subtracting height is
necessary to get offset of line and the 1 corrects for height difference.)
(\4BITLINEBLT (\ADDBASE SRCBASE (IPLUS (ITIMES (IDIFFERENCE SRCHEIGHT
(IPLUS
LINECOUNTER
SBOTTOM))
SRCRW)
SRCWRD))
SRCOFFSET
(\ADDBASE DESBASE (IPLUS (ITIMES (IDIFFERENCE DESHEIGHT
(IPLUS
LINECOUNTER
DBOTTOM))
DESRW)
DESWRD))
WIDTH MAP 0COLOR 1COLOR))
(COND
(DESALIGNLEFT (* move the color bits to the right and restore the
saved color bits.)
(BITBLT DESTCOLORBM DESALIGNLEFT DBOTTOM DESTCOLORBM
(IPLUS DESALIGNLEFT DESOFF)
DBOTTOM WIDTH HEIGHT (QUOTE INPUT)
(QUOTE REPLACE))
(BITBLT SCR 0 0 DESTCOLORBM DESALIGNLEFT DBOTTOM DESOFF HEIGHT
(QUOTE INPUT)
(QUOTE REPLACE]
[8 (PROG ((MAP (fetch (ARRAYP BASE) of (\MAP8 0COLOR 1COLOR)))
(SRCBASE (fetch BITMAPBASE of SOURCEBWBM))
(SRCHEIGHT (fetch BITMAPHEIGHT of SOURCEBWBM))
(SRCRW (fetch BITMAPRASTERWIDTH of SOURCEBWBM))
(SRCWRD (FOLDLO SLEFT BITSPERWORD))
(SRCOFFSET (MOD SLEFT BITSPERWORD))
(DESBASE (fetch BITMAPBASE of DESTCOLORBM))
(DESHEIGHT (fetch BITMAPHEIGHT of DESTCOLORBM))
(DESRW (fetch BITMAPRASTERWIDTH of DESTCOLORBM))
(DESWRD (FOLDLO DLEFT 2))
(DESOFF (MOD DLEFT 2)))
(for LINECOUNTER from 1 to HEIGHT
do
(* linecounter goes from 1 to height because bitmaps are stored internally with top first so subtracting height is
necessary to get offset of line and the 1 corrects for height difference.)
(\8BITLINEBLT (\ADDBASE SRCBASE (IPLUS (ITIMES (IDIFFERENCE SRCHEIGHT
(IPLUS
LINECOUNTER
SBOTTOM))
SRCRW)
SRCWRD))
SRCOFFSET
(\ADDBASE DESBASE (IPLUS (ITIMES (IDIFFERENCE DESHEIGHT
(IPLUS
LINECOUNTER
DBOTTOM))
DESRW)
DESWRD))
DESOFF WIDTH MAP 0COLOR 1COLOR]
(SHOULDNT])
(\8BITLINEBLT
[LAMBDA (SBASE SBITOFFSET DBASE DBITOFFSET WIDTH MAPBASE 0COLOR 1COLOR)
(* edited: "16-SEP-82 19:36")
(* moves one line of a black and white bitmap into a
color bitmap using a mapping table.)
[COND
((EQ 1 DBITOFFSET) (* move the first bit specially to get to word boundary
in destination.)
(\PUTBASEBYTE DBASE 1 (COND
((ZEROP (LOGAND (\GETBASE SBASE 0)
(\BITMASK SBITOFFSET)))
0COLOR)
(T 1COLOR)))
[COND
((EQ (SETQ SBITOFFSET (ADD1 SBITOFFSET))
BITSPERWORD) (* SBITOFFSET flowed onto next word.)
(SETQ SBITOFFSET 0)
(SETQ SBASE (\ADDBASE SBASE 1]
(SETQ DBITOFFSET 0)
(SETQ DBASE (\ADDBASE DBASE 1))
(SETQ WIDTH (SUB1 WIDTH]
(COND
((ZEROP (MOD SBITOFFSET 2)) (* case of moving even aligned bits.)
(PROG NIL
LP [COND
((AND (IGREATERP WIDTH (SUB1 BITSPERWORD))
(EQ SBITOFFSET 0)) (* move a source word's worth of bits.)
(\PUTBASE DBASE 0 (\GETBASE MAPBASE (fetch EN1 of SBASE)))
(\PUTBASE DBASE 1 (\GETBASE MAPBASE (fetch EN2 of SBASE)))
(\PUTBASE DBASE 2 (\GETBASE MAPBASE (fetch EN3 of SBASE)))
(\PUTBASE DBASE 3 (\GETBASE MAPBASE (fetch EN4 of SBASE)))
(\PUTBASE DBASE 4 (\GETBASE MAPBASE (fetch EN5 of SBASE)))
(\PUTBASE DBASE 5 (\GETBASE MAPBASE (fetch EN6 of SBASE)))
(\PUTBASE DBASE 6 (\GETBASE MAPBASE (fetch EN7 of SBASE)))
(\PUTBASE DBASE 7 (\GETBASE MAPBASE (fetch EN8 of SBASE)))
(SETQ DBASE (\ADDBASE DBASE 8))
(SETQ SBASE (\ADDBASE SBASE 1))
(SETQ WIDTH (IDIFFERENCE WIDTH BITSPERWORD)))
((EQ WIDTH 0)
(RETURN))
((EQ WIDTH 1) (* move last bit specially)
(\PUTBASEBYTE DBASE 0 (COND
((ZEROP (LOGAND (\GETBASE SBASE 0)
(\BITMASK SBITOFFSET)))
0COLOR)
(T 1COLOR)))
(RETURN))
(T (* move the rest of the first word or last word two at
a time.)
(\PUTBASEBYTE DBASE 0 (COND
((ZEROP (LOGAND (\GETBASE SBASE 0)
(\BITMASK SBITOFFSET)))
0COLOR)
(T 1COLOR)))
(\PUTBASEBYTE DBASE 1 (COND
([ZEROP (LOGAND (\GETBASE SBASE 0)
(\BITMASK (ADD1 SBITOFFSET]
0COLOR)
(T 1COLOR)))
(SETQ DBASE (\ADDBASE DBASE 1))
(SETQ WIDTH (IDIFFERENCE WIDTH 2))
(COND
((EQ SBITOFFSET 14)
(SETQ SBASE (\ADDBASE SBASE 1))
(SETQ SBITOFFSET 0))
(T (SETQ SBITOFFSET (IPLUS SBITOFFSET 2]
(GO LP)))
(T (* moving odd aligned bits.)
(PROG NIL
LP [COND
((AND (IGREATERP WIDTH (SUB1 BITSPERWORD))
(EQ SBITOFFSET 1))
(* move a source word's worth of bits. move the 1th thru 15th bits in the first word plus the 0th bit in the next
word.)
(\PUTBASE DBASE 0 (\GETBASE MAPBASE (fetch ODD2BIT1 of SBASE)))
(\PUTBASE DBASE 1 (\GETBASE MAPBASE (fetch ODD2BIT2 of SBASE)))
(\PUTBASE DBASE 2 (\GETBASE MAPBASE (fetch ODD2BIT3 of SBASE)))
(\PUTBASE DBASE 3 (\GETBASE MAPBASE (fetch ODD2BIT4 of SBASE)))
(\PUTBASE DBASE 4 (\GETBASE MAPBASE (fetch ODD2BIT5 of SBASE)))
(\PUTBASE DBASE 5 (\GETBASE MAPBASE (fetch ODD2BIT6 of SBASE)))
(\PUTBASE DBASE 6 (\GETBASE MAPBASE (fetch ODD2BIT7 of SBASE)))
(\PUTBASEBYTE DBASE 14 (COND
((ZEROP (fetch BIT15 of SBASE))
0COLOR)
(T 1COLOR)))
(\PUTBASEBYTE DBASE 15 (COND
([ZEROP (fetch BIT0 of (SETQ SBASE (\ADDBASE SBASE 1]
0COLOR)
(T 1COLOR)))
(SETQ DBASE (\ADDBASE DBASE 8))
(SETQ WIDTH (IDIFFERENCE WIDTH BITSPERWORD)))
((EQ WIDTH 0)
(RETURN))
((EQ WIDTH 1) (* move last bit specially)
(\PUTBASEBYTE DBASE 0 (COND
((ZEROP (LOGAND (\GETBASE SBASE 0)
(\BITMASK SBITOFFSET)))
0COLOR)
(T 1COLOR)))
(RETURN))
((EQ SBITOFFSET 15) (* case of moving one bit from each of two words in the
slow case.)
(\PUTBASEBYTE DBASE 0 (COND
((ZEROP (fetch BIT15 of SBASE))
0COLOR)
(T 1COLOR)))
(\PUTBASEBYTE DBASE (SETQ SBITOFFSET 1)
(COND
([ZEROP (fetch BIT0 of (SETQ SBASE (\ADDBASE SBASE 1]
0COLOR)
(T 1COLOR)))
(SETQ WIDTH (IDIFFERENCE WIDTH 2))
(SETQ DBASE (\ADDBASE DBASE 1)))
(T (* move the rest of the first word or the rest of last
word two at a time.)
(\PUTBASEBYTE DBASE 0 (COND
((ZEROP (LOGAND (\GETBASE SBASE 0)
(\BITMASK SBITOFFSET)))
0COLOR)
(T 1COLOR)))
(\PUTBASEBYTE DBASE 1 (COND
([ZEROP (LOGAND (\GETBASE SBASE 0)
(\BITMASK (ADD1 SBITOFFSET]
0COLOR)
(T 1COLOR)))
(SETQ SBITOFFSET (IPLUS SBITOFFSET 2))
(SETQ WIDTH (IDIFFERENCE WIDTH 2))
(SETQ DBASE (\ADDBASE DBASE 1]
(GO LP])
(\4BITLINEBLT
[LAMBDA (SBASE SBITOFFSET DBASE WIDTH MAPBASE 0COLOR 1COLOR)
(* rrb "15-OCT-82 09:28")
(* moves one line of a black and white bitmap into a color bitmap using a mapping table. Destination bit offset is
assumed to be 0 because \BWTOCOLORBLT arranges things so that it is.)
(SELECTQ
(MOD SBITOFFSET 4)
[0 (* case of moving even aligned bits.)
(PROG NIL
ONEWRDLP (* SBITOFFSET is either 0, 4, 8 or 12)
(COND
((AND (EQ SBITOFFSET 0)
(IGREATERP WIDTH (SUB1 BITSPERWORD)))
(* go to center loop.)
(GO LP))
((IGREATERP 4 WIDTH)
[PROG ((SWORDCONTENTS (\GETBASE SBASE 0)))
(SELECTQ WIDTH
(0)
[1 (PUTBASEBYTE DBASE 0
(LOGOR (LOGAND (\GETBASEBYTE DBASE 0)
15)
(LLSH (COND
((ZEROP (LOGAND SWORDCONTENTS
(\BITMASK SBITOFFSET)
))
0COLOR)
(T 1COLOR))
4]
[2 (PUTBASEBYTE DBASE 0
(LOGOR (LLSH (COND
((ZEROP (LOGAND SWORDCONTENTS
(\BITMASK SBITOFFSET)
))
0COLOR)
(T 1COLOR))
4)
(COND
([ZEROP (LOGAND SWORDCONTENTS
(\BITMASK (ADD1 SBITOFFSET]
0COLOR)
(T 1COLOR]
(PROGN [\PUTBASEBYTE DBASE 0
(LOGOR (LLSH (COND
((ZEROP (LOGAND SWORDCONTENTS
(\BITMASK
SBITOFFSET)))
0COLOR)
(T 1COLOR))
4)
(COND
([ZEROP (LOGAND SWORDCONTENTS
(\BITMASK
(ADD1 SBITOFFSET]
0COLOR)
(T 1COLOR]
(\PUTBASEBYTE
DBASE 1
(LOGOR (LLSH (COND
([ZEROP (LOGAND SWORDCONTENTS
(\BITMASK (IPLUS SBITOFFSET
2]
0COLOR)
(T 1COLOR))
4)
(LOGAND (\GETBASE DBASE 0)
15]
(RETURN))
(T (* move 4 bits from source to destination.)
[\PUTBASE DBASE 0 (\GETBASE MAPBASE (SELECTQ SBITOFFSET
(0 (fetch N1 of SBASE))
(4 (fetch N2 of SBASE))
(8 (fetch N3 of SBASE))
(fetch N4 of SBASE]
(SETQ DBASE (\ADDBASE DBASE 1))
(SETQ WIDTH (IDIFFERENCE WIDTH 4))
[COND
((EQ (SETQ SBITOFFSET (IPLUS SBITOFFSET 4))
16)
(SETQ SBITOFFSET 0)
(SETQ SBASE (\ADDBASE SBASE 1]
(GO ONEWRDLP)))
LP (COND
((IGREATERP WIDTH (SUB1 BITSPERWORD)) (* move a source word's worth of bits.)
(\PUTBASE DBASE 0 (\GETBASE MAPBASE (fetch N1 of SBASE)))
(\PUTBASE DBASE 1 (\GETBASE MAPBASE (fetch N2 of SBASE)))
(\PUTBASE DBASE 2 (\GETBASE MAPBASE (fetch N3 of SBASE)))
(\PUTBASE DBASE 3 (\GETBASE MAPBASE (fetch N4 of SBASE)))
(SETQ DBASE (\ADDBASE DBASE 4))
(SETQ SBASE (\ADDBASE SBASE 1))
(SETQ WIDTH (IDIFFERENCE WIDTH BITSPERWORD))
(GO LP))
(T (* finish off last less than 16 bits.)
(GO ONEWRDLP]
[1 (* moving bits that are aligned with 1 extra bit in the
following word of the source.)
(PROG NIL
ONEWRDLP (* SBITOFFSET is either 0, 4, 8 or 12)
(COND
((AND (EQ SBITOFFSET 1)
(IGREATERP WIDTH (SUB1 BITSPERWORD)))
(* go to center loop.)
(GO LP))
((IGREATERP 4 WIDTH)
[PROG ((SWORDCONTENTS (\GETBASE SBASE 0)))
(SELECTQ WIDTH
(0)
[1 (PUTBASEBYTE DBASE 0
(LOGOR (LLSH (COND
((ZEROP (LOGAND SWORDCONTENTS
(\BITMASK SBITOFFSET)
))
0COLOR)
(T 1COLOR))
4)
(LOGAND (\GETBASEBYTE DBASE 0)
15]
[2 (PUTBASEBYTE DBASE 0
(LOGOR (LLSH (COND
((ZEROP (LOGAND SWORDCONTENTS
(\BITMASK SBITOFFSET)
))
0COLOR)
(T 1COLOR))
4)
(COND
([ZEROP (LOGAND SWORDCONTENTS
(\BITMASK (ADD1 SBITOFFSET]
0COLOR)
(T 1COLOR]
(PROGN [\PUTBASEBYTE DBASE 0
(LOGOR (LLSH (COND
((ZEROP (LOGAND SWORDCONTENTS
(\BITMASK
SBITOFFSET)))
0COLOR)
(T 1COLOR))
4)
(COND
([ZEROP (LOGAND SWORDCONTENTS
(\BITMASK
(ADD1 SBITOFFSET]
0COLOR)
(T 1COLOR]
(\PUTBASEBYTE
DBASE 1
(LOGOR (LLSH (COND
([ZEROP (LOGAND SWORDCONTENTS
(\BITMASK (IPLUS SBITOFFSET
2]
0COLOR)
(T 1COLOR))
4)
(LOGAND (\GETBASE DBASE 0)
15]
(RETURN))
(T (* move 4 bits from source to destination.)
[\PUTBASE DBASE 0 (\GETBASE MAPBASE (SELECTQ SBITOFFSET
(1 (fetch BITS1TO4 of SBASE))
(5 (fetch BITS5TO8 of SBASE))
(9 (fetch BITS9TO12 of SBASE))
(LOGOR (LLSH (fetch BITS13TO15
of SBASE)
1)
(fetch BIT0
of (SETQ SBASE
(\ADDBASE SBASE 1]
(SETQ DBASE (\ADDBASE DBASE 1))
(SETQ WIDTH (IDIFFERENCE WIDTH 4))
(COND
((EQ (SETQ SBITOFFSET (IPLUS SBITOFFSET 4))
17) (* SBASE has already been incremented as part of
fetching the last 4 bits.)
(SETQ SBITOFFSET 1)))
(GO ONEWRDLP)))
LP (COND
((IGREATERP WIDTH (SUB1 BITSPERWORD)) (* move a source word's worth of bits.)
(\PUTBASE DBASE 0 (\GETBASE MAPBASE (fetch BITS1TO4 of SBASE)))
(\PUTBASE DBASE 1 (\GETBASE MAPBASE (fetch BITS5TO8 of SBASE)))
(\PUTBASE DBASE 2 (\GETBASE MAPBASE (fetch BITS9TO12 of SBASE)))
[\PUTBASE DBASE 3 (\GETBASE MAPBASE (LOGOR (LLSH (fetch BITS13TO15 of SBASE)
1)
(fetch BIT0 of (SETQ SBASE
(\ADDBASE SBASE 1]
(SETQ DBASE (\ADDBASE DBASE 4))
(SETQ WIDTH (IDIFFERENCE WIDTH BITSPERWORD))
(GO LP))
(T (* finish off last less than 16 bits.)
(GO ONEWRDLP]
[2 (* moving bits that are aligned with 2 extra bits in
the following word of the source.)
(PROG NIL
ONEWRDLP (* SBITOFFSET is either 2, 6, 10 or 14)
(COND
((AND (EQ SBITOFFSET 2)
(IGREATERP WIDTH (SUB1 BITSPERWORD)))
(* go to center loop.)
(GO LP))
((IGREATERP 4 WIDTH)
[PROG ((SWORDCONTENTS (\GETBASE SBASE 0)))
(SELECTQ
WIDTH
(0)
[1 (PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND
((ZEROP (LOGAND SWORDCONTENTS
(\BITMASK SBITOFFSET)
))
0COLOR)
(T 1COLOR))
4)
(LOGAND (\GETBASEBYTE DBASE 0)
15]
[2 (PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND
((ZEROP (LOGAND SWORDCONTENTS
(\BITMASK SBITOFFSET)
))
0COLOR)
(T 1COLOR))
4)
(COND
([ZEROP (LOGAND SWORDCONTENTS
(\BITMASK (ADD1 SBITOFFSET]
0COLOR)
(T 1COLOR]
(PROGN (* first two bits are always in this word.)
[\PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND
((ZEROP (LOGAND SWORDCONTENTS
(\BITMASK
SBITOFFSET)))
0COLOR)
(T 1COLOR))
4)
(COND
([ZEROP (LOGAND SWORDCONTENTS
(\BITMASK
(ADD1 SBITOFFSET]
0COLOR)
(T 1COLOR]
(\PUTBASEBYTE
DBASE 1
(LOGOR (LLSH (COND
([ZEROP (COND
((EQ SBITOFFSET 14)
(* the next one is in the next word if the offset is
14)
(fetch BIT0OFNEXTWORD of SBASE))
(T (LOGAND SWORDCONTENTS
(\BITMASK (IPLUS SBITOFFSET 2]
0COLOR)
(T 1COLOR))
4)
(LOGAND (\GETBASE DBASE 0)
15]
(RETURN))
(T (* move 4 bits from source to destination.)
[\PUTBASE DBASE 0 (\GETBASE MAPBASE (SELECTQ SBITOFFSET
(2 (fetch BITS2TO5 of SBASE))
(6 (fetch BITS6TO9 of SBASE))
(10 (fetch BITS10TO13 of SBASE))
(LOGOR (LLSH (fetch BITS14TO15
of SBASE)
2)
(fetch BITS0TO1
of (SETQ SBASE
(\ADDBASE SBASE 1]
(SETQ DBASE (\ADDBASE DBASE 1))
(SETQ WIDTH (IDIFFERENCE WIDTH 4))
(COND
((EQ (SETQ SBITOFFSET (IPLUS SBITOFFSET 4))
18) (* SBASE has already been incremented as part of
fetching the last 4 bits.)
(SETQ SBITOFFSET 2)))
(GO ONEWRDLP)))
LP (COND
((IGREATERP WIDTH (SUB1 BITSPERWORD)) (* move a source word's worth of bits.)
(\PUTBASE DBASE 0 (\GETBASE MAPBASE (fetch BITS2TO5 of SBASE)))
(\PUTBASE DBASE 1 (\GETBASE MAPBASE (fetch BITS6TO9 of SBASE)))
(\PUTBASE DBASE 2 (\GETBASE MAPBASE (fetch BITS10TO13 of SBASE)))
[\PUTBASE DBASE 3 (\GETBASE MAPBASE (LOGOR (LLSH (fetch BITS14TO15 of SBASE)
2)
(fetch BITS0TO1
of (SETQ SBASE (\ADDBASE SBASE 1]
(SETQ DBASE (\ADDBASE DBASE 4))
(SETQ WIDTH (IDIFFERENCE WIDTH BITSPERWORD))
(GO LP))
(T (* finish off last less than 16 bits.)
(GO ONEWRDLP]
(PROG NIL (* moving bits that are aligned with 3 extra bits in
the following word of the source.)
ONEWRDLP (* SBITOFFSET is either 3, 7, 11 or 15)
(COND
((AND (EQ SBITOFFSET 3)
(IGREATERP WIDTH (SUB1 BITSPERWORD))) (* go to center loop.)
(GO LP))
((IGREATERP 4 WIDTH)
[PROG ((SWORDCONTENTS (\GETBASE SBASE 0)))
(SELECTQ
WIDTH
(0)
[1 (PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND
((ZEROP (LOGAND SWORDCONTENTS
(\BITMASK SBITOFFSET)))
0COLOR)
(T 1COLOR))
4)
(LOGAND (\GETBASEBYTE DBASE 0)
15]
[2 (PUTBASEBYTE DBASE 0
(LOGOR (LLSH (COND
((ZEROP (LOGAND SWORDCONTENTS (\BITMASK
SBITOFFSET)))
0COLOR)
(T 1COLOR))
4)
(COND
([ZEROP (COND
((EQ SBITOFFSET 15)
(* the next bit is in the next word if the offset is
15)
(FETCH BIT0OFNEXTWORD OF SBASE))
(T (LOGAND SWORDCONTENTS
(\BITMASK (IPLUS SBITOFFSET 2]
0COLOR)
(T 1COLOR]
(PROGN (* first two bits are always in this word.)
[\PUTBASEBYTE DBASE 0
(LOGOR (LLSH (COND
((ZEROP (LOGAND SWORDCONTENTS
(\BITMASK SBITOFFSET)))
0COLOR)
(T 1COLOR))
4)
(COND
([ZEROP (COND
((EQ SBITOFFSET 15)
(* the next bit is in the next word if the offset is
15)
(fetch BIT0OFNEXTWORD of SBASE))
(T (LOGAND SWORDCONTENTS
(\BITMASK (IPLUS
SBITOFFSET 2]
0COLOR)
(T 1COLOR]
(\PUTBASEBYTE
DBASE 1
(LOGOR (LLSH (COND
([ZEROP (COND
((EQ SBITOFFSET 15)
(* the next one is in the next word if the offset is
15)
(fetch BIT1OFNEXTWORD of SBASE))
(T (LOGAND SWORDCONTENTS
(\BITMASK (IPLUS SBITOFFSET 2]
0COLOR)
(T 1COLOR))
4)
(LOGAND (\GETBASE DBASE 0)
15]
(RETURN))
(T (* move 4 bits from source to destination.)
[\PUTBASE DBASE 0 (\GETBASE MAPBASE (SELECTQ SBITOFFSET
(3 (fetch BITS3TO6 of SBASE))
(7 (fetch BITS7TO10 of SBASE))
(11 (fetch BITS11TO14 of SBASE))
(LOGOR (LLSH (fetch BIT15 of SBASE)
3)
(fetch BITS0TO2
of (SETQ SBASE
(\ADDBASE SBASE 1]
(SETQ DBASE (\ADDBASE DBASE 1))
(SETQ WIDTH (IDIFFERENCE WIDTH 4))
(COND
((EQ (SETQ SBITOFFSET (IPLUS SBITOFFSET 4))
19) (* SBASE has already been incremented as part of
fetching the last 4 bits.)
(SETQ SBITOFFSET 3)))
(GO ONEWRDLP)))
LP (COND
((IGREATERP WIDTH (SUB1 BITSPERWORD)) (* move a source word's worth of bits.)
(\PUTBASE DBASE 0 (\GETBASE MAPBASE (fetch BITS3TO6 of SBASE)))
(\PUTBASE DBASE 1 (\GETBASE MAPBASE (fetch BITS7TO10 of SBASE)))
(\PUTBASE DBASE 2 (\GETBASE MAPBASE (fetch BITS11TO14 of SBASE)))
[\PUTBASE DBASE 3 (\GETBASE MAPBASE (LOGOR (LLSH (fetch BIT15 of SBASE)
3)
(fetch BITS0TO2 of (SETQ SBASE
(\ADDBASE SBASE 1]
(SETQ DBASE (\ADDBASE DBASE 4))
(SETQ WIDTH (IDIFFERENCE WIDTH BITSPERWORD))
(GO LP))
(T (* finish off last less than 16 bits.)
(GO ONEWRDLP])
(COLORFILL
[LAMBDA (REGION COLOR# COLORBM OPERATION) (* rrb "21-DEC-82 20:54")
(* fills a region in a color bitmap with a color.
Calls the standard BITBLT with a texture.)
(PROG [(COLORBM (COND
((TYPENAMEP COLORBM (QUOTE BITMAP))
COLORBM)
((NULL COLORBM)
(COLORSCREENBITMAP))
(T (\ILLEGAL.ARG COLORBM]
(COND
((NULL REGION)
(COLORFILLAREA 0 0 NIL NIL COLOR# COLORBM OPERATION))
(T (COLORFILLAREA (fetch (REGION LEFT) of REGION)
(fetch (REGION BOTTOM) of REGION)
(fetch (REGION WIDTH) of REGION)
(fetch (REGION HEIGHT) of REGION)
COLOR# COLORBM OPERATION])
(COLORBACKGROUND
[LAMBDA (C) (* edited: "14-SEP-82 15:29")
(COLORFILL WHOLECOLORDISPLAY (OR C (QUOTE BLACK))
NIL
(QUOTE REPLACE])
(COLORFILLAREA
[LAMBDA (LEFT BOTTOM WIDTH HEIGHT COLOR# COLORBM OPERATION)
(* rrb "21-DEC-82 20:54")
(* fills an area of a color bitmap with color.)
(COND
[COLORBM (COND
((type? BITMAP COLORBM))
(T (\ILLEGAL.ARG COLORBM]
((SETQ COLORBM (COLORSCREENBITMAP)))
(T (\ILLEGAL.ARG COLORBM)))
(BITBLT NIL NIL NIL COLORBM LEFT BOTTOM WIDTH HEIGHT (QUOTE TEXTURE)
(OR OPERATION (QUOTE REPLACE))
COLOR#])
(COLORTEXTUREFROMCOLOR#
[LAMBDA (COLOR# NBITS) (* edited: "10-SEP-82 15:47")
(* returns a TEXTURE that is COLOR# tessellated in a
pattern to put down NBITS per pixel color)
(PROG NIL
(COND
((type? BITMAP COLOR#) (* already is a texture.)
(RETURN COLOR#)))
(COND
((NULL NBITS) (* assume the size of the current color display.)
(SETQ NBITS \COLORDISPLAYBITSPERPIXEL)))
(SETQ COLOR# (COLORNUMBERP COLOR# NBITS))
(RETURN (SELECTQ NBITS
(4 (LOGOR (LLSH COLOR# 12)
(LLSH COLOR# 8)
(LLSH COLOR# 4)
COLOR#))
(8 (PROG ((TEXTUREBITMAP (BITMAPCREATE 16 4))
(BITPATTERN (LOGOR (LLSH COLOR# 8)
COLOR#)))
(for I from 0 to 3 do (\BITMAPWORD TEXTUREBITMAP I BITPATTERN))
(RETURN TEXTUREBITMAP)))
(ERROR "Only 4 and 8 bits per pixel implemented."])
(\BITMAPWORD
[LAMBDA (BM WORDN NEWBITS) (* edited: " 8-SEP-82 10:54")
(* puts a words worth of bits into the WORDNth word of
a bitmap.)
(\PUTBASE (\ADDBASE (fetch (BITMAP BITMAPBASE) of BM)
WORDN)
0
(LOGAND NEWBITS WORDMASK])
)
(DEFINEQ
(COLORIZEBITMAP
[LAMBDA (BITMAP 0COLOR 1COLOR NBITS) (* rrb "21-DEC-82 21:18")
(* creates a copy of BITMAP that is in color form allowing NBITS per pixel. 0COLOR and 1COLOR are the color numbers
that get translated from 0 and 1 respectively.)
(PROG ([CM (BITMAPCREATE (fetch BITMAPWIDTH of BITMAP)
(fetch BITMAPHEIGHT of BITMAP)
(SETQ NBITS (\INSUREBITSPERPIXEL NBITS]
CBMPTR)
(\BWTOCOLORBLT BITMAP 0 0 CM 0 0 (fetch BITMAPWIDTH of BITMAP)
(fetch BITMAPHEIGHT of BITMAP)
(COLORNUMBERP 0COLOR)
(COLORNUMBERP 1COLOR)
NBITS)
(RETURN CM])
)
[DECLARE: EVAL@COMPILE
(ACCESSFNS 4BITCOLORMAP (DUMMY)
(CREATE (LET ((RESULT (ARRAY 16 NIL NIL 0)))
(for ELT from 0 to 15
do (SETCOLORMAPENTRY RESULT ELT
(create RGB
RED ← 0
GREEN ← 0
BLUE ← 0)))
RESULT))
[TYPE? (AND (ARRAYP DATUM)
(EQ (ARRAYSIZE DATUM)
16)
(EQ (ARRAYTYP DATUM)
(QUOTE POINTER])
(ACCESSFNS 8BITCOLORMAP (DUMMY)
(CREATE (LET ((RESULT (ARRAY 256 NIL NIL 0)))
(for ELT from 0 to 255
do (SETCOLORMAPENTRY RESULT ELT
(create RGB
RED ← 0
GREEN ← 0
BLUE ← 0)))
RESULT))
[TYPE? (AND (ARRAYP DATUM)
(EQ (ARRAYSIZE DATUM)
256)
(EQ (ARRAYTYP DATUM)
(QUOTE POINTER])
(RECORD RGB (RED GREEN BLUE))
(RECORD HLS (HUE LIGHTNESS SATURATION))
]
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(BLOCKRECORD NIBBLES ((N1 BITS 4)
(N2 BITS 4)
(N3 BITS 4)
(N4 BITS 4)))
(BLOCKRECORD ONEOFFSETBITACCESS ((BIT0 BITS 1)
(BITS1TO4 BITS 4)
(BITS5TO8 BITS 4)
(BITS9TO12 BITS 4)
(BITS13TO15 BITS 3)))
(BLOCKRECORD TWOOFFSETBITACCESS ((BITS0TO1 BITS 2)
(BITS2TO5 BITS 4)
(BITS6TO9 BITS 4)
(BITS10TO13 BITS 4)
(BITS14TO15 BITS 2)
(BIT0OFNEXTWORD BITS 1)
(BIT1OFNEXTWORD BITS 1)
(BITS2TO15OFNEXTWORD BITS 14)))
(BLOCKRECORD THREEOFFSETBTACCESS ((BITS0TO2 BITS 3)
(BITS3TO6 BITS 4)
(BITS7TO10 BITS 4)
(BITS11TO14 BITS 4)
(BIT15 BITS 1)))
(BLOCKRECORD 2BITNIBBLES ((EN1 BITS 2)
(EN2 BITS 2)
(EN3 BITS 2)
(EN4 BITS 2)
(EN5 BITS 2)
(EN6 BITS 2)
(EN7 BITS 2)
(EN8 BITS 2)))
(BLOCKRECORD ODD2BITNIBBLES ((BIT0 BITS 1)
(ODD2BIT1 BITS 2)
(ODD2BIT2 BITS 2)
(ODD2BIT3 BITS 2)
(ODD2BIT4 BITS 2)
(ODD2BIT5 BITS 2)
(ODD2BIT6 BITS 2)
(ODD2BIT7 BITS 2)
(BIT15 BITS 1)))
]
(DECLARE: EVAL@COMPILE
(RPAQQ \ColorScreenAddr 268)
(RPAQQ \ColorMapAddr 270)
(RPAQQ REDMASK 2048)
(RPAQQ GREENMASK 1024)
(RPAQQ BLUEMASK 512)
(RPAQQ COLORSOFFSETINMAP 2)
(RPAQQ INTENSITYSIZE 3)
(RPAQQ REDOFFSET 0)
(RPAQQ GREENOFFSET 1)
(RPAQQ BLUEOFFSET 2)
(RPAQQ \MaxBitsPerPixel 4)
(RPAQQ \MaxBitMapWidth 65535)
(RPAQQ \MaxBitMapHeight 65535)
(RPAQQ \MaxBitMapWords 131066)
(CONSTANTS (\ColorScreenAddr 268)
(\ColorMapAddr 270)
(REDMASK 2048)
(GREENMASK 1024)
(BLUEMASK 512)
(COLORSOFFSETINMAP 2)
(INTENSITYSIZE 3)
(REDOFFSET 0)
(GREENOFFSET 1)
(BLUEOFFSET 2)
(\MaxBitsPerPixel 4)
(\MaxBitMapWidth 65535)
(\MaxBitMapHeight 65535)
(\MaxBitMapWords 131066))
)
)
(* this should be in each device init)
(RPAQQ COLORSCREENWIDTH 640)
(RPAQQ COLORSCREENHEIGHT 480)
(DECLARE: EVAL@COMPILE
(RPAQQ MaxBitsPerPixel 8)
(RPAQQ PagesPerSegment 256)
(RPAQQ BITSPERWORD 16)
(RPAQQ ExtraColorDisplayPages 2)
(CONSTANTS (MaxBitsPerPixel 8)
(PagesPerSegment 256)
(BITSPERWORD 16)
(ExtraColorDisplayPages 2))
)
(RPAQ? \SystemColorMap )
(RPAQ? \COLORDISPLAYBITS )
(RPAQ? ColorScreenBitMap )
(RPAQ? LastSystemColorMap )
(RPAQ? \DefaultColorMap )
(RPAQ? \COLORDISPLAYBITSPERPIXEL 4)
(RPAQQ \DEFAULTCOLORINTENSITIES ((0 0 0)
(0 0 255)
(0 255 0)
(255 0 0)
(255 255 0)
(255 0 255)
(0 255 255)
(255 255 255)
(128 128 128)
(171 171 255)
(252 128 0)
(212 182 129)
(0 255 132)
(255 0 133)
(0 201 39)
(167 1 152)))
(RPAQQ COLORNAMES ((BLACK 0 0 0)
(BLUE 0 0 255)
(GREEN 0 255 0)
(RED 255 0 0)
(YELLOW 255 255 0)
(MAGENTA 255 0 255)
(CYAN 0 255 255)
(WHITE 255 255 255)))
(RPAQ \DEFAULT8BITCOLORINTENSITIES [for RED from 83 to 255 by 43 join
(for GREEN from 80 to 255 by 35 join
(for BLUE from 80 to 255 by 25 collect
(LIST RED GREEN BLUE])
(RPAQ \NULLINTENSITIES (for COLOR from 0 to 255 collect (LIST 0 0 0)))
(RPAQ WHOLECOLORDISPLAY (create REGION LEFT ← 0 BOTTOM ← 0 WIDTH ← COLORSCREENWIDTH HEIGHT ←
COLORSCREENHEIGHT))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \COLORDISPLAYBITS \COLORDISPLAYBITSPERPIXEL ColorScreenBitMap \SystemColorMap
LastSystemColorMap WHOLECOLORDISPLAY \COLORCURSOR)
)
[DECLARE: EVAL@COMPILE
(RECORD BRUSH (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR))
]
(PUTPROPS LLCOLOR COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3631 12985 (COLORDISPLAY 3641 . 6396) (SCREENON? 6398 . 6595) (COLORMAPBITS 6597 . 6850
) (COLORMAPENTRY 6852 . 6991) (SETCOLORMAPENTRY 6993 . 7140) (\CreateColorScreenBitMap 7142 . 9075) (
\GENERIC.COLORLEVEL 9077 . 9967) (SCREENCOLORMAP 9969 . 10538) (MAXIMUMCOLOR 10540 . 11041) (
COLORSCREENBITMAP 11043 . 11281) (\COLORDISPLAYBITS 11283 . 12670) (COLORNUMBERBITSPERPIXEL 12672 .
12983)) (12986 16353 (\STARTCOLOR 12996 . 13207) (\STOPCOLOR 13209 . 13388) (\SETSCREENCOLORMAP 13390
. 13846) (COLORLEVEL 13848 . 14711) (ROTATECOLORMAP 14713 . 14935) (\GENERIC.ROTATECOLORMAP 14937 .
16351)) (16421 24891 (COLORMAPCREATE 16431 . 17949) (REPEAT.TO.AT.LEAST.N 17951 . 18340) (COLORMAPOF
18342 . 18803) (COLORMAPP 18805 . 19288) (COLORMAPCOPY 19290 . 19773) (COLORNUMBERP 19775 . 21102) (
\LOOKUPCOLORNAME 21104 . 21459) (HLSP 21461 . 21845) (RGBP 21847 . 22482) (COLORFROMRGBLEVELS 22484 .
23144) (\POSSIBLECOLOR 23146 . 23694) (INTENSITIESFROMCOLORMAP 23696 . 24229) (SETCOLORINTENSITY 24231
. 24889)) (24892 28946 (\GENERICCOLORLEVEL 24902 . 26225) (\GENERICROTATECOLORMAP 26227 . 28944)) (
28947 32278 (\INSUREBITSPERPIXEL 28957 . 29512) (\FAST8BIT 29514 . 30730) (\MAP4 30732 . 31393) (\MAP8
31395 . 32276)) (32279 38069 (\GETCOLORBRUSH 32289 . 32971) (\DDSETCOLORFONT 32973 . 34323) (
\GETCOLORFONT 34325 . 35557) (\GETCOLORCSINFO 35559 . 36615) (\COLORFONTLOOKUP 36617 . 37041) (
\COLORFONTSTORE 37043 . 38067)) (38070 45801 (CHANGECURSORSCREEN 38080 . 40391) (\SETCOLORCURSORBM
40393 . 43499) (\TAKEDOWNCOLORCURSOR 43501 . 43972) (\IFCOLORDS\TAKEDOWNCOLORCURSOR 43974 . 44402) (
\PUTUPCOLORCURSOR 44404 . 45356) (\COLORCURSORDOWN 45358 . 45799)) (45802 51922 (\PIXELBLT.UFN 45812
. 51920)) (52677 56629 (\DRAWCOLORLINE1 52687 . 53161) (\DRAW4BPPCOLORLINE 53163 . 54968) (
\DRAW8BPPCOLORLINE 54970 . 56627)) (62246 91489 (\BWTOCOLORBLT 62256 . 66550) (\8BITLINEBLT 66552 .
72582) (\4BITLINEBLT 72584 . 88237) (COLORFILL 88239 . 89074) (COLORBACKGROUND 89076 . 89298) (
COLORFILLAREA 89300 . 89916) (COLORTEXTUREFROMCOLOR# 89918 . 91095) (\BITMAPWORD 91097 . 91487)) (
91490 92217 (COLORIZEBITMAP 91500 . 92215)))))
STOP