(FILECREATED " 2-Jul-85 12:14:03" {ERIS}<LISPCORE>LIBRARY>COLOR.;3 32967
changes to: (FNS EDITCOLORMAP2)
previous date: "19-Jun-85 17:53:13" {ERIS}<LISPCORE>LIBRARY>COLOR.;2)
(* Copyright (c) 1982, 1983, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT COLORCOMS)
(RPAQQ COLORCOMS ((FNS DISPLAYCOLORLEVELS DISPLAYHLSLEVEL DISPLAYHLSLEVELS HLSLEVEL HLSTORGB
HLSVALUEFN HLSVALUEFROMLEVEL LEVELFROMHLSVALUE RAINBOWMAP RGBTOHLS)
(FNS OVERPAINT BITMAPFROMSTRING SHADEBITMAP)
(FNS EDITCOLORMAP ADJUSTCOLORMAP EDITCOLORMAP1 EDITCOLORMAP2 GETCOLOR#FROMUSER
GETCOLOR#FROMSCREEN DISPLAYCOLORLEVEL FILLINREGION AREAFILL CENTEREDLEFT OUTLINEAREA
OUTLINEREGION SHOWCOLORTESTPATTERN SHOWCOLORBLOCKS MAPOFACOLOR)
(VARS EditColorMapHeight EditColorMapWidth (COLOR#MENUSAVE)
(CONTROLMENUSAVE)
(EDIT8BITCOLORMAPMENU)
(EDIT8BITCOLORMAPNUMBERREADER))
(GLOBALVARS COLOR#MENUSAVE CONTROLMENUSAVE EDIT8BITCOLORMAPMENU EDIT8BITCOLORMAPNUMBERREADER
EditColorMapHeight EditColorMapWidth)
(FILES LLCOLOR)
(FILES (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
READNUMBER)))
(DEFINEQ
(DISPLAYCOLORLEVELS
[LAMBDA (WIN) (* rrb "25-OCT-82 13:58")
(DISPLAYCOLORLEVEL (QUOTE RED)
NIL WIN)
(DISPLAYCOLORLEVEL (QUOTE GREEN)
NIL WIN)
(DISPLAYCOLORLEVEL (QUOTE BLUE)
NIL WIN])
(DISPLAYHLSLEVEL
[LAMBDA (HLS WHICHHLS NEWLEVEL WINDOW) (* rrb "25-OCT-82 16:28")
(PROG [(REGION (SELECTQ WHICHHLS
(HUE HUEREGION)
(LIGHTNESS LIGHTNESSREGION)
(SATURATION SATURATIONREGION)
(\ILLEGAL.ARG WHICHHLS]
(MOVETO (fetch LEFT of REGION)
VALBTM WINDOW) (* if there is a new level given, set it.)
(AND NEWLEVEL (HLSLEVEL HLS WHICHHLS NEWLEVEL)) (* overstrike extra digits in case the old value was
larger.)
(COND
((FIXP (SETQ NEWLEVEL (HLSLEVEL HLS WHICHHLS)))
(PRIN1 NEWLEVEL WINDOW)
(PRIN1 " " WINDOW))
(T (printout WINDOW .F5.3 NEWLEVEL)))
(FILLINREGION REGION (LEVELFROMHLSVALUE WHICHHLS NEWLEVEL)
GRAYSHADE WINDOW])
(DISPLAYHLSLEVELS
[LAMBDA (HLS WIN) (* rrb "25-OCT-82 14:08")
(* displays a hue lightness saturation triple in the
edit window.)
(DISPLAYHLSLEVEL HLS (QUOTE HUE)
NIL WIN)
(DISPLAYHLSLEVEL HLS (QUOTE LIGHTNESS)
NIL WIN)
(DISPLAYHLSLEVEL HLS (QUOTE SATURATION)
NIL WIN])
(HLSLEVEL
[LAMBDA (HLS FIELD NEWLEVEL) (* rrb "25-OCT-82 13:29")
(* returns the value of the named field from a hue
lightness saturation record.)
(SELECTQ FIELD
[HUE (PROG1 (fetch (HLS HUE) of HLS)
(AND NEWLEVEL (replace (HLS HUE) of HLS with NEWLEVEL]
[LIGHTNESS (PROG1 (fetch (HLS LIGHTNESS) of HLS)
(AND NEWLEVEL (replace (HLS LIGHTNESS) of HLS with NEWLEVEL]
[SATURATION (PROG1 (fetch (HLS SATURATION) of HLS)
(AND NEWLEVEL (replace (HLS SATURATION) of HLS with NEWLEVEL]
(SHOULDNT])
(HLSTORGB
[LAMBDA (HLS) (* rrb "25-OCT-82 16:21")
(* converts from a hue saturation lightness triple into red green blue triple. HUE is in range 0 to 360, lightness
and saturation are in the range 0 to 1.0 NIL)
(* this algorithm was taken from siggraph vol 13 number
3 August 1979: Status report on graphics standards
planning committee.)
(PROG ((H (fetch (HLS HUE) of HLS))
(L (fetch (HLS LIGHTNESS) of HLS))
(S (fetch (HLS SATURATION) of HLS))
Max Min)
[SETQ Max (COND
((FGREATERP .5 L)
(FTIMES L (FPLUS 1.0 S)))
(T (FDIFFERENCE (FPLUS L S)
(FTIMES L S]
(SETQ Min (FDIFFERENCE (FTIMES L 2)
Max))
(RETURN (create RGB
RED ←(HLSVALUEFN Min Max H)
GREEN ←(HLSVALUEFN Min Max (IDIFFERENCE H 120))
BLUE ←(HLSVALUEFN Min Max (IDIFFERENCE H 240])
(HLSVALUEFN
[LAMBDA (MIN MAX HUE) (* rrb "25-OCT-82 10:47")
(* internal value function for converting from HLS to
RGB.)
[COND
((ILESSP HUE 0)
(SETQ HUE (IPLUS HUE 360]
(FIX (FTIMES (COND
((ILESSP HUE 60)
(FPLUS MIN (FQUOTIENT (FTIMES (FDIFFERENCE MAX MIN)
HUE)
60)))
((ILESSP HUE 180)
MAX)
((ILESSP HUE 240)
(FPLUS MIN (FQUOTIENT (FTIMES (FDIFFERENCE MAX MIN)
(FDIFFERENCE 240 HUE))
60)))
(T MIN))
255])
(HLSVALUEFROMLEVEL
[LAMBDA (HLS LEVEL) (* rrb "25-OCT-82 13:26")
(* returns the scaled value of the hls marker on a scale
from 0 to 255)
(SELECTQ HLS
(HUE (IQUOTIENT (ITIMES LEVEL 360)
255))
(FQUOTIENT LEVEL 255])
(LEVELFROMHLSVALUE
[LAMBDA (HLS LEVEL) (* rrb "25-OCT-82 14:06")
(* returns the level on a scale from 0 to 255 that this
value would have.)
(SELECTQ HLS
(HUE (IQUOTIENT (ITIMES LEVEL 255)
360))
(FIX (FTIMES LEVEL 255])
(RAINBOWMAP
[LAMBDA (NBITS) (* rrb "21-OCT-82 18:14")
[OR NBITS (NULL (COLORDISPLAYP))
(SETQ NBITS (COLORMAPBITS (SCREENCOLORMAP]
(COLORMAPCREATE (COND
[(EQ NBITS 8)
(PROG ((MAXINTENSITY 255)
(MINVISIBLERED 69)
(MINVISIBLEBLUE 38)
(MINVISIBLEGREEN 38)
(NSTEPS (IQUOTIENT (EXPT 2 NBITS)
8))
REDSTEPSIZE GREENSTEPSIZE BLUESTEPSIZE)
(* determine how many steps are available for each transition from one color to the next. There are 8 such
transitions. red up, green up, red down, blue up, green down, red up, green up, all down)
(* minimum visible intensity values were emperically determined but will differ depending upon the brightness
setting of the individual display. They are also diddled to make the numer of steps come out right.)
(RETURN (NCONC (for I from MINVISIBLERED to MAXINTENSITY
by (SETQ REDSTEPSIZE (IQUOTIENT (IPLUS (IDIFFERENCE
MAXINTENSITY
MINVISIBLERED)
NSTEPS -2)
NSTEPS))
collect (* red up)
(LIST I 0 0))
(for I from MINVISIBLEGREEN to MAXINTENSITY
by (SETQ GREENSTEPSIZE
(IQUOTIENT (IPLUS (IDIFFERENCE MAXINTENSITY
MINVISIBLEGREEN)
-1 NSTEPS)
NSTEPS))
collect (* GREEN UP)
(LIST 255 I 0))
(for I from REDSTEPSIZE to (IDIFFERENCE MAXINTENSITY
MINVISIBLERED)
by REDSTEPSIZE collect
(* red down)
(LIST (IDIFFERENCE
MAXINTENSITY I)
255 0))
(CONS (QUOTE (0 255 0)))
(for I from MINVISIBLEBLUE to MAXINTENSITY
by (SETQ BLUESTEPSIZE (IQUOTIENT (IPLUS (IDIFFERENCE
MAXINTENSITY
MINVISIBLEBLUE)
-1 NSTEPS)
NSTEPS))
collect (* BLUE UP)
(LIST 0 255 I))
(for I from GREENSTEPSIZE to (IDIFFERENCE MAXINTENSITY
MINVISIBLEGREEN)
by GREENSTEPSIZE collect
(* GREEN down)
(LIST 0 (IDIFFERENCE
MAXINTENSITY I)
255))
(CONS (QUOTE (0 0 255)))
(for I from MINVISIBLERED to MAXINTENSITY by REDSTEPSIZE
collect (* red up)
(LIST I 0 255))
(for I from MINVISIBLEGREEN to MAXINTENSITY
by GREENSTEPSIZE collect
(* GREEN UP)
(LIST 255 I 255))
(for I from GREENSTEPSIZE to (IDIFFERENCE MAXINTENSITY
MINVISIBLEGREEN)
by GREENSTEPSIZE collect
(* all down)
(LIST (IDIFFERENCE
MAXINTENSITY I)
(IDIFFERENCE
MAXINTENSITY I)
(IDIFFERENCE
MAXINTENSITY I)))
(CONS (QUOTE (0 0 0]
(T RAINBOWINTENSITIES))
NBITS])
(RGBTOHLS
[LAMBDA (RGB GREEN BLUE) (* rrb "25-OCT-82 13:18")
(* converts from a red green blue triple of color
information into a hue lightness saturation triple.)
(* this algorithm was taken from siggraph vol 13 number
3 August 1979: Status report on graphics standards
planning committee.)
(PROG ((RED (COND
((LISTP RGB)
(fetch (RGB RED) of RGB))
(T RGB)))
(GREEN (COND
((LISTP RGB)
(fetch (RGB GREEN) of RGB))
(T GREEN)))
(BLUE (COND
((LISTP RGB)
(fetch (RGB BLUE) of RGB))
(T BLUE)))
R G B MAX MIN L)
(SETQ MAX (MAX RED GREEN BLUE))
(SETQ MIN (MIN RED GREEN BLUE))
(RETURN (COND
((EQ MAX MIN)
(create HLS
HUE ← 0
LIGHTNESS ←(FQUOTIENT MAX 255.0)
SATURATION ← 0.0))
(T (SETQ R (FQUOTIENT (IDIFFERENCE MAX RED)
(IDIFFERENCE MAX MIN)))
(SETQ G (FQUOTIENT (IDIFFERENCE MAX GREEN)
(IDIFFERENCE MAX MIN)))
(SETQ B (FQUOTIENT (IDIFFERENCE MAX BLUE)
(IDIFFERENCE MAX MIN)))
(create HLS
HUE ←(IMOD (FIX (FTIMES [COND
((EQ MAX RED)
(FPLUS 2.0 (FDIFFERENCE B G)))
((EQ MAX GREEN)
(FPLUS 4.0 (FDIFFERENCE R B)))
(T (FPLUS 6.0 (FDIFFERENCE G R]
60.0))
360)
LIGHTNESS ←(FQUOTIENT (SETQ L (FQUOTIENT (FPLUS MIN MAX)
2))
255)
SATURATION ←(COND
((FGREATERP .5 L)
(FQUOTIENT (IDIFFERENCE MAX MIN)
(IPLUS MAX MIN)))
(T (FQUOTIENT (IDIFFERENCE MAX MIN)
(IDIFFERENCE 510 (IPLUS MAX MIN])
)
(DEFINEQ
(OVERPAINT
[LAMBDA (BM1 BM2 X Y TXT SCR) (* rrb "21-DEC-82 22:16")
(* Uses BM1 as a mask thru which it paints the INVERSE
of texture onto BM2 at position X Y)
(PROG ((BMW (BITMAPWIDTH BM1))
(BMH (fetch BITMAPHEIGHT of BM1)))
(OR SCR (SETQ SCR (BITMAPCOPY BM1))) (* We need a scratch BM. Most demos cache one)
(BITBLT BM1 0 0 SCR 0 0 BMW BMH (QUOTE INPUT)
(QUOTE REPLACE))
(BITBLT NIL NIL NIL SCR 0 0 BMW BMH (QUOTE TEXTURE)
(QUOTE ERASE)
TXT)
(BITBLT BM1 0 0 BM2 X Y BMW BMH (QUOTE INPUT)
(QUOTE ERASE))
(BITBLT SCR 0 0 BM2 X Y BMW BMH (QUOTE INPUT)
(QUOTE PAINT])
(BITMAPFROMSTRING
[LAMBDA (STR FONT) (* rrb "17-DEC-82 13:16")
(OR STR (SETQ STR "Interlisp-D"))
[OR (FONTP FONT)
(SETQ FONT (FONTCREATE (QUOTE TIMESROMAND)
(QUOTE 36]
(PROG ((SCR (DSPCREATE))
(SW (STRINGWIDTH STR FONT))
(FH (FONTPROP FONT (QUOTE HEIGHT)))
BM)
(SETQ BM (BITMAPCREATE SW FH))
(DSPDESTINATION BM SCR)
(DSPFONT FONT SCR)
(MOVETO 0 (FONTPROP FONT (QUOTE DESCENT))
SCR)
(PRIN3 STR SCR)
(RETURN BM])
(SHADEBITMAP
[LAMBDA (BM T0 T1) (* bas: "25-APR-82 15:02")
(* Shades bitmap BM with T0 into 0 areas and T1 into 1
areas)
(BITBLT NIL NIL NIL BM NIL NIL NIL NIL (QUOTE TEXTURE)
(QUOTE INVERT)
(LOGAND T0 (LOGXOR T0 T1)))
(BITBLT NIL NIL NIL BM NIL NIL NIL NIL (QUOTE TEXTURE)
(QUOTE PAINT)
(LOGAND T0 T1))
(BITBLT NIL NIL NIL BM NIL NIL NIL NIL (QUOTE TEXTURE)
(QUOTE ERASE)
(LOGXOR (LOGOR T0 T1)
65535])
)
(DEFINEQ
(EDITCOLORMAP
[LAMBDA (VAR NOQFLG) (* rrb "21-OCT-82 18:15")
(* edits a color map.)
(RESETLST (PROG (CM)
[COND
((COLORMAPP VAR)
(SETQ CM VAR))
[(LITATOM VAR)
(COND
([COLORMAPP (SETQ CM (EVALV VAR (QUOTE EDITCOLORMAP]
(* use value.)
)
(T (SETQ CM (COLORMAPCREATE]
(T (* otherwise create a colormap)
(SETQ CM (COLORMAPCREATE]
[COND
((COLORDISPLAYP) (* colordisplay is on, ask if use want test pattern)
[COND
([AND (NOT NOQFLG)
(ASKUSER NIL NIL
(QUOTE (Would you like a test pattern on the color screen
while you are editting))
(QUOTE ((Y "es
" RETURN T)
(N "o
" RETURN NIL] (* if so, put up the test pattern and make the colormap
being editted the one used in the display.)
(COND
((EQ (COLORMAPBITS (SCREENCOLORMAP))
8) (* if * bit mode, put up blocks)
(SHOWCOLORBLOCKS))
(T (SHOWCOLORTESTPATTERN] (* and make the editted colormap be the screencolormap)
(RESETSAVE (SCREENCOLORMAP CM]
(RETURN (COND
((EDITCOLORMAP1 CM)
[COND
((AND VAR (LITATOM VAR)) (* set the variable.)
(STKEVAL (QUOTE EDITCOLORMAP)
(LIST (QUOTE SAVESET)
(KWOTE VAR)
(KWOTE CM]
CM])
(ADJUSTCOLORMAP
[LAMBDA (PRIMARY DELTA COLORMAP) (* rrb "16-NOV-82 15:05")
(* adds DELTA points of intensity to all values of
PRIMARY color in COLORMAP.)
(PROG [(CM (OR COLORMAP (SCREENCOLORMAP]
[for I from 1 to (MAXIMUMCOLOR CM)
do (COLORLEVEL CM I PRIMARY (IMIN 255 (IMAX 0 (IPLUS (COLORLEVEL CM I PRIMARY)
DELTA]
(RETURN CM])
(EDITCOLORMAP1
[LAMBDA (CM) (* rrb "25-OCT-82 15:47")
(* displays a colormap in a window and allows the user
to change it.)
(PROG ((WIN (PROGN (PROMPTPRINT "Select location of colormap editting window")
(CREATEW (GETBOXREGION EditColorMapWidth EditColorMapHeight)
"ColorMap editor")))
XPOS REDREGION GREENREGION BLUEREGION HUEREGION LIGHTNESSREGION SATURATIONREGION SETBTM)
(CLRPROMPT)
(WINDOWPROP WIN (QUOTE COLORMAP)
CM)
(MOVETO 35 4 WIN)
(SETQ XPOS (DSPXPOSITION NIL WIN))
(PRIN1 "RED" WIN)
(OUTLINEREGION (SETQ REDREGION (create REGION
LEFT ←(CENTEREDLEFT 10 XPOS (SETQ XPOS
(DSPXPOSITION NIL WIN)))
BOTTOM ←(SETQ SETBTM (IDIFFERENCE (DSPYPOSITION
NIL WIN)
(DSPLINEFEED
NIL WIN)))
WIDTH ← 10
HEIGHT ← 256))
2 NIL WIN)
(MOVETO XPOS 4 WIN)
(PRIN1 " " WIN)
(SETQ XPOS (DSPXPOSITION NIL WIN))
(PRIN1 "GREEN" WIN)
(OUTLINEREGION (SETQ GREENREGION (create REGION
LEFT ←(CENTEREDLEFT 10 XPOS (SETQ XPOS
(DSPXPOSITION NIL WIN)))
BOTTOM ← SETBTM
WIDTH ← 10
HEIGHT ← 256))
2 NIL WIN)
(MOVETO XPOS 4 WIN)
(PRIN1 " " WIN)
(SETQ XPOS (DSPXPOSITION NIL WIN))
(PRIN1 "BLUE" WIN)
(OUTLINEREGION (SETQ BLUEREGION (create REGION
LEFT ←(CENTEREDLEFT 10 XPOS (SETQ XPOS
(DSPXPOSITION NIL WIN)))
BOTTOM ← SETBTM
WIDTH ← 10
HEIGHT ← 256))
2 NIL WIN)
(PROGN (MOVETO (IPLUS XPOS 20)
4 WIN)
(PRIN1 " " WIN)
(SETQ XPOS (DSPXPOSITION NIL WIN))
(PRIN1 "hue" WIN)
(OUTLINEREGION (SETQ HUEREGION (create REGION
LEFT ←(CENTEREDLEFT 10 XPOS
(SETQ XPOS
(DSPXPOSITION NIL WIN)))
BOTTOM ← SETBTM
WIDTH ← 10
HEIGHT ← 256))
2 NIL WIN))
(PROGN (MOVETO XPOS 4 WIN)
(PRIN1 " " WIN)
(SETQ XPOS (DSPXPOSITION NIL WIN))
(PRIN1 "lightness" WIN)
(OUTLINEREGION (SETQ LIGHTNESSREGION (create REGION
LEFT ←(CENTEREDLEFT 10 XPOS
(SETQ XPOS
(DSPXPOSITION
NIL WIN)))
BOTTOM ← SETBTM
WIDTH ← 10
HEIGHT ← 256))
2 NIL WIN))
(PROGN (MOVETO XPOS 4 WIN)
(PRIN1 " " WIN)
(SETQ XPOS (DSPXPOSITION NIL WIN))
(PRIN1 " sat " WIN)
(OUTLINEREGION (SETQ SATURATIONREGION (create REGION
LEFT ←(CENTEREDLEFT 10 XPOS
(DSPXPOSITION
NIL WIN))
BOTTOM ← SETBTM
WIDTH ← 10
HEIGHT ← 256))
2 NIL WIN))
(PROMPTPRINT
"Left in rectangle sets the corresponding level.
Middle button in window brings up color number selection menu.
Middle in title brings up control menu (to STOP).")
(EDITCOLORMAP2 WIN)
(CLRPROMPT)
(CLOSEW WIN)
(RETURN CM])
(EDITCOLORMAP2
[LAMBDA (WIN) (* hdj "19-Jun-85 17:27")
(* internal function to EDITCOLORMAP which polls mouse
and updates fields.)
(PROG ((COLOR# 0)
(VALBTM (IPLUS (fetch (REGION BOTTOM) of REDREGION)
264))
COLOR#MENU CONTROLMENU (COLORMAP (WINDOWPROP WIN (QUOTE COLORMAP)))
LEVEL LASTX LASTY HLS)
(COND
[(type? 4BITCOLORMAP COLORMAP)
[SETQ COLOR#MENU
(COND
((TYPENAMEP COLOR#MENUSAVE (QUOTE MENU))
COLOR#MENUSAVE)
(T (SETQ COLOR#MENUSAVE
(create MENU
ITEMS ←(QUOTE (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15))
MENUROWS ← 2
CENTERFLG ← T
CHANGEOFFSETFLG ← T]
(SETQ CONTROLMENU (COND
((TYPENAMEP CONTROLMENUSAVE (QUOTE MENU))
CONTROLMENUSAVE)
(T (create MENU
ITEMS ←(QUOTE ((STOP (QUOTE STOP)
"Stops the color map editor.")
(PickPt (GETCOLOR#FROMSCREEN)
"prompts for a color from the color screen."]
[(type? 8BITCOLORMAP COLORMAP)
(SETQ CONTROLMENU (SETQ COLOR#MENU (COND
((TYPENAMEP EDIT8BITCOLORMAPMENU (QUOTE MENU))
EDIT8BITCOLORMAPMENU)
(T (create MENU
ITEMS ←(QUOTE ((STOP (QUOTE STOP)
"Stops the color map editor.")
(Input# (GETCOLOR#FROMUSER)
"prompts for a new color number via numberpad.")
(PickPt (GETCOLOR#FROMSCREEN)
"prompts for a color from the color screen."]
(T (SHOULDNT)))
COLORLP
(MOVETO 8 250 WIN)
(printout WIN .I3 COLOR#) (* show color number.)
(DISPLAYCOLORLEVELS WIN)
(DISPLAYHLSLEVELS [SETQ HLS (RGBTOHLS (COLORLEVEL COLORMAP COLOR# (QUOTE RED))
(COLORLEVEL COLORMAP COLOR# (QUOTE GREEN))
(COLORLEVEL COLORMAP COLOR# (QUOTE BLUE]
WIN)
WAITLP
(GETMOUSESTATE)
[COND
[(LASTMOUSESTATE MIDDLE)
(COND
[(EQ COLOR#MENU CONTROLMENU) (* in 8 bit mode, both menus are the same.)
(COND
((NUMBERP (SETQ LEVEL (MENU COLOR#MENU)))
(SETQ COLOR# LEVEL)
(GO COLORLP))
((EQ LEVEL (QUOTE STOP))
(RETURN]
(T (COND
((INSIDEP (DSPCLIPPINGREGION NIL WIN)
(LASTMOUSEX WIN)
(LASTMOUSEY WIN)) (* cursor is in interior)
(AND (SETQ LEVEL (MENU COLOR#MENU))
(SETQ COLOR# LEVEL)
(GO COLORLP)))
((EQ (SETQ LEVEL (MENU CONTROLMENU))
(QUOTE STOP))
(RETURN))
((NUMBERP LEVEL)
(SETQ COLOR# LEVEL)
(GO COLORLP]
((LASTMOUSESTATE RED)
(COND
[[SETQ COLOR (COND
((INSIDEP REDREGION (SETQ LASTX (LASTMOUSEX WIN))
(SETQ LASTY (LASTMOUSEY WIN)))
(QUOTE RED))
((INSIDEP GREENREGION LASTX LASTY)
(QUOTE GREEN))
((INSIDEP BLUEREGION LASTX LASTY)
(QUOTE BLUE]
(until (MOUSESTATE (NOT RED))
do (* as long as red is down, adjust the color.)
(COND
((NEQ [SETQ LEVEL (IMIN 255 (IMAX 0 (IDIFFERENCE (LASTMOUSEY WIN)
(fetch (REGION BOTTOM)
of REDREGION]
(COLORLEVEL COLORMAP COLOR# COLOR))
(* see if color level has changed.)
(DISPLAYCOLORLEVEL COLOR LEVEL WIN)
(DISPLAYHLSLEVELS [SETQ HLS (RGBTOHLS (COLORLEVEL COLORMAP COLOR#
(QUOTE RED))
(COLORLEVEL COLORMAP COLOR#
(QUOTE GREEN))
(COLORLEVEL COLORMAP COLOR#
(QUOTE BLUE]
WIN]
([SETQ COLOR (COND
((INSIDEP HUEREGION (SETQ LASTX (LASTMOUSEX WIN))
(SETQ LASTY (LASTMOUSEY WIN)))
(QUOTE HUE))
((INSIDEP LIGHTNESSREGION LASTX LASTY)
(QUOTE LIGHTNESS))
((INSIDEP SATURATIONREGION LASTX LASTY)
(QUOTE SATURATION]
(until (MOUSESTATE (NOT RED))
do (* as long as red is down, adjust the color.)
(COND
((NEQ [SETQ LEVEL (HLSVALUEFROMLEVEL
COLOR
(IMIN 255 (IMAX 0 (IDIFFERENCE (LASTMOUSEY WIN)
(fetch (REGION BOTTOM)
of REDREGION]
(HLSLEVEL HLS COLOR)) (* see if color level has changed.)
(DISPLAYHLSLEVEL HLS COLOR LEVEL WIN)
(* set the color levels of the current color and update
that display also.)
(for COLOR in (QUOTE (RED GREEN BLUE)) as LEVEL in (HLSTORGB HLS)
do (COLORLEVEL COLORMAP COLOR# COLOR LEVEL)
(DISPLAYCOLORLEVEL COLOR LEVEL WIN]
(GO WAITLP])
(GETCOLOR#FROMUSER
[LAMBDA NIL (* edited: " 8-SEP-82 21:44")
(* reads a color number from the user.)
(PROG (RESPONSE)
(MOVEW [COND
((TYPENAMEP EDIT8BITCOLORMAPNUMBERREADER (QUOTE WINDOW))
EDIT8BITCOLORMAPNUMBERREADER)
(T (SETQ EDIT8BITCOLORMAPNUMBERREADER
(CREATE.NUMBERPAD.READER (QUOTE (Enter color number to edit:))
(CREATE POSITION
XCOORD ← LASTMOUSEX
YCOORD ← LASTMOUSEY]
(CREATE POSITION
XCOORD ← LASTMOUSEX
YCOORD ← LASTMOUSEY))
LP (COND
([NULL (ERSETQ (SETQ RESPONSE (NUMBERPAD.READ EDIT8BITCOLORMAPNUMBERREADER]
(* currently there is no way NIL can be returned from
NUMBERPAD.READ but there should be a way to quit.)
(RETURN NIL))
((OR (ILESSP RESPONSE 0)
(IGREATERP RESPONSE 255))
(PROMPTPRINT "Color numbers must be between 0 and 255.")
(GO LP))
(T (RETURN RESPONSE])
(GETCOLOR#FROMSCREEN
[LAMBDA NIL (* rrb " 3-NOV-82 13:57")
(* returns the color number of a point selected by the
user.)
(RESETFORM (CHANGECURSORSCREEN (COLORSCREENBITMAP))
(PROG ((POS (GETPOSITION)))
(RETURN (AND POS (BITMAPBIT (COLORSCREENBITMAP)
(fetch XCOORD of POS)
(fetch YCOORD of POS])
(DISPLAYCOLORLEVEL
[LAMBDA (PRIMARYCOLOR NEWLEVEL WINDOW) (* rrb "25-OCT-82 14:03")
(PROG [(REGION (SELECTQ PRIMARYCOLOR
(RED REDREGION)
(BLUE BLUEREGION)
(GREEN GREENREGION)
(\ILLEGAL.ARG PRIMARYCOLOR]
(MOVETO (fetch LEFT of REGION)
VALBTM WINDOW) (* if there is a new level given, set it.)
(AND NEWLEVEL (COLORLEVEL (WINDOWPROP WIN (QUOTE COLORMAP))
COLOR# PRIMARYCOLOR NEWLEVEL))
(* overstrike extra digits in case the old value was
larger.)
(PRIN1 (SETQ NEWLEVEL (COLORLEVEL (WINDOWPROP WIN (QUOTE COLORMAP))
COLOR# PRIMARYCOLOR))
WINDOW)
(PRIN1 " " WINDOW)
(FILLINREGION REGION NEWLEVEL GRAYSHADE WINDOW])
(FILLINREGION
[LAMBDA (REGION HEIGHT GRAY WINDOW) (* rrb "23-FEB-82 12:26")
(* fills part of a region with gray.)
(DSPFILL REGION WHITESHADE (QUOTE REPLACE)
WINDOW)
(AREAFILL (fetch (REGION LEFT) of REGION)
(fetch (REGION BOTTOM) of REGION)
(fetch (REGION WIDTH) of REGION)
HEIGHT GRAY (QUOTE REPLACE)
WINDOW])
(AREAFILL
[LAMBDA (LFT BTM WDTH HGTH SHADE OPERATION WINDOW) (* fills an area of a window with shade.)
(BITBLT NIL NIL NIL WINDOW LFT BTM WDTH HGTH (QUOTE TEXTURE)
OPERATION SHADE])
(CENTEREDLEFT
[LAMBDA (WIDTH LEFT RIGHT) (* rrb "16-FEB-82 14:58")
(* returns the left point that would leave WIDTH
centered between LEFT and RIGHT)
(IQUOTIENT (IDIFFERENCE (IPLUS LEFT RIGHT)
WIDTH)
2])
(OUTLINEAREA
[LAMBDA (LFT BTM WDTH HGHT LINEWIDTH OPERATION WIN) (* rrb "17-FEB-82 10:59")
(* outlines an area of a window.)
(PROG (LEFTPLUSWIDTH RIGHTLINELEFT VERTLINETOP TOPY (LINEWIDTH (OR (NUMBERP LINEWIDTH)
1)))
(SETQ LFT (IDIFFERENCE LFT LINEWIDTH))
(SETQ BTM (IDIFFERENCE BTM LINEWIDTH))
(SETQ WDTH (IPLUS WDTH (ITIMES LINEWIDTH 2)))
(SETQ HGHT (IPLUS HGHT (ITIMES LINEWIDTH 2)))
(DRAWLINE LFT BTM LFT (SETQ VERTLINETOP (SUB1 (IPLUS BTM HGHT)))
LINEWIDTH OPERATION WIN)
(DRAWLINE (SETQ RIGHTLINELEFT (IDIFFERENCE (IPLUS LFT WDTH)
LINEWIDTH))
BTM RIGHTLINELEFT VERTLINETOP LINEWIDTH OPERATION WIN)
(DRAWLINE (SETQ LEFTPLUSWIDTH (IPLUS LFT LINEWIDTH))
BTM
(SETQ RIGHTLINELEFT (SUB1 RIGHTLINELEFT))
BTM LINEWIDTH OPERATION WIN)
(DRAWLINE LEFTPLUSWIDTH (SETQ TOPY (ADD1 (IDIFFERENCE VERTLINETOP LINEWIDTH)))
RIGHTLINELEFT TOPY LINEWIDTH OPERATION WIN])
(OUTLINEREGION
[LAMBDA (REGION OUTLINEWIDTH OPERATION WIN) (* rrb "17-FEB-82 10:58")
(* outlines the region REGION with a width wide line)
(OUTLINEAREA (fetch (REGION LEFT) of REGION)
(fetch (REGION BOTTOM) of REGION)
(fetch (REGION WIDTH) of REGION)
(fetch (REGION HEIGHT) of REGION)
OUTLINEWIDTH OPERATION WIN])
(SHOWCOLORTESTPATTERN
[LAMBDA (SIZE) (* edited: "10-SEP-82 10:07")
(* put a color test pattern on the display.)
(COLORFILL WHOLECOLORDISPLAY 0)
(SELECTQ \COLORDISPLAYBITSPERPIXEL
[4 (OR (NUMBERP SIZE)
(SETQ SIZE 20))
(for I from 1 to 7 as LEFT from 90 by 80 do (COLORFILLAREA LEFT 410 60 60 I))
(for I from 8 to 15 as LEFT from 10 by 80 do (COLORFILLAREA LEFT 330 60 60 I))
(for HORIZCOLOR from 0 as BOTTOM from 0 to 300 by SIZE
do (COND
((EQ HORIZCOLOR 16)
(SETQ HORIZCOLOR 0)))
(COLORFILLAREA 0 BOTTOM 640 SIZE HORIZCOLOR (COLORSCREENBITMAP)
(QUOTE REPLACE))
finally (for VERTCOLOR from 0 as LEFT from 0 to COLORSCREENWIDTH
by (ITIMES SIZE 2) do (COND
((EQ VERTCOLOR 16)
(SETQ VERTCOLOR 0)))
(COLORFILLAREA LEFT 0 SIZE BOTTOM VERTCOLOR
(COLORSCREENBITMAP)
(QUOTE REPLACE]
[8 (OR (NUMBERP SIZE)
(SETQ SIZE 1))
(for HORIZCOLOR from 0 as BOTTOM from 0 to COLORSCREENHEIGHT by SIZE
do (COND
((EQ HORIZCOLOR 256)
(SETQ HORIZCOLOR 0)))
(COLORFILLAREA 0 BOTTOM COLORSCREENWIDTH SIZE HORIZCOLOR (COLORSCREENBITMAP)
(QUOTE REPLACE))
finally (for VERTCOLOR from 0 as LEFT from 0 to COLORSCREENWIDTH
by (ITIMES SIZE 2) do (COND
((EQ VERTCOLOR 256)
(SETQ VERTCOLOR 0)))
(COLORFILLAREA LEFT 0 SIZE BOTTOM VERTCOLOR
(COLORSCREENBITMAP)
(QUOTE REPLACE]
(SHOULDNT])
(SHOWCOLORBLOCKS
[LAMBDA NIL (* edited: "10-SEP-82 14:38")
(* puts up color blocks for an 8 bit color display.)
(bind BOTTOM (WIDTH ←(IQUOTIENT COLORSCREENWIDTH 16))
(HEIGHT ←(IQUOTIENT COLORSCREENHEIGHT 16))
(COLOR# ← 0) for I from 15 to 0 by -1 do (SETQ BOTTOM (ADD1 (ITIMES HEIGHT I)))
(for LEFT from 0 to (IDIFFERENCE COLORSCREENWIDTH
WIDTH)
by WIDTH
do (COLORFILLAREA LEFT BOTTOM WIDTH HEIGHT
COLOR# (COLORSCREENBITMAP))
(SETQ COLOR# (ADD1 COLOR#])
(MAPOFACOLOR
[LAMBDA (PRIMARIES) (* rrb "22-SEP-82 17:06")
(AND (NLISTP PRIMARIES)
(SETQ PRIMARIES (CONS PRIMARIES)))
(PROG ((MAXCOLOR (MAXIMUMCOLOR))
(MINVISIBLEINTENSITY 45))
(RETURN (COLORMAPCREATE (CONS (QUOTE (0 0 0))
(for I from 1 to MAXCOLOR bind THISLEVEL
collect [SETQ THISLEVEL
(COND
((EQ MAXCOLOR 255)
(* if 255 colors, there is enough for all of them.)
I)
(T (IPLUS (IQUOTIENT (ITIMES I
(IDIFFERENCE
255
MINVISIBLEINTENSITY))
MAXCOLOR)
MINVISIBLEINTENSITY]
(LIST (COND
((FMEMB (QUOTE RED)
PRIMARIES)
THISLEVEL)
(T 0))
(COND
((FMEMB (QUOTE GREEN)
PRIMARIES)
THISLEVEL)
(T 0))
(COND
((FMEMB (QUOTE BLUE)
PRIMARIES)
THISLEVEL)
(T 0])
)
(RPAQQ EditColorMapHeight 315)
(RPAQQ EditColorMapWidth 380)
(RPAQQ COLOR#MENUSAVE NIL)
(RPAQQ CONTROLMENUSAVE NIL)
(RPAQQ EDIT8BITCOLORMAPMENU NIL)
(RPAQQ EDIT8BITCOLORMAPNUMBERREADER NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS COLOR#MENUSAVE CONTROLMENUSAVE EDIT8BITCOLORMAPMENU EDIT8BITCOLORMAPNUMBERREADER
EditColorMapHeight EditColorMapWidth)
)
(FILESLOAD LLCOLOR)
(FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
READNUMBER)
(PUTPROPS COLOR COPYRIGHT ("Xerox Corporation" 1982 1983 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1156 11113 (DISPLAYCOLORLEVELS 1166 . 1455) (DISPLAYHLSLEVEL 1457 . 2301) (
DISPLAYHLSLEVELS 2303 . 2749) (HLSLEVEL 2751 . 3466) (HLSTORGB 3468 . 4516) (HLSVALUEFN 4518 . 5143) (
HLSVALUEFROMLEVEL 5145 . 5512) (LEVELFROMHLSVALUE 5514 . 5887) (RAINBOWMAP 5889 . 9236) (RGBTOHLS 9238
. 11111)) (11114 13060 (OVERPAINT 11124 . 11913) (BITMAPFROMSTRING 11915 . 12474) (SHADEBITMAP 12476
. 13058)) (13061 32396 (EDITCOLORMAP 13071 . 14715) (ADJUSTCOLORMAP 14717 . 15219) (EDITCOLORMAP1
15221 . 18448) (EDITCOLORMAP2 18450 . 23787) (GETCOLOR#FROMUSER 23789 . 24893) (GETCOLOR#FROMSCREEN
24895 . 25376) (DISPLAYCOLORLEVEL 25378 . 26252) (FILLINREGION 26254 . 26732) (AREAFILL 26734 . 26942)
(CENTEREDLEFT 26944 . 27289) (OUTLINEAREA 27291 . 28374) (OUTLINEREGION 28376 . 28831) (
SHOWCOLORTESTPATTERN 28833 . 30615) (SHOWCOLORBLOCKS 30617 . 31312) (MAPOFACOLOR 31314 . 32394)))))
STOP