-
-
Notifications
You must be signed in to change notification settings - Fork 24
/
Copy pathSKETCHCOLOR
99 lines (85 loc) · 4.78 KB
/
SKETCHCOLOR
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")
(FILECREATED " 9-Jan-87 16:47:16" {ERIS}<LISPCORE>LIBRARY>SKETCHCOLOR.;2 4779
changes to%: (VARS BLACKSHADE16 DARKGRAY16 MEDIUMGRAY16 LIGHTGRAY16 WHITESHADE16 REDTEXTURE
GREENTEXTURE BLUETEXTURE SKETCHCOLORCOMS)
previous date%: "29-Oct-85 14:44:30" {ERIS}<LISPCORE>LIBRARY>SKETCHCOLOR.;1)
(* "
Copyright (c) 1985, 1987 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT SKETCHCOLORCOMS)
(RPAQQ SKETCHCOLORCOMS ((FNS COLORTEXTURETEST LEVELTEXTURE PRIMARYTEXTURE)
(VARS (SKETCHINCOLORFLG T))
(FILES COLOR STYLESHEET)
(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 " " '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 'TEXTURE '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 'INPUT 'ERASE)
(RETURN TEXTURE])
)
(RPAQQ SKETCHINCOLORFLG T)
(FILESLOAD COLOR STYLESHEET)
(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 1987))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (771 3368 (COLORTEXTURETEST 781 . 2128) (LEVELTEXTURE 2130 . 2662) (PRIMARYTEXTURE 2664
. 3366)))))
STOP