(FILECREATED "18-Feb-85 15:14:41" {ERIS}<LISPCORE>LIBRARY>DOLPHINCOLOR.;2 8139
changes to: (VARS DOLPHINCOLORCOMS)
previous date: " 4-Feb-85 19:14:23" {ERIS}<LISPCORE>LIBRARY>DOLPHINCOLOR.;1)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT DOLPHINCOLORCOMS)
(RPAQQ DOLPHINCOLORCOMS [(COMS (* Dolphin machine dependent color display fns)
(FNS \DOLPHININITCOLOR)
(FNS \DOLPHIN\STARTCOLOR \DOLPHIN\STOPCOLOR \DOLPHIN\SETSCREENCOLORMAP
\DOLPHINCOLORLEVEL \DOLPHINROTATECOLORMAP))
(DECLARE: DONTEVAL@COMPILE DOCOPY (P (\DOLPHININITCOLOR)
(\CREATEDISPLAY (QUOTE
DOLPHINCOLORDISPLAY)
\DOLPHINWSOPS
\DOLPHINWSDATA])
(* Dolphin machine dependent color display fns)
(DEFINEQ
(\DOLPHININITCOLOR
[LAMBDA NIL (* hdj "31-Jan-85 17:22")
(DECLARE (GLOBALVARS \DOLPHINWSOPS \DOLPHINWSDATA))
(SETQ \DOLPHINWSOPS (create WSOPS
WSCHANGEBACKGROUND ←(FUNCTION COLORBACKGROUND)
WSCHANGEBACKGROUNDBORDER ←(FUNCTION NILL)
WSDISPLAYHEIGHT ←(FUNCTION NILL)
STARTCOLOR ←(FUNCTION \DOLPHIN\STARTCOLOR)
STOPCOLOR ←(FUNCTION \DOLPHIN\STOPCOLOR)
SETSCREENCOLORMAP ←(FUNCTION \DOLPHIN\SETSCREENCOLORMAP)
COLORLEVEL ←(FUNCTION \DOLPHINCOLORLEVEL)
ROTATECOLORMAP ←(FUNCTION \DOLPHINROTATECOLORMAP)))
(SETQ \DOLPHINWSDATA
(create WSDATA
WSDESTINATION ← ColorScreenBitMap
WSREGION ←(create REGION
LEFT ← 0
BOTTOM ← 0
WIDTH ← 640
HEIGHT ← 480])
)
(DEFINEQ
(\DOLPHIN\STARTCOLOR
[LAMBDA (DISPLAY COLORMAP PTRTOBITS BITSPP) (* hdj " 4-Feb-85 19:10")
(* 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 DISPLAY)
(EMPUTBASE \ColorScreenAddr (LOLOC PTRTOBITS))
(EMPUTBASE (ADD1 \ColorScreenAddr)
(HILOC PTRTOBITS])
(\DOLPHIN\STOPCOLOR
[LAMBDA (DISPLAY) (* hdj " 4-Feb-85 19:11")
(* 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 (DISPLAY COLORMAP) (* hdj " 4-Feb-85 19:12")
(* 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 (DISPLAY COLORMAP COLOR# PRIMARYCOLOR NEWLEVEL) (* hdj " 4-Feb-85 19: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 (DISPLAY COLORMAP STARTCOLOR THRUCOLOR) (* hdj " 4-Feb-85 19:14")
(* 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: DONTEVAL@COMPILE DOCOPY
(\DOLPHININITCOLOR)
(\CREATEDISPLAY (QUOTE DOLPHINCOLORDISPLAY)
\DOLPHINWSOPS \DOLPHINWSDATA)
)
(PUTPROPS DOLPHINCOLOR COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (823 1673 (\DOLPHININITCOLOR 833 . 1671)) (1674 7923 (\DOLPHIN\STARTCOLOR 1684 . 2247) (
\DOLPHIN\STOPCOLOR 2249 . 2992) (\DOLPHIN\SETSCREENCOLORMAP 2994 . 3879) (\DOLPHINCOLORLEVEL 3881 .
5203) (\DOLPHINROTATECOLORMAP 5205 . 7921)))))
STOP