Commit 7883fdb1 authored by rtoy's avatar rtoy

Merge portable-clx (2009-06-16) to main branch. Tested by running

src/contrib/games/feebs and hemlock which works (in non-unicode
builds).
parent 8f28c28f
$Id: CHANGES,v 1.6 2007/08/21 15:49:27 fgilham Exp $
$Id: CHANGES,v 1.7 2009/06/17 18:22:45 rtoy Rel $
Details of changes since R5:
......
-*- Text -*-
$Id: NEWS,v 1.2 2009/06/11 16:03:56 rtoy Exp $
$Id: NEWS,v 1.3 2009/06/17 18:22:45 rtoy Rel $
-- Changes in telent CLX 0.7.3, Tue Mar 28 2006 ---
Support for Allegro CL (6.2 and later) (Mikel Evins)
Latin 1 keysyms (Christophe Rhodes)
Some protocol fixes (Douglas Crosher)
Define a RENDER-OP type (Douglas Crosher)
Define a RENDER-OP typ (Douglas Crosher)
--- Changes in SBCL CLX 0.7.2, Tue Jan 10 2006 ---
......@@ -56,7 +56,7 @@ has been included in demo/clipboard.lisp
Bug fix: change the sizes of certain fields in a WM-SIZE-HINT to be 32
bits wide, as per the ICCCM specifications. Fixes a problem seen with
the MacOS X11 window manager, that uses very large hint values.
the MacOS X11 window manger, that uses very large hint values.
(Patch from Eric Marsden)
Bug fix: +POINTER-EVENT-MASK-VECTOR+ is supposed to be a vector of
......@@ -69,7 +69,7 @@ Bug fix: xrender now compiles properly when *DEF-CLX-CLASS-USE-DEFCLASS*
A change in the implementation of PROCESS-BLOCK and PROCESS-WAKEUP
under multithreaded SBCL. Previous versions used queues and condition
variables, but this seems to have undesirable performance
variables, but this seems to have undesireable performance
characteristics; the newer version uses a polling loop calling
sched_yield() inside, which greatly improves responsiveness, but is
more CPU-hungry (as perceived by top(1), at least; in theory it
......@@ -150,7 +150,7 @@ Implement CLX MP dependencies for SBCL: HOLDING-LOCK, PROCESS-BLOCK, etc
Many bug fixes
* asking for text extents on uncached fonts could potentially deadlock
* asking for text extents on unchached fonts could potentially deadlock
http://article.gmane.org/gmane.lisp.clx.devel/16
* lots of compiler warnings, style-warnings, notes cleared up
......@@ -160,5 +160,6 @@ Style and ANSI cleanups
* Much renaming of constants from *foo* to +foo+
* Change old-style COMPILE LOAD EVAL to new-style :COMPILE-TOPLEVEL
:LOAD-TOPLEVEL :EXECUTE in EVAL-WHENs.
* Change old-style COMPILE LOAD EVAL to new-style :COMPILE-TOPLEVEL
:LOAD-TOPLEVEL :EXECUTE in EVAL-WHENs.
$Id: README,v 1.5 2009/06/11 16:03:56 rtoy Exp $
$Id: README,v 1.6 2009/06/17 18:22:45 rtoy Rel $
This directory contains CLX, an X11 client library for Common
Lisp. The code was originally taken from a CMUCL distribution, was
modified somewhat in order to make it compile and run under SBCL, then
......@@ -38,7 +38,7 @@ your bug has been fixed already.
darcs get http://verisons.telent.net/clx # version from which releases are made
http://common-lisp.net/~crhodes/clx # patches merged by Christophe
http://monday-monkey.com/repos/clx/ # OpenMCL tree by Bryan O'Connor?
http://monday-monkey.com/repos/clx/ # OpenMCL tree by bryan o'connor?
= Building using asdf-install
......
$Id: README-R5,v 1.1 2007/08/21 15:49:27 fgilham Exp $
$Id: README-R5,v 1.2 2009/06/17 18:22:45 rtoy Rel $
Original CLX README, retained for historical information
---
......
......@@ -41,7 +41,7 @@
;;; the new drawable. The caches are initialized to NIL and allocated as needed.
#+cmu
(ext:file-comment "$Id: attributes.lisp,v 1.7 2007/08/21 15:49:27 fgilham Exp $")
(ext:file-comment "$Id: attributes.lisp,v 1.8 2009/06/17 18:22:45 rtoy Rel $")
(in-package :xlib)
......@@ -69,14 +69,14 @@
(defmacro state-geometry-changes (state) `(fifth ,state))
(defmacro drawable-equal-function ()
(if (member 'drawable +clx-cached-types+)
''eq ;; Allows the compiler to use the microcoded ASSQ primitive on LISPM's
''drawable-equal))
;; Since drawables are not always cached, we must use drawable-equal
;; to determine equality.
''drawable-equal)
(defmacro window-equal-function ()
(if (member 'window +clx-cached-types+)
''eq
''drawable-equal))
;; Since windows are not always cached, we must use window-equal
;; to determine equality.
''window-equal)
(defmacro with-state ((drawable) &body body)
;; Allows a consistent view to be obtained of data returned by GetWindowAttributes
......@@ -498,8 +498,13 @@
(declare (clx-values (or null colormap)))
(with-attributes (window :sizes 32)
(let ((id (resource-id-get 28)))
(if (zerop id) nil
(lookup-colormap (window-display window) id)))))
(if (zerop id)
nil
(let ((colormap (lookup-colormap (window-display window) id)))
(unless (colormap-visual-info colormap)
(setf (colormap-visual-info colormap)
(visual-info (window-display window) (resource-id-get 8))))
colormap)))))
(defun set-window-colormap (window colormap)
(change-window-attribute
......
......@@ -13,7 +13,7 @@
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#+cmu
(ext:file-comment "$Id: big-requests.lisp,v 1.1 2007/08/21 15:49:27 fgilham Exp $")
(ext:file-comment "$Id: big-requests.lisp,v 1.2 2009/06/17 18:22:45 rtoy Rel $")
(in-package "XLIB")
......
......@@ -50,7 +50,7 @@
;; request won't be left after aborts (e.g. control-abort on a lispm).
#+cmu
(ext:file-comment "$Id: buffer.lisp,v 1.9 2007/08/21 15:49:27 fgilham Exp $")
(ext:file-comment "$Id: buffer.lisp,v 1.10 2009/06/17 18:22:45 rtoy Rel $")
(in-package :xlib)
......
......@@ -20,7 +20,7 @@
;;;
#+cmu
(ext:file-comment "$Id: bufmac.lisp,v 1.5 2007/08/21 15:49:27 fgilham Exp $")
(ext:file-comment "$Id: bufmac.lisp,v 1.6 2009/06/17 18:22:45 rtoy Rel $")
(in-package :xlib)
......
;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*-
#+cmu
(ext:file-comment "$Id: build-clx.lisp,v 1.4 2007/08/21 15:49:27 fgilham Exp $")
(ext:file-comment "$Id: build-clx.lisp,v 1.5 2009/06/17 18:22:45 rtoy Rel $")
;;; Load this file if you want to compile CLX in its entirety.
(proclaim '(optimize (speed 3) (safety 1) (space 1)
......
......@@ -2,7 +2,7 @@
;;;(common-lisp:use-package (list :common-lisp))
#+cmu
(ext:file-comment "$Id: clx-module.lisp,v 1.1 2007/08/21 15:49:27 fgilham Exp $")
(ext:file-comment "$Id: clx-module.lisp,v 1.2 2009/06/17 18:22:45 rtoy Rel $")
(provide :clx)
(load "clx:defsystem.lisp")
......
;;; -*- Lisp -*- mode
;;; Original copyright message from defsystem.lisp:
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Portions Copyright (C) 1987 Texas Instruments Incorporated.
;;; Portions Copyright (C) 1988, 1989 Franz Inc, Berkeley, Ca.
;;;
;;; 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.
;;;
;;; Texas Instruments Incorporated provides this software "as is"
;;; without express or implied warranty.
;;;
;;; Franz Incorporated provides this software "as is" without express
;;; or implied warranty.
(defpackage :clx-system (:use :cl :asdf))
(in-package :clx-system)
(pushnew :clx-ansi-common-lisp *features*)
(defclass clx-source-file (cl-source-file) ())
(defclass xrender-source-file (clx-source-file) ())
;;; CL-SOURCE-FILE, not CLX-SOURCE-FILE, so that we're not accused of
;;; cheating by rebinding *DERIVE-FUNCTION-TYPES* :-)
(defclass example-source-file (cl-source-file) ())
(defclass legacy-file (static-file) ())
(defsystem CLX
:depends-on (#+sbcl sb-bsd-sockets)
:version "0.7.2"
:serial t
:default-component-class clx-source-file
:components
((:file "package")
(:file "depdefs")
(:file "clx")
#-(or openmcl allegro) (:file "dependent")
#+openmcl (:file "dep-openmcl")
#+allegro (:file "dep-allegro")
(:file "macros")
(:file "bufmac")
(:file "buffer")
(:file "display")
(:file "gcontext")
(:file "input")
(:file "requests")
(:file "fonts")
(:file "graphics")
(:file "text")
(:file "attributes")
(:file "translate")
(:file "keysyms")
(:file "manager")
(:file "image")
(:file "resource")
#+allegro
(:file "excldep" :pathname "excldep.lisp")
(:module extensions
:pathname #.(make-pathname :directory '(:relative))
:components
((:file "shape")
(:file "big-requests")
(:file "xvidmode")
(:xrender-source-file "xrender")
(:file "glx")
(:file "gl" :depends-on ("glx"))
(:file "dpms")
(:file "xtest")
(:file "screensaver")
(:file "xinerama")))
(:module demo
:default-component-class example-source-file
:components
((:file "bezier")
;; KLUDGE: this requires "bezier" for proper operation,
;; but we don't declare that dependency here, because
;; asdf doesn't load example files anyway.
(:file "beziertest")
(:file "clclock")
(:file "clipboard")
(:file "clx-demos")
(:file "gl-test")
;; FIXME: compiling this generates 30-odd spurious code
;; deletion notes. Find out why, and either fix or
;; workaround the problem.
(:file "mandel")
(:file "menu")
(:file "zoid")))
(:module test
:default-component-class example-source-file
:components
((:file "image")
;; KLUDGE: again, this depends on "zoid"
(:file "trapezoid")))
(:static-file "NEWS")
(:static-file "CHANGES")
(:static-file "README")
(:static-file "README-R5")
(:legacy-file "exclMakefile")
(:legacy-file "exclREADME")
(:legacy-file "exclcmac" :pathname "exclcmac.lisp")
(:legacy-file "excldepc" :pathname "excldep.c")
(:legacy-file "sockcl" :pathname "sockcl.lisp")
(:legacy-file "socket" :pathname "socket.c")
(:legacy-file "defsystem" :pathname "defsystem.lisp")
(:legacy-file "provide" :pathname "provide.lisp")
(:legacy-file "cmudep" :pathname "cmudep.lisp")
(:module manual
;; TODO: teach asdf how to process texinfo files
:components ((:static-file "clx.texinfo")))
(:module debug
:default-component-class legacy-file
:components
((:file "debug" :pathname "debug.lisp")
(:file "describe" :pathname "describe.lisp")
(:file "event-test" :pathname "event-test.lisp")
(:file "keytrans" :pathname "keytrans.lisp")
(:file "trace" :pathname "trace.lisp")
(:file "util" :pathname "util.lisp")))))
(defmethod perform ((o load-op) (f example-source-file))
;; do nothing. We want to compile them when CLX is compiled, but
;; not load them when CLX is loaded.
t)
#+sbcl
(defmethod perform :around ((o compile-op) (f xrender-source-file))
;; RENDER would appear to be an inherently slow protocol; further,
;; it's not set in stone, and consequently we care less about speed
;; than we do about correctness.
(handler-bind ((sb-ext:compiler-note #'muffle-warning))
(call-next-method)))
#+sbcl
(defmethod perform :around ((o compile-op) (f clx-source-file))
;; our CLX library should compile without WARNINGs, and ideally
;; without STYLE-WARNINGs. Since it currently does, let's enforce
;; it here so that we can catch regressions easily.
(let ((on-warnings (operation-on-warnings o))
(on-failure (operation-on-failure o)))
(unwind-protect
(progn
(setf (operation-on-warnings o) :error
(operation-on-failure o) :error)
;; a variety of accessors, such as AREF-CARD32, are not
;; declared INLINE. Without this (non-ANSI)
;; static-type-inference behaviour, SBCL emits an extra 100
;; optimization notes (roughly one fifth of all of the
;; notes emitted). Since the internals are unlikely to
;; change much, and certainly the internals should stay in
;; sync, enabling this extension is a win. (Note that the
;; use of this does not imply that applications using CLX
;; calls that expand into calls to these accessors will be
;; optimized in the same way).
(let ((sb-ext:*derive-function-types* t)
(sadx (find-symbol "STACK-ALLOCATE-DYNAMIC-EXTENT" :sb-c))
(sadx-var (find-symbol "*STACK-ALLOCATE-DYNAMIC-EXTENT*" :sb-ext)))
;; deeply unportable stuff, this. I will be shot. We
;; want to enable the dynamic-extent declarations in CLX.
(when (and sadx (sb-c::policy-quality-name-p sadx))
;; no way of setting it back short of yet more yukky stuff
(proclaim `(optimize (,sadx 3))))
(if sadx-var
(progv (list sadx-var) (list t)
(call-next-method))
(call-next-method))))
(setf (operation-on-warnings o) on-warnings
(operation-on-failure o) on-failure))))
#+sbcl
(defmethod perform :around (o (f clx-source-file))
;; SBCL signals an error if DEFCONSTANT is asked to redefine a
;; constant unEQLly. For CLX's purposes, however, we are defining
;; structured constants (lists and arrays) not for EQLity, but for
;; the purposes of constant-folding operations such as (MEMBER FOO
;; +BAR+), so it is safe to abort the redefinition provided the
;; structured data is sufficiently equal.
(handler-bind
((sb-ext:defconstant-uneql
(lambda (c)
;; KLUDGE: this really means "don't warn me about
;; efficiency of generic array access, please"
(declare (optimize (sb-ext:inhibit-warnings 3)))
(let ((old (sb-ext:defconstant-uneql-old-value c))
(new (sb-ext:defconstant-uneql-new-value c)))
(typecase old
(list (when (equal old new) (abort c)))
(string (when (and (typep new 'string)
(string= old new))
(abort c)))
(simple-vector
(when (and (typep new 'simple-vector)
(= (length old) (length new))
(every #'eql old new))
(abort c)))
(array
(when (and (typep new 'array)
(equal (array-dimensions old)
(array-dimensions new))
(equal (array-element-type old)
(array-element-type new))
(dotimes (i (array-total-size old) t)
(unless (eql (row-major-aref old i)
(row-major-aref new i))
(return nil))))
(abort c))))))))
(call-next-method)))
......@@ -77,7 +77,7 @@
;;; progress. Bug reports should be addressed to bug-clx@expo.lcs.mit.edu.
#+cmu
(ext:file-comment "$Id: clx.lisp,v 1.15 2007/08/21 15:49:27 fgilham Exp $")
(ext:file-comment "$Id: clx.lisp,v 1.16 2009/06/17 18:22:45 rtoy Rel $")
;; Note: all of the following is in the package XLIB.
......@@ -829,19 +829,18 @@
(getf (font-properties font) name))
(macrolet ((make-mumble-equal (type)
;; When cached, EQ works fine, otherwise test resource id's and displays
;; Since caching is only done for objects created by the
;; client, we must always compare ID and display for
;; non-identical mumbles.
(let ((predicate (xintern type '-equal))
(id (xintern type '-id))
(dpy (xintern type '-display)))
(if (member type +clx-cached-types+)
`(within-definition (,type make-mumble-equal)
(declaim (inline ,predicate))
(defun ,predicate (a b) (eq a b)))
`(within-definition (,type make-mumble-equal)
(defun ,predicate (a b)
(declare (type ,type a b))
(and (= (,id a) (,id b))
(eq (,dpy a) (,dpy b)))))))))
`(within-definition (,type make-mumble-equal)
(defun ,predicate (a b)
(declare (type ,type a b))
(or (eql a b)
(and (= (,id a) (,id b))
(eq (,dpy a) (,dpy b)))))))))
(make-mumble-equal window)
(make-mumble-equal pixmap)
(make-mumble-equal cursor)
......
......@@ -21,7 +21,7 @@
;;; Created 04/09/87 14:30:41 by LaMott G. OREN
#+cmu
(ext:file-comment "$Id: debug.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $")
(ext:file-comment "$Id: debug.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $")
(in-package :xlib)
......
......@@ -21,7 +21,7 @@
;;; Created 07/15/87 by LaMott G. OREN
#cmu
(ext:file-comment "$Id: describe.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $")
(ext:file-comment "$Id: describe.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $")
(in-package :xlib)
......@@ -79,7 +79,7 @@
(string8
(format t " Bytes:~%~v@t" margin)
(dotimes (k (- length (- j start)))
(format t "~a" (code-char (card8-get j)))
(format t "~a" (int-char (card8-get j)))
(incf j)))
(otherwise
(format t " Bytes:~%~v@t" margin)
......
......@@ -3,7 +3,7 @@
;;; This code was intended for CLUE. --FMG
#+cmu
(ext:file-comment "$Id: event-test.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $")
(ext:file-comment "$Id: event-test.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $")
(defpackage "XTEST"
(:use :xlib :common-lisp)
......
......@@ -19,22 +19,22 @@
;;;
#+cmu
(ext:file-comment "$Id: keytrans.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $")
(ext:file-comment "$Id: keytrans.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $")
(in-package :xlib)
(defun list-missing-keysyms ()
;; Lists explorer characters which have no keysyms
(dotimes (i 256)
(unless (character->keysyms (code-char i))
(format t "~%(define-keysym ~@c ~d)" (code-char i) i))))
(unless (character->keysyms (int-char i))
(format t "~%(define-keysym ~@c ~d)" (int-char i) i))))
(defun list-multiple-keysyms ()
;; Lists characters with more than one keysym
(dotimes (i 256)
(when (cdr (character->keysyms (code-char i)))
(format t "~%Character ~@c [~d] has keysyms" (code-char i) i)
(dolist (keysym (character->keysyms (code-char i)))
(when (cdr (character->keysyms (int-char i)))
(format t "~%Character ~@c [~d] has keysyms" (int-char i) i)
(dolist (keysym (character->keysyms (int-char i)))
(format t " ~d ~d" (ldb (byte 8 8) keysym) (ldb (byte 8 0) keysym))))))
(defun check-lowercase-keysyms ()
......@@ -55,7 +55,7 @@
char
(and lowercase (ldb (byte 8 8) lowercase))
(and lowercase (ldb (byte 8 0) lowercase))
(code-char lowercase)
(int-char lowercase)
(ldb (byte 8 8) (char-int should-be))
(ldb (byte 8 0) (char-int should-be))
should-be)))
......
......@@ -33,7 +33,7 @@
;;; Created 09/14/87 by LaMott G. OREN
#+cmu
(ext:file-comment "$Id: trace.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $")
(ext:file-comment "$Id: trace.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $")
(in-package :xlib)
......
......@@ -21,7 +21,7 @@
;;; Created 04/09/87 14:30:41 by LaMott G. OREN
#+cmu
(ext:file-comment "$Id: util.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $")
(ext:file-comment "$Id: util.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $")
(in-package :xlib)
......@@ -148,13 +148,12 @@
;; Returns a list of windows in the order that they are printed.
(declare (arglist window)
(type window window)
(clx-values (list window)))
(values (list window)))
(let ((props (mapcar #'(lambda (prop)
(multiple-value-bind (data type format)
(get-property window prop)
(case type
(:string (setq data (map 'string #'code-char data)))
(:utf8_string (setq data (map 'string #'code-char data))))
(:string (setq data (coerce data 'string))))
(list prop format type data)))
(list-properties window)))
(result (list window)))
......
......@@ -34,7 +34,7 @@
;;; sbcl
#+cmu
(ext:file-comment "$Id: defsystem.lisp,v 1.8 2007/08/21 15:49:28 fgilham Exp $")
(ext:file-comment "$Id: defsystem.lisp,v 1.9 2009/06/17 18:22:45 rtoy Rel $")
#+(or Genera Minima sbcl ecl)
(eval-when (:compile-toplevel :load-toplevel :execute)
......
......@@ -19,7 +19,7 @@
;;;
#+cmu
(ext:file-comment "$Id: bezier.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $")
(ext:file-comment "$Id: bezier.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $")
(in-package :xlib)
......
......@@ -19,7 +19,7 @@
;;;
#+cmu
(ext:file-comment "$Id: beziertest.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $")
(ext:file-comment "$Id: beziertest.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $")
(in-package :xlib)
......@@ -60,11 +60,11 @@
;; we don't need to worry about overflows.
(let ((factor (ash (min width height) 5)))
(dotimes (i (length lines))
(setf (svref lines i)
(ash (* (svref lines i) factor) -16)))
(setf (aref lines i)
(ash (* (aref lines i) factor) -16)))
(dotimes (i (length curves))
(setf (svref curves i)
(ash (* (svref curves i) factor) -16))))
(setf (aref curves i)
(ash (* (aref curves i) factor) -16))))
(map-window win) ; Map the window
;; Handle events
......
#+cmu
(ext:file-comment "$Id: clclock.lisp,v 1.1 2007/08/21 15:49:29 fgilham Exp $")
(ext:file-comment "$Id: clclock.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $")
(defpackage "XCLCLOCK"
(:use "CL")
......
......@@ -60,7 +60,7 @@
;;; DEALINGS IN THE SOFTWARE.
#+cmu
(ext:file-comment "$Id: clipboard.lisp,v 1.1 2007/08/21 15:49:29 fgilham Exp $")
(ext:file-comment "$Id: clipboard.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $")
(defpackage "CLIPBOARD"
(:use "CL" "XLIB")
......
......@@ -7,7 +7,7 @@
;;;
#+cmu
(ext:file-comment "$Id: clx-demos.lisp,v 1.1 2007/08/21 15:49:29 fgilham Exp $")
(ext:file-comment "$Id: clx-demos.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $")
(defpackage :demos (:use :common-lisp)
(:export do-all-demos demo))
......@@ -32,17 +32,14 @@
(defvar *white-pixel* nil)
(defvar *window* nil)
(defvar *delay* .01) ; This is necessary on current hardware to make the demos run slow enough
; to actually see something.
(defmacro defdemo (fun-name demo-name args x y width height doc &rest forms)
`(progn
(defun ,fun-name ,args
,doc
(unless *display*
;; #+:cmu
;; (multiple-value-setq (*display* *screen*) (ext:open-clx-display))
#+(or cmu sbcl allegro)
#+:cmu
(multiple-value-setq (*display* *screen*) (ext:open-clx-display))
#+(or sbcl allegro clisp)
(progn
(setf *display* (xlib::open-default-display))
(setf *screen* (xlib:display-default-screen *display*)))
......@@ -174,8 +171,7 @@
(+ 4 (random (truncate width 3)))
(+ 4 (random (truncate height 3)))
t))
(xlib:display-force-output *display*)
(sleep *delay*)))
(xlib:display-force-output *display*)))
(xlib:free-gcontext gcontext)
(xlib:free-pixmap pixmap)))
......@@ -306,8 +302,7 @@
(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*))))))
(xlib:display-force-output *display*))))))
(defdemo qix-demo "Qix" (&optional (lengths '(30 30)) (duration 2000))
......@@ -519,9 +514,7 @@
,x ,y ,width ,height t))
(defmacro update-screen ()
`(progn
(xlib:display-force-output *display*)
(sleep *delay*)))
`(xlib:display-force-output *display*))
;;;; Moving disks up and down
......@@ -767,7 +760,7 @@
;;; 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))
(x-velocity 0) (elasticity 0.85) (gravity 2))
(unless (< 0 elasticity 1)
(error "Elasticity must be between 0 and 1."))
(unless (plusp gravity)
......@@ -782,43 +775,41 @@
(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*)
(sleep *delay*)
(return))
(setq y-velocity next-y-velocity)
(setq y next-y))
(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*)
(sleep *delay*))))))))
(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))