-
-
Notifications
You must be signed in to change notification settings - Fork 24
/
Copy pathCOLORPOLYGONS
465 lines (436 loc) · 27.3 KB
/
COLORPOLYGONS
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
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
(FILECREATED " 3-Sep-86 22:07:11" {ERIS}<LISPCORE>LIBRARY>COLORPOLYGONS.;4 27440
changes to: (FNS MOTIONIT COLORPOLYGONS.ROTATECOLORMAP)
previous date: " 6-Jun-86 00:35:47" {ERIS}<LISPCORE>LIBRARY>COLORPOLYGONS.;2)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT COLORPOLYGONSCOMS)
(RPAQQ COLORPOLYGONSCOMS ((FNS COLORPOLYGONS COLORPOLYGON COLORPOLYGONS.ROTATECOLORMAP)
(FNS BLACKHOLE BLACKHOLE1 COLORCONNECTPOLYS COLORDRAWPOLY1
DRAWCOLORPOLYSTEPS LENSE LINETEST MAPIT MAPIT2 MOTIONIT ONECOLORPOLY
RANDOMPT)
(INITVARS (MOTIONMAP)
(ONEMAP)
(PRETTYMAP))
(VARS MOTIONMAPCOLORS ONEMAPCOLORS PRETTYCOLORS)))
(DEFINEQ
(COLORPOLYGONS
(LAMBDA (DS) (* kbr: " 6-Jun-86 00:16")
(PROG (BITSPERPIXEL NPTS)
(COND
((NULL DS)
(SETQ DS (DSPCREATE (COLORSCREENBITMAP)))
(DSPCLIPPINGREGION (LIST 0 0 (BITMAPWIDTH (COLORSCREENBITMAP))
(BITMAPHEIGHT (COLORSCREENBITMAP)))
DS)))
LP (COLORPOLYGON DS)
(COLORPOLYGONS.ROTATECOLORMAP)
(GO LP))))
(COLORPOLYGON
(LAMBDA (DS) (* kbr: " 6-Jun-86 00:10")
(PROG (NPTS)
(COLORCONNECTPOLYS (for I from 1 to (SETQ NPTS (RAND 3 8)) collect (RANDOMPT DS))
(for I from 1 to NPTS collect (RANDOMPT DS))
(ITIMES 15 (RAND 3 4))
T 1 1 15 8 DS))))
(COLORPOLYGONS.ROTATECOLORMAP
(LAMBDA NIL (* kbr: " 3-Sep-86 21:31")
(PROG (BITSPERPIXEL)
(SETQ BITSPERPIXEL (BITSPERPIXEL (COLORSCREENBITMAP)))
(COND
((EQ BITSPERPIXEL 4)
(OR MOTIONMAP (SETQ MOTIONMAP (COLORMAPCREATE MOTIONMAPCOLORS BITSPERPIXEL)))
(OR PRETTYMAP (SETQ PRETTYMAP (COLORMAPCREATE PRETTYCOLORS BITSPERPIXEL)))
(SETQ WAITTIME 70))
(T (OR MOTIONMAP
(SETQ MOTIONMAP
(COLORMAPCREATE (for I from 1 to 8
join (NCONC (for J from 0 to 255 by 8
collect (LIST 0 0 J))
(for J from 1 to 8
collect (QUOTE (128 128 128)))))
BITSPERPIXEL)))
(OR PRETTYMAP (SETQ PRETTYMAP (RAINBOWMAP 8)))
(SETQ WAITTIME 20)))
(SCREENCOLORMAP MOTIONMAP)
(CD.QUITP 40)
(until (CD.QUITP) do (ROTATECOLORMAP 1))
(SCREENCOLORMAP PRETTYMAP)
(CD.QUITP 40)
(until (CD.QUITP) do (ROTATECOLORMAP 1)
(DISMISS WAITTIME)))))
)
(DEFINEQ
(BLACKHOLE
(LAMBDA (PTLST DS DENSITY PERCENT) (* kbr: " 5-Jun-86 23:45")
(* maps a list of points onto itself
repeatedly until closure)
(PROG NIL
(DSPFILL NIL NIL 0 DS)
(BLACKHOLE1 PTLST DS (OR DENSITY 3)
(OR PERCENT 30)))))
(BLACKHOLE1
(LAMBDA (PTLST DS DENSITY PERCENT) (* kbr: " 5-Jun-86 23:46")
(* maps a list of points onto itself
repeatedly until closure)
(PROG (CENTERX CENTERY X Y OTHERPTS)
(SETQ CENTERX (IQUOTIENT (for PT in PTLST sum (fetch (POSITION XCOORD) of PT))
(LENGTH PTLST)))
(SETQ CENTERY (IQUOTIENT (for PT in PTLST sum (fetch (POSITION YCOORD) of PT))
(LENGTH PTLST))) (* make another polygon that is 80%%
of the way to the edge.)
(SETQ OTHERPTS (for PT in PTLST
collect (create POSITION
XCOORD _ (COND
((IGREATERP (SETQ X (fetch (POSITION XCOORD)
of PT))
CENTERX)
(IPLUS CENTERX (IQUOTIENT (ITIMES
PERCENT
(IDIFFERENCE
X CENTERX))
100)))
(T (IDIFFERENCE CENTERX
(IQUOTIENT (ITIMES PERCENT
(IDIFFERENCE
CENTERX X))
100))))
YCOORD _ (COND
((IGREATERP (SETQ Y (fetch (POSITION YCOORD)
of PT))
CENTERY)
(IPLUS CENTERY (IQUOTIENT (ITIMES
PERCENT
(IDIFFERENCE
Y CENTERY))
100)))
(T (IDIFFERENCE CENTERY
(IQUOTIENT (ITIMES PERCENT
(IDIFFERENCE
CENTERY Y))
100)))))))
(* make sure the number of steps is
integral to number of colors.)
(* draw from the outer one into the
inner one, shifted by one)
(DRAWCOLORPOLYSTEPS PTLST (SETQ OTHERPTS (APPEND (CDR OTHERPTS)
(LIST (CAR OTHERPTS))))
(ITIMES (OR DENSITY 3)
15)
T 1 (MAXIMUMCOLOR)
DS)
(COND
((AND (for PT in OTHERPTS thereis (IGREATERP (ABS (IDIFFERENCE CENTERX
(fetch (POSITION XCOORD)
of PT)))
20))
(for PT in OTHERPTS thereis (IGREATERP (ABS (IDIFFERENCE CENTERY
(fetch (POSITION YCOORD)
of PT)))
20)))
(BLACKHOLE1 OTHERPTS DS (ADD1 DENSITY)
PERCENT))))))
(COLORCONNECTPOLYS
(LAMBDA (FROMS TOS NSTEPS CONNECTEDFLG INCOLOR? FROMCOLOR TOCOLOR TWEENCOLOR DS)
(* kbr: " 6-Jun-86 00:03")
(* draws the source and destination
polygons and shows the track taken by
the sides; then leaves the trace of
the polygon in tranformation)
(SETQ LASTPOLYGONFROMS FROMS)
(SETQ LASTPOLYGONTOS TOS)
(ERSETQ (PROG NIL
(DSPFILL NIL NIL NIL DS)
(COLORDRAWPOLY1 FROMS 1 CONNECTEDFLG (OR FROMCOLOR INCOLOR?)
DS)
(COLORDRAWPOLY1 TOS 1 CONNECTEDFLG (OR TOCOLOR INCOLOR?)
DS)
(SETQ DIFFS (for FPT in FROMS as TPT in TOS
do (DRAWBETWEEN FPT TPT 1 NIL DS (OR TWEENCOLOR 15))))
(DISMISS 1500)
(DSPFILL NIL NIL NIL DS)
(DRAWCOLORPOLYSTEPS FROMS TOS NSTEPS CONNECTEDFLG INCOLOR? TOCOLOR DS)))))
(COLORDRAWPOLY1
(LAMBDA (PTLIST WIDTH CONNECT? COLOR DS) (* rrb "11-OCT-82 11:43")
(* draws a closed polygon of the
points given)
(COND
(PTLIST (for PTA in PTLIST as PTB in (CDR PTLIST)
do (DRAWBETWEEN PTA PTB WIDTH (DSPOPERATION NIL DS)
DS
(COND
((LISTP COLOR) (* COLOR can be a list of colors for
each side.)
(PROG1 (CAR COLOR)
(SETQ COLOR (COND
((CDR COLOR))
(T (CAR COLOR))))))
(T COLOR)))
finally (AND CONNECT? (DRAWBETWEEN (CAR (LAST PTLIST))
(CAR PTLIST)
WIDTH
(DSPOPERATION NIL DS)
DS
(COND
((LISTP COLOR)
(PROG1 (CAR COLOR)
(SETQ COLOR (COND
((CDR COLOR))
(T (CAR COLOR))))))
(T COLOR)))
DS))))
(BLOCK)))
(DRAWCOLORPOLYSTEPS
(LAMBDA (FROMS TOS NSTEPS CONNECTEDFLG FROMCOLOR MAXCOLOR DS)
(* rrb "15-OCT-82 14:47")
(PROG (DIFFS XFROMS)
(SETQ XFROMS (COPY FROMS))
(SETQ DIFFS (for FPT in XFROMS as TPT in TOS collect (create POSITION
XCOORD _
(IDIFFERENCE
(fetch (POSITION XCOORD)
of TPT)
(fetch (POSITION XCOORD)
of FPT))
YCOORD _
(IDIFFERENCE
(fetch (POSITION YCOORD)
of TPT)
(fetch (POSITION YCOORD)
of FPT)))))
(for I from 1 to NSTEPS
do (COLORDRAWPOLY1 XFROMS 1 CONNECTEDFLG (COND
((FIXP FROMCOLOR)
(COND
((IGREATERP FROMCOLOR MAXCOLOR)
(SETQ FROMCOLOR 1)))
(PROG1 FROMCOLOR (SETQ FROMCOLOR
(ADD1 FROMCOLOR))))
(T FROMCOLOR))
DS)
(for PT in XFROMS as DIF in DIFFS as FROMPT in FROMS
do (replace (POSITION XCOORD) of PT
with (IPLUS (fetch (POSITION XCOORD) of FROMPT)
(IQUOTIENT (ITIMES (fetch (POSITION XCOORD) of DIF)
I)
NSTEPS)))
(replace (POSITION YCOORD) of PT
with (IPLUS (fetch (POSITION YCOORD) of FROMPT)
(IQUOTIENT (ITIMES (fetch (POSITION YCOORD) of DIF)
I)
NSTEPS)))) finally (COLORDRAWPOLY1
XFROMS 1 CONNECTEDFLG
(COND
((FIXP FROMCOLOR)
(COND
((IGREATERP FROMCOLOR MAXCOLOR
)
(SETQ FROMCOLOR 1)))
(PROG1 FROMCOLOR (SETQ FROMCOLOR
(ADD1 FROMCOLOR
))))
(T FROMCOLOR))
DS))
(RETURN FROMCOLOR))))
(LENSE
(LAMBDA (PTLST DS DENSITY PERCENT OUTTOOFLG) (* kbr: " 5-Jun-86 23:52")
(* maps a list of points onto itself
repeatedly until closure)
(PROG (CENTERX CENTERY X Y OTHERPTS MAXCOLOR ENDCOLOR)
(SETQ CENTERX (IQUOTIENT (for PT in PTLST sum (fetch (POSITION XCOORD) of PT))
(LENGTH PTLST)))
(SETQ CENTERY (IQUOTIENT (for PT in PTLST sum (fetch (POSITION YCOORD) of PT))
(LENGTH PTLST)))
(SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL (COLORSCREENBITMAP))))
(DSPFILL NIL NIL NIL DS) (* make another polygon that is 80%%
of the way to the edge.)
(SETQ OTHERPTS (for PT in PTLST
collect (create POSITION
XCOORD _ (COND
((IGREATERP (SETQ X (fetch (POSITION XCOORD)
of PT))
CENTERX)
(IPLUS CENTERX (IQUOTIENT (ITIMES
PERCENT
(IDIFFERENCE
X CENTERX))
100)))
(T (IDIFFERENCE CENTERX
(IQUOTIENT (ITIMES PERCENT
(IDIFFERENCE
CENTERX X))
100))))
YCOORD _ (COND
((IGREATERP (SETQ Y (fetch (POSITION YCOORD)
of PT))
CENTERY)
(IPLUS CENTERY (IQUOTIENT (ITIMES
PERCENT
(IDIFFERENCE
Y CENTERY))
100)))
(T (IDIFFERENCE CENTERY
(IQUOTIENT (ITIMES PERCENT
(IDIFFERENCE
CENTERY Y))
100)))))))
(* make sure the number of steps is
integral to number of colors.)
(* draw from the outer one into the
inner one, shifted by one)
(SETQ ENDCOLOR (DRAWCOLORPOLYSTEPS PTLST (CONS (CAR (LAST OTHERPTS))
(BUTLAST OTHERPTS))
(ITIMES (OR DENSITY 3)
15)
T 1 MAXCOLOR DS)) (* draw from the inner polygon to the
outer one shifted by two sides)
(AND OUTTOOFLG (DRAWCOLORPOLYSTEPS (APPEND (CDR OTHERPTS)
(LIST (CAR OTHERPTS)))
PTLST
(ITIMES (OR DENSITY 3)
15)
T ENDCOLOR MAXCOLOR DS)))))
(LINETEST
(LAMBDA (DS)
(for Y from 100 to 400 by 300 do (for I from 100 to 400 by 20
do (DRAWLINE 250 250 I Y 1 NIL DS (RAND 1 15))))
(for X from 100 to 400 by 300 do (for I from 100 to 400 by 20
do (DRAWLINE 250 250 X I 1 NIL DS (RAND 1 15))))))
(MAPIT
(LAMBDA (PTLST DS DENSITY) (* kbr: " 5-Jun-86 23:52")
(* maps a list of points onto itself)
(DSPFILL NIL NIL NIL DS)
(DRAWCOLORPOLYSTEPS PTLST (SETQ PTLST (APPEND (CDR PTLST)
(CONS (CAR PTLST))))
(ITIMES (OR DENSITY 3)
15)
T 1 (MAXIMUMCOLOR (BITSPERPIXEL (COLORSCREENBITMAP)))
DS)))
(MAPIT2
(LAMBDA (N DS DENSITY) (* kbr: " 5-Jun-86 23:53")
(* create a random list of N points
and maps it onto N others.)
(PROG (ORGPOINTS NOWCOLOR MAXCOLOR)
(SETQ ORGPOINTS (for I from 1 to N collect (RANDOMPT DS)))
(SETQ NOWCOLOR 1)
(SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL (COLORSCREENBITMAP))))
(DSPFILL NIL NIL NIL DS)
(SETQ STARTPTS ORGPOINTS) (* make sure the number of steps is
integral to number of colors.)
(for COUNTER from 1 to N
do (* make the first pt of the new set
the same as the last pt of the
previous one.)
(SETQ NEWPTS (COND
((EQ COUNTER N) (* for the past group, return to the
starting points.)
ORGPOINTS)
(T (CONS (CAR (LAST STARTPTS))
(COND
((EQ COUNTER (SUB1 N))
(* for next to last group make the
last point the same as the start.)
(NCONC1 (for I from 1 to (IDIFFERENCE N 2)
collect (RANDOMPT DS))
(CAR ORGPOINTS)))
(T (for I from 1 to (SUB1 N) collect (RANDOMPT DS))))))))
(SETQ NOWCOLOR (DRAWCOLORPOLYSTEPS STARTPTS NEWPTS (ITIMES (OR DENSITY 3)
15)
NIL NOWCOLOR MAXCOLOR DS))
(SETQ STARTPTS NEWPTS)))))
(MOTIONIT
(LAMBDA (WINDOW) (* kbr: " 3-Sep-86 22:06")
(PROG NIL
LP (SCREENCOLORMAP ONEMAP)
(ONECOLORPOLY (RAND 3 4)
45 T 1 1 15 8 WINDOW)
(DISMISS 2000)
(SCREENCOLORMAP MOTIONMAP)
(CD.QUITP 10)
(until (CD.QUITP) do (ROTATECOLORMAP 1)
(DISMISS 75))
(SCREENCOLORMAP PRETTYMAP)
(CD.QUITP 20)
(until (CD.QUITP) do (ROTATECOLORMAP 1)
(DISMISS 75))
(SCREENCOLORMAP ONEMAP)
(DISMISS 2000)
(GO LP))))
(ONECOLORPOLY
(LAMBDA (NPOINTS NSTEPS CONNECTED? INCOLOR? FROMCOLOR TOCOLOR TWEENCOLOR DS)
(* rrb "11-OCT-82 11:41")
(* draws a polygon figure on the display stream DS.
INCOLOR? can be NIL for black and white case, a color number for the increment
each polygons case, or a list of color numbers to be used for each edge of the
polygons.)
(COLORCONNECTPOLYS (for I from 1 to NPOINTS collect (RANDOMPT DS))
(for I from 1 to NPOINTS collect (RANDOMPT DS))
(OR NSTEPS POLYGONSTEPS)
CONNECTED? INCOLOR? TOCOLOR FROMCOLOR TWEENCOLOR DS)))
(RANDOMPT
(LAMBDA (DS) (* kbr: " 6-Jun-86 00:01")
(PROG (REG)
(SETQ REG (DSPCLIPPINGREGION NIL DS))
(RETURN (create POSITION
XCOORD _ (RAND (fetch (REGION LEFT) of REG)
(fetch (REGION RIGHT) of REG))
YCOORD _ (RAND (fetch (REGION BOTTOM) of REG)
(fetch (REGION TOP) of REG)))))))
)
(RPAQ? MOTIONMAP )
(RPAQ? ONEMAP )
(RPAQ? PRETTYMAP )
(RPAQQ MOTIONMAPCOLORS ((0 0 0)
(0 0 0)
(0 0 0)
(0 0 0)
(0 0 0)
(0 0 0)
(0 0 0)
(0 0 79)
(0 0 126)
(0 0 168)
(0 0 199)
(0 0 255)
(0 0 0)
(0 0 0)
(0 0 0)
(0 0 0)))
(RPAQQ ONEMAPCOLORS ((100 100 100)
(255 0 0)
(255 0 0)
(255 0 0)
(255 0 0)
(255 0 0)
(255 0 0)
(255 0 0)
(255 0 0)
(255 0 0)
(255 0 0)
(255 0 0)
(255 0 0)
(255 0 0)
(255 0 0)
(255 0 0)))
(RPAQQ PRETTYCOLORS ((0 0 0)
(255 0 0)
(255 206 0)
(255 255 0)
(128 255 0)
(0 255 0)
(0 255 128)
(0 255 255)
(0 128 255)
(0 0 255)
(128 0 255)
(255 0 255)
(255 128 255)
(217 210 195)
(160 172 180)
(203 161 75)))
(PUTPROPS COLORPOLYGONS COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (876 3221 (COLORPOLYGONS 886 . 1403) (COLORPOLYGON 1405 . 1808) (
COLORPOLYGONS.ROTATECOLORMAP 1810 . 3219)) (3222 25720 (BLACKHOLE 3232 . 3670) (BLACKHOLE1 3672 . 8507
) (COLORCONNECTPOLYS 8509 . 9805) (COLORDRAWPOLY1 9807 . 11661) (DRAWCOLORPOLYSTEPS 11663 . 15717) (
LENSE 15719 . 20419) (LINETEST 20421 . 20841) (MAPIT 20843 . 21355) (MAPIT2 21357 . 23757) (MOTIONIT
23759 . 24427) (ONECOLORPOLY 24429 . 25187) (RANDOMPT 25189 . 25718)))))
STOP