/[cmucl]/src/contrib/demos/demos.lisp
ViewVC logotype

Contents of /src/contrib/demos/demos.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Fri Apr 2 04:15:28 2004 UTC (10 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2004-10, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, unicode-utf16-sync-2008-12, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, merge-sse2-packed, mod-arith-base, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, RELEASE_20b, snapshot-2008-04, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.2: +1 -1 lines
Fix typo:  6.4 should be (* pi 2)

From Fred Gilham, via cmucl-imp, 2004-04-01
1 ;;; -*- Mode: Lisp; Package: Demos -*-
2 ;;;
3 ;;; This file contains various graphics hacks written and ported over the
4 ;;; years by various and numerous persons.
5 ;;;
6 ;;; This file should be portable to any valid Common Lisp with CLX -- DEC 88.
7 ;;;
8 ;;; CMUCL MP support by Douglas Crosher 1998.
9 ;;; Enhancements including the CLX menu, rewrite of the greynetic
10 ;;; demo, and other fixes by Fred Gilham 1998.
11 ;;;
12 ;;; To run first compile and load menu.lisp, then after compiling and
13 ;;; loading this file run (demos:demo) to create a menu of demos.
14 ;;;
15
16 (eval-when (compile load eval)
17 (defpackage "DEMOS"
18 (:use "COMMON-LISP")
19 (:export "DO-ALL-DEMOS" "DEMO" "BOUNCING-BALL-DEMO" "BOUNCE-DEMO"
20 "FAST-HANOI-DEMO" "GREYNETIC-DEMO" "PETAL-DEMO" "PLAID-DEMO"
21 "QIX-DEMO" "RECURRENCE-DEMO" "SHOVE-BOUNCE-DEMO"
22 "SLOW-HANOI-DEMO")))
23
24 (in-package "DEMOS")
25
26
27 ;;;; Graphic demos wrapper macro.
28
29 ;;; This wrapper macro should be reconsidered with respect to its property
30 ;;; list usage. Possibly a demo structure should be used with *demos*
31 ;;; pointing to these instead of function names. Also, something should
32 ;;; be done about a title window that displays the name of the demo while
33 ;;; it is running.
34
35 (defparameter *demos* nil)
36
37 (defvar *display* nil)
38 (defvar *screen* nil)
39 (defvar *root* nil)
40 (defvar *black-pixel* nil)
41 (defvar *white-pixel* nil)
42 (defvar *window* nil)
43
44 ;;; Machine-dependent; should calibrate this on the fly.
45 ;;; Set it to zero to have the demos go too fast.
46 (defvar *delay* .01)
47
48 (defun wait-for-mapping (display win)
49 (xlib:display-finish-output display)
50 (multiple-value-bind (width height x y mapped) (full-window-state win)
51 (declare (ignore width height x y))
52 (if (eq mapped :viewable)
53 t
54 (wait-for-mapping display win))))
55
56 (defun wait-for-unmapping (display win)
57 (xlib:display-finish-output display)
58 (multiple-value-bind (width height x y mapped) (full-window-state win)
59 (declare (ignore width height x y))
60 (if (eq mapped :unmapped)
61 t
62 (wait-for-unmapping display win))))
63
64 (defmacro defdemo (fun-name demo-name args x y width height doc &rest forms)
65 `(progn
66 (defun ,fun-name ,args
67 ,doc
68 (unless *display*
69 #+:cmu
70 (multiple-value-setq (*display* *screen*) (ext:open-clx-display))
71 #-:cmu
72 (progn
73 ;; Portable method
74 (setf *display* (xlib:open-display (machine-instance)))
75 (setf *screen* (xlib:display-default-screen *display*)))
76 (setf *root* (xlib:screen-root *screen*))
77 (setf *black-pixel* (xlib:screen-black-pixel *screen*))
78 (setf *white-pixel* (xlib:screen-white-pixel *screen*)))
79 (let ((*window* (xlib:create-window :parent *root*
80 :x ,x :y ,y
81 :event-mask '(:visibility-change)
82 :width ,width :height ,height
83 :background *black-pixel*
84 :border *white-pixel*
85 :border-width 2
86 ;:override-redirect :on
87 )))
88 (xlib:set-wm-properties *window*
89 :name ,demo-name
90 :icon-name ,demo-name
91 :resource-name ,demo-name
92 :x ,x :y ,y :width ,width :height ,height
93 :user-specified-position-p t
94 :user-specified-size-p t
95 :min-width ,width :min-height ,height
96 :width-inc nil :height-inc nil)
97 (xlib:map-window *window*)
98 ;; Wait until we get mapped before doing anything.
99 (wait-for-mapping *display* *window*)
100 (unwind-protect
101 (progn ,@forms)
102 (xlib:unmap-window *window*)
103 (wait-for-unmapping *display* *window*))))
104 (setf (get ',fun-name 'demo-name) ',demo-name)
105 (setf (get ',fun-name 'demo-doc) ',doc)
106 (export ',fun-name)
107 (pushnew ',fun-name *demos*)
108 ',fun-name))
109
110
111 ;;;; Main entry points.
112
113 (defun do-all-demos ()
114 (dolist (demo *demos*)
115 (funcall demo)
116 (sleep 3)))
117
118 ;;; DEMO
119
120 (defvar *name-to-function* (make-hash-table :test #'eq))
121 (defvar *keyword-package* (find-package "KEYWORD"))
122 (defvar *demo-names* nil)
123
124 (defun demo-chooser ()
125 (let ((*demo-names* '("Quit")))
126 (dolist (d *demos*)
127 (setf (gethash (intern (string-upcase (get d 'demo-name))
128 *keyword-package*)
129 *name-to-function*)
130 d)
131 (push (get d 'demo-name) *demo-names*))
132
133 (multiple-value-bind (display screen) (ext:open-clx-display)
134 (let* ((fg-color (xlib:screen-white-pixel screen))
135 (bg-color (xlib:screen-black-pixel screen))
136 (nice-font (xlib:open-font display "fixed")))
137
138 (let ((a-menu (xlib::create-menu
139 (xlib::screen-root screen) ;the menu's parent
140 fg-color bg-color nice-font)))
141
142 (setf (xlib::menu-title a-menu) "Please pick your favorite demo:")
143 (xlib::menu-set-item-list a-menu *demo-names*)
144 (unwind-protect
145 (do (choice)
146 ((and (setf choice (xlib::menu-choose a-menu 100 100))
147 (string-equal "Quit" choice)))
148 (let* ((demo-choice (intern (string-upcase choice)
149 *keyword-package*))
150 (fun (gethash demo-choice *name-to-function*)))
151 (setf choice nil)
152 (when fun
153 #-mp (funcall fun)
154 #+mp (mp:make-process #'(lambda ()
155 (funcall fun))
156 :name (format nil "~S"
157 demo-choice)))))
158 (xlib::close-display display)))))))
159
160 #-mp
161 (defun demo ()
162 (demo-chooser))
163
164 ;;; Example of how the multi-process support can be setup for use
165 ;;; with CLX.
166 #+mp
167 (defun demo ()
168 ;; Set the event server timeout so that an interactive process
169 ;; can act as the idle loop.
170 (setf lisp::*max-event-to-sec* 0)
171 (setf lisp::*max-event-to-usec* 10000)
172 ;;
173 ;; Start a background SIGALRM driven process-yield. This is
174 ;; currently not safe in CMUCL but almost works.
175 ;(mp::start-sigalrm-yield 0 250000)
176 ;;
177 ;; Setup the initial process as the idle process.
178 (setf mp::*idle-process* mp::*initial-process*)
179 ;;
180 ;; Startup a process to run the menu.
181 (mp:make-process #'demo-chooser :name "Demos Menu")
182 ;; Can start multiple demo menus.
183 (mp:make-process #'demo-chooser :name "Demos Menu")
184 ;;
185 ;; Optionally start the idle-process-loop which will better time any
186 ;; process sleeping.
187 (setf mp::*idle-loop-timeout* 0.010d0)
188 (mp::idle-process-loop))
189
190
191
192 ;;;; Shared demo utilities.
193
194 (defun full-window-state (w)
195 (xlib:with-state (w)
196 (values (xlib:drawable-width w) (xlib:drawable-height w)
197 (xlib:drawable-x w) (xlib:drawable-y w)
198 (xlib:window-map-state w))))
199
200
201 ;;;; Greynetic.
202
203 (defun make-random-bitmap ()
204 (let ((bitmap-data (make-array '(32 32) :initial-element 0
205 :element-type 'xlib::bit)))
206 (dotimes (i 4)
207 (declare (fixnum i))
208 (let ((nibble (random 16)))
209 (setf nibble (logior nibble (ash nibble 4))
210 nibble (logior nibble (ash nibble 8))
211 nibble (logior nibble (ash nibble 12))
212 nibble (logior nibble (ash nibble 16)))
213 (dotimes (j 32)
214 (let ((bit (if (logbitp j nibble) 1 0)))
215 (setf (aref bitmap-data i j) bit
216 (aref bitmap-data (+ 4 i) j) bit
217 (aref bitmap-data (+ 8 i) j) bit
218 (aref bitmap-data (+ 12 i) j) bit
219 (aref bitmap-data (+ 16 i) j) bit
220 (aref bitmap-data (+ 20 i) j) bit
221 (aref bitmap-data (+ 24 i) j) bit
222 (aref bitmap-data (+ 28 i) j) bit)))))
223 bitmap-data))
224
225
226 (defun make-random-pixmap ()
227 (let ((image (xlib:create-image :depth 1 :data (make-random-bitmap))))
228 (make-pixmap image 32 32)))
229
230 (defvar *pixmaps* nil)
231
232 (defun make-pixmap (image width height)
233 (let* ((pixmap (xlib:create-pixmap :width width :height height
234 :depth 1 :drawable *root*))
235 (gc (xlib:create-gcontext :drawable pixmap
236 :background *black-pixel*
237 :foreground *white-pixel*)))
238 (xlib:put-image pixmap gc image :x 0 :y 0 :width width :height height)
239 (xlib:free-gcontext gc)
240 pixmap))
241
242
243 ;;;
244 ;;; This function returns one of the pixmaps in the *pixmaps* array.
245 (defun greynetic-pixmapper ()
246 (aref *pixmaps* (random (length *pixmaps*))))
247
248
249 (defun greynetic (window duration)
250 (let* ((depth (xlib:drawable-depth window))
251 (draw-gcontext (xlib:create-gcontext :drawable window
252 :foreground *white-pixel*
253 :background *black-pixel*))
254 ;; Need a random state per process.
255 (*random-state* (make-random-state t))
256 (*pixmaps* (let ((pixmap-array (make-array 30)))
257 (dotimes (i 30)
258 (setf (aref pixmap-array i) (make-random-pixmap)))
259 pixmap-array)))
260
261 (unwind-protect
262 (multiple-value-bind (width height) (full-window-state window)
263 (declare (fixnum width height))
264 (let ((border-x (truncate width 20))
265 (border-y (truncate height 20)))
266 (declare (fixnum border-x border-y))
267 (dotimes (i duration)
268 (let ((pixmap (greynetic-pixmapper)))
269 (xlib:with-gcontext (draw-gcontext
270 :foreground (random (ash 1 depth))
271 :background (random (ash 1 depth))
272 :stipple pixmap
273 :fill-style
274 :opaque-stippled)
275 (cond ((zerop (mod i 500))
276 (xlib:clear-area window)
277 (sleep .1))
278 (t
279 (sleep *delay*)))
280 (if (< (random 3) 2)
281 (let* ((w (+ border-x
282 (truncate (* (random (- width
283 (* 2 border-x)))
284 (random width)) width)))
285 (h (+ border-y
286 (truncate (* (random (- height
287 (* 2 border-y)))
288 (random height)) height)))
289 (x (random (- width w)))
290 (y (random (- height h))))
291 (declare (fixnum w h x y))
292 (if (zerop (random 2))
293 (xlib:draw-rectangle window draw-gcontext
294 x y w h t)
295 (xlib:draw-arc window draw-gcontext
296 x y w h 0 (* 2 pi) t)))
297 (let ((p1-x (+ border-x
298 (random (- width (* 2 border-x)))))
299 (p1-y (+ border-y
300 (random (- height (* 2 border-y)))))
301 (p2-x (+ border-x
302 (random (- width (* 2 border-x)))))
303 (p2-y (+ border-y
304 (random (- height (* 2 border-y)))))
305 (p3-x (+ border-x
306 (random (- width (* 2 border-x)))))
307 (p3-y (+ border-y
308 (random (- height (* 2 border-y))))))
309 (declare (fixnum p1-x p1-y p2-x p2-y p3-x p3-y))
310 (xlib:draw-lines window draw-gcontext
311 (list p1-x p1-y p2-x p2-y p3-x p3-y)
312 :relative-p nil
313 :fill-p t
314 :shape :convex)))
315 (xlib:display-force-output *display*))))))
316 (dotimes (i (length *pixmaps*))
317 (xlib:free-pixmap (aref *pixmaps* i)))
318 (xlib:free-gcontext draw-gcontext))))
319
320
321 (defdemo greynetic-demo "Greynetic" (&optional (duration 3000))
322 100 100 600 600
323 "Displays random grey rectangles."
324 (greynetic *window* duration))
325
326
327 ;;;; Qix.
328
329 (defstruct qix
330 buffer
331 (dx1 5)
332 (dy1 10)
333 (dx2 10)
334 (dy2 5))
335
336 (defun construct-qix (length)
337 (let ((qix (make-qix)))
338 (setf (qix-buffer qix) (make-circular-list length))
339 qix))
340
341 (defun make-circular-list (length)
342 (let ((l (make-list length)))
343 (rplacd (last l) l)))
344
345
346 (defun qix (window lengths duration)
347 "Each length is the number of lines to put in a qix, and that many qix
348 (of the correct size) are put up on the screen. Lets the qix wander around
349 the screen for Duration steps."
350 (let ((histories (mapcar #'construct-qix lengths))
351 (depth (xlib:drawable-depth window))
352 (*random-state* (make-random-state t)))
353 (multiple-value-bind (width height) (full-window-state window)
354 (declare (fixnum width height))
355 (xlib:clear-area window)
356 (xlib:display-force-output *display*)
357 (do ((h histories (cdr h))
358 (l lengths (cdr l)))
359 ((null h))
360 (do ((x (qix-buffer (car h)) (cdr x))
361 (i 0 (1+ i)))
362 ((= i (car l)))
363 (rplaca x (make-array 5))))
364 ;; Start each qix at a random spot on the screen.
365 (dolist (h histories)
366 (let ((x (random width))
367 (y (random height)))
368 (rplaca (qix-buffer h)
369 (make-array 5 :initial-contents (list x y x y -1)))))
370 (rplacd (last histories) histories)
371 (let* ((x1 0) (y1 0) (x2 0) (y2 0)
372 (dx1 0) (dy1 0) (dx2 0) (dy2 0)
373 tem line next-line qix
374 (gc (xlib:create-gcontext :drawable window
375 :background *black-pixel*
376 :line-width 0 :line-style :solid
377 :function boole-xor)))
378 (declare (fixnum x1 y1 x2 y2 dx1 dy1 dx2 dy2))
379 (dotimes (i duration)
380 ;; Line is the next line in the next qix. Rotate this qix and
381 ;; the qix ring.
382 (setq qix (car histories))
383 (setq line (car (qix-buffer qix)))
384 (setq next-line (cadr (qix-buffer qix)))
385 (setf (qix-buffer qix) (cdr (qix-buffer qix)))
386 (setq histories (cdr histories))
387 (setf x1 (svref line 0))
388 (setf y1 (svref line 1))
389 (setf x2 (svref line 2))
390 (setf y2 (svref line 3))
391 (setf (xlib:gcontext-foreground gc) (svref line 4))
392 (setf (xlib:gcontext-function gc) boole-xor)
393 (xlib:draw-line window gc x1 y1 x2 y2)
394 (setq dx1 (- (+ (qix-dx1 qix) (random 3)) 1))
395 (setq dy1 (- (+ (qix-dy1 qix) (random 3)) 1))
396 (setq dx2 (- (+ (qix-dx2 qix) (random 3)) 1))
397 (setq dy2 (- (+ (qix-dy2 qix) (random 3)) 1))
398 (cond ((> dx1 10) (setq dx1 10))
399 ((< dx1 -10) (setq dx1 -10)))
400 (cond ((> dy1 10) (setq dy1 10))
401 ((< dy1 -10) (setq dy1 -10)))
402 (cond ((> dx2 10) (setq dx2 10))
403 ((< dx2 -10) (setq dx2 -10)))
404 (cond ((> dy2 10) (setq dy2 10))
405 ((< dy2 -10) (setq dy2 -10)))
406 (cond ((or (>= (setq tem (+ x1 dx1)) width) (minusp tem))
407 (setq dx1 (- dx1))))
408 (cond ((or (>= (setq tem (+ x2 dx2)) width) (minusp tem))
409 (setq dx2 (- dx2))))
410 (cond ((or (>= (setq tem (+ y1 dy1)) height) (minusp tem))
411 (setq dy1 (- dy1))))
412 (cond ((or (>= (setq tem (+ y2 dy2)) height) (minusp tem))
413 (setq dy2 (- dy2))))
414 (setf (qix-dy2 qix) dy2)
415 (setf (qix-dx2 qix) dx2)
416 (setf (qix-dy1 qix) dy1)
417 (setf (qix-dx1 qix) dx1)
418 (when (svref next-line 0)
419 (setf (xlib:gcontext-foreground gc) (svref next-line 4))
420 (xlib:draw-line window gc
421 (svref next-line 0) (svref next-line 1)
422 (svref next-line 2) (svref next-line 3)))
423 (setf (svref next-line 0) (+ x1 dx1))
424 (setf (svref next-line 1) (+ y1 dy1))
425 (setf (svref next-line 2) (+ x2 dx2))
426 (setf (svref next-line 3) (+ y2 dy2))
427 (setf (svref next-line 4) (random (ash 1 depth)))
428 (sleep *delay*)
429 (xlib:display-force-output *display*))))))
430
431
432 (defdemo qix-demo "Qix" (&optional (lengths '(30 30 14 12 7)) (duration 2000))
433 0 0 700 700
434 "Hypnotic wandering lines."
435 (qix *window* lengths duration))
436
437
438
439 ;;;; Petal.
440
441 ;;; Fast sine constants:
442
443 (defconstant d360 #o5500)
444 (defconstant d270 #o4160)
445 (defconstant d180 #o2640)
446 (defconstant d90 #o1320)
447 (defconstant vecmax 2880)
448
449 (defconstant sin-array
450 '#(#o0 #o435 #o1073 #o1531 #o2166 #o2623 #o3260
451 #o3714 #o4350 #o5003 #o5435 #o6066 #o6516 #o7145
452 #o7573 #o10220 #o10644 #o11266 #o11706 #o12326
453 #o12743 #o13357 #o13771 #o14401 #o15007 #o15414
454 #o16016 #o16416 #o17013 #o17407 #o20000 #o20366
455 #o20752 #o21333 #o21711 #o22265 #o22636 #o23204
456 #o23546 #o24106 #o24443 #o24774 #o25323 #o25645
457 #o26165 #o26501 #o27011 #o27316 #o27617 #o30115
458 #o30406 #o30674 #o31156 #o31434 #o31706 #o32154
459 #o32416 #o32654 #o33106 #o33333 #o33554 #o33771
460 #o34202 #o34406 #o34605 #o35000 #o35167 #o35351
461 #o35526 #o35677 #o36043 #o36203 #o36336 #o36464
462 #o36605 #o36721 #o37031 #o37134 #o37231 #o37322
463 #o37407 #o37466 #o37540 #o37605 #o37646 #o37701
464 #o37730 #o37751 #o37766 #o37775 #o40000))
465
466 (defmacro psin (val)
467 `(let* ((val ,val)
468 neg
469 frac
470 sinlo)
471 (if (>= val d180)
472 (setq neg t
473 val (- val d180)))
474 (if (>= val d90)
475 (setq val (- d180 val)))
476 (setq frac (logand val 7))
477 (setq val (ash val -3))
478 ;;
479 (setq sinlo (if (>= val 90)
480 (svref sin-array 90)
481 (svref sin-array val)))
482 ;;
483 (if (< val 90)
484 (setq sinlo
485 (+ sinlo (ash (* frac (- (svref sin-array (1+ val)) sinlo))
486 -3))))
487 ;;
488 (if neg
489 (- sinlo)
490 sinlo)))
491
492 (defmacro pcos (x)
493 `(let ((tmp (- ,x d270)))
494 (psin (if (minusp tmp) (+ tmp d360) tmp))))
495
496
497 ;;;; Miscellaneous petal hackery.
498
499 (defmacro high-16bits-* (a b)
500 `(let ((a-h (ash ,a -8))
501 (b-h (ash ,b -8)))
502 (+ (* a-h b-h)
503 (ash (* a-h (logand ,b 255)) -8)
504 (ash (* b-h (logand ,a 255)) -8))))
505
506 (defun complete (style petal)
507 (let ((repnum 1)
508 factor cntval needed)
509 (dotimes (i 3)
510 (case i
511 (0 (setq factor 2 cntval 6))
512 (1 (setq factor 3 cntval 2))
513 (2 (setq factor 5 cntval 1)))
514 (do ()
515 ((or (minusp cntval) (not (zerop (rem style factor)))))
516 (setq repnum (* repnum factor))
517 (setq cntval (1- cntval))
518 (setq style (floor style factor))))
519 (setq needed (floor vecmax repnum))
520 (if (and (not (oddp needed)) (oddp petal)) (floor needed 2) needed)))
521
522
523 ;;;; Petal Parameters and Petal itself
524
525 (defparameter continuous t)
526 (defparameter styinc 7)
527 (defparameter petinc 1)
528 (defparameter scalfac-fac 8192)
529
530 (defun petal (petal-window &optional (how-many 10) (style 0) (petal 0))
531 (let ((width 800)
532 (height 800)
533 (depth (xlib:drawable-depth petal-window))
534 (*random-state* (make-random-state t)))
535 (xlib:clear-area petal-window)
536 (xlib:display-force-output *display*)
537 (let ((veccnt 0)
538 (nustyle 722)
539 (nupetal 3)
540 (scalfac (1+ (floor scalfac-fac (min width height))))
541 (ctrx (floor width 2))
542 (ctry (floor height 2))
543 (tt 0)
544 (s 0)
545 (lststyle 0)
546 (lstpetal 0)
547 (petstyle 0)
548 (vectors 0)
549 (r 0)
550 (x1 0)
551 (y1 0)
552 (x2 0)
553 (y2 0)
554 (i 0)
555 (gc (xlib:create-gcontext :drawable petal-window
556 :foreground *white-pixel*
557 :background *black-pixel*
558 :line-width 0 :line-style :solid)))
559 (loop
560 (when (zerop veccnt)
561 (setq tt 0 s 0 lststyle style lstpetal petal petal nupetal
562 style nustyle petstyle (rem (* petal style) d360)
563 vectors (complete style petal))
564 (when continuous
565 (setq nupetal (+ nupetal petinc)
566 nustyle (+ nustyle styinc)))
567 (when (or (/= lststyle style) (/= lstpetal petal))
568 (setf (xlib:gcontext-foreground gc)
569 (random (ash 1 depth)))
570 (xlib:clear-area petal-window)
571 (xlib:display-force-output *display*)))
572 (when (or (/= lststyle style) (/= lstpetal petal))
573 (setq veccnt (1+ veccnt) i veccnt x1 x2 y1 y2
574 tt (rem (+ tt style) d360)
575 s (rem (+ s petstyle) d360)
576 r (pcos s))
577 (setq x2 (+ ctrx (floor (high-16bits-* (pcos tt) r) scalfac))
578 y2 (+ ctry (floor (high-16bits-* (psin tt) r) scalfac)))
579 (when (/= i 1)
580 (xlib:draw-line petal-window gc x1 y1 x2 y2)
581 (xlib:display-force-output *display*)))
582 (when (> veccnt vectors)
583 (setq veccnt 0)
584 (setq how-many (1- how-many))
585 (sleep 2)
586 (when (zerop how-many) (return)))))))
587
588 (defdemo petal-demo "Petal" (&optional (how-many 10) (style 0) (petal 0))
589 100 100 800 800
590 "Flower-like display."
591 (petal *window* how-many style petal))
592
593
594 ;;;; Hanoi.
595
596 ;;; Random parameters:
597
598 (defparameter disk-thickness 15 "The thickness of a disk in pixels.")
599 (defparameter disk-spacing (+ disk-thickness 3)
600 "The amount of vertical space used by a disk on a needle.")
601 (defvar *horizontal-velocity* 30 "The speed at which disks slide sideways.")
602 (defvar *vertical-velocity* 24 "The speed at which disks move up and down.")
603
604 ;;; These variables are bound by the main function.
605
606 (defvar *hanoi-window* () "The window that Hanoi is happening on.")
607 (defvar *hanoi-window-height* () "The height of the viewport Hanoi is happening on.")
608 (defvar *transfer-height* () "The height at which disks are transferred.")
609 (defvar *hanoi-gcontext* () "The graphics context for Hanoi under X11.")
610
611 ;;; Needle Functions
612
613 (defstruct disk
614 size)
615
616 (defstruct needle
617 position
618 disk-stack)
619
620 ;;; Needle-Top-Height returns the height of the top disk on NEEDLE.
621
622 (defun needle-top-height (needle)
623 (- *hanoi-window-height*
624 (* disk-spacing (length (the list (needle-disk-stack needle))))))
625
626 (defvar available-disks
627 (do ((i 10 (+ i 10))
628 (dlist () (cons (make-disk :size i) dlist)))
629 ((> i 80) dlist)))
630
631 (defvar needle-1 (make-needle :position 184))
632 (defvar needle-2 (make-needle :position 382))
633 (defvar needle-3 (make-needle :position 584))
634
635 ;;; Graphic interface abstraction:
636
637 ;;; Invert-Rectangle calls the CLX function draw-rectangle with "fill-p"
638 ;;; set to T. Update-Screen forces the display output.
639 ;;;
640 (defmacro invert-rectangle (x y height width)
641 `(xlib:draw-rectangle *hanoi-window* *hanoi-gcontext*
642 ,x ,y ,width ,height t))
643
644 (defun update-screen ()
645 (xlib:display-force-output *display*)
646 (sleep *delay*))
647
648
649 ;;;; Moving disks up and down
650
651 ;;; Slide-Up slides the image of a disk up from the coordinates X,
652 ;;; START-Y to the point X, END-Y. DISK-SIZE is the size of the disk to
653 ;;; move. START-Y must be greater than END-Y
654
655 (defun slide-up (start-y end-y x disk-size)
656 (multiple-value-bind (number-moves pixels-left)
657 (truncate (- start-y end-y) *vertical-velocity*)
658 (do ((x (- x disk-size))
659 (width (* disk-size 2))
660 (old-y start-y (- old-y *vertical-velocity*))
661 (new-y (- start-y *vertical-velocity*) (- new-y *vertical-velocity*))
662 (number-moves number-moves (1- number-moves)))
663 ((zerop number-moves)
664 (when (plusp pixels-left)
665 (invert-rectangle x (- old-y pixels-left) disk-thickness width)
666 (invert-rectangle x old-y disk-thickness width)
667 (update-screen)))
668 ;; Loop body writes disk at new height & erases at old height.
669 (invert-rectangle x old-y disk-thickness width)
670 (invert-rectangle x new-y disk-thickness width)
671 (update-screen))))
672
673 ;;; Slide-Down slides the image of a disk down from the coordinates X,
674 ;;; START-Y to the point X, END-Y. DISK-SIZE is the size of the disk to
675 ;;; move. START-Y must be less than END-Y.
676
677 (defun slide-down (start-y end-y x disk-size)
678 (multiple-value-bind (number-moves pixels-left)
679 (truncate (- end-y start-y) *vertical-velocity*)
680 (do ((x (- x disk-size))
681 (width (* disk-size 2))
682 (old-y start-y (+ old-y *vertical-velocity*))
683 (new-y (+ start-y *vertical-velocity*) (+ new-y *vertical-velocity*))
684 (number-moves number-moves (1- number-moves)))
685 ((zerop number-moves)
686 (when (plusp pixels-left)
687 (invert-rectangle x (+ old-y pixels-left) disk-thickness width)
688 (invert-rectangle x old-y disk-thickness width)
689 (update-screen)))
690 ;; Loop body writes disk at new height & erases at old height.
691 (invert-rectangle X old-y disk-thickness width)
692 (invert-rectangle X new-y disk-thickness width)
693 (update-screen))))
694
695
696 ;;;; Lifting and Droping Disks
697
698 ;;; Lift-disk pops the top disk off of needle and raises it up to the
699 ;;; transfer height. The disk is returned.
700
701 (defun lift-disk (needle)
702 "Pops the top disk off of NEEDLE, Lifts it above the needle, & returns it."
703 (let* ((height (needle-top-height needle))
704 (disk (pop (needle-disk-stack needle))))
705 (slide-up height
706 *transfer-height*
707 (needle-position needle)
708 (disk-size disk))
709 disk))
710
711 ;;; Drop-disk drops a disk positioned over needle at the transfer height
712 ;;; onto needle. The disk is pushed onto needle.
713
714 (defun drop-disk (disk needle)
715 "DISK must be positioned above NEEDLE. It is dropped onto NEEDLE."
716 (push disk (needle-disk-stack needle))
717 (slide-down *transfer-height*
718 (needle-top-height needle)
719 (needle-position needle)
720 (disk-size disk))
721 t)
722
723
724 ;;; Drop-initial-disk is the same as drop-disk except that the disk is
725 ;;; drawn once before dropping.
726
727 (defun drop-initial-disk (disk needle)
728 "DISK must be positioned above NEEDLE. It is dropped onto NEEDLE."
729 (let* ((size (disk-size disk))
730 (lx (- (needle-position needle) size)))
731 (invert-rectangle lx *transfer-height* disk-thickness (* size 2))
732 (push disk (needle-disk-stack needle))
733 (slide-down *transfer-height*
734 (needle-top-height needle)
735 (needle-position needle)
736 (disk-size disk))
737 t))
738
739
740 ;;;; Sliding Disks Right and Left
741
742 ;;; Slide-Right slides the image of a disk located at START-X, Y to the
743 ;;; position END-X, Y. DISK-SIZE is the size of the disk. START-X is
744 ;;; less than END-X.
745
746 (defun slide-right (start-x end-x Y disk-size)
747 (multiple-value-bind (number-moves pixels-left)
748 (truncate (- end-x start-x) *horizontal-velocity*)
749 (do ((right-x (+ start-x disk-size) (+ right-x *horizontal-velocity*))
750 (left-x (- start-x disk-size) (+ left-x *horizontal-velocity*))
751 (number-moves number-moves (1- number-moves)))
752 ((zerop number-moves)
753 (when (plusp pixels-left)
754 (invert-rectangle right-x Y disk-thickness pixels-left)
755 (invert-rectangle left-x Y disk-thickness pixels-left)
756 (update-screen)))
757 ;; Loop body adds chunk *horizontal-velocity* pixels wide to right
758 ;; side of disk, then chops off left side.
759 (invert-rectangle right-x Y disk-thickness *horizontal-velocity*)
760 (invert-rectangle left-x Y disk-thickness *horizontal-velocity*)
761 (update-screen))))
762
763 ;;; Slide-Left is the same as Slide-Right except that START-X is greater
764 ;;; than END-X.
765
766 (defun slide-left (start-x end-x Y disk-size)
767 (multiple-value-bind (number-moves pixels-left)
768 (truncate (- start-x end-x) *horizontal-velocity*)
769 (do ((right-x (- (+ start-x disk-size) *horizontal-velocity*)
770 (- right-x *horizontal-velocity*))
771 (left-x (- (- start-x disk-size) *horizontal-velocity*)
772 (- left-x *horizontal-velocity*))
773 (number-moves number-moves (1- number-moves)))
774 ((zerop number-moves)
775 (when (plusp pixels-left)
776 (setq left-x (- (+ left-x *horizontal-velocity*) pixels-left))
777 (setq right-x (- (+ right-x *horizontal-velocity*) pixels-left))
778 (invert-rectangle left-x Y disk-thickness pixels-left)
779 (invert-rectangle right-x Y disk-thickness pixels-left)
780 (update-screen)))
781 ;; Loop body adds chunk *horizontal-velocity* pixels wide to left
782 ;; side of disk, then chops off right side.
783 (invert-rectangle left-x Y disk-thickness *horizontal-velocity*)
784 (invert-rectangle right-x Y disk-thickness *horizontal-velocity*)
785 (update-screen))))
786
787
788 ;;;; Transferring Disks
789
790 ;;; Transfer disk slides a disk at the transfer height from a position
791 ;;; over START-NEEDLE to a position over END-NEEDLE. Modified disk is
792 ;;; returned.
793
794 (defun transfer-disk (disk start-needle end-needle)
795 "Moves DISK from a position over START-NEEDLE to a position over END-NEEDLE."
796 (let ((start (needle-position start-needle))
797 (end (needle-position end-needle)))
798 (if (< start end)
799 (slide-right start end *transfer-height* (disk-size disk))
800 (slide-left start end *transfer-height* (disk-size disk)))
801 disk))
802
803
804 ;;; Move-One-Disk moves the top disk from START-NEEDLE to END-NEEDLE.
805
806 (defun move-one-disk (start-needle end-needle)
807 "Moves the disk on top of START-NEEDLE to the top of END-NEEDLE."
808 (drop-disk (transfer-disk (lift-disk start-needle)
809 start-needle
810 end-needle)
811 end-needle)
812 t)
813
814 ;;; Move-N-Disks moves the top N disks from START-NEEDLE to END-NEEDLE
815 ;;; obeying the rules of the towers of hannoi problem. To move the
816 ;;; disks, a third needle, TEMP-NEEDLE, is needed for temporary storage.
817
818 (defun move-n-disks (n start-needle end-needle temp-needle)
819 "Moves the top N disks from START-NEEDLE to END-NEEDLE.
820 Uses TEMP-NEEDLE for temporary storage."
821 (cond ((= n 1)
822 (move-one-disk start-needle end-needle))
823 (t
824 (move-n-disks (1- n) start-needle temp-needle end-needle)
825 (move-one-disk start-needle end-needle)
826 (move-n-disks (1- n) temp-needle end-needle start-needle)))
827 t)
828
829
830 ;;;; Hanoi itself.
831
832 (defun hanoi (window n)
833 (multiple-value-bind (width height) (full-window-state window)
834 (declare (ignore width))
835 (let* ((*hanoi-window* window)
836 (*hanoi-window-height* height)
837 (*transfer-height* (- height (* disk-spacing n)))
838 (*hanoi-gcontext* (xlib:create-gcontext :drawable *hanoi-window*
839 :foreground *white-pixel*
840 :background *black-pixel*
841 :fill-style :solid
842 :function boole-xor
843 )))
844 (xlib:clear-area *hanoi-window*)
845 (xlib:display-force-output *display*)
846 (let ((needle-1 (make-needle :position 184))
847 (needle-2 (make-needle :position 382))
848 (needle-3 (make-needle :position 584)))
849 (setf (needle-disk-stack needle-1) ())
850 (setf (needle-disk-stack needle-2) ())
851 (setf (needle-disk-stack needle-3) ())
852 (do ((n n (1- n))
853 (available-disks available-disks (cdr available-disks)))
854 ((zerop n))
855 (drop-initial-disk (car available-disks) needle-1))
856 (move-n-disks n needle-1 needle-3 needle-2)
857 t))))
858
859 ;;; Change the names of these when the DEMO loop isn't so stupid.
860 ;;;
861 (defdemo slow-hanoi-demo "Slow-towers-of-Hanoi" (&optional (how-many 4))
862 0 100 768 300
863 "Solves the Towers of Hanoi problem before your very eyes."
864 (let ((*horizontal-velocity* 3)
865 (*vertical-velocity* 1))
866 (hanoi *window* how-many)))
867 ;;;
868 (defdemo fast-hanoi-demo "Fast-towers-of-Hanoi" (&optional (how-many 7))
869 0 100 768 300
870 "Solves the Towers of Hanoi problem before your very eyes."
871 (hanoi *window* how-many))
872
873
874
875 ;;;; Bounce window.
876
877 ;;; BOUNCE-WINDOW takes a window and seemingly drops it to the bottom of
878 ;;; the screen. Optionally, the window can have an initial x velocity,
879 ;;; screen border elasticity, and gravity value. The outer loop is
880 ;;; entered the first time with the window at its initial height, but
881 ;;; each iteration after this, the loop starts with the window at the
882 ;;; bottom of the screen heading upward. The inner loop, except for the
883 ;;; first execution, carries the window up until the negative velocity
884 ;;; becomes positive, carrying the window down to bottom when the
885 ;;; velocity is positive. Due to number lossage, ROUND'ing and
886 ;;; TRUNC'ing when the velocity gets so small will cause the window to
887 ;;; head upward with the same velocity over two iterations which will
888 ;;; cause the window to bounce forever, so we have prev-neg-velocity and
889 ;;; number-problems to check for this. This is not crucial with the x
890 ;;; velocity since the loop terminates as a function of the y velocity.
891 ;;;
892 (defun bounce-window (window &optional
893 (x-velocity 0) (elasticity 0.85) (gravity 2))
894 (unless (< 0 elasticity 1)
895 (error "Elasticity must be between 0 and 1."))
896 (unless (plusp gravity)
897 (error "Gravity must be positive."))
898 (multiple-value-bind (width height x y mapped) (full-window-state window)
899 (when (eq mapped :viewable)
900 (let ((top-of-window-at-bottom (- (xlib:drawable-height *root*) height))
901 (left-of-window-at-right (- (xlib:drawable-width *root*) width))
902 (y-velocity 0)
903 (prev-neg-velocity most-negative-fixnum)
904 (number-problems nil))
905 (declare (fixnum top-of-window-at-bottom left-of-window-at-right
906 y-velocity))
907 (loop
908 (when (= prev-neg-velocity 0) (return t))
909 (let ((negative-velocity (minusp y-velocity)))
910 (loop
911 (let ((next-y (+ y y-velocity))
912 (next-y-velocity (+ y-velocity gravity)))
913 (declare (fixnum next-y next-y-velocity))
914 (when (> next-y top-of-window-at-bottom)
915 (cond
916 (number-problems
917 (setf y-velocity (incf prev-neg-velocity)))
918 (t
919 (setq y-velocity
920 (- (truncate (* elasticity y-velocity))))
921 (when (= y-velocity prev-neg-velocity)
922 (incf y-velocity)
923 (setf number-problems t))
924 (setf prev-neg-velocity y-velocity)))
925 (setf y top-of-window-at-bottom)
926 (setf (xlib:drawable-x window) x
927 (xlib:drawable-y window) y)
928 (xlib:display-force-output *display*)
929 (return))
930 (setq y-velocity next-y-velocity)
931 (setq y next-y))
932 (when (and negative-velocity (>= y-velocity 0))
933 (setf negative-velocity nil))
934 (let ((next-x (+ x x-velocity)))
935 (declare (fixnum next-x))
936 (when (or (> next-x left-of-window-at-right)
937 (< next-x 0))
938 (setq x-velocity (- (truncate (* elasticity x-velocity)))))
939 (setq x next-x))
940 (setf (xlib:drawable-x window) x
941 (xlib:drawable-y window) y)
942 (xlib:display-force-output *display*))))))))
943
944 ;;; Change the name of this when DEMO is not so stupid.
945 ;;;
946 (defdemo shove-bounce-demo "Shove-bounce" ()
947 100 100 300 300
948 "Drops the demo window with an inital X velocity which bounces off
949 screen borders."
950 (bounce-window *window* 30))
951
952 (defdemo bounce-demo "Bounce" ()
953 100 100 300 300
954 "Drops the demo window which bounces off screen borders."
955 (bounce-window *window*))
956
957
958 ;;;; Recurrence Demo
959
960 ;;; Copyright (C) 1988 Michael O. Newton (newton@csvax.caltech.edu)
961
962 ;;; Permission is granted to any individual or institution to use, copy,
963 ;;; modify, and distribute this software, provided that this complete
964 ;;; copyright and permission notice is maintained, intact, in all copies and
965 ;;; supporting documentation.
966
967 ;;; The author provides this software "as is" without express or
968 ;;; implied warranty.
969
970 ;;; This routine plots the recurrence
971 ;;; x <- y(1+sin(0.7x)) - 1.2(|x|)^.5
972 ;;; y <- .21 - x
973 ;;; As described in a ?? 1983 issue of the Mathematical Intelligencer
974
975 (defun recurrence (display window &optional (point-count 10000))
976 (let ((gc (xlib:create-gcontext :drawable window
977 :background *black-pixel*
978 :foreground *white-pixel*)))
979 (multiple-value-bind (width height) (full-window-state window)
980 (xlib:clear-area window)
981 (draw-ppict window gc point-count 0.0 0.0 (* width 0.5) (* height 0.5))
982 (xlib:display-force-output display)
983 (sleep *delay*))
984 (xlib:free-gcontext gc)))
985
986 ;;; Draw points. X assumes points are in the range of width x height,
987 ;;; with 0,0 being upper left and 0,H being lower left.
988 ;;; hw and hh are half-width and half-height of screen
989
990 (defun draw-ppict (win gc count x y hw hh)
991 "Recursively draw pretty picture"
992 (unless (zerop count)
993 (let ((xf (floor (* (+ 1.0 x) hw ))) ;These lines center the picture
994 (yf (floor (* (+ 0.7 y) hh ))))
995 (xlib:draw-point win gc xf yf)
996 (draw-ppict win gc (1- count)
997 (- (* y (1+ (sin (* 0.7 x)))) (* 1.2 (sqrt (abs x))))
998 (- 0.21 x)
999 hw
1000 hh))))
1001
1002 (defdemo recurrence-demo "Recurrence" ()
1003 10 10 700 700
1004 "Plots a cool recurrence relation."
1005 (recurrence *display* *window*))
1006
1007
1008 ;;;; Plaid
1009
1010 ;;;
1011 ;;; Translated from the X11 Plaid Demo written in C by Christopher Hoover.
1012 ;;;
1013
1014 (defmacro rect-x (rects n)
1015 `(svref ,rects (ash ,n 2)))
1016 (defmacro rect-y (rects n)
1017 `(svref ,rects (+ (ash ,n 2) 1)))
1018 (defmacro rect-width (rects n)
1019 `(svref ,rects (+ (ash ,n 2) 2)))
1020 (defmacro rect-height (rects n)
1021 `(svref ,rects (+ (ash ,n 2) 3)))
1022
1023 (defun plaid (display window &optional (num-iterations 10000) (num-rectangles 10))
1024 (let ((gcontext (xlib:create-gcontext :drawable window
1025 :function boole-c2
1026 :plane-mask (logxor *white-pixel*
1027 *black-pixel*)
1028 :background *black-pixel*
1029 :foreground *white-pixel*
1030 :fill-style :solid))
1031 (rectangles (make-array (* 4 num-rectangles)
1032 :element-type 'number
1033 :initial-element 0)))
1034 (multiple-value-bind (width height) (full-window-state window)
1035 (let ((center-x (ash width -1))
1036 (center-y (ash height -1))
1037 (x-dir -2)
1038 (y-dir -2)
1039 (x-off 2)
1040 (y-off 2))
1041 (dotimes (iter (truncate num-iterations num-rectangles))
1042 (dotimes (i num-rectangles)
1043 (setf (rect-x rectangles i) (- center-x x-off))
1044 (setf (rect-y rectangles i) (- center-y y-off))
1045 (setf (rect-width rectangles i) (ash x-off 1))
1046 (setf (rect-height rectangles i) (ash y-off 1))
1047 (incf x-off x-dir)
1048 (incf y-off y-dir)
1049 (when (or (<= x-off 0) (>= x-off center-x))
1050 (decf x-off (ash x-dir 1))
1051 (setf x-dir (- x-dir)))
1052 (when (or (<= y-off 0) (>= y-off center-y))
1053 (decf y-off (ash y-dir 1))
1054 (setf y-dir (- y-dir))))
1055 (xlib:draw-rectangles window gcontext rectangles t)
1056 (sleep *delay*)
1057 (xlib:display-force-output display))))
1058 (xlib:free-gcontext gcontext)))
1059
1060 (defdemo plaid-demo "Plaid" (&optional (iterations 10000) (num-rectangles 10))
1061 10 10 101 201
1062 "Plaid, man."
1063 (plaid *display* *window* iterations num-rectangles))
1064
1065
1066 ;;;; Bball demo
1067
1068 ;;;
1069 ;;; Ported to CLX by Blaine Burks
1070 ;;;
1071
1072 (defvar *ball-size-x* 36)
1073 (defvar *ball-size-y* 34)
1074
1075
1076 (defun xor-ball (pixmap window gcontext x y)
1077 (xlib:copy-plane pixmap gcontext 1
1078 0 0
1079 *ball-size-x* *ball-size-y*
1080 window
1081 x y))
1082
1083 (defconstant bball-gravity 1)
1084 (defconstant maximum-x-drift 7)
1085
1086 (defvar *max-bball-x*)
1087 (defvar *max-bball-y*)
1088
1089 (defstruct ball
1090 (x (random (- *max-bball-x* *ball-size-x*)))
1091 (y (random (- *max-bball-y* *ball-size-y*)))
1092 (dx (if (zerop (random 2)) (random maximum-x-drift)
1093 (- (random maximum-x-drift))))
1094 (dy 0))
1095
1096 (defun get-bounce-image ()
1097 "Returns the pixmap to be bounced around the screen."
1098 (xlib::bitmap-image #*000000000000000000000000000000000000
1099 #*000000000000000000000000000000000000
1100 #*000000000000000000001000000010000000
1101 #*000000000000000000000000000100000000
1102 #*000000000000000000000100001000000000
1103 #*000000000000000010000000010000000000
1104 #*000000000000000000100010000000000000
1105 #*000000000000000000001000000000000000
1106 #*000000000001111100000000000101010000
1107 #*000000000010000011000111000000000000
1108 #*000000000100000000111000000000000000
1109 #*000000000100000000000000000100000000
1110 #*000000000100000000001000100010000000
1111 #*000000111111100000010000000001000000
1112 #*000000111111100000100000100000100000
1113 #*000011111111111000000000000000000000
1114 #*001111111111111110000000100000000000
1115 #*001111111111111110000000000000000000
1116 #*011111111111111111000000000000000000
1117 #*011111111111111111000000000000000000
1118 #*111111111111110111100000000000000000
1119 #*111111111111111111100000000000000000
1120 #*111111111111111101100000000000000000
1121 #*111111111111111101100000000000000000
1122 #*111111111111111101100000000000000000
1123 #*111111111111111111100000000000000000
1124 #*111111111111110111100000000000000000
1125 #*011111111111111111000000000000000000
1126 #*011111111111011111000000000000000000
1127 #*001111111111111110000000000000000000
1128 #*001111111111111110000000000000000000
1129 #*000011111111111000000000000000000000
1130 #*000000111111100000000000000000000000
1131 #*000000000000000000000000000000000000))
1132
1133
1134 (defun bounce-1-ball (pixmap window gcontext ball)
1135 (let ((x (ball-x ball))
1136 (y (ball-y ball))
1137 (dx (ball-dx ball))
1138 (dy (ball-dy ball)))
1139 (xor-ball pixmap window gcontext x y)
1140 (setq x (+ x dx))
1141 (setq y (+ y dy))
1142 (if (or (< x 0) (> x (- *max-bball-x* *ball-size-x*)))
1143 (setq x (- x dx)
1144 dx (- dx)))
1145 (if (> y (- *max-bball-y* *ball-size-y*))
1146 (setq y (- y dy)
1147 dy (- dy)))
1148 (setq dy (+ dy bball-gravity))
1149 (setf (ball-x ball) x)
1150 (setf (ball-y ball) y)
1151 (setf (ball-dx ball) dx)
1152 (setf (ball-dy ball) dy)
1153 (xor-ball pixmap window gcontext x y)))
1154
1155 (defun bounce-balls (display window how-many duration)
1156 (xlib:clear-area window)
1157 (xlib:display-force-output display)
1158 (multiple-value-bind (*max-bball-x* *max-bball-y*) (full-window-state window)
1159 (let* ((balls (do ((i 0 (1+ i))
1160 (list () (cons (make-ball) list)))
1161 ((= i how-many) list)))
1162 (gcontext (xlib:create-gcontext :drawable window
1163 :foreground *white-pixel*
1164 :background *black-pixel*
1165 :function boole-xor
1166 :exposures :off))
1167 (bounce-pixmap (xlib:create-pixmap :width 36 :height 34 :depth 1
1168 :drawable window))
1169 (pixmap-gc (xlib:create-gcontext :drawable bounce-pixmap
1170 :foreground *white-pixel*
1171 :background *black-pixel*)))
1172 (xlib:put-image bounce-pixmap pixmap-gc (get-bounce-image)
1173 :x 0 :y 0 :width 36 :height 34)
1174 (xlib:free-gcontext pixmap-gc)
1175 (dolist (ball balls)
1176 (xor-ball bounce-pixmap window gcontext (ball-x ball) (ball-y ball)))
1177 (dotimes (i duration)
1178 (dolist (ball balls)
1179 (bounce-1-ball bounce-pixmap window gcontext ball)
1180 (xlib:display-force-output display))
1181 (sleep *delay*))
1182 (xlib:free-pixmap bounce-pixmap)
1183 (xlib:free-gcontext gcontext))))
1184
1185 (defdemo bouncing-ball-demo "Bouncing-Ball" (&optional (how-many 5) (duration 500))
1186 36 34 700 500
1187 "Bouncing balls in space."
1188 (bounce-balls *display* *window* how-many duration))

  ViewVC Help
Powered by ViewVC 1.1.5