(FILECREATED "29-Oct-85 14:44:30" {PHYLUM}<PAPERWORKS>SKETCHCOLOR.;1 6850
changes to: (VARS SKETCHCOLORCOMS)
(ADVICE \POLYSHADE.DISPLAY \FILLCIRCLE.DISPLAY))
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT SKETCHCOLORCOMS)
(RPAQQ SKETCHCOLORCOMS ((FNS COLORTEXTURETEST LEVELTEXTURE PRIMARYTEXTURE TEXTUREOFCOLOR
INSURE.RGB.COLOR)
(UGLYVARS BLACKSHADE16 DARKGRAY16 MEDIUMGRAY16 LIGHTGRAY16 WHITESHADE16
REDTEXTURE GREENTEXTURE BLUETEXTURE)
(VARS (SKETCHINCOLORFLG T))
(FILES COLOR)
(ADVISE \FILLCIRCLE.DISPLAY \POLYSHADE.DISPLAY)))
(DEFINEQ
(COLORTEXTURETEST
[LAMBDA (W) (* rrb "22-Aug-85 10:16")
(* puts up a test pattern of primary colors.)
(PROG ((LFT 90))
(CLEARW W)
(for BLUELEVEL from 94 by 50 to 300
do (printout W "BLUE: " BLUELEVEL " " (QUOTE RED))
(DSPYPOSITION (DIFFERENCE (DSPYPOSITION NIL W)
50)
W)
(DSPXPOSITION 0 W)
(for GREENLEVEL from 94 by 50 to 300
do (printout W "Green: " GREENLEVEL)
[for REDLEVEL from 94 by 50 to 300
do (BITBLT NIL 0 0 W (DIFFERENCE REDLEVEL 20)
(DSPYPOSITION NIL W)
45 45 (QUOTE TEXTURE)
(QUOTE REPLACE)
(TEXTUREOFCOLOR (LIST REDLEVEL GREENLEVEL BLUELEVEL]
(DSPYPOSITION (DIFFERENCE (DSPYPOSITION NIL W)
50)
W)
(DSPXPOSITION 0 W])
(LEVELTEXTURE
[LAMBDA (LEVEL) (* rrb "20-Aug-85 16:42")
(* returns a 16x16 texture which is merged so that only light bits on both go to light with a primary color pattern
to get a level primary pattern.)
(COND
((ILESSP LEVEL 100)
BLACKSHADE16)
((ILESSP LEVEL 150)
DARKGRAY16)
((ILESSP LEVEL 200)
MEDIUMGRAY16)
((ILESSP LEVEL 245)
LIGHTGRAY16)
(T WHITESHADE16])
(PRIMARYTEXTURE
[LAMBDA (PRIMARY LEVEL) (* rrb "20-Aug-85 16:42")
(* returns the 16x16 texture for a primary color
level.)
(PROG [(TEXTURE (BITMAPCOPY (SELECTQ PRIMARY
(RED REDTEXTURE)
(BLUE BLUETEXTURE)
(GREEN GREENTEXTURE)
(\ILLEGAL.ARG PRIMARY]
(BITBLT (LEVELTEXTURE LEVEL)
0 0 TEXTURE 0 0 16 16 (QUOTE INPUT)
(QUOTE ERASE))
(RETURN TEXTURE])
(TEXTUREOFCOLOR
[LAMBDA (COLOR) (* rrb "29-Oct-85 11:51")
(* returns a texture to represent a color on a black
and white display)
(PROG ((RGB (INSURE.RGB.COLOR COLOR)))
(RETURN (COND
((AND (IGREATERP (fetch (RGB RED) of RGB)
245)
(IGREATERP (fetch (RGB GREEN) of RGB)
245)
(IGREATERP (fetch (RGB BLUE) of RGB)
245)) (* special case white)
BLACKSHADE16)
(T (PROG [(TEX (PRIMARYTEXTURE (QUOTE RED)
(fetch (RGB RED) of RGB]
(BITBLT NIL NIL NIL TEX 0 0 16 16 (QUOTE TEXTURE)
(QUOTE PAINT)
(PRIMARYTEXTURE (QUOTE BLUE)
(fetch (RGB BLUE) of RGB)))
(BITBLT NIL NIL NIL TEX 0 0 16 16 (QUOTE TEXTURE)
(QUOTE PAINT)
(PRIMARYTEXTURE (QUOTE GREEN)
(fetch (RGB GREEN) of RGB)))
(RETURN TEX])
(INSURE.RGB.COLOR
[LAMBDA (COLOR NOERRFLG) (* rrb "29-Oct-85 11:50")
(* returns the RGB triple for a color.)
(PROG (LEVELS)
(RETURN (COND
[(FIXP COLOR) (* don't know what to do with color numbers so error)
(COND
(NOERRFLG NIL)
(T (\ILLEGAL.ARG COLOR]
[(LITATOM COLOR)
(COND
((SETQ LEVELS (\LOOKUPCOLORNAME COLOR))
(* recursively look up color number)
(INSURE.RGB.COLOR (CDR LEVELS)
NOERRFLG))
(NOERRFLG NIL)
(T (ERROR "Unknown color name" COLOR]
((HLSP COLOR) (* HLS form convert to RGB)
(HLSTORGB COLOR))
((RGBP COLOR) (* check for RGB or HLS)
COLOR)
(NOERRFLG NIL)
(T (\ILLEGAL.ARG COLOR])
)
(READVARS BLACKSHADE16 DARKGRAY16 MEDIUMGRAY16 LIGHTGRAY16 WHITESHADE16 REDTEXTURE GREENTEXTURE
BLUETEXTURE)
({(READBITMAP)(16 16
"OOOO"
"OOOO"
"OOOO"
"OOOO"
"OOOO"
"OOOO"
"OOOO"
"OOOO"
"OOOO"
"OOOO"
"OOOO"
"OOOO"
"OOOO"
"OOOO"
"OOOO"
"OOOO")} {(READBITMAP)(16 16
"NMGG"
"KGMM"
"MNKK"
"GKNN"
"MNKK"
"GKNM"
"NMGN"
"KGMG"
"NKKM"
"KNNK"
"GGMN"
"MMGG"
"GGKM"
"MJOG"
"NOEK"
"KMNN")} {(READBITMAP)(16 16
"JJJJ"
"EEEE"
"JJJJ"
"EEEE"
"JJJJ"
"EEEE"
"JJJJ"
"EEEE"
"JJJJ"
"EEEE"
"JJJJ"
"EEEE"
"JJJJ"
"EEEE"
"JJJJ"
"EEEE")} {(READBITMAP)(16 16
"HBDB"
"BHAA"
"DDHD"
"AABH"
"HHDA"
"BBAD"
"DDHB"
"AABH"
"HDAD"
"AADA"
"DHBH"
"BBHB"
"HHAD"
"ABDA"
"DDHH"
"BABB")} {(READBITMAP)(16 16
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@")} {(READBITMAP)(16 16
"LLLL"
"LLLL"
"LLLL"
"LLLL"
"LLLL"
"LLLL"
"LLLL"
"LLLL"
"LLLL"
"LLLL"
"LLLL"
"LLLL"
"LLLL"
"LLLL"
"LLLL"
"LLLL")} {(READBITMAP)(16 16
"CLCL"
"O@O@"
"LCLC"
"@O@O"
"CLCL"
"O@O@"
"LCLC"
"@O@O"
"CLCL"
"O@O@"
"LCLC"
"@O@O"
"CLCL"
"O@O@"
"LCLC"
"@O@O")} {(READBITMAP)(16 16
"LFGA"
"NCCH"
"GAIL"
"CHLN"
"ALFG"
"HNCC"
"LGAI"
"NCHL"
"GALF"
"CHNC"
"ILGA"
"LNCH"
"FGAL"
"CCHN"
"AILG"
"HLNC")})
(RPAQQ SKETCHINCOLORFLG T)
(FILESLOAD COLOR)
(PUTPROPS \FILLCIRCLE.DISPLAY READVICE [NIL (BEFORE NIL (COND ((LISTP TEXTURE)
(COND ((TEXTUREP (CAR TEXTURE))
(SETQ TEXTURE (CAR TEXTURE)))
(T (SETQ TEXTURE
(TEXTUREOFCOLOR
(CADR TEXTURE])
(PUTPROPS \POLYSHADE.DISPLAY READVICE [NIL (BEFORE NIL (COND ((LISTP FILL.SHADE)
(COND ((TEXTUREP (CAR FILL.SHADE))
(SETQ FILL.SHADE (CAR
FILL.SHADE)))
(T (SETQ FILL.SHADE
(TEXTUREOFCOLOR
(CADR FILL.SHADE])
(READVISE \FILLCIRCLE.DISPLAY \POLYSHADE.DISPLAY)
(PUTPROPS SKETCHCOLOR COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (635 4930 (COLORTEXTURETEST 645 . 1694) (LEVELTEXTURE 1696 . 2192) (PRIMARYTEXTURE 2194
. 2780) (TEXTUREOFCOLOR 2782 . 3923) (INSURE.RGB.COLOR 3925 . 4928)))))
STOP