(FILECREATED "27-Mar-84 15:33:17" {PHYLUM}<LISP>LIBRARY>LLCOLOR.;6 96226
changes to: (VARS LLCOLORCOMS)
previous date: " 1-Mar-84 11:35:22" {PHYLUM}<LISP>LIBRARY>LLCOLOR.;5)
(* Copyright (c) 1982, 1983, 1984 by Xerox Corporation)
(PRETTYCOMPRINT LLCOLORCOMS)
(RPAQQ LLCOLORCOMS ((COMS (* patch put here that can be deleted after the lldisplay of March 9, 1984
is incorporated into the release)
(FNS COLORDISPLAYP))
(FNS COLORDISPLAY COLORMAPBITS \CreateColorScreenBitMap SCREENCOLORMAP MAXIMUMCOLOR
COLORSCREENBITMAP \COLORDISPLAYBITS COLORNUMBERBITSPERPIXEL)
(FNS COLORMAPCREATE COLORMAPOF COLORMAPP COLORMAPCOPY COLORNUMBERP \LOOKUPCOLORNAME HLSP RGBP
COLORFROMRGBLEVELS \POSSIBLECOLOR INTENSITIESFROMCOLORMAP SETCOLORINTENSITY)
(FNS \INSUREBITSPERPIXEL \FAST4BIT \FAST8BIT \MAP4 \MAP8)
(FNS \GETCOLORBRUSH \DDSETCOLORFONT \GETCOLORFONT \COLORFONTLOOKUP \COLORFONTSTORE)
(FNS CHANGECURSORSCREEN \SETCOLORCURSORBM \TAKEDOWNCOLORCURSOR \IFCOLORDS\TAKEDOWNCOLORCURSOR
\PUTUPCOLORCURSOR \COLORCURSORDOWN)
(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 COLORMAPP 8BITCOLORMAPP RGB HLS)
(DECLARE: DONTCOPY (RECORDS NIBBLES ONEOFFSETBITACCESS TWOOFFSETBITACCESS THREEOFFSETBTACCESS
2BITNIBBLES ODD2BITNIBBLES))
(CONSTANTS (COLORSCREENWIDTH 640)
(COLORSCREENHEIGHT 480)
(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]
(WHOLECOLORDISPLAY (create REGION LEFT ← 0 BOTTOM ← 0 WIDTH ← COLORSCREENWIDTH HEIGHT ←
COLORSCREENHEIGHT)))
(GLOBALVARS \COLORDISPLAYBITS \COLORDISPLAYBITSPERPIXEL ColorScreenBitMap \SystemColorMap
LastSystemColorMap WHOLECOLORDISPLAY \COLORCURSOR)
[COMS (* Dolphin machine dependent fns)
(FNS \DOLPHIN\STARTCOLOR \DOLPHIN\STOPCOLOR \DOLPHIN\SETSCREENCOLORMAP
\DOLPHINCOLORLEVEL \DOLPHINROTATECOLORMAP)
(DECLARE: DONTCOPY (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]
[COMS (* Dorado machine dependent fns)
(FNS \DORADO\STARTCOLOR \DORADO\STOPCOLOR \DORADO\SETSCREENCOLORMAP \DORADOCOLORLEVEL
\DORADOROTATECOLORMAP \DORADO\SETONECOLOR)
(FNS \DORADO\LOOKATA \DORADO\MAKEATABLE)
(DECLARE: DONTEVAL@LOAD DOCOPY (VARS (\DORADO\ATABLEIMAGE)))
(GLOBALVARS \DORADO\ATABLEIMAGE)
(DECLARE: DONTCOPY (RECORDS MonitorCB ChannelCB ColorCB ColorEntry)
(CONSTANTS (pplOffset 255)
(MCBPtr 268)
(MCBSeal 65326)
(MCBLow 160)
(MCBSize 8)
(AFlagsMask 4)
(ChCBLow 168)
(ChCBSize 8)
(ColCBLow 176)
(ColCBSize 16)
(CMapPages 8]
(FNS \SETMACHINEDEPENDENTCOLORFNS)
(VARS MACHINEDEPENDENTCOLORFNS)
(P (\SETMACHINEDEPENDENTCOLORFNS))
(RECORDS BRUSH)))
(* patch put here that can be deleted after the lldisplay of March 9, 1984 is incorporated into
the release)
(DEFINEQ
(COLORDISPLAYP
[LAMBDA NIL (* rrb "16-Feb-84 18:50")
(* is the color display on?)
\SystemColorMap])
)
(DEFINEQ
(COLORDISPLAY
[LAMBDA (COLORMAPIFON BITSPERPIXEL CLEARSCREENFLG) (* rrb "13-Dec-83 10:46")
(* turns the color display on and off)
(PROG1 \SystemColorMap (* return whether on not it is on.)
(COND
(COLORMAPIFON (SETQ BITSPERPIXEL (\INSUREBITSPERPIXEL BITSPERPIXEL))
[COND
[\SystemColorMap (* 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]
(T (* turn it on)
(\SETMACHINEDEPENDENTCOLORFNS)
(* ensure machine dependent functions have been set up.)
(\CreateColorScreenBitMap BITSPERPIXEL)
(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))]
(AND CLEARSCREENFLG (COLORBACKGROUND 0)))
(\SystemColorMap (* 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)
(SETQ LastSystemColorMap \SystemColorMap)
(SETQ \SystemColorMap NIL)
(\UNLOCKPAGES (fetch (BITMAP BITMAPBASE) of CBITMAP)
(FOLDHI (ITIMES (fetch BITMAPRASTERWIDTH
of CBITMAP)
(fetch BITMAPHEIGHT
of CBITMAP))
WordsPerPage)))])
(COLORMAPBITS
[LAMBDA (COLORMAP?) (* agb: " 4-SEP-82 19:07")
(COND
((type? COLORMAPP COLORMAP?)
4)
((type? 8BITCOLORMAPP COLORMAP?)
8)
(T (\ILLEGAL.ARG COLORMAP?])
(\CreateColorScreenBitMap
[LAMBDA (BITSPP) (* rrb "21-DEC-82 20:44")
(* creates and locks the pages for the color display bit
map and returns a BITMAP descriptor for it.)
(COND
((type? BITMAP ColorScreenBitMap) (* reuse the same BITMAP ptr so that it will stay EQ to
the one in user datastructures.)
(replace BITMAPBASE of ColorScreenBitMap with (\COLORDISPLAYBITS BITSPP))
(replace BITMAPWIDTH of ColorScreenBitMap with (ITIMES COLORSCREENWIDTH BITSPP))
(replace BITMAPRASTERWIDTH of ColorScreenBitMap with (FOLDHI (ITIMES COLORSCREENWIDTH BITSPP)
BITSPERWORD))
(replace BITMAPHEIGHT of ColorScreenBitMap with COLORSCREENHEIGHT)
(replace (BITMAP BITMAPBITSPERPIXEL) of ColorScreenBitMap with BITSPP)
ColorScreenBitMap)
(T (SETQ ColorScreenBitMap (create BITMAP
BITMAPBASE ←(\COLORDISPLAYBITS BITSPP)
BITMAPRASTERWIDTH ←(FOLDHI (ITIMES COLORSCREENWIDTH BITSPP)
BITSPERWORD)
BITMAPWIDTH ←(ITIMES COLORSCREENWIDTH BITSPP)
BITMAPHEIGHT ← COLORSCREENHEIGHT
BITMAPBITSPERPIXEL ← BITSPP])
(SCREENCOLORMAP
[LAMBDA (NEWCOLORMAP) (* rrb "13-Dec-83 10:46")
(* 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.)
(PROG1 \SystemColorMap (AND NEWCOLORMAP (SETQ NEWCOLORMAP (COLORMAPOF NEWCOLORMAP))
(UNINTERRUPTABLY
(\SETSCREENCOLORMAP NEWCOLORMAP)
(* if new color map, call machine dependent function to
install it.)
(SETQ \SystemColorMap NEWCOLORMAP))])
(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) (* lmm " 9-SEP-83 21:21")
(* returns a pointer to the bits that the color board
needs.)
(UNINTERRUPTABLY
(PROG ((NPAGES (IPLUS (FOLDHI (ITIMES (FOLDHI (ITIMES COLORSCREENWIDTH BITSPP)
BITSPERWORD)
COLORSCREENHEIGHT)
WORDSPERPAGE)
ExtraColorDisplayPages)))
[COND
((OR (NOT \COLORDISPLAYBITS)
(ILESSP \COLORDISPLAYSIZE NPAGES)) (* must allocate something)
(COND
((OR (NOT \COLORDISPLAYBITS)
(NEQ (SUB1 (PAGELOC \COLORDISPLAYBITS))
\LASTARRAYPAGE)) (* Can't reuse old stuff)
(SETQ \COLORDISPLAYSIZE 0)))
(until (IGEQ \COLORDISPLAYSIZE NPAGES)
do (\CHECKFORSTORAGEFULL)
(add \COLORDISPLAYSIZE 2) (* allocate two pages)
[\NEW2PAGE (SETQ \COLORDISPLAYBITS (create POINTER
PAGE# ←(SUB1 \LASTARRAYPAGE]
(add \LASTARRAYPAGE -2]
(SETQ \COLORDISPLAYBITSPERPIXEL BITSPP)
(RETURN \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
(COLORMAPCREATE
[LAMBDA (INTENSITIES BITSPERPIXEL) (* edited: " 9-SEP-82 11:47")
(* creates a color map. Starts with a reasonable color
set. COLORMAPS must be on multiple of 16 word boundaries
for D0 hardware.)
(SELECTQ (OR BITSPERPIXEL \COLORDISPLAYBITSPERPIXEL)
(4 (PROG ((CMAP (create COLORMAPP)))
(for I from 0 to 15 as COLORS in (OR (LISTP (OR INTENSITIES
\DEFAULTCOLORINTENSITIES))
(\ILLEGAL.ARG INTENSITIES))
do (SETCOLORINTENSITY CMAP I COLORS))
(RETURN CMAP)))
(8 (PROG ((CMAP (create 8BITCOLORMAPP)))
(* 8BITCOLORMAPP is a datatype of one pointer to a block of 384 words. This extra indirection is because datatypes
can't be more than 256 words.)
(* make the lowest 16 colors the same as in the 4 bit
case)
(for I from 0 to 255 as COLORS in (OR (LISTP (OR INTENSITIES (APPEND
\DEFAULTCOLORINTENSITIES
\DEFAULT8BITCOLORINTENSITIES)))
(\ILLEGAL.ARG INTENSITIES))
do (SETCOLORINTENSITY CMAP I COLORS))
(RETURN CMAP)))
(\ILLEGAL.ARG BITSPERPIXEL])
(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) (* rrb "21-OCT-82 18:32")
(* returns COLORMAP? if it is a colormap.)
(AND (OR (AND (OR (NULL BITSPERPIXEL)
(EQ BITSPERPIXEL 4))
(type? COLORMAPP COLORMAP?))
(AND (OR (NULL BITSPERPIXEL)
(EQ BITSPERPIXEL 8))
(type? 8BITCOLORMAPP 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) (* rrb "21-OCT-82 18:29")
(* 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 (for PRIM
in (QUOTE (RED GREEN BLUE))
collect (COLORLEVEL CM I PRIM])
(SETCOLORINTENSITY
[LAMBDA (COLORMAP COLOR# INTENSITIES) (* rrb "13-DEC-82 13:15")
(* 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)))
(COLORLEVEL COLORMAP COLOR# (QUOTE RED)
(fetch (RGB RED) of RGB))
(COLORLEVEL COLORMAP COLOR# (QUOTE GREEN)
(fetch (RGB GREEN) of RGB))
(COLORLEVEL COLORMAP COLOR# (QUOTE BLUE)
(fetch (RGB BLUE) of RGB])
)
(DEFINEQ
(\INSUREBITSPERPIXEL
[LAMBDA (NBITS) (* rrb "21-DEC-82 21:00")
(* 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)
(COND
((AND (EQ (MACHINETYPE)
(QUOTE DORADO))
(EQ NBITS 8))
8)
(T (\ILLEGAL.ARG NBITS])
(\FAST4BIT
[LAMBDA (A B N MAP) (* bas: " 3-MAY-82 03:00")
(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 N1 of AW)))
(OR (IGREATERP N (add I 1))
(RETURN))
(\PUTBASE B I (ELT MAP (fetch N2 of AW)))
(OR (IGREATERP N (add I 1))
(RETURN))
(\PUTBASE B I (ELT MAP (fetch N3 of AW)))
(OR (IGREATERP N (add I 1))
(RETURN))
(\PUTBASE B I (ELT MAP (fetch N4 of AW)))
(add I 1])
(\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) (* rrb " 5-Dec-83 12:57")
(* makes a font descriptor that has a character bitmap
that is colorized.)
(OR (\COLORFONTLOOKUP BWFONT FORECOLOR BACKCOLOR NBITS)
(\COLORFONTSTORE (create FONTDESCRIPTOR
using BWFONT CHARACTERBITMAP ←(COLORIZEBITMAP
(fetch (FONTDESCRIPTOR CHARACTERBITMAP)
of (PROG1 (FONTCREATE (fetch (FONTDESCRIPTOR FONTFAMILY)
of BWFONT)
(fetch (FONTDESCRIPTOR FONTSIZE)
of BWFONT)
(fetch (FONTDESCRIPTOR FONTFACE)
of BWFONT)
(fetch (FONTDESCRIPTOR ROTATION)
of BWFONT)
(fetch (FONTDESCRIPTOR FONTDEVICE)
of BWFONT))
(* 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.)
))
(COLORNUMBERP BACKCOLOR)
(COLORNUMBERP FORECOLOR)
NBITS))
BWFONT FORECOLOR BACKCOLOR NBITS])
(\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])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR 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
(DATATYPE COLORMAPP ((UNUSED1 2 WORD)
(COLORINTENSITIES 48 WORD)
(UNUSED2 14 WORD)))
(DATATYPE 8BITCOLORMAPP (COLORINTENSITIES)
COLORINTENSITIES ←(\ALLOCBLOCK 384))
(RECORD RGB (RED GREEN BLUE))
(RECORD HLS (HUE LIGHTNESS SATURATION))
]
(/DECLAREDATATYPE (QUOTE COLORMAPP)
(QUOTE (WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD
WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD
WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD
WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD
WORD WORD WORD WORD WORD WORD WORD)))
(/DECLAREDATATYPE (QUOTE 8BITCOLORMAPP)
(QUOTE (POINTER)))
(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 COLORSCREENWIDTH 640)
(RPAQQ COLORSCREENHEIGHT 480)
(RPAQQ MaxBitsPerPixel 8)
(RPAQQ PagesPerSegment 256)
(RPAQQ BITSPERWORD 16)
(RPAQQ ExtraColorDisplayPages 2)
(CONSTANTS (COLORSCREENWIDTH 640)
(COLORSCREENHEIGHT 480)
(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 WHOLECOLORDISPLAY (create REGION LEFT ← 0 BOTTOM ← 0 WIDTH ← COLORSCREENWIDTH HEIGHT ←
COLORSCREENHEIGHT))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \COLORDISPLAYBITS \COLORDISPLAYBITSPERPIXEL ColorScreenBitMap \SystemColorMap
LastSystemColorMap WHOLECOLORDISPLAY \COLORCURSOR)
)
(* Dolphin machine dependent fns)
(DEFINEQ
(\DOLPHIN\STARTCOLOR
[LAMBDA (COLORMAP PTRTOBITS BITSPP) (* rrb " 2-JUL-82 16:01")
(* turns on the color display with a given colormap and
pointer to the screen bitmap.)
(COND
((NEQ BITSPP 4)
(ERROR "Color only comes in 4 bit per pixel on this machine." BITSPP)))
(SCREENCOLORMAP COLORMAP)
(EMPUTBASE \ColorScreenAddr (LOLOC PTRTOBITS))
(EMPUTBASE (ADD1 \ColorScreenAddr)
(HILOC PTRTOBITS])
(\DOLPHIN\STOPCOLOR
[LAMBDA NIL (* rrb "13-Dec-83 10:46")
(* turns the color display off unlocks the colormap and
clobbers it.)
(EMPUTBASE (ADD1 \ColorScreenAddr)
0) (* set HILOC of color screen to turn off microcode
first.)
(EMPUTBASE \ColorScreenAddr 0)
(DISMISS 100) (* Wait for ucode to notice)
(EMPUTBASE (ADD1 \ColorMapAddr)
0)
(EMPUTBASE \ColorMapAddr 0)
(AND (COLORMAPP \SystemColorMap)
(\UNLOCKPAGES \SystemColorMap 1])
(\DOLPHIN\SETSCREENCOLORMAP
[LAMBDA (COLORMAP) (* rrb "13-Dec-83 10:46")
(* machine dependent part of setting the colormap. Turn off the hardware so that it doesn't get half of the old
map and half of the new one. This is always called from code that is UNINTERRUPTABLY)
(EMPUTBASE (ADD1 \ColorScreenAddr)
(PROG1 (EMGETBASE (ADD1 \ColorScreenAddr))
(EMPUTBASE (ADD1 \ColorScreenAddr)
0) (* unlock old map)
(AND (type? COLORMAPP \SystemColorMap)
(\UNLOCKPAGES \SystemColorMap 1))
(* lock new one)
(\LOCKPAGES COLORMAP 1)
(EMPUTBASE \ColorMapAddr (LOLOC COLORMAP))
(EMPUTBASE (ADD1 \ColorMapAddr)
(HILOC COLORMAP])
(\DOLPHINCOLORLEVEL
[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])
(\DOLPHINROTATECOLORMAP
[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])
)
(DECLARE: DONTCOPY
(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))
)
)
(* Dorado machine dependent fns)
(DEFINEQ
(\DORADO\STARTCOLOR
[LAMBDA (COLORMAP PTRTOBITS BITSPP) (* rrb "29-JUN-83 16:55")
(PROG ((MCB (EMADDRESS MCBLow))
(AC (EMADDRESS ChCBLow))
(CB (EMADDRESS ColCBLow)))
(\ZEROWORDS MCB (\ADDBASE MCB MCBSize))
(\ZEROWORDS AC (\ADDBASE AC ChCBSize))
(\ZEROWORDS CB (\ADDBASE CB ColCBSize)) (* Set up color control block)
(OR \DORADO\ATABLEIMAGE (\DORADO\MAKEATABLE COLORMAP))
(* Cant SCREENCOLOR map it til other structures are set)
(\LOCKPAGES \DORADO\ATABLEIMAGE CMapPages)
(replace ATableHi of CB with (\HILOC \DORADO\ATABLEIMAGE))
(* Reverse pointer)
(replace ATableLo of CB with (\LOLOC \DORADO\ATABLEIMAGE))
(replace VBtoVS of CB with 3)
(replace VStoVS of CB with 3)
(replace VStoVB of CB with 16)
(replace VisibleLines of CB with 240)
(replace X of CB with 379)
(replace W of CB with 6)
(replace A of CB with 35)
(replace BtoA of CB with 18)
(replace clockm of CB with 88)
(replace clockd of CB with 12) (* set up channel control block)
(replace wordsPerLine of AC with (FOLDHI (ITIMES COLORSCREENWIDTH BITSPP)
BITSPERWORD))
(replace bitmapHi of AC with (HILOC PTRTOBITS))
(replace bitmapLo of AC with (LOLOC PTRTOBITS))
(replace linesPerField of AC with (IQUOTIENT COLORSCREENHEIGHT 2))
(replace pixelsPerLine of AC with (IPLUS COLORSCREENWIDTH pplOffset))
(replace leftMargin of AC with 40)
(replace scan of AC with (SELECTQ BITSPP
(4 (* Magic constants = 164B)
116)
(8 (* Magic constants = 170B)
120)
(\ILLEGAL.ARG BITSPP)))
(replace Seal of MCB with MCBSeal)
(replace Flags of MCB with 60)
(replace ACB of MCB with ChCBLow) (* Wyatt used an empty A bitmap to establish scan mode.
Why? We dont)
(replace colorCB of MCB with ColCBLow)
(EMPUTBASE MCBPtr MCBLow)
(SCREENCOLORMAP COLORMAP) (* Waits for ucode in \SETSCREENCOLORMAP)
(* Wyatt now installed the real AC)
NIL])
(\DORADO\STOPCOLOR
[LAMBDA NIL (* rrb " 6-JUL-83 12:19")
(PROG ((MCB (EMADDRESS MCBLow)))
(replace ACB of MCB with 0)
(\ZEROWORDS \DORADO\ATABLEIMAGE (\ADDBASE \DORADO\ATABLEIMAGE 32))
(* Black)
(\DORADO\LOOKATA MCB)
(EMPUTBASE MCBPtr 0)
(\UNLOCKPAGES \DORADO\ATABLEIMAGE CMapPages])
(\DORADO\SETSCREENCOLORMAP
[LAMBDA (COLORMAP) (* edited: " 9-SEP-82 12:30")
(OR \DORADO\ATABLEIMAGE (SHOULDNT))
(SELECTQ (TYPENAME COLORMAP)
[COLORMAPP (for I from 0 by 2 to 31 as J from 0 by 128
do (\PUTBASE \DORADO\ATABLEIMAGE J (\GETBASE COLORMAP I))
(\PUTBASE \DORADO\ATABLEIMAGE (ADD1 J)
(\GETBASE COLORMAP (ADD1 I]
[8BITCOLORMAPP (bind (COLORMAPBASE ←(fetch (8BITCOLORMAPP COLORINTENSITIES)
of COLORMAP))
for I from 0 by 2 to 511 as J from 0 by 8
do (\PUTBASE \DORADO\ATABLEIMAGE J (\GETBASE COLORMAPBASE I))
(\PUTBASE \DORADO\ATABLEIMAGE (ADD1 J)
(\GETBASE COLORMAPBASE (ADD1 I]
(\ILLEGAL.ARG COLORMAP))
(\DORADO\LOOKATA (EMADDRESS MCBLow])
(\DORADOCOLORLEVEL
[LAMBDA (COLORMAP COLOR# PRIMARYCOLOR NEWLEVEL) (* rrb "13-Dec-83 10:46")
(* this code uses the COLORMAPP for storing the 4 bit per pixel dorado colormap but uses a different format from
the DOLPHIN. I think this will lead to problems if a colormap created for one of the machines is moved to the
other one without recreating it.)
(PROG ((COLOR# (COLORNUMBERP COLOR#))
BASE CE)
(SETQ BASE (SELECTQ (TYPENAME COLORMAP)
(COLORMAPP COLORMAP)
(8BITCOLORMAPP (fetch (8BITCOLORMAPP COLORINTENSITIES) of COLORMAP))
(\ILLEGAL.ARG COLORMAP)))
(SETQ CE (\ADDBASE BASE (LLSH COLOR# 1)))
(RETURN (PROG1 (SELECTQ PRIMARYCOLOR
(RED (IPLUS (LLSH (fetch RedHi of CE)
4)
(fetch RedLo of CE)))
(BLUE (fetch Blue of CE))
(GREEN (fetch Green of CE))
(\ILLEGAL.ARG PRIMARYCOLOR))
(COND
(NEWLEVEL (SETQ NEWLEVEL (LOGAND NEWLEVEL 255))
(SELECTQ PRIMARYCOLOR
(RED (replace RedHi of CE with (LRSH NEWLEVEL 4))
(replace RedLo of CE with (LOGAND NEWLEVEL 15)))
(BLUE (replace Blue of CE with NEWLEVEL))
(GREEN (replace Green of CE with NEWLEVEL))
NIL)
(COND
((EQ COLORMAP \SystemColorMap)
(\DORADO\SETONECOLOR BASE COLOR#])
(\DORADOROTATECOLORMAP
[LAMBDA (COLORMAP STARTCOLOR THRUCOLOR) (* edited: " 9-SEP-82 12:30")
(OR \DORADO\ATABLEIMAGE (SHOULDNT))
[PROG ((BITSPP (COLORMAPBITS COLORMAP))
TMP S0 S1)
(SETQ STARTCOLOR (COND
(STARTCOLOR (COLORNUMBERP STARTCOLOR))
(T 0)))
[SETQ THRUCOLOR (COND
(THRUCOLOR (COLORNUMBERP THRUCOLOR))
(T (SUB1 (EXPT 2 BITSPP]
[COND
((ILESSP THRUCOLOR STARTCOLOR)
(SETQ STARTCOLOR (PROG1 THRUCOLOR (SETQ THRUCOLOR STARTCOLOR]
(COND
((EQ BITSPP 4) (* uses constants for 16 colors.)
(SETQ TMP (LLSH THRUCOLOR 7))
(SETQ S0 (\GETBASE \DORADO\ATABLEIMAGE TMP))
(SETQ S1 (\GETBASE \DORADO\ATABLEIMAGE (ADD1 TMP)))
[for I from TMP to (LLSH (ADD1 STARTCOLOR)
7)
by -128
do (\PUTBASE \DORADO\ATABLEIMAGE I (\GETBASE \DORADO\ATABLEIMAGE (IDIFFERENCE I 128))
)
(\PUTBASE \DORADO\ATABLEIMAGE (ADD1 I)
(\GETBASE \DORADO\ATABLEIMAGE (IDIFFERENCE I 127]
(\PUTBASE \DORADO\ATABLEIMAGE (LLSH STARTCOLOR 7)
S0)
(\PUTBASE \DORADO\ATABLEIMAGE (ADD1 (LLSH STARTCOLOR 7))
S1))
(T (* uses constants for 8 bits per pixel color)
(SETQ TMP (LLSH THRUCOLOR 3))
(SETQ S0 (\GETBASE \DORADO\ATABLEIMAGE TMP))
(SETQ S1 (\GETBASE \DORADO\ATABLEIMAGE (ADD1 TMP)))
[for I from TMP to (LLSH (ADD1 STARTCOLOR)
3)
by -8
do (\PUTBASE \DORADO\ATABLEIMAGE I (\GETBASE \DORADO\ATABLEIMAGE (IDIFFERENCE
I 8)))
(\PUTBASE \DORADO\ATABLEIMAGE (ADD1 I)
(\GETBASE \DORADO\ATABLEIMAGE (IDIFFERENCE I 7]
(\PUTBASE \DORADO\ATABLEIMAGE (LLSH STARTCOLOR 3)
S0)
(\PUTBASE \DORADO\ATABLEIMAGE (ADD1 (LLSH STARTCOLOR 3))
S1]
(\DORADO\LOOKATA (EMADDRESS MCBLow])
(\DORADO\SETONECOLOR
[LAMBDA (COLORMAPBASE CN) (* edited: " 9-SEP-82 12:31")
(OR \DORADO\ATABLEIMAGE (SHOULDNT))
[PROG [(I (LLSH CN 1))
(J (LLSH CN (IDIFFERENCE 11 \COLORDISPLAYBITSPERPIXEL]
(\PUTBASE \DORADO\ATABLEIMAGE J (\GETBASE COLORMAPBASE I))
(\PUTBASE \DORADO\ATABLEIMAGE (ADD1 J)
(\GETBASE COLORMAPBASE (ADD1 I]
(\DORADO\LOOKATA (EMADDRESS MCBLow])
)
(DEFINEQ
(\DORADO\LOOKATA
[LAMBDA (MCB) (* bas: "11-APR-82 16:38")
(replace Flags of MCB with (LOGOR AFlagsMask (fetch Flags of MCB)))
(while (EQ AFlagsMask (LOGAND AFlagsMask (fetch Flags of MCB))) do
(* wait for microcode to notice)])
(\DORADO\MAKEATABLE
[LAMBDA (CM) (* rrb " 2-JUL-82 19:09")
(SETQ \DORADO\ATABLEIMAGE (\ALLOCBLOCK (ITIMES CMapPages 128)
NIL 128])
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(RPAQQ \DORADO\ATABLEIMAGE NIL)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \DORADO\ATABLEIMAGE)
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(BLOCKRECORD MonitorCB ((Seal WORD)
(Flags WORD)
(ACB WORD)
(NIL WORD)
(colorCB WORD)))
(BLOCKRECORD ChannelCB ((NIL WORD)
(wordsPerLine WORD)
(bitmapLo WORD)
(bitmapHi WORD)
(linesPerField WORD)
(pixelsPerLine WORD)
(leftMargin WORD)
(scan WORD)))
(BLOCKRECORD ColorCB ((ATableLo WORD)
(ATableHi WORD)
(NIL 6 WORD)
(VBtoVS BYTE)
(VStoVS BYTE)
(VStoVB WORD)
(VisibleLines WORD)
(X WORD)
(W BYTE)
(A BYTE)
(BtoA WORD)
(clockm BITS 12)
(clockd BITS 4)
(NIL WORD)))
(BLOCKRECORD ColorEntry ((NIL BITS 4)
(RedLo BITS 4)
(Blue BYTE)
(NIL BITS 4)
(Green BITS 8)
(RedHi BITS 4)))
]
(DECLARE: EVAL@COMPILE
(RPAQQ pplOffset 255)
(RPAQQ MCBPtr 268)
(RPAQQ MCBSeal 65326)
(RPAQQ MCBLow 160)
(RPAQQ MCBSize 8)
(RPAQQ AFlagsMask 4)
(RPAQQ ChCBLow 168)
(RPAQQ ChCBSize 8)
(RPAQQ ColCBLow 176)
(RPAQQ ColCBSize 16)
(RPAQQ CMapPages 8)
(CONSTANTS (pplOffset 255)
(MCBPtr 268)
(MCBSeal 65326)
(MCBLow 160)
(MCBSize 8)
(AFlagsMask 4)
(ChCBLow 168)
(ChCBSize 8)
(ColCBLow 176)
(ColCBSize 16)
(CMapPages 8))
)
)
(DEFINEQ
(\SETMACHINEDEPENDENTCOLORFNS
[LAMBDA (MTYPE) (* rrb "25-APR-83 10:23")
(OR MTYPE (SETQ MTYPE (MACHINETYPE)))
(for FN in MACHINEDEPENDENTCOLORFNS
do (MOVD (PACK* "\" MTYPE FN)
FN)
(COND
((GETD FN))
(T (* running on a machine that doesn't have any color
functions; make them all NILL so that at least no errors
are generated.)
(MOVD (QUOTE NILL)
FN])
)
(RPAQQ MACHINEDEPENDENTCOLORFNS (\STARTCOLOR \STOPCOLOR \SETSCREENCOLORMAP COLORLEVEL ROTATECOLORMAP))
(\SETMACHINEDEPENDENTCOLORFNS)
[DECLARE: EVAL@COMPILE
(RECORD BRUSH (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR))
]
(PUTPROPS LLCOLOR COPYRIGHT ("Xerox Corporation" 1982 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (4394 4631 (COLORDISPLAYP 4404 . 4629)) (4632 11867 (COLORDISPLAY 4642 . 7433) (
COLORMAPBITS 7435 . 7679) (\CreateColorScreenBitMap 7681 . 8991) (SCREENCOLORMAP 8993 . 9653) (
MAXIMUMCOLOR 9655 . 10143) (COLORSCREENBITMAP 10145 . 10383) (\COLORDISPLAYBITS 10385 . 11552) (
COLORNUMBERBITSPERPIXEL 11554 . 11865)) (11868 19689 (COLORMAPCREATE 11878 . 13255) (COLORMAPOF 13257
. 13694) (COLORMAPP 13696 . 14137) (COLORMAPCOPY 14139 . 14618) (COLORNUMBERP 14620 . 15847) (
\LOOKUPCOLORNAME 15849 . 16201) (HLSP 16203 . 16547) (RGBP 16549 . 17108) (COLORFROMRGBLEVELS 17110 .
17730) (\POSSIBLECOLOR 17732 . 18244) (INTENSITIESFROMCOLORMAP 18246 . 18839) (SETCOLORINTENSITY 18841
. 19687)) (19690 23385 (\INSUREBITSPERPIXEL 19700 . 20307) (\FAST4BIT 20309 . 20922) (\FAST8BIT 20924
. 21972) (\MAP4 21974 . 22571) (\MAP8 22573 . 23383)) (23386 27860 (\GETCOLORBRUSH 23396 . 24038) (
\DDSETCOLORFONT 24040 . 25366) (\GETCOLORFONT 25368 . 26579) (\COLORFONTLOOKUP 26581 . 26972) (
\COLORFONTSTORE 26974 . 27858)) (27861 35332 (CHANGECURSORSCREEN 27871 . 30068) (\SETCOLORCURSORBM
30070 . 33097) (\TAKEDOWNCOLORCURSOR 33099 . 33554) (\IFCOLORDS\TAKEDOWNCOLORCURSOR 33556 . 33977) (
\PUTUPCOLORCURSOR 33979 . 34899) (\COLORCURSORDOWN 34901 . 35330)) (36090 39842 (\DRAWCOLORLINE1 36100
. 36562) (\DRAW4BPPCOLORLINE 36564 . 38265) (\DRAW8BPPCOLORLINE 38267 . 39840)) (47493 74303 (
\BWTOCOLORBLT 47503 . 51614) (\8BITLINEBLT 51616 . 57031) (\4BITLINEBLT 57033 . 71220) (COLORFILL
71222 . 72025) (COLORBACKGROUND 72027 . 72237) (COLORFILLAREA 72239 . 72819) (COLORTEXTUREFROMCOLOR#
72821 . 73922) (\BITMAPWORD 73924 . 74301)) (74304 75015 (COLORIZEBITMAP 74314 . 75013)) (78562 84371
(\DOLPHIN\STARTCOLOR 78572 . 79112) (\DOLPHIN\STOPCOLOR 79114 . 79838) (\DOLPHIN\SETSCREENCOLORMAP
79840 . 80693) (\DOLPHINCOLORLEVEL 80695 . 81914) (\DOLPHINROTATECOLORMAP 81916 . 84369)) (85220 93298
(\DORADO\STARTCOLOR 85230 . 88036) (\DORADO\STOPCOLOR 88038 . 88513) (\DORADO\SETSCREENCOLORMAP 88515
. 89391) (\DORADOCOLORLEVEL 89393 . 90870) (\DORADOROTATECOLORMAP 90872 . 92848) (\DORADO\SETONECOLOR
92850 . 93296)) (93299 93903 (\DORADO\LOOKATA 93309 . 93701) (\DORADO\MAKEATABLE 93703 . 93901)) (
95365 95919 (\SETMACHINEDEPENDENTCOLORFNS 95375 . 95917)))))
STOP