Refactor Demos

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

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*)
+

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*)