diff --git a/clx.asd b/clx.asd index 01d676a..1024cf6 100644 --- a/clx.asd +++ b/clx.asd @@ -119,9 +119,18 @@ Independent FOSS developers" ((:file "menu") (:file "bezier") (:file "beziertest" :depends-on ("bezier")) - (:file "clclock") (:file "clipboard") (:file "clx-demos") + (:file "clclock") + (:file "bouncing-balls") + (:file "plaid") + (:file "recurrence") + (:file "bounce-window") + (:file "hanoi") + (:file "petal") + (:file "qix") + (:file "greynetic") + (:file "hello-world") (:file "gl-test") ;; FIXME: compiling this generates 30-odd spurious code ;; deletion notes. Find out why, and either fix or diff --git a/demo/bounce-window.lisp b/demo/bounce-window.lisp new file mode 100644 index 0000000..414172a --- /dev/null +++ b/demo/bounce-window.lisp @@ -0,0 +1,100 @@ +(defpackage #:xlib-demo/bounce-window + (:use :common-lisp :xlib :xlib-demo/demos) + (:export #:bounce-window)) + +(in-package :xlib-demo/bounce-window) + + +;;;; Bounce window. + +;;; BOUNCE-WINDOW takes a window and seemingly drops it to the bottom of +;;; the screen. Optionally, the window can have an initial x velocity, +;;; screen border elasticity, and gravity value. The outer loop is +;;; entered the first time with the window at its initial height, but +;;; each iteration after this, the loop starts with the window at the +;;; bottom of the screen heading upward. The inner loop, except for the +;;; first execution, carries the window up until the negative velocity +;;; becomes positive, carrying the window down to bottom when the +;;; velocity is positive. Due to number lossage, ROUND'ing and +;;; TRUNC'ing when the velocity gets so small will cause the window to +;;; head upward with the same velocity over two iterations which will +;;; cause the window to bounce forever, so we have prev-neg-velocity and +;;; number-problems to check for this. This is not crucial with the x +;;; velocity since the loop terminates as a function of the y velocity. +;;; +(defun bounce-window (&key (x 100) (y 100) (width 300) (height 300) + (x-velocity 0) (elasticity 0.85) (gravity 2)) + (unless (< 0 elasticity 1) + (error "Elasticity must be between 0 and 1.")) + (unless (plusp gravity) + (error "Gravity must be positive.")) + (with-x11-context () + (let ((window (create-window + :parent (screen-root *screen*) + :x x :y y :width width :height height + :background *white-pixel*))) + (xlib:set-wm-properties window + :name "Bounce Window" + :x x :y y + :width width :height height + :user-specified-position-p t + :user-specified-size-p t + :min-width width :min-height height + :max-width width :max-height height) + (xlib:map-window window) + (xlib:display-force-output *display*) + (do ((attempts 0 (1+ attempts))) + ((or (eq (xlib:window-map-state window) :viewable) + (>= attempts 100))) ; wait 1 sec before giving up + (sleep 0.01)) + (let ((top-of-window-at-bottom (- (xlib:drawable-height *root*) height)) + (left-of-window-at-right (- (xlib:drawable-width *root*) width)) + (y-velocity 0) + (prev-neg-velocity most-negative-fixnum) + (number-problems nil)) + (declare (fixnum top-of-window-at-bottom left-of-window-at-right + y-velocity)) + (loop + (when (= prev-neg-velocity 0) (return t)) + (let ((negative-velocity (minusp y-velocity))) + (loop + (let ((next-y (+ y y-velocity)) + (next-y-velocity (+ y-velocity gravity))) + (declare (fixnum next-y next-y-velocity)) + (when (> next-y top-of-window-at-bottom) + (cond + (number-problems + (setf y-velocity (incf prev-neg-velocity))) + (t + (setq y-velocity + (- (truncate (* elasticity y-velocity)))) + (when (= y-velocity prev-neg-velocity) + (incf y-velocity) + (setf number-problems t)) + (setf prev-neg-velocity y-velocity))) + (setf y top-of-window-at-bottom) + (setf (xlib:drawable-x window) x + (xlib:drawable-y window) y) + (xlib:display-force-output *display*) + (return)) + (setq y-velocity next-y-velocity) + (setq y next-y) + (sleep (/ *delay* 100))) + (when (and negative-velocity (>= y-velocity 0)) + (setf negative-velocity nil)) + (let ((next-x (+ x x-velocity))) + (declare (fixnum next-x)) + (when (or (> next-x left-of-window-at-right) + (< next-x 0)) + (setq x-velocity (- (truncate (* elasticity x-velocity))))) + (setq x next-x)) + (setf (xlib:drawable-x window) x + (xlib:drawable-y window) y) + (xlib:display-force-output *display*)))))))) + +(push (make-demo :name "Shove-bounce" + :function (lambda () (bounce-window :x-velocity 3))) + *demos*) + +(push (make-demo :name "Bounce" :function #'bounce-window) *demos*) + diff --git a/demo/bouncing-balls.lisp b/demo/bouncing-balls.lisp new file mode 100644 index 0000000..3d95feb --- /dev/null +++ b/demo/bouncing-balls.lisp @@ -0,0 +1,155 @@ +(defpackage #:xlib-demo/bouncing-balls + (:use :common-lisp :xlib :xlib-demo/demos) + (:export #:bouncing-balls)) + +(in-package :xlib-demo/bouncing-balls) + + + +;;;; Bball demo + +;;; +;;; Ported to CLX by Blaine Burks +;;; + +(defvar *ball-size-x* 36) +(defvar *ball-size-y* 34) + +(defun xor-ball (pixmap window gcontext x y) + (xlib:copy-plane pixmap gcontext 1 + 0 0 + *ball-size-x* *ball-size-y* + window + x y)) + +(defconstant bball-gravity 1) +(defconstant maximum-x-drift 7) + +(defvar *max-bball-x*) +(defvar *max-bball-y*) + +(defstruct ball + (x (random (- *max-bball-x* *ball-size-x*))) + (y (random (- *max-bball-y* *ball-size-y*))) + (dx (if (zerop (random 2)) (random maximum-x-drift) + (- (random maximum-x-drift)))) + (dy 0)) + +(defun get-bounce-image () + "Returns the pixmap to be bounced around the screen." + (xlib::bitmap-image #*000000000000000000000000000000000000 + #*000000000000000000000000000000000000 + #*000000000000000000001000000010000000 + #*000000000000000000000000000100000000 + #*000000000000000000000100001000000000 + #*000000000000000010000000010000000000 + #*000000000000000000100010000000000000 + #*000000000000000000001000000000000000 + #*000000000001111100000000000101010000 + #*000000000010000011000111000000000000 + #*000000000100000000111000000000000000 + #*000000000100000000000000000100000000 + #*000000000100000000001000100010000000 + #*000000111111100000010000000001000000 + #*000000111111100000100000100000100000 + #*000011111111111000000000000000000000 + #*001111111111111110000000100000000000 + #*001111111111111110000000000000000000 + #*011111111111111111000000000000000000 + #*011111111111111111000000000000000000 + #*111111111111110111100000000000000000 + #*111111111111111111100000000000000000 + #*111111111111111101100000000000000000 + #*111111111111111101100000000000000000 + #*111111111111111101100000000000000000 + #*111111111111111111100000000000000000 + #*111111111111110111100000000000000000 + #*011111111111111111000000000000000000 + #*011111111111011111000000000000000000 + #*001111111111111110000000000000000000 + #*001111111111111110000000000000000000 + #*000011111111111000000000000000000000 + #*000000111111100000000000000000000000 + #*000000000000000000000000000000000000)) + + +(defun bounce-1-ball (pixmap window gcontext ball) + (let ((x (ball-x ball)) + (y (ball-y ball)) + (dx (ball-dx ball)) + (dy (ball-dy ball))) + (xor-ball pixmap window gcontext x y) + (setq x (+ x dx)) + (setq y (+ y dy)) + (if (or (< x 0) (> x (- *max-bball-x* *ball-size-x*))) + (setq x (- x dx) + dx (- dx))) + (if (> y (- *max-bball-y* *ball-size-y*)) + (setq y (- y dy) + dy (- dy))) + (setq dy (+ dy bball-gravity)) + (setf (ball-x ball) x) + (setf (ball-y ball) y) + (setf (ball-dx ball) dx) + (setf (ball-dy ball) dy) + (xor-ball pixmap window gcontext x y))) + +(defun bounce-balls (&optional (how-many 5) (duration 500)) + (with-x11-context () + (let ((window (create-window + :parent (screen-root *screen*) + :x 36 :y 34 :width 700 :height 500 + :background *white-pixel* + :event-mask '(:structure-notify)))) + (xlib:set-wm-properties window :name "Bouncing balls") + (xlib:map-window window) + (xlib:clear-area window) + (xlib:display-finish-output *display*) + (do ((attempts 0 (1+ attempts))) + ((or (eq (xlib:window-map-state window) :viewable) + (>= attempts 100))) ; wait 1 sec before giving up + (sleep 0.01)) + (multiple-value-bind (*max-bball-x* *max-bball-y*) + (full-window-state window) + (let* ((balls (do ((i 0 (1+ i)) + (list () (cons (make-ball) list))) + ((= i how-many) list))) + (gcontext (xlib:create-gcontext :drawable window + :foreground *white-pixel* + :background *black-pixel* + :function boole-xor + :exposures :off)) + (bounce-pixmap (xlib:create-pixmap :width 38 :height 34 :depth 1 + :drawable window)) + (pixmap-gc (xlib:create-gcontext :drawable bounce-pixmap + :foreground *white-pixel* + :background *black-pixel*)) + (runningp t)) + (xlib:put-image bounce-pixmap pixmap-gc (get-bounce-image) + :x 0 :y 0 :width 38 :height 34) + (xlib:free-gcontext pixmap-gc) + (dolist (ball balls) + (xor-ball bounce-pixmap window gcontext (ball-x ball) (ball-y ball))) + (xlib:display-finish-output *display*) + (dotimes (i duration) + (unless runningp (return)) + (xlib:event-case (*display* :timeout 0 :discard-p t) + (:destroy-notify + (event-window) + (when (xlib:window-equal event-window window) + (setf runningp nil) + t)) + (otherwise + (event-window) + (when (xlib:window-equal event-window window) + t))) + (when runningp + (ignore-errors + (dolist (ball balls) + (bounce-1-ball bounce-pixmap window gcontext ball) + (xlib:display-finish-output *display*)))) + (sleep (/ *delay* 50.0))) + (xlib:free-pixmap bounce-pixmap) + (xlib:free-gcontext gcontext)))))) + +(push (make-demo :name "Bouncing Balls" :function #'bounce-balls) *demos*) diff --git a/demo/clclock.lisp b/demo/clclock.lisp index c519261..28b4a38 100644 --- a/demo/clclock.lisp +++ b/demo/clclock.lisp @@ -1,12 +1,9 @@ (defpackage #:xlib-demo/clclock - (:use "CL") - (:export "CLOCK")) + (:use :common-lisp :xlib :xlib-demo/demos) + (:export #:clock)) (in-package #:xlib-demo/clclock) -(declaim (special *display* *screen* *colormap* *font* *win* *gcontext* - *background* *palette* *black*)) - (defun romanize (arg) (if (zerop arg) "O" @@ -16,60 +13,70 @@ (multiple-value-bind (s m h) (decode-universal-time (get-universal-time)) (format nil "~a ~a ~a" (romanize h) (romanize m) (romanize s)))) -(defun update-clockface () +(defun update-clockface (window gcontext background) (let ((string (clock-string))) - (let ((string-width (xlib:text-width *gcontext* string))) - (xlib:draw-rectangle *win* *background* + (let ((string-width (xlib:text-width gcontext string))) + (xlib:draw-rectangle window background 0 0 - (xlib:drawable-width *win*) - (xlib:drawable-height *win*) + (xlib:drawable-width window) + (xlib:drawable-height window) :fill-p) - (xlib:draw-glyphs *win* *gcontext* + (xlib:draw-glyphs window gcontext (- (truncate - (- (xlib:drawable-width *win*) string-width) + (- (xlib:drawable-width window) string-width) 2) 10) - (- (xlib:drawable-height *win*) 10) + (- (xlib:drawable-height window) 10) string))) (xlib:display-force-output *display*)) (defun clock () - (let* ((*display* (xlib:open-default-display)) - (*screen* (xlib:display-default-screen *display*)) - (*colormap* (xlib:screen-default-colormap *screen*)) - - (*font* (xlib:open-font *display* "fixed"))) + (with-x11-context () (multiple-value-bind (width ascent) (xlib:text-extents *font* "XVIIII XXXVIIII XXXVIIII") - (setq *win* (xlib:create-window - :parent (xlib:screen-root *screen*) - :x 512 - :y 512 - :width (+ 20 width) - :height (+ 20 ascent) - :background (xlib:alloc-color *colormap* - (xlib:lookup-color *colormap* - "midnightblue"))) - *gcontext* (xlib:create-gcontext - :drawable *win* + (let* ((midnightblue + (xlib:alloc-color + *colormap* + (xlib:lookup-color *colormap* "midnightblue"))) + (window (xlib:create-window + :parent (xlib:screen-root *screen*) + :x 512 + :y 512 + :width (+ 20 width) + :height (+ 20 ascent) + :background midnightblue + :event-mask '(:structure-notify))) + (gcontext (xlib:create-gcontext + :drawable window :fill-style :solid - :background (xlib:screen-white-pixel *screen*) - :foreground (xlib:alloc-color *colormap* - (xlib:lookup-color - *colormap* - "yellow")) - :font *font*) - *background* (xlib:create-gcontext - :drawable *win* + :background *white-pixel* + :foreground + (xlib:alloc-color + *colormap* + (xlib:lookup-color *colormap* "yellow")) + :font *font*)) + (background (xlib:create-gcontext + :drawable window :fill-style :solid - :background (xlib:screen-white-pixel *screen*) - :foreground (xlib:alloc-color *colormap* - (xlib:lookup-color *colormap* - "midnightblue")) - :font *font*) - *palette* nil - *black* (xlib:screen-black-pixel *screen*))) - (xlib:map-window *win*) - (loop - (update-clockface) - (sleep 1)))) + :background *white-pixel* + :foreground midnightblue + :font *font*))) + (xlib:map-window window) + (loop with runningp = t + while runningp do + (xlib:event-case (*display* :timeout 1 :discard-p t) + (:destroy-notify + (event-window) + (when (xlib:window-equal event-window window) + (setf runningp nil) + t)) + (otherwise + (event-window) + (when (and event-window window + (xlib:window-equal event-window window)) + t))) + (ignore-errors + (update-clockface window gcontext background))))))) + +(push (make-demo :name "Clock" :function #'clock) *demos*) + diff --git a/demo/clx-demos.lisp b/demo/clx-demos.lisp index 05a5a1c..a6192ec 100644 --- a/demo/clx-demos.lisp +++ b/demo/clx-demos.lisp @@ -1,5 +1,3 @@ -;;; -*- Mode: Lisp; Package: Demos -*- -;;; ;;; This file contains various graphics hacks written and ported over the ;;; years by various and numerous persons. ;;; @@ -11,1095 +9,180 @@ ;;; ;;; Backported some changes found in CMUCL repository -- jd 2018-12-29. + (defpackage #:xlib-demo/demos (:use :common-lisp) - (:export #:demo)) + (:export #:demo + #:*display* #:*screen* #:*root* :*colormap* + #:*black-pixel* #:*white-pixel* #:*font* + #:*font* #:*window* + #:*demos* #:*delay* + + #:make-demo + #:with-x11-context + #:full-window-state)) (in-package :xlib-demo/demos) - -;;;; Graphic demos wrapper macro. +(defparameter *display* nil + "The current X11 display connection.") -;;; This wrapper macro should be reconsidered with respect to its property -;;; list usage. Possibly a demo structure should be used with *demos* -;;; pointing to these instead of function names. Also, something should -;;; be done about a title window that displays the name of the demo while -;;; it is running. +(defparameter *screen* nil + "The current default screen of the current display.") -(defparameter *demos* nil) -(defparameter *delay* 0.5) +(defparameter *root* nil + "The root window of the current screen.") -(defvar *display* nil) -(defvar *screen* nil) -(defvar *root* nil) -(defvar *black-pixel* nil) -(defvar *white-pixel* nil) -(defvar *window* nil) +(defparameter *colormap* nil + "The default colormap for the current screen.") -(defmacro defdemo (fun-name demo-name args x y width height doc &rest forms) - `(progn - (defun ,fun-name ,args - ,doc - (let* ((*display* (or *display* - (xlib:open-default-display) - (xlib:open-display (machine-instance)))) - (*screen* (xlib:display-default-screen *display*)) - (*root* (xlib:screen-root *screen*)) - (*black-pixel* (xlib:screen-black-pixel *screen*)) - (*white-pixel* (xlib:screen-white-pixel *screen*)) - (*window* (xlib:create-window :parent *root* - :x ,x :y ,y - :event-mask '(:visibility-change) - :width ,width :height ,height - :background *white-pixel* - :border *black-pixel* - :border-width 2 - :override-redirect :off))) - (xlib:set-wm-properties *window* - :name ,demo-name - :icon-name ,demo-name - :resource-name ,demo-name - :x ,x :y ,y :width ,width :height ,height - :user-specified-position-p t - :user-specified-size-p t - :min-width ,width :min-height ,height - :width-inc nil :height-inc nil) - (xlib:map-window *window*) - ;; Wait until we get mapped before doing anything. - (xlib:display-finish-output *display*) - (unwind-protect (progn ,@forms) - (xlib:display-finish-output *display*) - (xlib:unmap-window *window*)))) - (setf (get ',fun-name 'demo-name) ',demo-name) - (setf (get ',fun-name 'demo-doc) ',doc) - (pushnew ',fun-name *demos*) - ',fun-name)) +(defparameter *black-pixel* nil + "The pixel value that represents black on the current screen.") - -;;; DEMO +(defparameter *white-pixel* nil + "The pixel value that represents white on the current screen.") -(defvar *name-to-function* (make-hash-table :test #'eq)) -(defvar *keyword-package* (find-package "KEYWORD")) -(defvar *demo-names* nil) +(defparameter *font* nil + "The default font used for text rendering in demos.") -(defun demo () - (let ((*demo-names* '("Quit"))) - (dolist (d *demos*) - (setf (gethash (intern (string-upcase (get d 'demo-name)) - *keyword-package*) - *name-to-function*) - d) - (push (get d 'demo-name) *demo-names*)) - - (let* ((display (xlib:open-default-display)) - (screen (xlib:display-default-screen display)) - (fg-color (xlib:screen-white-pixel screen)) - (bg-color (xlib:screen-black-pixel screen)) - (nice-font (xlib:open-font display "fixed"))) - - (let ((a-menu (xlib::create-menu - (xlib::screen-root screen) ;the menu's parent - fg-color bg-color nice-font))) - - (setf (xlib::menu-title a-menu) "Please pick your favorite demo:") - (xlib::menu-set-item-list a-menu *demo-names*) - (ignore-errors ;; closing window is not handled properly in menu. - (unwind-protect - (do ((choice (xlib::menu-choose a-menu 100 100) - (xlib::menu-choose a-menu 100 100))) - ((and choice (string-equal "Quit" choice))) - (let* ((demo-choice (intern (string-upcase choice) - *keyword-package*)) - (fun (gethash demo-choice *name-to-function*))) - (setf choice nil) - (when fun - (ignore-errors (funcall fun))))) - (xlib:display-finish-output display) - (xlib:close-display display))))))) +(defparameter *window* nil + "The current demo window.") + +(defparameter *demos* '() "Registry of available demos.") +(declaim (type list *demos*)) + +(defparameter *delay* 0.5) - -;;;; Shared demo utilities. +(defstruct demo + (name "" :type string ) + (function nil :type function)) + +(defun open-default-font (display) + (xlib:open-font display + (or (first + (xlib:list-font-names + display + "-adobe-courier-medium-r-*--48-0-0-0-m-0-*-*" + :max-fonts 1)) + "fixed"))) + +(defmacro with-x11-context (&body body) + `(let* ((*display* (or (xlib:open-default-display) + (xlib:open-display (machine-instance)))) + (*screen* (xlib:display-default-screen *display*)) + (*root* (xlib:screen-root *screen*)) + (*colormap* (xlib:screen-default-colormap *screen*)) + (*black-pixel* (xlib:screen-black-pixel *screen*)) + (*white-pixel* (xlib:screen-white-pixel *screen*)) + (*font* (open-default-font *display*))) + (setf (xlib:display-report-asynchronous-errors *display*) + '(:after-finish-output)) + (unwind-protect + (progn ,@body) + (xlib:close-display *display*)))) (defun full-window-state (w) (xlib:with-state (w) (values (xlib:drawable-width w) (xlib:drawable-height w) - (xlib:drawable-x w) (xlib:drawable-y w) - (xlib:window-map-state w)))) - - -(defun make-random-bitmap () - (let ((bitmap-data (make-array '(32 32) :initial-element 0 - :element-type 'xlib::bit))) - (dotimes (i 4) - (declare (fixnum i)) - (let ((nibble (random 16))) - (setf nibble (logior nibble (ash nibble 4)) - nibble (logior nibble (ash nibble 8)) - nibble (logior nibble (ash nibble 12)) - nibble (logior nibble (ash nibble 16))) - (dotimes (j 32) - (let ((bit (if (logbitp j nibble) 1 0))) - (setf (aref bitmap-data i j) bit - (aref bitmap-data (+ 4 i) j) bit - (aref bitmap-data (+ 8 i) j) bit - (aref bitmap-data (+ 12 i) j) bit - (aref bitmap-data (+ 16 i) j) bit - (aref bitmap-data (+ 20 i) j) bit - (aref bitmap-data (+ 24 i) j) bit - (aref bitmap-data (+ 28 i) j) bit))))) - bitmap-data)) - - -(defun make-random-pixmap () - (let ((image (xlib:create-image :depth 1 :data (make-random-bitmap)))) - (make-pixmap image 32 32))) - -(defvar *pixmaps* nil) - -(defun make-pixmap (image width height) - (let* ((pixmap (xlib:create-pixmap :width width :height height - :depth 1 :drawable *root*)) - (gc (xlib:create-gcontext :drawable pixmap - :background *black-pixel* - :foreground *white-pixel*))) - (xlib:put-image pixmap gc image :x 0 :y 0 :width width :height height) - (xlib:free-gcontext gc) - pixmap)) - - -;;; -;;; This function returns one of the pixmaps in the *pixmaps* array. -(defun greynetic-pixmapper () - (aref *pixmaps* (random (length *pixmaps*)))) - - -(defun greynetic (window duration) - (let* ((depth (xlib:drawable-depth window)) - (draw-gcontext (xlib:create-gcontext :drawable window - :foreground *white-pixel* - :background *black-pixel*)) - ;; Need a random state per process. - (*random-state* (make-random-state t)) - (*pixmaps* (let ((pixmap-array (make-array 30))) - (dotimes (i 30) - (setf (aref pixmap-array i) (make-random-pixmap))) - pixmap-array))) - - (unwind-protect - (multiple-value-bind (width height) (full-window-state window) - (declare (fixnum width height)) - (let ((border-x (truncate width 20)) - (border-y (truncate height 20))) - (declare (fixnum border-x border-y)) - (dotimes (i duration) - (let ((pixmap (greynetic-pixmapper))) - (xlib:with-gcontext (draw-gcontext - :foreground (random (ash 1 depth)) - :background (random (ash 1 depth)) - :stipple pixmap - :fill-style - :opaque-stippled) - (cond ((zerop (mod i 500)) - (xlib:clear-area window) - (sleep .1)) - (t - (sleep (/ *delay* 20)))) - (if (< (random 3) 2) - (let* ((w (+ border-x - (truncate (* (random (- width - (* 2 border-x))) - (random width)) width))) - (h (+ border-y - (truncate (* (random (- height - (* 2 border-y))) - (random height)) height))) - (x (random (- width w))) - (y (random (- height h)))) - (declare (fixnum w h x y)) - (if (zerop (random 2)) - (xlib:draw-rectangle window draw-gcontext - x y w h t) - (xlib:draw-arc window draw-gcontext - x y w h 0 (* 2 pi) t))) - (let ((p1-x (+ border-x - (random (- width (* 2 border-x))))) - (p1-y (+ border-y - (random (- height (* 2 border-y))))) - (p2-x (+ border-x - (random (- width (* 2 border-x))))) - (p2-y (+ border-y - (random (- height (* 2 border-y))))) - (p3-x (+ border-x - (random (- width (* 2 border-x))))) - (p3-y (+ border-y - (random (- height (* 2 border-y)))))) - (declare (fixnum p1-x p1-y p2-x p2-y p3-x p3-y)) - (xlib:draw-lines window draw-gcontext - (list p1-x p1-y p2-x p2-y p3-x p3-y) - :relative-p nil - :fill-p t - :shape :convex))) - (xlib:display-force-output *display*)))))) - (dotimes (i (length *pixmaps*)) - (xlib:free-pixmap (aref *pixmaps* i))) - (xlib:free-gcontext draw-gcontext)))) - - -(defdemo greynetic-demo "Greynetic" (&optional (duration 300)) - 100 100 600 600 - "Displays random grey rectangles." - (greynetic *window* duration)) - - -;;;; Qix. - -(defstruct qix - buffer - (dx1 5) - (dy1 10) - (dx2 10) - (dy2 5)) - -(defun construct-qix (length) - (let ((qix (make-qix))) - (setf (qix-buffer qix) (make-circular-list length)) - qix)) - -(defun make-circular-list (length) - (let ((l (make-list length))) - (rplacd (last l) l))) - - -(defun qix (window lengths duration) - "Each length is the number of lines to put in a qix, and that many qix - (of the correct size) are put up on the screen. Lets the qix wander around - the screen for Duration steps." - (let ((histories (mapcar #'construct-qix lengths))) - (multiple-value-bind (width height) (full-window-state window) - (declare (fixnum width height)) - (xlib:clear-area window) - (xlib:display-force-output *display*) - (do ((h histories (cdr h)) - (l lengths (cdr l))) - ((null h)) - (do ((x (qix-buffer (car h)) (cdr x)) - (i 0 (1+ i))) - ((= i (car l))) - (rplaca x (make-array 4)))) - ;; Start each qix at a random spot on the screen. - (dolist (h histories) - (let ((x (random width)) - (y (random height))) - (rplaca (qix-buffer h) - (make-array 4 :initial-contents (list x y x y))))) - (rplacd (last histories) histories) - (let ((x1 0) (y1 0) (x2 0) (y2 0) - (dx1 0) (dy1 0) (dx2 0) (dy2 0) - tem line next-line qix - (gc (xlib:create-gcontext :drawable window - :foreground *white-pixel* - :background *black-pixel* - :line-width 0 :line-style :solid - :function boole-c2))) - (declare (fixnum x1 y1 x2 y2 dx1 dy1 dx2 dy2)) - (dotimes (i duration) - ;; Line is the next line in the next qix. Rotate this qix and - ;; the qix ring. - (setq qix (car histories)) - (setq line (car (qix-buffer qix))) - (setq next-line (cadr (qix-buffer qix))) - (setf (qix-buffer qix) (cdr (qix-buffer qix))) - (setq histories (cdr histories)) - (setf x1 (svref line 0)) - (setf y1 (svref line 1)) - (setf x2 (svref line 2)) - (setf y2 (svref line 3)) - (xlib:draw-line window gc x1 y1 x2 y2) - (setq dx1 (- (+ (qix-dx1 qix) (random 3)) 1)) - (setq dy1 (- (+ (qix-dy1 qix) (random 3)) 1)) - (setq dx2 (- (+ (qix-dx2 qix) (random 3)) 1)) - (setq dy2 (- (+ (qix-dy2 qix) (random 3)) 1)) - (cond ((> dx1 10) (setq dx1 10)) - ((< dx1 -10) (setq dx1 -10))) - (cond ((> dy1 10) (setq dy1 10)) - ((< dy1 -10) (setq dy1 -10))) - (cond ((> dx2 10) (setq dx2 10)) - ((< dx2 -10) (setq dx2 -10))) - (cond ((> dy2 10) (setq dy2 10)) - ((< dy2 -10) (setq dy2 -10))) - (cond ((or (>= (setq tem (+ x1 dx1)) width) (minusp tem)) - (setq dx1 (- dx1)))) - (cond ((or (>= (setq tem (+ x2 dx2)) width) (minusp tem)) - (setq dx2 (- dx2)))) - (cond ((or (>= (setq tem (+ y1 dy1)) height) (minusp tem)) - (setq dy1 (- dy1)))) - (cond ((or (>= (setq tem (+ y2 dy2)) height) (minusp tem)) - (setq dy2 (- dy2)))) - (setf (qix-dy2 qix) dy2) - (setf (qix-dx2 qix) dx2) - (setf (qix-dy1 qix) dy1) - (setf (qix-dx1 qix) dx1) -` (when (svref next-line 0) - (xlib:draw-line window gc - (svref next-line 0) (svref next-line 1) - (svref next-line 2) (svref next-line 3))) - (setf (svref next-line 0) (+ x1 dx1)) - (setf (svref next-line 1) (+ y1 dy1)) - (setf (svref next-line 2) (+ x2 dx2)) - (setf (svref next-line 3) (+ y2 dy2)) - (xlib:display-force-output *display*)))))) - - -(defdemo qix-demo "Qix" (&optional (lengths '(30 30)) (duration 2000)) - 0 0 700 700 - "Hypnotic wandering lines." - (qix *window* lengths duration)) - + (xlib:drawable-x w) (xlib:drawable-y w) + (xlib:window-map-state w)))) + +(defun start-in-thread (function name &optional args) + #+sbcl + (sb-thread:make-thread + (lambda () (apply function args)) + :name name) + + #+(and cmu mp) + (mp:make-process + (lambda () (apply function args)) + :name name) + + #+(and ecl threads) + (mp:process-run-function + name + (lambda () (apply function args))) + + #+(and clasp threads) + (mp:process-run-function + name + (lambda () (apply function args))) + + #+abcl + (threads:make-thread + (lambda () (apply function args)) + :name name) + + #-(or sbcl (and cmu mp) (and ecl threads) (and clasp threads) abcl) + (progn + (warn "Threading not supported on this Lisp implementation") + nil)) - -;;;; Petal. - -;;; Fast sine constants: - -(defconstant d360 #o5500) -(defconstant d270 #o4160) -(defconstant d180 #o2640) -(defconstant d90 #o1320) -(defconstant vecmax 2880) - -(defparameter sin-array - '#(#o0 #o435 #o1073 #o1531 #o2166 #o2623 #o3260 - #o3714 #o4350 #o5003 #o5435 #o6066 #o6516 #o7145 - #o7573 #o10220 #o10644 #o11266 #o11706 #o12326 - #o12743 #o13357 #o13771 #o14401 #o15007 #o15414 - #o16016 #o16416 #o17013 #o17407 #o20000 #o20366 - #o20752 #o21333 #o21711 #o22265 #o22636 #o23204 - #o23546 #o24106 #o24443 #o24774 #o25323 #o25645 - #o26165 #o26501 #o27011 #o27316 #o27617 #o30115 - #o30406 #o30674 #o31156 #o31434 #o31706 #o32154 - #o32416 #o32654 #o33106 #o33333 #o33554 #o33771 - #o34202 #o34406 #o34605 #o35000 #o35167 #o35351 - #o35526 #o35677 #o36043 #o36203 #o36336 #o36464 - #o36605 #o36721 #o37031 #o37134 #o37231 #o37322 - #o37407 #o37466 #o37540 #o37605 #o37646 #o37701 - #o37730 #o37751 #o37766 #o37775 #o40000)) - -(defmacro psin (val) - `(let* ((val ,val) - neg - frac - sinlo) - (if (>= val d180) - (setq neg t - val (- val d180))) - (if (>= val d90) - (setq val (- d180 val))) - (setq frac (logand val 7)) - (setq val (ash val -3)) - ;; - (setq sinlo (if (>= val 90) - (svref sin-array 90) - (svref sin-array val))) - ;; - (if (< val 90) - (setq sinlo - (+ sinlo (ash (* frac (- (svref sin-array (1+ val)) sinlo)) - -3)))) - ;; - (if neg - (- sinlo) - sinlo))) - -(defmacro pcos (x) - `(let ((tmp (- ,x d270))) - (psin (if (minusp tmp) (+ tmp d360) tmp)))) - - -;;;; Miscellaneous petal hackery. - -(defmacro high-16bits-* (a b) - `(let ((a-h (ash ,a -8)) - (b-h (ash ,b -8))) - (+ (* a-h b-h) - (ash (* a-h (logand ,b 255)) -8) - (ash (* b-h (logand ,a 255)) -8)))) - -(defun complete (style petal) - (let ((repnum 1) - factor cntval needed) - (dotimes (i 3) - (case i - (0 (setq factor 2 cntval 6)) - (1 (setq factor 3 cntval 2)) - (2 (setq factor 5 cntval 1))) - (do () - ((or (minusp cntval) (not (zerop (rem style factor))))) - (setq repnum (* repnum factor)) - (setq cntval (1- cntval)) - (setq style (floor style factor)))) - (setq needed (floor vecmax repnum)) - (if (and (not (oddp needed)) (oddp petal)) (floor needed 2) needed))) - - -;;;; Petal Parameters and Petal itself - -(defparameter continuous t) -(defparameter styinc 2) -(defparameter petinc 1) -(defparameter scalfac-fac 8192) +(defun demo () + (with-x11-context () + (let* ((menu (xlib::create-menu *root* *white-pixel* *black-pixel* + *font*)) + (menu-window (xlib::menu-window menu))) + (setf (xlib:window-event-mask (xlib::menu-window menu)) + (xlib:make-event-mask :structure-notify :leave-window + :exposure) + + (xlib::menu-title menu) + "Please pick your favorite demo:") + (xlib::menu-set-item-list + menu + (append (mapcar #'demo-name *demos*) '("Quit"))) + (xlib::menu-present menu 0 0) -(defun petal (petal-window &optional (how-many 10) (style 0) (petal 0)) - (let ((width 512) - (height 512)) - (xlib:clear-area petal-window) - (xlib:display-force-output *display*) - (let ((veccnt 0) - (nustyle 722) - (nupetal 3) - (scalfac (1+ (floor scalfac-fac (min width height)))) - (ctrx (floor width 2)) - (ctry (floor height 2)) - (tt 0) - (s 0) - (lststyle 0) - (lstpetal 0) - (petstyle 0) - (vectors 0) - (r 0) - (x1 0) - (y1 0) - (x2 0) - (y2 0) - (i 0) - (gc (xlib:create-gcontext :drawable petal-window - :foreground *black-pixel* - :background *white-pixel* - :line-width 0 :line-style :solid))) (loop - (when (zerop veccnt) - (setq tt 0 s 0 lststyle style lstpetal petal petal nupetal - style nustyle petstyle (rem (* petal style) d360) - vectors (complete style petal)) - (when continuous - (setq nupetal (+ nupetal petinc) - nustyle (+ nustyle styinc))) - (when (or (/= lststyle style) (/= lstpetal petal)) - (xlib:clear-area petal-window) - (xlib:display-force-output *display*))) - (when (or (/= lststyle style) (/= lstpetal petal)) - (setq veccnt (1+ veccnt) i veccnt x1 x2 y1 y2 - tt (rem (+ tt style) d360) - s (rem (+ s petstyle) d360) - r (pcos s)) - (setq x2 (+ ctrx (floor (high-16bits-* (pcos tt) r) scalfac)) - y2 (+ ctry (floor (high-16bits-* (psin tt) r) scalfac))) - (when (/= i 1) - (xlib:draw-line petal-window gc x1 y1 x2 y2) - (xlib:display-force-output *display*))) - (when (> veccnt vectors) - (setq veccnt 0) - (setq how-many (1- how-many)) - (sleep 2) - (when (zerop how-many) (return))))))) - -(defdemo petal-demo "Petal" (&optional (how-many 10) (style 0) (petal 0)) - 100 100 512 512 - "Flower-like display." - (petal *window* how-many style petal)) - - -;;;; Hanoi. - -;;; Random parameters: - -(defparameter disk-thickness 15 "The thickness of a disk in pixels.") -(defparameter disk-spacing (+ disk-thickness 3) - "The amount of vertical space used by a disk on a needle.") -(defvar *horizontal-velocity* 20 "The speed at which disks slide sideways.") -(defvar *vertical-velocity* 12 "The speed at which disks move up and down.") - -;;; These variables are bound by the main function. - -(defvar *hanoi-window* () "The window that Hanoi is happening on.") -(defvar *hanoi-window-height* () "The height of the viewport Hanoi is happening on.") -(defvar *transfer-height* () "The height at which disks are transferred.") -(defvar *hanoi-gcontext* () "The graphics context for Hanoi under X11.") - -;;; Needle Functions - -(defstruct disk - size) - -(defstruct needle - position - disk-stack) - -;;; Needle-Top-Height returns the height of the top disk on NEEDLE. - -(defun needle-top-height (needle) - (- *hanoi-window-height* - (* disk-spacing (length (the list (needle-disk-stack needle)))))) - -(defvar available-disks - (do ((i 10 (+ i 10)) - (dlist () (cons (make-disk :size i) dlist))) - ((> i 80) dlist))) - -(defvar needle-1 (make-needle :position 184)) -(defvar needle-2 (make-needle :position 382)) -(defvar needle-3 (make-needle :position 584)) - -;;; Graphic interface abstraction: - -;;; Invert-Rectangle calls the CLX function draw-rectangle with "fill-p" -;;; set to T. Update-Screen forces the display output. -;;; -(defmacro invert-rectangle (x y height width) - `(xlib:draw-rectangle *hanoi-window* *hanoi-gcontext* - ,x ,y ,width ,height t)) - -(defmacro update-screen () - `(xlib:display-force-output *display*)) - - -;;;; Moving disks up and down - -;;; Slide-Up slides the image of a disk up from the coordinates X, -;;; START-Y to the point X, END-Y. DISK-SIZE is the size of the disk to -;;; move. START-Y must be greater than END-Y - -(defun slide-up (start-y end-y x disk-size) - (multiple-value-bind (number-moves pixels-left) - (truncate (- start-y end-y) *vertical-velocity*) - (do ((x (- x disk-size)) - (width (* disk-size 2)) - (old-y start-y (- old-y *vertical-velocity*)) - (new-y (- start-y *vertical-velocity*) (- new-y *vertical-velocity*)) - (number-moves number-moves (1- number-moves))) - ((zerop number-moves) - (when (plusp pixels-left) - (invert-rectangle x (- old-y pixels-left) disk-thickness width) - (invert-rectangle x old-y disk-thickness width) - (update-screen))) - ;; Loop body writes disk at new height & erases at old height. - (invert-rectangle x old-y disk-thickness width) - (invert-rectangle x new-y disk-thickness width) - (update-screen)))) - -;;; Slide-Down slides the image of a disk down from the coordinates X, -;;; START-Y to the point X, END-Y. DISK-SIZE is the size of the disk to -;;; move. START-Y must be less than END-Y. - -(defun slide-down (start-y end-y x disk-size) - (multiple-value-bind (number-moves pixels-left) - (truncate (- end-y start-y) *vertical-velocity*) - (do ((x (- x disk-size)) - (width (* disk-size 2)) - (old-y start-y (+ old-y *vertical-velocity*)) - (new-y (+ start-y *vertical-velocity*) (+ new-y *vertical-velocity*)) - (number-moves number-moves (1- number-moves))) - ((zerop number-moves) - (when (plusp pixels-left) - (invert-rectangle x (+ old-y pixels-left) disk-thickness width) - (invert-rectangle x old-y disk-thickness width) - (update-screen))) - ;; Loop body writes disk at new height & erases at old height. - (invert-rectangle X old-y disk-thickness width) - (invert-rectangle X new-y disk-thickness width) - (update-screen)))) - - -;;;; Lifting and Droping Disks - -;;; Lift-disk pops the top disk off of needle and raises it up to the -;;; transfer height. The disk is returned. - -(defun lift-disk (needle) - "Pops the top disk off of NEEDLE, Lifts it above the needle, & returns it." - (let* ((height (needle-top-height needle)) - (disk (pop (needle-disk-stack needle)))) - (slide-up height - *transfer-height* - (needle-position needle) - (disk-size disk)) - disk)) - -;;; Drop-disk drops a disk positioned over needle at the transfer height -;;; onto needle. The disk is pushed onto needle. - -(defun drop-disk (disk needle) - "DISK must be positioned above NEEDLE. It is dropped onto NEEDLE." - (push disk (needle-disk-stack needle)) - (slide-down *transfer-height* - (needle-top-height needle) - (needle-position needle) - (disk-size disk)) - t) - - -;;; Drop-initial-disk is the same as drop-disk except that the disk is -;;; drawn once before dropping. - -(defun drop-initial-disk (disk needle) - "DISK must be positioned above NEEDLE. It is dropped onto NEEDLE." - (let* ((size (disk-size disk)) - (lx (- (needle-position needle) size))) - (invert-rectangle lx *transfer-height* disk-thickness (* size 2)) - (push disk (needle-disk-stack needle)) - (slide-down *transfer-height* - (needle-top-height needle) - (needle-position needle) - (disk-size disk)) - t)) - - -;;;; Sliding Disks Right and Left - -;;; Slide-Right slides the image of a disk located at START-X, Y to the -;;; position END-X, Y. DISK-SIZE is the size of the disk. START-X is -;;; less than END-X. - -(defun slide-right (start-x end-x Y disk-size) - (multiple-value-bind (number-moves pixels-left) - (truncate (- end-x start-x) *horizontal-velocity*) - (do ((right-x (+ start-x disk-size) (+ right-x *horizontal-velocity*)) - (left-x (- start-x disk-size) (+ left-x *horizontal-velocity*)) - (number-moves number-moves (1- number-moves))) - ((zerop number-moves) - (when (plusp pixels-left) - (invert-rectangle right-x Y disk-thickness pixels-left) - (invert-rectangle left-x Y disk-thickness pixels-left) - (update-screen))) - ;; Loop body adds chunk *horizontal-velocity* pixels wide to right - ;; side of disk, then chops off left side. - (invert-rectangle right-x Y disk-thickness *horizontal-velocity*) - (invert-rectangle left-x Y disk-thickness *horizontal-velocity*) - (update-screen)))) - -;;; Slide-Left is the same as Slide-Right except that START-X is greater -;;; than END-X. - -(defun slide-left (start-x end-x Y disk-size) - (multiple-value-bind (number-moves pixels-left) - (truncate (- start-x end-x) *horizontal-velocity*) - (do ((right-x (- (+ start-x disk-size) *horizontal-velocity*) - (- right-x *horizontal-velocity*)) - (left-x (- (- start-x disk-size) *horizontal-velocity*) - (- left-x *horizontal-velocity*)) - (number-moves number-moves (1- number-moves))) - ((zerop number-moves) - (when (plusp pixels-left) - (setq left-x (- (+ left-x *horizontal-velocity*) pixels-left)) - (setq right-x (- (+ right-x *horizontal-velocity*) pixels-left)) - (invert-rectangle left-x Y disk-thickness pixels-left) - (invert-rectangle right-x Y disk-thickness pixels-left) - (update-screen))) - ;; Loop body adds chunk *horizontal-velocity* pixels wide to left - ;; side of disk, then chops off right side. - (invert-rectangle left-x Y disk-thickness *horizontal-velocity*) - (invert-rectangle right-x Y disk-thickness *horizontal-velocity*) - (update-screen)))) - - -;;;; Transferring Disks - -;;; Transfer disk slides a disk at the transfer height from a position -;;; over START-NEEDLE to a position over END-NEEDLE. Modified disk is -;;; returned. - -(defun transfer-disk (disk start-needle end-needle) - "Moves DISK from a position over START-NEEDLE to a position over END-NEEDLE." - (let ((start (needle-position start-needle)) - (end (needle-position end-needle))) - (if (< start end) - (slide-right start end *transfer-height* (disk-size disk)) - (slide-left start end *transfer-height* (disk-size disk))) - disk)) - - -;;; Move-One-Disk moves the top disk from START-NEEDLE to END-NEEDLE. - -(defun move-one-disk (start-needle end-needle) - "Moves the disk on top of START-NEEDLE to the top of END-NEEDLE." - (drop-disk (transfer-disk (lift-disk start-needle) - start-needle - end-needle) - end-needle) - (sleep *delay*) - t) - -;;; Move-N-Disks moves the top N disks from START-NEEDLE to END-NEEDLE -;;; obeying the rules of the towers of hannoi problem. To move the -;;; disks, a third needle, TEMP-NEEDLE, is needed for temporary storage. - -(defun move-n-disks (n start-needle end-needle temp-needle) - "Moves the top N disks from START-NEEDLE to END-NEEDLE. - Uses TEMP-NEEDLE for temporary storage." - (cond ((= n 1) - (move-one-disk start-needle end-needle)) - (t - (move-n-disks (1- n) start-needle temp-needle end-needle) - (move-one-disk start-needle end-needle) - (move-n-disks (1- n) temp-needle end-needle start-needle))) - t) - - -;;;; Hanoi itself. - -(defun hanoi (window n) - (multiple-value-bind (width height) (full-window-state window) - (declare (ignore width)) - (let* ((*hanoi-window* window) - (*hanoi-window-height* height) - (*transfer-height* (- height (* disk-spacing n))) - (*hanoi-gcontext* (xlib:create-gcontext :drawable *hanoi-window* - :foreground *white-pixel* - :background *black-pixel* - :fill-style :solid - :function boole-c2))) - (xlib:clear-area *hanoi-window*) - (xlib:display-force-output *display*) - (let ((needle-1 (make-needle :position 184)) - (needle-2 (make-needle :position 382)) - (needle-3 (make-needle :position 584))) - (setf (needle-disk-stack needle-1) ()) - (setf (needle-disk-stack needle-2) ()) - (setf (needle-disk-stack needle-3) ()) - (do ((n n (1- n)) - (available-disks available-disks (cdr available-disks))) - ((zerop n)) - (drop-initial-disk (car available-disks) needle-1)) - (move-n-disks n needle-1 needle-3 needle-2) - t)))) - -;;; Change the names of these when the DEMO loop isn't so stupid. -;;; -(defdemo slow-hanoi-demo "Slow-towers-of-Hanoi" (&optional (how-many 4)) - 0 100 768 300 - "Solves the Towers of Hanoi problem before your very eyes." - (let ((*horizontal-velocity* 3) - (*vertical-velocity* 1)) - (hanoi *window* how-many))) -;;; -(defdemo fast-hanoi-demo "Fast-towers-of-Hanoi" (&optional (how-many 7)) - 0 100 768 300 - "Solves the Towers of Hanoi problem before your very eyes." - (hanoi *window* how-many)) - - - -;;;; Bounce window. - -;;; BOUNCE-WINDOW takes a window and seemingly drops it to the bottom of -;;; the screen. Optionally, the window can have an initial x velocity, -;;; screen border elasticity, and gravity value. The outer loop is -;;; entered the first time with the window at its initial height, but -;;; each iteration after this, the loop starts with the window at the -;;; bottom of the screen heading upward. The inner loop, except for the -;;; first execution, carries the window up until the negative velocity -;;; becomes positive, carrying the window down to bottom when the -;;; velocity is positive. Due to number lossage, ROUND'ing and -;;; TRUNC'ing when the velocity gets so small will cause the window to -;;; head upward with the same velocity over two iterations which will -;;; cause the window to bounce forever, so we have prev-neg-velocity and -;;; number-problems to check for this. This is not crucial with the x -;;; velocity since the loop terminates as a function of the y velocity. -;;; -(defun bounce-window (window &optional - (x-velocity 0) (elasticity 0.85) (gravity 2)) - (unless (< 0 elasticity 1) - (error "Elasticity must be between 0 and 1.")) - (unless (plusp gravity) - (error "Gravity must be positive.")) - (multiple-value-bind (width height x y mapped) (full-window-state window) - (when (eq mapped :viewable) - (let ((top-of-window-at-bottom (- (xlib:drawable-height *root*) height)) - (left-of-window-at-right (- (xlib:drawable-width *root*) width)) - (y-velocity 0) - (prev-neg-velocity most-negative-fixnum) - (number-problems nil)) - (declare (fixnum top-of-window-at-bottom left-of-window-at-right - y-velocity)) - (loop - (when (= prev-neg-velocity 0) (return t)) - (let ((negative-velocity (minusp y-velocity))) - (loop - (let ((next-y (+ y y-velocity)) - (next-y-velocity (+ y-velocity gravity))) - (declare (fixnum next-y next-y-velocity)) - (when (> next-y top-of-window-at-bottom) - (cond - (number-problems - (setf y-velocity (incf prev-neg-velocity))) - (t - (setq y-velocity - (- (truncate (* elasticity y-velocity)))) - (when (= y-velocity prev-neg-velocity) - (incf y-velocity) - (setf number-problems t)) - (setf prev-neg-velocity y-velocity))) - (setf y top-of-window-at-bottom) - (setf (xlib:drawable-x window) x - (xlib:drawable-y window) y) - (xlib:display-force-output *display*) - (return)) - (setq y-velocity next-y-velocity) - (setq y next-y) - (sleep (/ *delay* 100))) - (when (and negative-velocity (>= y-velocity 0)) - (setf negative-velocity nil)) - (let ((next-x (+ x x-velocity))) - (declare (fixnum next-x)) - (when (or (> next-x left-of-window-at-right) - (< next-x 0)) - (setq x-velocity (- (truncate (* elasticity x-velocity))))) - (setq x next-x)) - (setf (xlib:drawable-x window) x - (xlib:drawable-y window) y) - (xlib:display-force-output *display*)))))))) - -;;; Change the name of this when DEMO is not so stupid. -;;; -(defdemo shove-bounce-demo "Shove-bounce" () - 100 100 300 300 - "Drops the demo window with an inital X velocity which bounces off - screen borders." - (bounce-window *window* 3)) - -(defdemo bounce-demo "Bounce" () - 100 100 300 300 - "Drops the demo window which bounces off screen borders." - (bounce-window *window*)) - - -;;;; Recurrence Demo - -;;; Copyright (C) 1988 Michael O. Newton (newton@csvax.caltech.edu) - -;;; Permission is granted to any individual or institution to use, copy, -;;; modify, and distribute this software, provided that this complete -;;; copyright and permission notice is maintained, intact, in all copies and -;;; supporting documentation. - -;;; The author provides this software "as is" without express or -;;; implied warranty. - -;;; This routine plots the recurrence -;;; x <- y(1+sin(0.7x)) - 1.2(|x|)^.5 -;;; y <- .21 - x -;;; As described in a ?? 1983 issue of the Mathematical Intelligencer - -(defun recurrence (display window &optional (point-count 10000)) - (let ((gc (xlib:create-gcontext :drawable window - :background *white-pixel* - :foreground *black-pixel*))) - (multiple-value-bind (width height) (full-window-state window) - (xlib:clear-area window) - (draw-ppict window gc point-count 0.0 0.0 (* width 0.5) (* height 0.5)) - (xlib:display-finish-output display) - (sleep 1)) - (xlib:free-gcontext gc))) - -;;; Draw points. X assumes points are in the range of width x height, -;;; with 0,0 being upper left and 0,H being lower left. -;;; hw and hh are half-width and half-height of screen - -(defun draw-ppict (win gc count x y hw hh) - "Recursively draw pretty picture" - (unless (zerop count) - (let ((xf (floor (* (+ 1.0 x) hw ))) ;These lines center the picture - (yf (floor (* (+ 0.7 y) hh )))) - (xlib:draw-point win gc xf yf) - (draw-ppict win gc (1- count) - (- (* y (1+ (sin (* 0.7 x)))) (* 1.2 (sqrt (abs x)))) - (- 0.21 x) - hw - hh)))) - -(defdemo recurrence-demo "Recurrence" () - 10 10 700 700 - "Plots a cool recurrence relation." - (recurrence *display* *window*)) - - -;;;; Plaid - -;;; -;;; Translated from the X11 Plaid Demo written in C by Christopher Hoover. -;;; - -(defmacro rect-x (rects n) - `(svref ,rects (ash ,n 2))) -(defmacro rect-y (rects n) - `(svref ,rects (+ (ash ,n 2) 1))) -(defmacro rect-width (rects n) - `(svref ,rects (+ (ash ,n 2) 2))) -(defmacro rect-height (rects n) - `(svref ,rects (+ (ash ,n 2) 3))) - -(defun plaid (display window &optional (num-iterations 10000) (num-rectangles 10)) - (let ((gcontext (xlib:create-gcontext :drawable window - :function boole-c2 - :plane-mask (logxor *white-pixel* - *black-pixel*) - :background *black-pixel* - :foreground *white-pixel* - :fill-style :solid)) - (rectangles (make-array (* 4 num-rectangles) - :element-type 'number - :initial-element 0))) - (multiple-value-bind (width height) (full-window-state window) - (let ((center-x (ash width -1)) - (center-y (ash height -1)) - (x-dir -2) - (y-dir -2) - (x-off 2) - (y-off 2)) - (dotimes (iter (truncate num-iterations num-rectangles)) - (dotimes (i num-rectangles) - (setf (rect-x rectangles i) (- center-x x-off)) - (setf (rect-y rectangles i) (- center-y y-off)) - (setf (rect-width rectangles i) (ash x-off 1)) - (setf (rect-height rectangles i) (ash y-off 1)) - (incf x-off x-dir) - (incf y-off y-dir) - (when (or (<= x-off 0) (>= x-off center-x)) - (decf x-off (ash x-dir 1)) - (setf x-dir (- x-dir))) - (when (or (<= y-off 0) (>= y-off center-y)) - (decf y-off (ash y-dir 1)) - (setf y-dir (- y-dir)))) - (xlib:draw-rectangles window gcontext rectangles t) - (sleep *delay*) - (xlib:display-force-output display)))) - (xlib:free-gcontext gcontext))) - -(defdemo plaid-demo "Plaid" (&optional (iterations 10000) (num-rectangles 10)) - 10 10 101 201 - "Plaid, man." - (plaid *display* *window* iterations num-rectangles)) - - -;;;; Bball demo - -;;; -;;; Ported to CLX by Blaine Burks -;;; - -(defvar *ball-size-x* 36) -(defvar *ball-size-y* 34) - -(defun xor-ball (pixmap window gcontext x y) - (xlib:copy-plane pixmap gcontext 1 - 0 0 - *ball-size-x* *ball-size-y* - window - x y)) - -(defconstant bball-gravity 1) -(defconstant maximum-x-drift 7) - -(defvar *max-bball-x*) -(defvar *max-bball-y*) - -(defstruct ball - (x (random (- *max-bball-x* *ball-size-x*))) - (y (random (- *max-bball-y* *ball-size-y*))) - (dx (if (zerop (random 2)) (random maximum-x-drift) - (- (random maximum-x-drift)))) - (dy 0)) - -(defun get-bounce-image () - "Returns the pixmap to be bounced around the screen." - (xlib::bitmap-image #*000000000000000000000000000000000000 - #*000000000000000000000000000000000000 - #*000000000000000000001000000010000000 - #*000000000000000000000000000100000000 - #*000000000000000000000100001000000000 - #*000000000000000010000000010000000000 - #*000000000000000000100010000000000000 - #*000000000000000000001000000000000000 - #*000000000001111100000000000101010000 - #*000000000010000011000111000000000000 - #*000000000100000000111000000000000000 - #*000000000100000000000000000100000000 - #*000000000100000000001000100010000000 - #*000000111111100000010000000001000000 - #*000000111111100000100000100000100000 - #*000011111111111000000000000000000000 - #*001111111111111110000000100000000000 - #*001111111111111110000000000000000000 - #*011111111111111111000000000000000000 - #*011111111111111111000000000000000000 - #*111111111111110111100000000000000000 - #*111111111111111111100000000000000000 - #*111111111111111101100000000000000000 - #*111111111111111101100000000000000000 - #*111111111111111101100000000000000000 - #*111111111111111111100000000000000000 - #*111111111111110111100000000000000000 - #*011111111111111111000000000000000000 - #*011111111111011111000000000000000000 - #*001111111111111110000000000000000000 - #*001111111111111110000000000000000000 - #*000011111111111000000000000000000000 - #*000000111111100000000000000000000000 - #*000000000000000000000000000000000000)) - - -(defun bounce-1-ball (pixmap window gcontext ball) - (let ((x (ball-x ball)) - (y (ball-y ball)) - (dx (ball-dx ball)) - (dy (ball-dy ball))) - (xor-ball pixmap window gcontext x y) - (setq x (+ x dx)) - (setq y (+ y dy)) - (if (or (< x 0) (> x (- *max-bball-x* *ball-size-x*))) - (setq x (- x dx) - dx (- dx))) - (if (> y (- *max-bball-y* *ball-size-y*)) - (setq y (- y dy) - dy (- dy))) - (setq dy (+ dy bball-gravity)) - (setf (ball-x ball) x) - (setf (ball-y ball) y) - (setf (ball-dx ball) dx) - (setf (ball-dy ball) dy) - (xor-ball pixmap window gcontext x y))) - -(defun bounce-balls (display window how-many duration) - (xlib:clear-area window) - (xlib:display-finish-output display) - (multiple-value-bind (*max-bball-x* *max-bball-y*) (full-window-state window) - (let* ((balls (do ((i 0 (1+ i)) - (list () (cons (make-ball) list))) - ((= i how-many) list))) - (gcontext (xlib:create-gcontext :drawable window - :foreground *white-pixel* - :background *black-pixel* - :function boole-xor - :exposures :off)) - (bounce-pixmap (xlib:create-pixmap :width 38 :height 34 :depth 1 - :drawable window)) - (pixmap-gc (xlib:create-gcontext :drawable bounce-pixmap - :foreground *white-pixel* - :background *black-pixel*))) - (xlib:put-image bounce-pixmap pixmap-gc (get-bounce-image) - :x 0 :y 0 :width 38 :height 34) - (xlib:free-gcontext pixmap-gc) - (dolist (ball balls) - (xor-ball bounce-pixmap window gcontext (ball-x ball) (ball-y ball))) - (xlib:display-finish-output display) - (dotimes (i duration) - (dolist (ball balls) - (bounce-1-ball bounce-pixmap window gcontext ball) - (xlib:display-finish-output display)) - (sleep (/ *delay* 50.0))) - (xlib:free-pixmap bounce-pixmap) - (xlib:free-gcontext gcontext)))) - -(defdemo bouncing-ball-demo "Bouncing-Ball" (&optional (how-many 5) (duration 500)) - 36 34 700 500 - "Bouncing balls in space." - (bounce-balls *display* *window* how-many duration)) + with quit-requested = nil + with items of-type list = (xlib::menu-item-alist menu) + until quit-requested do + (xlib:event-case (*display* :timeout 0.01 :force-output-p t) + (:destroy-notify + (event-window) + (when (xlib:window-equal event-window menu-window) + (setf quit-requested t) + t)) + (:exposure + (event-window count) + (when (xlib:window-equal event-window menu-window) + (locally (declare (type xlib:card8 count)) + ;; Only refresh on final exposure event + (when (zerop count) + (xlib::menu-refresh menu))) + t)) + (:button-release + (event-window) + (let ((item-name (second (assoc event-window items)))) + (when item-name + (if (string-equal "Quit" item-name) + (setf quit-requested t) + (let ((demo (find item-name + *demos* + :key #'demo-name + :test #'string-equal))) + (start-in-thread + (lambda () (funcall (demo-function demo))) + (demo-name demo)))))) + t) + (:enter-notify + (window) + (locally (declare (type xlib:window window)) + (let ((position (position window items :key #'first))) + (when position + (xlib::menu-highlight-item menu position)))) + t) + (:leave-notify + (window) + (locally (declare (type xlib:window window)) + (let ((position (position window items :key #'first))) + (when position + (xlib::menu-unhighlight-item menu position)))) + t) + (otherwise + () + t)))))) + +#+nil +(demo) diff --git a/demo/greynetic.lisp b/demo/greynetic.lisp new file mode 100644 index 0000000..2a44b86 --- /dev/null +++ b/demo/greynetic.lisp @@ -0,0 +1,133 @@ +(defpackage #:xlib-demo/greynetic + (:use :common-lisp :xlib :xlib-demo/demos) + (:export #:greynetic)) + +(in-package :xlib-demo/greynetic) + +(defvar *pixmaps* nil) + +(defun make-random-bitmap () + (let ((bitmap-data (make-array '(32 32) :initial-element 0 + :element-type 'xlib::bit))) + (dotimes (i 4) + (declare (fixnum i)) + (let ((nibble (random 16))) + (setf nibble (logior nibble (ash nibble 4)) + nibble (logior nibble (ash nibble 8)) + nibble (logior nibble (ash nibble 12)) + nibble (logior nibble (ash nibble 16))) + (dotimes (j 32) + (let ((bit (if (logbitp j nibble) 1 0))) + (setf (aref bitmap-data i j) bit + (aref bitmap-data (+ 4 i) j) bit + (aref bitmap-data (+ 8 i) j) bit + (aref bitmap-data (+ 12 i) j) bit + (aref bitmap-data (+ 16 i) j) bit + (aref bitmap-data (+ 20 i) j) bit + (aref bitmap-data (+ 24 i) j) bit + (aref bitmap-data (+ 28 i) j) bit))))) + bitmap-data)) + +(defun make-random-pixmap () + (let ((image (xlib:create-image :depth 1 :data (make-random-bitmap)))) + (make-pixmap image 32 32))) + +(defun make-pixmap (image width height) + (let* ((pixmap (xlib:create-pixmap :width width :height height + :depth 1 :drawable *root*)) + (gc (xlib:create-gcontext :drawable pixmap + :background *black-pixel* + :foreground *white-pixel*))) + (xlib:put-image pixmap gc image :x 0 :y 0 :width width :height height) + (xlib:free-gcontext gc) + pixmap)) + + +;;; +;;; This function returns one of the pixmaps in the *pixmaps* array. +(defun greynetic-pixmapper () + (aref *pixmaps* (random (length *pixmaps*)))) + +(defun greynetic (&optional (duration 300)) + (with-x11-context () + (let* ((window (create-window + :parent (screen-root *screen*) + :x 100 :y 100 :width 600 :height 600 + :background *black-pixel*)) + (depth (xlib:drawable-depth window)) + (draw-gcontext (xlib:create-gcontext :drawable window + :foreground *white-pixel* + :background *black-pixel*)) + ;; Need a random state per process. + (*random-state* (make-random-state t)) + (*pixmaps* (let ((pixmap-array (make-array 30))) + (dotimes (i 30) + (setf (aref pixmap-array i) (make-random-pixmap))) + pixmap-array))) + (xlib:set-wm-properties window :name "Greynetic") + (xlib:map-window window) + (xlib:display-force-output *display*) + (unwind-protect + (multiple-value-bind (width height) (full-window-state window) + (declare (fixnum width height)) + (let ((border-x (truncate width 20)) + (border-y (truncate height 20))) + (declare (fixnum border-x border-y)) + (dotimes (i duration) + (let ((pixmap (greynetic-pixmapper))) + (xlib:with-gcontext (draw-gcontext + :foreground (random (ash 1 depth)) + :background (random (ash 1 depth)) + :stipple pixmap + :fill-style + :opaque-stippled) + (cond ((zerop (mod i 500)) + (xlib:clear-area window) + (sleep .1)) + (t + (sleep (/ *delay* 20)))) + (if (< (random 3) 2) + (let* ((w (+ border-x + (truncate (* (random (- width + (* 2 border-x))) + (random width)) + width))) + (h (+ border-y + (truncate (* (random (- height + (* 2 border-y))) + (random height)) + height))) + (x (random (- width w))) + (y (random (- height h)))) + (declare (fixnum w h x y)) + (if (zerop (random 2)) + (xlib:draw-rectangle window draw-gcontext + x y w h t) + (xlib:draw-arc window draw-gcontext + x y w h 0 (* 2 pi) t))) + (let ((p1-x (+ border-x + (random (- width (* 2 border-x))))) + (p1-y (+ border-y + (random (- height (* 2 border-y))))) + (p2-x (+ border-x + (random (- width (* 2 border-x))))) + (p2-y (+ border-y + (random (- height (* 2 border-y))))) + (p3-x (+ border-x + (random (- width (* 2 border-x))))) + (p3-y (+ border-y + (random (- height (* 2 border-y)))))) + (declare (fixnum p1-x p1-y p2-x p2-y p3-x p3-y)) + (xlib:draw-lines window draw-gcontext + (list p1-x p1-y p2-x p2-y p3-x p3-y) + :relative-p nil + :fill-p t + :shape :convex))) + (xlib:display-force-output *display*)))))) + (dotimes (i (length *pixmaps*)) + (xlib:free-pixmap (aref *pixmaps* i))) + (xlib:free-gcontext draw-gcontext))))) + + +(push (make-demo :name "Greynetic" :function #'greynetic) *demos*) + diff --git a/demo/hanoi.lisp b/demo/hanoi.lisp new file mode 100644 index 0000000..0ec738c --- /dev/null +++ b/demo/hanoi.lisp @@ -0,0 +1,272 @@ +(defpackage #:xlib-demo/hanoi + (:use :common-lisp :xlib :xlib-demo/demos) + (:export #:hanoi)) + +(in-package :xlib-demo/hanoi) + +;;;; Hanoi. + +;;; Random parameters: + +(defparameter *disk-height* 15 + "The height of a disk in pixels.") +(defparameter *disk-spacing* (+ *disk-height* 3) + "The amount of vertical space used by a disk on a needle.") +(defvar *horizontal-velocity* 20 + "The speed at which disks slide sideways.") +(defvar *vertical-velocity* 12 + "The speed at which disks move up and down.") + +;;; These variables are bound by the main function. + +(defvar *hanoi-window* nil + "The window that Hanoi is happening on.") +(defvar *hanoi-window-height* nil + "The height of the viewport Hanoi is happening on.") +(defvar *transfer-height* nil + "The height at which disks are transferred.") +(defvar *hanoi-gcontext* nil + "The graphics context for Hanoi under X11.") + +;;; Needle Functions + +(defstruct disk + half-width) + +(defstruct needle + position + (disk-stack ())) + +(defun needle-top-height (needle) + "Returns the height of the top disk on NEEDLE." + (- *hanoi-window-height* + (* *disk-spacing* (length (the list (needle-disk-stack needle)))))) + +;;; Graphic interface abstraction: + +(defmacro invert-rectangle (x y half-width height) + "Calls the CLX function draw-rectangle with FILL-P set to T." + `(xlib:draw-rectangle *hanoi-window* *hanoi-gcontext* + ,x ,y ,half-width ,height t)) + +(defmacro update-screen () + "Forces the display output." + `(xlib:display-force-output *display*)) + + +;;;; Moving disks up and down + +(defun slide-up (start-y end-y x disk-half-width) + "Slides the image of a disk up from the coordinates (X, START-Y) to the +point (X, END-Y). DISK-HALF-WIDTH is the half-width of the disk to move. START-Y +must be greater than END-Y." + (multiple-value-bind (number-moves pixels-left) + (truncate (- start-y end-y) *vertical-velocity*) + (do ((x (- x disk-half-width)) + (width (* disk-half-width 2)) + (old-y start-y (- old-y *vertical-velocity*)) + (new-y (- start-y *vertical-velocity*) (- new-y *vertical-velocity*)) + (number-moves number-moves (1- number-moves))) + ((zerop number-moves) + (when (plusp pixels-left) + (invert-rectangle x (- old-y pixels-left) width *disk-height*) + (invert-rectangle x old-y width *disk-height*) + (update-screen))) + ;; Loop body writes disk at new height & erases at old height. + (invert-rectangle x old-y width *disk-height*) + (invert-rectangle x new-y width *disk-height*) + (update-screen) + (sleep (/ *delay* 100))))) + +(defun slide-down (start-y end-y x disk-half-width) + "Slides the image of a disk down from the coordinates (X, START-Y) to the +point (X, END-Y). DISK-HALF-WIDTH is the half-width of the disk to move. START-Y +must be less than END-Y." + (multiple-value-bind (number-moves pixels-left) + (truncate (- end-y start-y) *vertical-velocity*) + (do ((x (- x disk-half-width)) + (width (* disk-half-width 2)) + (old-y start-y (+ old-y *vertical-velocity*)) + (new-y (+ start-y *vertical-velocity*) (+ new-y *vertical-velocity*)) + (number-moves number-moves (1- number-moves))) + ((zerop number-moves) + (when (plusp pixels-left) + (invert-rectangle x (+ old-y pixels-left) width *disk-height*) + (invert-rectangle x old-y width *disk-height*) + (update-screen))) + ;; Loop body writes disk at new height & erases at old height. + (invert-rectangle X old-y width *disk-height*) + (invert-rectangle X new-y width *disk-height*) + (update-screen) + (sleep (/ *delay* 100))))) + + +;;;; Lifting and Droping Disks + +(defun lift-disk (needle) + "Pops the top disk off of needle and raises it up to the transfer height. +The disk is returned." + (let* ((height (needle-top-height needle)) + (disk (pop (needle-disk-stack needle)))) + (slide-up height + *transfer-height* + (needle-position needle) + (disk-half-width disk)) + disk)) + +(defun drop-disk (disk needle) + "Drops DISK positioned over NEEDLE at the transfer height onto NEEDLE. +DISK is pushed onto NEEDLE disk stack." + (push disk (needle-disk-stack needle)) + (slide-down *transfer-height* + (needle-top-height needle) + (needle-position needle) + (disk-half-width disk)) + t) + + +(defun drop-initial-disk (disk needle) + "The function is the same as DROP-DISK except that the disk is drawn once +before dropping." + (let* ((half-width (disk-half-width disk)) + (lx (- (needle-position needle) half-width))) + (invert-rectangle lx *transfer-height* (* half-width 2) *disk-height*) + (push disk (needle-disk-stack needle)) + (slide-down *transfer-height* + (needle-top-height needle) + (needle-position needle) + (disk-half-width disk)) + t)) + + +;;;; Sliding Disks Right and Left + +(defun slide-right (start-x end-x Y disk-half-width) + "Slides the image of a disk located at (START-X, Y) to the position +(END-X, Y). DISK-HALF-WIDTH is the half-width of the disk. START-X is +less than END-X." + (multiple-value-bind (number-moves pixels-left) + (truncate (- end-x start-x) *horizontal-velocity*) + (do ((right-x (+ start-x disk-half-width) (+ right-x *horizontal-velocity*)) + (left-x (- start-x disk-half-width) (+ left-x *horizontal-velocity*)) + (number-moves number-moves (1- number-moves))) + ((zerop number-moves) + (when (plusp pixels-left) + (invert-rectangle right-x Y pixels-left *disk-height*) + (invert-rectangle left-x Y pixels-left *disk-height*) + (update-screen))) + ;; Loop body adds chunk *horizontal-velocity* pixels wide to right + ;; side of disk, then chops off left side. + (invert-rectangle right-x Y *horizontal-velocity* *disk-height*) + (invert-rectangle left-x Y *horizontal-velocity* *disk-height*) + (update-screen) + (sleep (/ *delay* 100))))) + +(defun slide-left (start-x end-x Y disk-half-width) + "The same as SLIDE-RIGHT except that START-X is greater than END-X." + (multiple-value-bind (number-moves pixels-left) + (truncate (- start-x end-x) *horizontal-velocity*) + (do ((right-x (- (+ start-x disk-half-width) *horizontal-velocity*) + (- right-x *horizontal-velocity*)) + (left-x (- (- start-x disk-half-width) *horizontal-velocity*) + (- left-x *horizontal-velocity*)) + (number-moves number-moves (1- number-moves))) + ((zerop number-moves) + (when (plusp pixels-left) + (setq left-x (- (+ left-x *horizontal-velocity*) pixels-left)) + (setq right-x (- (+ right-x *horizontal-velocity*) pixels-left)) + (invert-rectangle left-x Y pixels-left *disk-height*) + (invert-rectangle right-x Y pixels-left *disk-height*) + (update-screen))) + ;; Loop body adds chunk *horizontal-velocity* pixels wide to left + ;; side of disk, then chops off right side. + (invert-rectangle left-x Y *horizontal-velocity* *disk-height*) + (invert-rectangle right-x Y *horizontal-velocity* *disk-height*) + (update-screen) + (sleep (/ *delay* 100))))) + + +;;;; Transferring Disks + +(defun transfer-disk (disk start-needle end-needle) + "Slides a disk at the transfer height from a position over START-NEEDLE +to a position over END-NEEDLE. Modified disk is returned." + "Moves DISK from a position over START-NEEDLE to a position over END-NEEDLE." + (let ((start (needle-position start-needle)) + (end (needle-position end-needle))) + (if (< start end) + (slide-right start end *transfer-height* (disk-half-width disk)) + (slide-left start end *transfer-height* (disk-half-width disk))) + disk)) + + +(defun move-one-disk (start-needle end-needle) + "Moves the top disk from START-NEEDLE to END-NEEDLE." + "Moves the disk on top of START-NEEDLE to the top of END-NEEDLE." + (drop-disk (transfer-disk (lift-disk start-needle) + start-needle + end-needle) + end-needle) + t) + +(defun move-n-disks (n start-needle end-needle temp-needle) + "Moves the top N disks from START-NEEDLE to END-NEEDLE obeying the rules +of the towers of hannoi problem. To move the disks, a third needle, +TEMP-NEEDLE, is needed for temporary storage." + (cond ((= n 1) + (move-one-disk start-needle end-needle)) + (t + (move-n-disks (1- n) start-needle temp-needle end-needle) + (move-one-disk start-needle end-needle) + (move-n-disks (1- n) temp-needle end-needle start-needle))) + t) + + +;;;; Hanoi itself. + +(defun hanoi (n title x y width height) + (with-x11-context () + (let ((window (create-window + :parent (screen-root *screen*) + :x x :y y :width width :height height + :background *white-pixel*))) + (multiple-value-bind (width height) (full-window-state window) + (declare (ignore width)) + (let* ((*hanoi-window* window) + (*hanoi-window-height* height) + (*transfer-height* (- height (* *disk-spacing* n) 100)) + (*hanoi-gcontext* + (xlib:create-gcontext :drawable *hanoi-window* + :foreground *white-pixel* + :fill-style :solid + :function boole-xor))) + (xlib:set-wm-properties *hanoi-window* :name title) + (xlib:clear-area *hanoi-window*) + (xlib:map-window *hanoi-window*) + (xlib:display-force-output *display*) + (let ((needle-1 (make-needle :position 184)) + (needle-2 (make-needle :position 382)) + (needle-3 (make-needle :position 584))) + (do ((n n (1- n))) + ((zerop n)) + (sleep *delay*) + (drop-initial-disk (make-disk :half-width (* n 10)) needle-1)) + (sleep *delay*) + (move-n-disks n needle-1 needle-3 needle-2) + (sleep *delay*) + t)))))) + +(push (make-demo + :name "Slow towers of Hanoi" + :function (lambda () + (let ((*horizontal-velocity* 3) + (*vertical-velocity* 1)) + (hanoi 4 "Slow towers of Hanoi" 0 100 768 300)))) + *demos*) + +(push (make-demo + :name "Fast towers of Hanoi" + :function (lambda () + (hanoi 7 "Fast towers of Hanoi" 100 200 768 300))) + *demos*) + diff --git a/demo/hello-world.lisp b/demo/hello-world.lisp new file mode 100644 index 0000000..8654f3d --- /dev/null +++ b/demo/hello-world.lisp @@ -0,0 +1,62 @@ +(defpackage #:xlib-demo/hello-world + (:use :common-lisp :xlib :xlib-demo/demos) + (:export #:hello-world)) + +(in-package :xlib-demo/hello-world) + +(defun hello-world () + (with-x11-context () + (let* ((string "Hello, World!") + (border 1) ; Minimum margin around the text + (width (+ (text-width *font* string) (* 2 border))) + (height (+ (max-char-ascent *font*) + (max-char-descent *font*) + (* 2 border))) + (x (truncate (- (screen-width *screen*) width) 2)) + (y (truncate (- (screen-height *screen*) height) 2)) + (window (create-window + :parent (screen-root *screen*) + :x x :y y :width width :height height + :background *black-pixel* + :border *white-pixel* + :border-width 1 + :colormap (screen-default-colormap *screen*) + :bit-gravity :center + :event-mask '(:exposure :button-press))) + (gcontext (create-gcontext :drawable window + :background *black-pixel* + :foreground *white-pixel* + :font *font*))) + ;; Set window manager hints + (set-wm-properties window + :name 'hello-world + :icon-name string + :resource-name string + :resource-class 'hello-world + ;; :command (list 'hello-world) + :x x :y y :width width :height height + :min-width width :min-height height + :input :off :initial-state :normal) + (map-window window) ; Map the window + ;; Handle events + (event-case (*display* :discard-p t :force-output-p t) + (exposure ;; Come here on exposure events + (window count) + (locally (declare (type xlib:card8 count)) + (when (zerop count) ;; Ignore all but the last exposure event + (with-state (window) + (let ((x (truncate (- (drawable-width window) width) 2)) + (y (truncate (- (+ (drawable-height window) + (max-char-ascent *font*)) + (max-char-descent *font*)) + 2))) + ;; Draw text centered in widnow + (clear-area window) + (draw-glyphs window gcontext x y string))) + ;; Returning non-nil causes event-case to exit + nil))) + ;; Pressing any mouse-button exits + (button-press () t))))) + +(push (make-demo :name "Hello, World!" :function #'hello-world) + *demos*) diff --git a/demo/hello.lisp b/demo/hello.lisp deleted file mode 100644 index a3fbd88..0000000 --- a/demo/hello.lisp +++ /dev/null @@ -1,65 +0,0 @@ -;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*- - -(in-package :xlib) - -(defun hello-world (host &rest args &key (string "Hello World") (font "fixed")) - ;; CLX demo, says STRING using FONT in its own window on HOST - (let ((display nil) - (abort t)) - (unwind-protect - (progn - (setq display (open-display host)) - (multiple-value-prog1 - (let* ((screen (display-default-screen display)) - (black (screen-black-pixel screen)) - (white (screen-white-pixel screen)) - (font (open-font display font)) - (border 1) ; Minimum margin around the text - (width (+ (text-width font string) (* 2 border))) - (height (+ (max-char-ascent font) (max-char-descent font) (* 2 border))) - (x (truncate (- (screen-width screen) width) 2)) - (y (truncate (- (screen-height screen) height) 2)) - (window (create-window :parent (screen-root screen) - :x x :y y :width width :height height - :background black - :border white - :border-width 1 - :colormap (screen-default-colormap screen) - :bit-gravity :center - :event-mask '(:exposure :button-press))) - (gcontext (create-gcontext :drawable window - :background black - :foreground white - :font font))) - ;; Set window manager hints - (set-wm-properties window - :name 'hello-world - :icon-name string - :resource-name string - :resource-class 'hello-world - :command (list* 'hello-world host args) - :x x :y y :width width :height height - :min-width width :min-height height - :input :off :initial-state :normal) - (map-window window) ; Map the window - ;; Handle events - (event-case (display :discard-p t :force-output-p t) - (exposure ;; Come here on exposure events - (window count) - (when (zerop count) ;; Ignore all but the last exposure event - (with-state (window) - (let ((x (truncate (- (drawable-width window) width) 2)) - (y (truncate (- (+ (drawable-height window) - (max-char-ascent font)) - (max-char-descent font)) - 2))) - ;; Draw text centered in widnow - (clear-area window) - (draw-glyphs window gcontext x y string))) - ;; Returning non-nil causes event-case to exit - nil)) - (button-press () t))) ;; Pressing any mouse-button exits - (setq abort nil))) - ;; Ensure display is closed when done - (when display - (close-display display :abort abort))))) diff --git a/demo/petal.lisp b/demo/petal.lisp new file mode 100644 index 0000000..a5caea4 --- /dev/null +++ b/demo/petal.lisp @@ -0,0 +1,160 @@ +(defpackage #:xlib-demo/petal + (:use :common-lisp :xlib :xlib-demo/demos) + (:export #:petal)) + +(in-package :xlib-demo/petal) + + +;;; Fast sine constants: + +(defconstant d360 #o5500) +(defconstant d270 #o4160) +(defconstant d180 #o2640) +(defconstant d90 #o1320) +(defconstant vecmax 2880) + +(defparameter sin-array + '#(#o0 #o435 #o1073 #o1531 #o2166 #o2623 #o3260 + #o3714 #o4350 #o5003 #o5435 #o6066 #o6516 #o7145 + #o7573 #o10220 #o10644 #o11266 #o11706 #o12326 + #o12743 #o13357 #o13771 #o14401 #o15007 #o15414 + #o16016 #o16416 #o17013 #o17407 #o20000 #o20366 + #o20752 #o21333 #o21711 #o22265 #o22636 #o23204 + #o23546 #o24106 #o24443 #o24774 #o25323 #o25645 + #o26165 #o26501 #o27011 #o27316 #o27617 #o30115 + #o30406 #o30674 #o31156 #o31434 #o31706 #o32154 + #o32416 #o32654 #o33106 #o33333 #o33554 #o33771 + #o34202 #o34406 #o34605 #o35000 #o35167 #o35351 + #o35526 #o35677 #o36043 #o36203 #o36336 #o36464 + #o36605 #o36721 #o37031 #o37134 #o37231 #o37322 + #o37407 #o37466 #o37540 #o37605 #o37646 #o37701 + #o37730 #o37751 #o37766 #o37775 #o40000)) + +(defmacro psin (val) + `(let* ((val ,val) + neg + frac + sinlo) + (if (>= val d180) + (setq neg t + val (- val d180))) + (if (>= val d90) + (setq val (- d180 val))) + (setq frac (logand val 7)) + (setq val (ash val -3)) + ;; + (setq sinlo (if (>= val 90) + (svref sin-array 90) + (svref sin-array val))) + ;; + (if (< val 90) + (setq sinlo + (+ sinlo (ash (* frac (- (svref sin-array (1+ val)) sinlo)) + -3)))) + ;; + (if neg + (- sinlo) + sinlo))) + +(defmacro pcos (x) + `(let ((tmp (- ,x d270))) + (psin (if (minusp tmp) (+ tmp d360) tmp)))) + + +;;;; Miscellaneous petal hackery. + +(defmacro high-16bits-* (a b) + `(let ((a-h (ash ,a -8)) + (b-h (ash ,b -8))) + (+ (* a-h b-h) + (ash (* a-h (logand ,b 255)) -8) + (ash (* b-h (logand ,a 255)) -8)))) + +(defun complete (style petal) + (let ((repnum 1) + factor cntval needed) + (dotimes (i 3) + (case i + (0 (setq factor 2 cntval 6)) + (1 (setq factor 3 cntval 2)) + (2 (setq factor 5 cntval 1))) + (do () + ((or (minusp cntval) (not (zerop (rem style factor))))) + (setq repnum (* repnum factor)) + (setq cntval (1- cntval)) + (setq style (floor style factor)))) + (setq needed (floor vecmax repnum)) + (if (and (not (oddp needed)) (oddp petal)) (floor needed 2) needed))) + + +;;;; Petal Parameters and Petal itself + +(defparameter continuous t) +(defparameter styinc 2) +(defparameter petinc 1) +(defparameter scalfac-fac 8192) + +(defun petal (&optional (how-many 10) (style 0) (petal 0)) + (with-x11-context () + (let* ((width 512) + (height 512) + (petal-window (create-window + :parent (screen-root *screen*) + :x 200 :y 200 :width width :height height + :background *white-pixel*))) + (xlib:set-wm-properties petal-window + :name "Petal: flower-like display") + (xlib:map-window petal-window) + (xlib:clear-area petal-window) + (xlib:display-force-output *display*) + (let ((veccnt 0) + (nustyle 722) + (nupetal 3) + (scalfac (1+ (floor scalfac-fac (min width height)))) + (ctrx (floor width 2)) + (ctry (floor height 2)) + (tt 0) + (s 0) + (lststyle 0) + (lstpetal 0) + (petstyle 0) + (vectors 0) + (r 0) + (x1 0) + (y1 0) + (x2 0) + (y2 0) + (i 0) + (gc (xlib:create-gcontext :drawable petal-window + :foreground *black-pixel* + :background *white-pixel* + :line-width 0 :line-style :solid))) + (loop + (when (zerop veccnt) + (setq tt 0 s 0 lststyle style lstpetal petal petal nupetal + style nustyle petstyle (rem (* petal style) d360) + vectors (complete style petal)) + (when continuous + (setq nupetal (+ nupetal petinc) + nustyle (+ nustyle styinc))) + (when (or (/= lststyle style) (/= lstpetal petal)) + (xlib:clear-area petal-window) + (xlib:display-force-output *display*))) + (when (or (/= lststyle style) (/= lstpetal petal)) + (setq veccnt (1+ veccnt) i veccnt x1 x2 y1 y2 + tt (rem (+ tt style) d360) + s (rem (+ s petstyle) d360) + r (pcos s)) + (setq x2 (+ ctrx (floor (high-16bits-* (pcos tt) r) scalfac)) + y2 (+ ctry (floor (high-16bits-* (psin tt) r) scalfac))) + (when (/= i 1) + (xlib:draw-line petal-window gc x1 y1 x2 y2) + (xlib:display-force-output *display*))) + (when (> veccnt vectors) + (setq veccnt 0) + (setq how-many (1- how-many)) + (sleep 2) + (when (zerop how-many) (return)))))))) + +(push (make-demo :name "Petal" :function #'petal) *demos*) + diff --git a/demo/plaid.lisp b/demo/plaid.lisp new file mode 100644 index 0000000..84d3ce9 --- /dev/null +++ b/demo/plaid.lisp @@ -0,0 +1,73 @@ +(defpackage #:xlib-demo/plaid + (:use :common-lisp :xlib :xlib-demo/demos) + (:export #:plaid)) + +(in-package :xlib-demo/plaid) + + + +;;;; Plaid + +;;; +;;; Translated from the X11 Plaid Demo written in C by Christopher Hoover. +;;; + +(defmacro rect-x (rects n) + `(svref ,rects (ash ,n 2))) +(defmacro rect-y (rects n) + `(svref ,rects (+ (ash ,n 2) 1))) +(defmacro rect-width (rects n) + `(svref ,rects (+ (ash ,n 2) 2))) +(defmacro rect-height (rects n) + `(svref ,rects (+ (ash ,n 2) 3))) + +(defun plaid (&optional (num-iterations 10000) (num-rectangles 10)) + (with-x11-context () + (let* ((window (create-window + :parent (screen-root *screen*) + :x 10 :y 10 :width 700 :height 700 + :background *white-pixel*)) + (gcontext (xlib:create-gcontext :drawable window + :function boole-c2 + :plane-mask (logxor *white-pixel* + *black-pixel*) + :background *black-pixel* + :foreground *white-pixel* + :fill-style :solid)) + (rectangles (make-array (* 4 num-rectangles) + :element-type 'number + :initial-element 0))) + (xlib:set-wm-properties window :name "Plaid") + (xlib:map-window window) + (do ((attempts 0 (1+ attempts))) + ((or (eq (xlib:window-map-state window) :viewable) + (>= attempts 100))) ; wait 1 sec before giving up + (sleep 0.01)) + (multiple-value-bind (width height) (full-window-state window) + (let ((center-x (ash width -1)) + (center-y (ash height -1)) + (x-dir -2) + (y-dir -2) + (x-off 2) + (y-off 2)) + (dotimes (iter (truncate num-iterations num-rectangles)) + (dotimes (i num-rectangles) + (setf (rect-x rectangles i) (- center-x x-off)) + (setf (rect-y rectangles i) (- center-y y-off)) + (setf (rect-width rectangles i) (ash x-off 1)) + (setf (rect-height rectangles i) (ash y-off 1)) + (incf x-off x-dir) + (incf y-off y-dir) + (when (or (<= x-off 0) (>= x-off center-x)) + (decf x-off (ash x-dir 1)) + (setf x-dir (- x-dir))) + (when (or (<= y-off 0) (>= y-off center-y)) + (decf y-off (ash y-dir 1)) + (setf y-dir (- y-dir)))) + (xlib:draw-rectangles window gcontext rectangles t) + (sleep *delay*) + (xlib:display-force-output *display*)))) + (xlib:free-gcontext gcontext)))) + +(push (make-demo :name "Plaid" :function #'plaid) *demos*) + diff --git a/demo/qix.lisp b/demo/qix.lisp new file mode 100644 index 0000000..ca301b2 --- /dev/null +++ b/demo/qix.lisp @@ -0,0 +1,115 @@ +(defpackage #:xlib-demo/qix + (:use :common-lisp :xlib :xlib-demo/demos) + (:export #:qix)) + +(in-package :xlib-demo/qix) + +(defstruct qix + buffer + (dx1 5) + (dy1 10) + (dx2 10) + (dy2 5)) + +(defun construct-qix (length) + (let ((qix (make-qix))) + (setf (qix-buffer qix) (make-circular-list length)) + qix)) + +(defun make-circular-list (length) + (let ((l (make-list length))) + (rplacd (last l) l))) + + +(defun qix (&optional (lengths '(30 30)) (duration 2000)) + "Each length is the number of lines to put in a qix, and that many qix + (of the correct size) are put up on the screen. Lets the qix wander around + the screen for Duration steps." + (with-x11-context () + (let ((window (create-window + :parent (screen-root *screen*) + :x 0 :y 0 :width 700 :height 700 + :background *white-pixel*)) + (histories (mapcar #'construct-qix lengths))) + (xlib:set-wm-properties window + :name "Qix: hypnotic wandering lines") + (xlib:map-window window) + (xlib:display-force-output *display*) + (multiple-value-bind (width height) (full-window-state window) + (declare (fixnum width height)) + (xlib:clear-area window) + (xlib:display-force-output *display*) + (do ((h histories (cdr h)) + (l lengths (cdr l))) + ((null h)) + (do ((x (qix-buffer (car h)) (cdr x)) + (i 0 (1+ i))) + ((= i (car l))) + (rplaca x (make-array 4)))) + ;; Start each qix at a random spot on the screen. + (dolist (h histories) + (let ((x (random width)) + (y (random height))) + (rplaca (qix-buffer h) + (make-array 4 :initial-contents (list x y x y))))) + (rplacd (last histories) histories) + (let ((x1 0) (y1 0) (x2 0) (y2 0) + (dx1 0) (dy1 0) (dx2 0) (dy2 0) + tem line next-line qix + (gc (xlib:create-gcontext :drawable window + :foreground *white-pixel* + :background *black-pixel* + :line-width 0 :line-style :solid + :function boole-c2))) + (declare (fixnum x1 y1 x2 y2 dx1 dy1 dx2 dy2)) + (dotimes (i duration) + ;; Line is the next line in the next qix. Rotate this qix and + ;; the qix ring. + (setq qix (car histories)) + (setq line (car (qix-buffer qix))) + (setq next-line (cadr (qix-buffer qix))) + (setf (qix-buffer qix) (cdr (qix-buffer qix))) + (setq histories (cdr histories)) + (setf x1 (svref line 0)) + (setf y1 (svref line 1)) + (setf x2 (svref line 2)) + (setf y2 (svref line 3)) + (xlib:draw-line window gc x1 y1 x2 y2) + (setq dx1 (- (+ (qix-dx1 qix) (random 3)) 1)) + (setq dy1 (- (+ (qix-dy1 qix) (random 3)) 1)) + (setq dx2 (- (+ (qix-dx2 qix) (random 3)) 1)) + (setq dy2 (- (+ (qix-dy2 qix) (random 3)) 1)) + (cond ((> dx1 10) (setq dx1 10)) + ((< dx1 -10) (setq dx1 -10))) + (cond ((> dy1 10) (setq dy1 10)) + ((< dy1 -10) (setq dy1 -10))) + (cond ((> dx2 10) (setq dx2 10)) + ((< dx2 -10) (setq dx2 -10))) + (cond ((> dy2 10) (setq dy2 10)) + ((< dy2 -10) (setq dy2 -10))) + (cond ((or (>= (setq tem (+ x1 dx1)) width) (minusp tem)) + (setq dx1 (- dx1)))) + (cond ((or (>= (setq tem (+ x2 dx2)) width) (minusp tem)) + (setq dx2 (- dx2)))) + (cond ((or (>= (setq tem (+ y1 dy1)) height) (minusp tem)) + (setq dy1 (- dy1)))) + (cond ((or (>= (setq tem (+ y2 dy2)) height) (minusp tem)) + (setq dy2 (- dy2)))) + (setf (qix-dy2 qix) dy2) + (setf (qix-dx2 qix) dx2) + (setf (qix-dy1 qix) dy1) + (setf (qix-dx1 qix) dx1) + ` (when (svref next-line 0) + (xlib:draw-line window gc + (svref next-line 0) (svref next-line 1) + (svref next-line 2) (svref next-line 3))) + (setf (svref next-line 0) (+ x1 dx1)) + (setf (svref next-line 1) (+ y1 dy1)) + (setf (svref next-line 2) (+ x2 dx2)) + (setf (svref next-line 3) (+ y2 dy2)) + (xlib:display-force-output *display*) + (sleep (/ *delay* 100)))))))) + + +(push (make-demo :name "Qix" :function #'qix) *demos*) + diff --git a/demo/recurrence.lisp b/demo/recurrence.lisp new file mode 100644 index 0000000..7bcf886 --- /dev/null +++ b/demo/recurrence.lisp @@ -0,0 +1,65 @@ +(defpackage #:xlib-demo/recurrence + (:use :common-lisp :xlib :xlib-demo/demos) + (:export #:recurrence)) + +(in-package :xlib-demo/recurrence) + + + +;;;; Recurrence Demo + +;;; Copyright (C) 1988 Michael O. Newton (newton@csvax.caltech.edu) + +;;; Permission is granted to any individual or institution to use, copy, +;;; modify, and distribute this software, provided that this complete +;;; copyright and permission notice is maintained, intact, in all copies and +;;; supporting documentation. + +;;; The author provides this software "as is" without express or +;;; implied warranty. + +;;; This routine plots the recurrence +;;; x <- y(1+sin(0.7x)) - 1.2(|x|)^.5 +;;; y <- .21 - x +;;; As described in a ?? 1983 issue of the Mathematical Intelligencer + +(defun recurrence (&optional (point-count 10000)) + (with-x11-context () + (let* ((window (create-window + :parent (screen-root *screen*) + :x 10 :y 10 :width 700 :height 700 + :background *white-pixel*)) + (gc (xlib:create-gcontext :drawable window + :background *white-pixel* + :foreground *black-pixel*))) + (xlib:set-wm-properties window :name "Recurrence") + (xlib:map-window window) + (do ((attempts 0 (1+ attempts))) + ((or (eq (xlib:window-map-state window) :viewable) + (>= attempts 100))) ; wait 1 sec before giving up + (sleep 0.01)) + (multiple-value-bind (width height) (full-window-state window) + (xlib:clear-area window) + (draw-ppict window gc point-count 0.0 0.0 (* width 0.5) (* height 0.5)) + (xlib:display-finish-output *display*) + (sleep 1)) + (xlib:free-gcontext gc)))) + +;;; Draw points. X assumes points are in the range of width x height, +;;; with 0,0 being upper left and 0,H being lower left. +;;; hw and hh are half-width and half-height of screen + +(defun draw-ppict (win gc count x y hw hh) + "Recursively draw pretty picture" + (unless (zerop count) + (let ((xf (floor (* (+ 1.0 x) hw ))) ; These lines center the picture + (yf (floor (* (+ 0.7 y) hh )))) + (xlib:draw-point win gc xf yf) + (draw-ppict win gc (1- count) + (- (* y (1+ (sin (* 0.7 x)))) (* 1.2 (sqrt (abs x)))) + (- 0.21 x) + hw + hh)))) + +(push (make-demo :name "Recurrence" :function #'recurrence) *demos*) +