Raymond Toy pushed to branch upstream-clx at cmucl / cmucl

Commits:

5 changed files:

Changes:

  • src/clx/clx.asd
    ... ... @@ -116,7 +116,8 @@ Independent FOSS developers"
    116 116 
       :components
    117 117 
       ((:module "demo"
    118 118 
     	    :components
    119 
    -	    ((:file "bezier")
    119 
    +	    ((:file "menu")
    120 
    +             (:file "bezier")
    120 121 
     	     (:file "beziertest" :depends-on ("bezier"))
    121 122 
     	     (:file "clclock")
    122 123 
     	     (:file "clipboard")
    ... ... @@ -126,7 +127,6 @@ Independent FOSS developers"
    126 127 
     	     ;; deletion notes.  Find out why, and either fix or
    127 128 
     	     ;; workaround the problem.
    128 129 
     	     (:file "mandel")
    129 
    -	     (:file "menu")
    130 130 
     	     (:file "zoid")
    131 131 
     	     (:file "image")
    132 132 
     	     (:file "trapezoid" :depends-on ("zoid"))))))

  • src/clx/demo/clx-demos.lisp
    ... ... @@ -5,9 +5,15 @@
    5 5 
     ;;;
    6 6 
     ;;; This file should be portable to any valid Common Lisp with CLX -- DEC 88.
    7 7 
     ;;;
    8 
    +;;; CMUCL MP support by Douglas Crosher 1998.
    9 
    +;;; Enhancements including the CLX menu, rewrite of the greynetic
    10 
    +;;; demo, and other fixes by Fred Gilham 1998.
    11 
    +;;;
    12 
    +;;; Backported some changes found in CMUCL repository -- jd 2018-12-29.
    8 13
    9 
    -(defpackage #:xlib-demo/demos (:use :common-lisp)
    10 
    -  (:export do-all-demos demo))
    14 
    +(defpackage #:xlib-demo/demos
    15 
    +  (:use :common-lisp)
    16 
    +  (:export #:demo))
    11 17
    12 18 
     (in-package :xlib-demo/demos)
    13 19
    ... ... @@ -21,6 +27,7 @@
    21 27 
     ;;; it is running.
    22 28
    23 29 
     (defparameter *demos* nil)
    30 
    +(defparameter *delay* 0.5)
    24 31
    25 32 
     (defvar *display* nil)
    26 33 
     (defvar *screen* nil)
    ... ... @@ -33,105 +40,82 @@
    33 40 
       `(progn
    34 41 
          (defun ,fun-name ,args
    35 42 
            ,doc
    36 
    -       (unless *display*
    37 
    -	 #+:cmu
    38 
    -	 (multiple-value-setq (*display* *screen*) (ext:open-clx-display))
    39 
    -	 #+(or sbcl allegro clisp lispworks)
    40 
    -	 (progn
    41 
    -	   (setf *display* (xlib::open-default-display))
    42 
    -	   (setf *screen* (xlib:display-default-screen *display*)))
    43 
    -	 #-(or cmu sbcl allegro clisp lispworks)
    44 
    -	 (progn
    45 
    -	   ;; Portable method
    46 
    -	   (setf *display* (xlib:open-display (machine-instance)))
    47 
    -	   (setf *screen* (xlib:display-default-screen *display*)))
    48 
    -	 (setf *root* (xlib:screen-root *screen*))
    49 
    -	 (setf *black-pixel* (xlib:screen-black-pixel *screen*))
    50 
    -	 (setf *white-pixel* (xlib:screen-white-pixel *screen*)))
    51 
    -       (let ((*window* (xlib:create-window :parent *root*
    52 
    -					   :x ,x :y ,y
    53 
    -					   :event-mask nil
    54 
    -					   :width ,width :height ,height
    55 
    -					   :background *white-pixel*
    56 
    -					   :border *black-pixel*
    57 
    -					   :border-width 2
    58 
    -					   :override-redirect :on)))
    43 
    +       (let* ((*display* (or *display*
    44 
    +                             (xlib:open-default-display)
    45 
    +                             (xlib:open-display (machine-instance))))
    46 
    +              (*screen* (xlib:display-default-screen *display*))
    47 
    +              (*root* (xlib:screen-root *screen*))
    48 
    +              (*black-pixel* (xlib:screen-black-pixel *screen*))
    49 
    +              (*white-pixel* (xlib:screen-white-pixel *screen*))
    50 
    +              (*window* (xlib:create-window :parent *root*
    51 
    +                                            :x ,x :y ,y
    52 
    +                                            :event-mask '(:visibility-change)
    53 
    +                                            :width ,width :height ,height
    54 
    +                                            :background *white-pixel*
    55 
    +                                            :border *black-pixel*
    56 
    +                                            :border-width 2
    57 
    +                                            :override-redirect :off)))
    58 
    +         (xlib:set-wm-properties *window*
    59 
    +				 :name ,demo-name
    60 
    +				 :icon-name ,demo-name
    61 
    +				 :resource-name ,demo-name
    62 
    +				 :x ,x :y ,y :width ,width :height ,height
    63 
    +				 :user-specified-position-p t
    64 
    +				 :user-specified-size-p t
    65 
    +				 :min-width ,width :min-height ,height
    66 
    +				 :width-inc nil :height-inc nil)
    59 67 
     	 (xlib:map-window *window*)
    60 
    -	 ;;
    61 
    -	 ;; I hate to do this since this is not something any normal
    62 
    -	 ;; program should do ...
    63 
    -	 (setf (xlib:window-priority *window*) :above)
    64 
    -	 (xlib:display-finish-output *display*)
    65 
    -	 (unwind-protect
    66 
    -	      (progn ,@forms)
    67 
    -	   (xlib:unmap-window *window*)
    68 
    -	   (xlib:display-finish-output *display*))))
    68 
    +	 ;; Wait until we get mapped before doing anything.
    69 
    +         (xlib:display-finish-output *display*)
    70 
    +	 (unwind-protect (progn ,@forms)
    71 
    +           (xlib:display-finish-output *display*)
    72 
    +	   (xlib:unmap-window *window*))))
    69 73 
         (setf (get ',fun-name 'demo-name) ',demo-name)
    70 74 
         (setf (get ',fun-name 'demo-doc) ',doc)
    71 
    -    (export ',fun-name)
    72 75 
         (pushnew ',fun-name *demos*)
    73 76 
         ',fun-name))
    74 77
    75 78
    76 
    -;;;; Main entry points.
    77 
    -
    78 
    -(defun do-all-demos ()
    79 
    -  (loop
    80 
    -   (dolist (demo *demos*)
    81 
    -     (funcall demo)
    82 
    -     (sleep 3))))
    83 
    -
    84 
    -;;; DEMO is a hack to get by.  It should be based on creating a menu.  At
    85 
    -;;; that time, *name-to-function* should be deleted, since this mapping will
    86 
    -;;; be manifested in the menu slot name cross its action.  Also the
    87 
    -;;; "Shove-bounce" demo should be renamed to "Shove bounce"; likewise for
    88 
    -;;; "Fast-towers-of-Hanoi" and "Slow-towers-of-hanoi".
    89 
    -;;;
    79 
    +;;; DEMO
    90 80
    91 81 
     (defvar *name-to-function* (make-hash-table :test #'eq))
    92 82 
     (defvar *keyword-package* (find-package "KEYWORD"))
    83 
    +(defvar *demo-names* nil)
    93 84
    94 85 
     (defun demo ()
    95 
    -  (macrolet ((read-demo ()
    96 
    -	       `(let ((*package* *keyword-package*))
    97 
    -		  (read))))
    86 
    +  (let ((*demo-names* '("Quit")))
    98 87 
         (dolist (d *demos*)
    99 88 
           (setf (gethash (intern (string-upcase (get d 'demo-name))
    100 89 
     			     *keyword-package*)
    101 90 
     		     *name-to-function*)
    102 
    -	    d))
    103 
    -    (loop
    104 
    -      (fresh-line)
    105 
    -      (dolist (d *demos*)
    106 
    -	(write-string "   ")
    107 
    -	(write-line (get d 'demo-name)))
    108 
    -      (write-string "   ")
    109 
    -      (write-line "Help <demo name>")
    110 
    -      (write-string "   ")
    111 
    -      (write-line "Quit")
    112 
    -      (write-string "Enter demo name: ")
    113 
    -      (let ((demo (read-demo)))
    114 
    -	(case demo
    115 
    -	  (:help
    116 
    -	   (let* ((demo (read-demo))
    117 
    -		  (fun (gethash demo *name-to-function*)))
    118 
    -	     (fresh-line)
    119 
    -	     (if fun
    120 
    -		 (format t "~&~%~A~&~%" (get fun 'demo-doc))
    121 
    -		 (format t "Unknown demo name -- ~A." demo))))
    122 
    -	  (:quit (return t))
    123 
    -	  (t
    124 
    -	   (let ((fun (gethash demo *name-to-function*)))
    125 
    -	     (if fun
    126 
    -		 #+mp
    127 
    -		 (mp:make-process #'(lambda ()
    128 
    -				      (loop
    129 
    -				       (funcall fun)
    130 
    -				       (sleep 2)))
    131 
    -				  :name (format nil "~S" demo))
    132 
    -		 #-mp
    133 
    -		 (funcall fun)
    134 
    -		 (format t "~&~%Unknown demo name -- ~A.~&~%" demo)))))))))
    91 
    +	    d)
    92 
    +      (push (get d 'demo-name) *demo-names*))
    93 
    +
    94 
    +    (let* ((display (xlib:open-default-display))
    95 
    +           (screen (xlib:display-default-screen display))
    96 
    +           (fg-color (xlib:screen-white-pixel screen))
    97 
    +           (bg-color (xlib:screen-black-pixel screen))
    98 
    +           (nice-font (xlib:open-font display "fixed")))
    99 
    +
    100 
    +      (let ((a-menu (xlib::create-menu
    101 
    +                     (xlib::screen-root screen) ;the menu's parent
    102 
    +                     fg-color bg-color nice-font)))
    103 
    +
    104 
    +        (setf (xlib::menu-title a-menu) "Please pick your favorite demo:")
    105 
    +        (xlib::menu-set-item-list a-menu *demo-names*)
    106 
    +        (ignore-errors ;; closing window is not handled properly in menu.
    107 
    +          (unwind-protect
    108 
    +               (do ((choice (xlib::menu-choose a-menu 100 100)
    109 
    +                            (xlib::menu-choose a-menu 100 100)))
    110 
    +                   ((and choice (string-equal "Quit" choice)))
    111 
    +                 (let* ((demo-choice (intern (string-upcase choice)
    112 
    +                                             *keyword-package*))
    113 
    +                        (fun (gethash demo-choice *name-to-function*)))
    114 
    +                   (setf choice nil)
    115 
    +                   (when fun
    116 
    +                     (ignore-errors (funcall fun)))))
    117 
    +            (xlib:display-finish-output display)
    118 
    +            (xlib:close-display display)))))))
    135 119
    136 120
    137 121 
     ;;;; Shared demo utilities.
    ... ... @@ -143,60 +127,124 @@
    143 127 
     	    (xlib:window-map-state w))))
    144 128
    145 129
    146 
    -;;;; Greynetic.
    147 
    -
    148 
    -;;; GREYNETIC displays random sized and shaded boxes in a window.  This is
    149 
    -;;; real slow.  It needs work.
    150 
    -;;;
    151 
    -(defun greynetic (window duration)
    152 
    -  (let* ((pixmap (xlib:create-pixmap :width 32 :height 32 :depth 1
    153 
    -				     :drawable window))
    154 
    -	 (gcontext (xlib:create-gcontext :drawable window
    155 
    -					 :background *white-pixel*
    156 
    -					 :foreground *black-pixel*
    157 
    -					 :tile pixmap
    158 
    -					 :fill-style :tiled)))
    159 
    -    (multiple-value-bind (width height) (full-window-state window)
    160 
    -      (dotimes (i duration)
    161 
    -	(let* ((pixmap-data (greynetic-pixmapper))
    162 
    -	       (image (xlib:create-image :width 32 :height 32
    163 
    -					 :depth 1 :data pixmap-data)))
    164 
    -	  (xlib:put-image pixmap gcontext image :x 0 :y 0 :width 32 :height 32)
    165 
    -	  (xlib:draw-rectangle window gcontext
    166 
    -			       (- (random width) 5)
    167 
    -			       (- (random height) 5)
    168 
    -			       (+ 4 (random (truncate width 3)))
    169 
    -			       (+ 4 (random (truncate height 3)))
    170 
    -			       t))
    171 
    -	(xlib:display-force-output *display*)))
    172 
    -    (xlib:free-gcontext gcontext)
    173 
    -    (xlib:free-pixmap pixmap)))
    174 
    -
    175 
    -(defvar *greynetic-pixmap-array*
    176 
    -  (make-array '(32 32) :initial-element 0 :element-type 'xlib:pixel))
    177 
    -
    178 
    -(defun greynetic-pixmapper ()
    179 
    -  (let ((pixmap-data *greynetic-pixmap-array*))
    130 
    +(defun make-random-bitmap ()
    131 
    +  (let ((bitmap-data (make-array '(32 32) :initial-element 0
    132 
    +				 :element-type 'xlib::bit)))
    180 133 
         (dotimes (i 4)
    181 134 
           (declare (fixnum i))
    182 135 
           (let ((nibble (random 16)))
    183 
    -	(setf nibble (logior nibble (ash nibble 4))
    184 
    -	      nibble (logior nibble (ash nibble 8))
    185 
    -	      nibble (logior nibble (ash nibble 12))
    186 
    -	      nibble (logior nibble (ash nibble 16)))
    187 
    -	(dotimes (j 32)
    188 
    -	  (let ((bit (if (logbitp j nibble) 1 0)))
    189 
    -	    (setf (aref pixmap-data i j) bit
    190 
    -		  (aref pixmap-data (+ 4 i) j) bit
    191 
    -		  (aref pixmap-data (+ 8 i) j) bit
    192 
    -		  (aref pixmap-data (+ 12 i) j) bit
    193 
    -		  (aref pixmap-data (+ 16 i) j) bit
    194 
    -		  (aref pixmap-data (+ 20 i) j) bit
    195 
    -		  (aref pixmap-data (+ 24 i) j) bit
    196 
    -		  (aref pixmap-data (+ 28 i) j) bit)))))
    197 
    -    pixmap-data))
    198 
    -
    199 
    -#+nil
    136 
    +        (setf nibble (logior nibble (ash nibble 4))
    137 
    +              nibble (logior nibble (ash nibble 8))
    138 
    +              nibble (logior nibble (ash nibble 12))
    139 
    +              nibble (logior nibble (ash nibble 16)))
    140 
    +        (dotimes (j 32)
    141 
    +          (let ((bit (if (logbitp j nibble) 1 0)))
    142 
    +            (setf (aref bitmap-data i j) bit
    143 
    +                  (aref bitmap-data (+ 4 i) j) bit
    144 
    +                  (aref bitmap-data (+ 8 i) j) bit
    145 
    +                  (aref bitmap-data (+ 12 i) j) bit
    146 
    +                  (aref bitmap-data (+ 16 i) j) bit
    147 
    +                  (aref bitmap-data (+ 20 i) j) bit
    148 
    +                  (aref bitmap-data (+ 24 i) j) bit
    149 
    +                  (aref bitmap-data (+ 28 i) j) bit)))))
    150 
    +    bitmap-data))
    151 
    +
    152 
    +
    153 
    +(defun make-random-pixmap ()
    154 
    +  (let ((image (xlib:create-image :depth 1 :data (make-random-bitmap))))
    155 
    +    (make-pixmap image 32 32)))
    156 
    +
    157 
    +(defvar *pixmaps* nil)
    158 
    +
    159 
    +(defun make-pixmap (image width height)
    160 
    +  (let* ((pixmap (xlib:create-pixmap :width width :height height
    161 
    +				     :depth 1 :drawable *root*))
    162 
    +	 (gc (xlib:create-gcontext :drawable pixmap
    163 
    +				   :background *black-pixel*
    164 
    +				   :foreground *white-pixel*)))
    165 
    +    (xlib:put-image pixmap gc image :x 0 :y 0 :width width :height height)
    166 
    +    (xlib:free-gcontext gc)
    167 
    +    pixmap))
    168 
    +
    169 
    +
    170 
    +;;;
    171 
    +;;; This function returns one of the pixmaps in the *pixmaps* array.
    172 
    +(defun greynetic-pixmapper ()
    173 
    +  (aref *pixmaps* (random (length *pixmaps*))))
    174 
    +
    175 
    +
    176 
    +(defun greynetic (window duration)
    177 
    +  (let* ((depth (xlib:drawable-depth window))
    178 
    +	 (draw-gcontext (xlib:create-gcontext :drawable window
    179 
    +					      :foreground *white-pixel*
    180 
    +					      :background *black-pixel*))
    181 
    +	 ;; Need a random state per process.
    182 
    +	 (*random-state* (make-random-state t))
    183 
    +	 (*pixmaps* (let ((pixmap-array (make-array 30)))
    184 
    +		      (dotimes (i 30)
    185 
    +			(setf (aref pixmap-array i) (make-random-pixmap)))
    186 
    +		      pixmap-array)))
    187 
    +
    188 
    +    (unwind-protect
    189 
    +	(multiple-value-bind (width height) (full-window-state window)
    190 
    +	  (declare (fixnum width height))
    191 
    +	  (let ((border-x (truncate width 20))
    192 
    +		(border-y (truncate height 20)))
    193 
    +	    (declare (fixnum border-x border-y))
    194 
    +	    (dotimes (i duration)
    195 
    +	      (let ((pixmap (greynetic-pixmapper)))
    196 
    +		(xlib:with-gcontext (draw-gcontext
    197 
    +				     :foreground (random (ash 1 depth))
    198 
    +				     :background (random (ash 1 depth))
    199 
    +				     :stipple pixmap
    200 
    +				     :fill-style
    201 
    +				     :opaque-stippled)
    202 
    +		   (cond ((zerop (mod i 500))
    203 
    +			  (xlib:clear-area window)
    204 
    +			  (sleep .1))
    205 
    +			 (t
    206 
    +			  (sleep *delay*)))
    207 
    +		   (if (< (random 3) 2)
    208 
    +		       (let* ((w (+ border-x
    209 
    +				    (truncate (* (random (- width
    210 
    +							    (* 2 border-x)))
    211 
    +						 (random width)) width)))
    212 
    +			      (h (+ border-y
    213 
    +				    (truncate (* (random (- height
    214 
    +							    (* 2 border-y)))
    215 
    +						 (random height)) height)))
    216 
    +			      (x (random (- width w)))
    217 
    +			      (y (random (- height h))))
    218 
    +			 (declare (fixnum w h x y))
    219 
    +			 (if (zerop (random 2))
    220 
    +			     (xlib:draw-rectangle window draw-gcontext
    221 
    +						  x y w h t)
    222 
    +			     (xlib:draw-arc window draw-gcontext
    223 
    +					    x y w h 0 (* 2 pi) t)))
    224 
    +		       (let ((p1-x (+ border-x
    225 
    +				      (random (- width (* 2 border-x)))))
    226 
    +			     (p1-y (+ border-y
    227 
    +				      (random (- height (* 2 border-y)))))
    228 
    +			     (p2-x (+ border-x
    229 
    +				      (random (- width (* 2 border-x)))))
    230 
    +			     (p2-y (+ border-y
    231 
    +				      (random (- height (* 2 border-y)))))
    232 
    +			     (p3-x (+ border-x
    233 
    +				      (random (- width (* 2 border-x)))))
    234 
    +			     (p3-y (+ border-y
    235 
    +				      (random (- height (* 2 border-y))))))
    236 
    +			 (declare (fixnum p1-x p1-y p2-x p2-y p3-x p3-y))
    237 
    +			 (xlib:draw-lines window draw-gcontext
    238 
    +					  (list p1-x p1-y p2-x p2-y p3-x p3-y)
    239 
    +					  :relative-p nil
    240 
    +					  :fill-p t
    241 
    +					  :shape :convex)))
    242 
    +		   (xlib:display-force-output *display*))))))
    243 
    +      (dotimes (i (length *pixmaps*))
    244 
    +	(xlib:free-pixmap (aref *pixmaps* i)))
    245 
    +      (xlib:free-gcontext draw-gcontext))))
    246 
    +
    247 
    +
    200 248 
     (defdemo greynetic-demo "Greynetic" (&optional (duration 300))
    201 249 
       100 100 600 600
    202 250 
       "Displays random grey rectangles."
    ... ... @@ -677,6 +725,7 @@
    677 725 
     			    start-needle
    678 726 
     			    end-needle)
    679 727 
     	     end-needle)
    728 
    +  (sleep *delay*)
    680 729 
       t)
    681 730
    682 731 
     ;;; Move-N-Disks moves the top N disks from START-NEEDLE to END-NEEDLE
    ... ... @@ -775,27 +824,28 @@
    775 824 
     	  (when (= prev-neg-velocity 0) (return t))
    776 825 
     	  (let ((negative-velocity (minusp y-velocity)))
    777 826 
     	    (loop
    778 
    -	      (let ((next-y (+ y y-velocity))
    779 
    -		    (next-y-velocity (+ y-velocity gravity)))
    780 
    -		(declare (fixnum next-y next-y-velocity))
    781 
    -		(when (> next-y top-of-window-at-bottom)
    782 
    -		  (cond
    783 
    -		   (number-problems
    784 
    -		    (setf y-velocity (incf prev-neg-velocity)))
    785 
    -		   (t
    786 
    -		    (setq y-velocity
    787 
    -			  (- (truncate (* elasticity y-velocity))))
    788 
    -		    (when (= y-velocity prev-neg-velocity)
    789 
    -		      (incf y-velocity)
    790 
    -		      (setf number-problems t))
    791 
    -		    (setf prev-neg-velocity y-velocity)))
    792 
    -		  (setf y top-of-window-at-bottom)
    793 
    -		  (setf (xlib:drawable-x window) x
    794 
    -			(xlib:drawable-y window) y)
    795 
    -		  (xlib:display-force-output *display*)
    796 
    -		  (return))
    797 
    -		(setq y-velocity next-y-velocity)
    798 
    -		(setq y next-y))
    827 
    +               (let ((next-y (+ y y-velocity))
    828 
    +                     (next-y-velocity (+ y-velocity gravity)))
    829 
    +                 (declare (fixnum next-y next-y-velocity))
    830 
    +                 (when (> next-y top-of-window-at-bottom)
    831 
    +                   (cond
    832 
    +                     (number-problems
    833 
    +                      (setf y-velocity (incf prev-neg-velocity)))
    834 
    +                     (t
    835 
    +                      (setq y-velocity
    836 
    +                            (- (truncate (* elasticity y-velocity))))
    837 
    +                      (when (= y-velocity prev-neg-velocity)
    838 
    +                        (incf y-velocity)
    839 
    +                        (setf number-problems t))
    840 
    +                      (setf prev-neg-velocity y-velocity)))
    841 
    +                   (setf y top-of-window-at-bottom)
    842 
    +                   (setf (xlib:drawable-x window) x
    843 
    +                         (xlib:drawable-y window) y)
    844 
    +                   (xlib:display-force-output *display*)
    845 
    +                   (return))
    846 
    +                 (setq y-velocity next-y-velocity)
    847 
    +                 (setq y next-y)
    848 
    +                 (sleep (/ *delay* 100)))
    799 849 
     	      (when (and negative-velocity (>= y-velocity 0))
    800 850 
     		(setf negative-velocity nil))
    801 851 
     	      (let ((next-x (+ x x-velocity)))
    ... ... @@ -814,7 +864,7 @@
    814 864 
       100 100 300 300
    815 865 
       "Drops the demo window with an inital X velocity which bounces off
    816 866 
       screen borders."
    817 
    -  (bounce-window *window* 30))
    867 
    +  (bounce-window *window* 3))
    818 868
    819 869 
     (defdemo bounce-demo "Bounce" ()
    820 870 
       100 100 300 300
    ... ... @@ -846,8 +896,8 @@
    846 896 
         (multiple-value-bind (width height) (full-window-state window)
    847 897 
           (xlib:clear-area window)
    848 898 
           (draw-ppict window gc point-count 0.0 0.0 (* width 0.5) (* height 0.5))
    849 
    -      (xlib:display-force-output display)
    850 
    -      (sleep 4))
    899 
    +      (xlib:display-finish-output display)
    900 
    +      (sleep 1))
    851 901 
         (xlib:free-gcontext gc)))
    852 902
    853 903 
     ;;; Draw points.  X assumes points are in the range of width x height,
    ... ... @@ -892,8 +942,8 @@
    892 942 
     					:function boole-c2
    893 943 
     					:plane-mask (logxor *white-pixel*
    894 944 
     							    *black-pixel*)
    895 
    -					:background *white-pixel*
    896 
    -					:foreground *black-pixel*
    945 
    +					:background *black-pixel*
    946 
    +					:foreground *white-pixel*
    897 947 
     					:fill-style :solid))
    898 948 
     	(rectangles (make-array (* 4 num-rectangles)
    899 949 
     				:element-type 'number
    ... ... @@ -920,6 +970,7 @@
    920 970 
     	      (decf y-off (ash y-dir 1))
    921 971 
     	      (setf y-dir (- y-dir))))
    922 972 
     	  (xlib:draw-rectangles window gcontext rectangles t)
    973 
    +	  (sleep *delay*)
    923 974 
     	  (xlib:display-force-output display))))
    924 975 
         (xlib:free-gcontext gcontext)))
    925 976
    ... ... @@ -938,9 +989,12 @@
    938 989 
     (defvar *ball-size-x* 38)
    939 990 
     (defvar *ball-size-y* 34)
    940 991
    941 
    -(defmacro xor-ball (pixmap window gcontext x y)
    942 
    -  `(xlib:copy-area ,pixmap ,gcontext 0 0 *ball-size-x* *ball-size-y*
    943 
    -		   ,window ,x ,y))
    992 
    +(defun xor-ball (pixmap window gcontext x y)
    993 
    +  (xlib:copy-plane pixmap gcontext 1
    994 
    +		  0 0
    995 
    +		  *ball-size-x* *ball-size-y*
    996 
    +		  window
    997 
    +		  x y))
    944 998
    945 999 
     (defconstant bball-gravity 1)
    946 1000 
     (defconstant maximum-x-drift 7)
    ... ... @@ -1016,7 +1070,7 @@
    1016 1070
    1017 1071 
     (defun bounce-balls (display window how-many duration)
    1018 1072 
       (xlib:clear-area window)
    1019 
    -  (xlib:display-force-output display)
    1073 
    +  (xlib:display-finish-output display)
    1020 1074 
       (multiple-value-bind (*max-bball-x* *max-bball-y*) (full-window-state window)
    1021 1075 
         (let* ((balls (do ((i 0 (1+ i))
    1022 1076 
     		       (list () (cons (make-ball) list)))
    ... ... @@ -1036,16 +1090,16 @@
    1036 1090 
           (xlib:free-gcontext pixmap-gc)
    1037 1091 
           (dolist (ball balls)
    1038 1092 
     	(xor-ball bounce-pixmap window gcontext (ball-x ball) (ball-y ball)))
    1039 
    -      (xlib:display-force-output display)
    1093 
    +      (xlib:display-finish-output display)
    1040 1094 
           (dotimes (i duration)
    1041 1095 
     	(dolist (ball balls)
    1042 
    -	  (bounce-1-ball bounce-pixmap window gcontext ball))
    1043 
    -	(xlib:display-force-output display))
    1096 
    +	  (bounce-1-ball bounce-pixmap window gcontext ball)
    1097 
    +          (xlib:display-finish-output display))
    1098 
    +	(sleep (/ *delay* 50.0)))
    1044 1099 
           (xlib:free-pixmap bounce-pixmap)
    1045 1100 
           (xlib:free-gcontext gcontext))))
    1046 1101
    1047 
    -#+nil
    1048 1102 
     (defdemo bouncing-ball-demo "Bouncing-Ball" (&optional (how-many 5) (duration 500))
    1049 
    -  34 34 700 500
    1103 
    +  36 34 700 500
    1050 1104 
       "Bouncing balls in space."
    1051 1105 
       (bounce-balls *display*  *window* how-many duration))

  • src/clx/demo/menu.lisp
    ... ... @@ -27,7 +27,8 @@
    27 27 
     ;;;                                                                                  |
    28 28 
     ;;;----------------------------------------------------------------------------------+
    29 29
    30 
    -
    30 
    +;;; Some changes are backported from CMUCL CLX source (our implementation had
    31 
    +;;; errors when we tried to use menu). This one is a little shorter.
    31 32
    32 33 
     (defstruct (menu)
    33 34 
       "A simple menu of text strings."
    ... ... @@ -45,29 +46,27 @@
    45 46
    46 47 
     (defun create-menu (parent-window text-color background-color text-font)
    47 48 
       (make-menu
    48 
    -    ;; Create menu graphics context
    49 
    -    :gcontext (CREATE-GCONTEXT :drawable   parent-window
    50 
    -			       :foreground text-color
    51 
    -			       :background background-color
    52 
    -			       :font       text-font)
    53 
    -    ;; Create menu window
    54 
    -    :window   (CREATE-WINDOW
    55 
    -		:parent       parent-window
    56 
    -		:class        :input-output
    57 
    -		:x            0			;temporary value
    58 
    -		:y            0			;temporary value
    59 
    -		:width        16		;temporary value
    60 
    -		:height       16		;temporary value
    61 
    -		:border-width 2
    62 
    -		:border       text-color
    63 
    -		:background   background-color
    64 
    -		:save-under   :on
    65 
    -		:override-redirect :on		;override window mgr when positioning
    66 
    -		:event-mask   (MAKE-EVENT-MASK :leave-window
    67 
    -					       :exposure))))
    68 
    -
    69 
    -
    70 
    -(defun menu-set-item-list (menu &rest item-strings)
    49 
    +   ;; Create menu graphics context
    50 
    +   :gcontext (CREATE-GCONTEXT :drawable   parent-window
    51 
    +			      :foreground text-color
    52 
    +			      :background background-color
    53 
    +			      :font       text-font)
    54 
    +   ;; Create menu window
    55 
    +   :window   (CREATE-WINDOW
    56 
    +	      :parent       parent-window
    57 
    +	      :class        :input-output
    58 
    +	      :x            0			;temporary value
    59 
    +	      :y            0			;temporary value
    60 
    +	      :width        16			;temporary value
    61 
    +	      :height       16			;temporary value
    62 
    +	      :border-width 2
    63 
    +	      :border       text-color
    64 
    +	      :background   background-color
    65 
    +	      :save-under   :on
    66 
    +	      ;; :override-redirect :on		;override window mgr when positioning
    67 
    +	      :event-mask   (MAKE-EVENT-MASK :leave-window :exposure))))
    68 
    +
    69 
    +(defun menu-set-item-list (menu item-strings)
    71 70 
       ;; Assume the new items will change the menu's width and height
    72 71 
       (setf (menu-geometry-changed-p menu) t)
    73 72
    ... ... @@ -148,7 +147,11 @@
    148 147
    149 148
    150 149 
     (defun menu-refresh (menu)
    151 
    - (let* ((gcontext   (menu-gcontext menu))
    150 
    +  (xlib:set-wm-properties (menu-window menu)
    151 
    +			  :name (menu-title menu)
    152 
    +			  :icon-name (menu-title menu)
    153 
    +			  :resource-name (menu-title menu))
    154 
    +  (let* ((gcontext   (menu-gcontext menu))
    152 155 
             (baseline-y (FONT-ASCENT (GCONTEXT-FONT gcontext))))
    153 156
    154 157 
        ;; Show title centered in "reverse-video"
    ... ... @@ -217,7 +220,7 @@
    217 220 
     		   t)))
    218 221
    219 222 
         ;; Erase the menu
    220 
    -    (UNMAP-WINDOW mw)
    223 
    +;;;    (UNMAP-WINDOW mw)
    221 224
    222 225 
         ;; Return selected item string, if any
    223 226 
         (unless (eq selected-item :none) selected-item)))
    ... ... @@ -272,111 +275,3 @@
    272 275
    273 276 
         ;; Make menu visible
    274 277 
         (MAP-WINDOW menu-window)))
    275 
    -
    276 
    -(defun just-say-lisp (&optional (font-name "fixed"))
    277 
    -  (let* ((display   (open-default-display))
    278 
    -	 (screen    (first (DISPLAY-ROOTS display)))
    279 
    -	 (fg-color  (SCREEN-BLACK-PIXEL screen))
    280 
    -	 (bg-color  (SCREEN-WHITE-PIXEL screen))
    281 
    -	 (nice-font (OPEN-FONT display font-name))
    282 
    -	 (a-menu    (create-menu (screen-root screen)	;the menu's parent
    283 
    -				 fg-color bg-color nice-font)))
    284 
    -
    285 
    -    (setf (menu-title a-menu) "Please pick your favorite language:")
    286 
    -    (menu-set-item-list a-menu "Fortran" "APL" "Forth" "Lisp")
    287 
    -
    288 
    -    ;; Bedevil the user until he picks a nice programming language
    289 
    -    (unwind-protect
    290 
    -	(do (choice)
    291 
    -	    ((and (setf choice (menu-choose a-menu 100 100))
    292 
    -		  (string-equal "Lisp" choice))))
    293 
    -
    294 
    -      (CLOSE-DISPLAY display))))
    295 
    -
    296 
    -
    297 
    -(defun pop-up (host strings &key (title "Pick one:") (font "fixed"))
    298 
    -  (let* ((display   (OPEN-DISPLAY host))
    299 
    -	 (screen    (first (DISPLAY-ROOTS display)))
    300 
    -	 (fg-color  (SCREEN-BLACK-PIXEL screen))
    301 
    -	 (bg-color  (SCREEN-WHITE-PIXEL screen))
    302 
    -	 (font      (OPEN-FONT display font))
    303 
    -	 (parent-width 400)
    304 
    -	 (parent-height 400)
    305 
    -	 (parent    (CREATE-WINDOW :parent (SCREEN-ROOT screen)
    306 
    -				   :override-redirect :on
    307 
    -				   :x 100 :y 100
    308 
    -				   :width parent-width :height parent-height
    309 
    -				   :background bg-color
    310 
    -				   :event-mask (MAKE-EVENT-MASK :button-press
    311 
    -								:exposure)))
    312 
    -	 (a-menu    (create-menu parent fg-color bg-color font))
    313 
    -	 (prompt    "Press a button...")
    314 
    -	 (prompt-gc (CREATE-GCONTEXT :drawable parent
    315 
    -				     :foreground fg-color
    316 
    -				     :background bg-color
    317 
    -				     :font font))
    318 
    -	 (prompt-y  (FONT-ASCENT font))
    319 
    -	 (ack-y     (- parent-height  (FONT-DESCENT font))))
    320 
    -
    321 
    -    (setf (menu-title a-menu) title)
    322 
    -    (apply #'menu-set-item-list a-menu strings)
    323 
    -
    324 
    -    ;; Present main window
    325 
    -    (MAP-WINDOW parent)
    326 
    -
    327 
    -    (flet ((display-centered-text
    328 
    -	     (window string gcontext height width)
    329 
    -	     (multiple-value-bind (w a d l r fa fd) (text-extents gcontext string)
    330 
    -	       (declare (ignore a d l r))
    331 
    -	       (let ((box-height (+ fa fd)))
    332 
    -
    333 
    -		 ;; Clear previous text
    334 
    -		 (CLEAR-AREA window
    335 
    -			     :x 0 :y (- height fa)
    336 
    -			     :width width :height box-height)
    337 
    -
    338 
    -		 ;; Draw new text
    339 
    -		 (DRAW-IMAGE-GLYPHS window gcontext (round (- width w) 2) height string)))))
    340 
    -
    341 
    -      (unwind-protect
    342 
    -	  (loop
    343 
    -	    (EVENT-CASE (display :force-output-p t)
    344 
    -
    345 
    -	      (:exposure (count)
    346 
    -
    347 
    -			 ;; Display prompt
    348 
    -			 (when (zerop count)
    349 
    -			   (display-centered-text
    350 
    -			     parent
    351 
    -			     prompt
    352 
    -			     prompt-gc
    353 
    -			     prompt-y
    354 
    -			     parent-width))
    355 
    -			 t)
    356 
    -
    357 
    -	      (:button-press (x y)
    358 
    -
    359 
    -			     ;; Pop up the menu
    360 
    -			     (let ((choice (menu-choose a-menu x y)))
    361 
    -			       (if choice
    362 
    -				   (display-centered-text
    363 
    -				     parent
    364 
    -				     (format nil "You have selected ~a." choice)
    365 
    -				     prompt-gc
    366 
    -				     ack-y
    367 
    -				     parent-width)
    368 
    -
    369 
    -				   (display-centered-text
    370 
    -				     parent
    371 
    -				     "No selection...try again."
    372 
    -				     prompt-gc
    373 
    -				     ack-y
    374 
    -				     parent-width)))
    375 
    -			     t)
    376 
    -
    377 
    -	      (otherwise ()
    378 
    -			 ;;Ignore and discard any other event
    379 
    -			 t)))
    380 
    -
    381 
    -	(CLOSE-DISPLAY display)))))
    382 
    -

  • src/clx/dependent.lisp
    ... ... @@ -1061,36 +1061,56 @@
    1061 1061 
     ;;; :TIMEOUT if it times out, NIL otherwise.
    1062 1062
    1063 1063 
     ;;; The default implementation
    1064 
    -
    1065 
    -;; Poll for input every *buffer-read-polling-time* SECONDS.
    1066 
    -#-(or CMU sbcl)
    1067 
    -(defparameter *buffer-read-polling-time* 0.5)
    1068 
    -
    1069 
    -#-(or CMU sbcl clisp)
    1064 
    +#-(or cmu sbcl clisp (and ecl serve-event))
    1065 
    +(progn
    1066 
    +  ;; Issue a warning to incentivize providing better implementation.
    1067 
    +  (eval-when (:compile-toplevel :load-toplevel :execute)
    1068 
    +    (warn "XLIB::BUFFER-INPUT-WAIT-DEFAULT: timeout polling used."))
    1069 
    +  ;; Poll for input every *buffer-read-polling-time* SECONDS.
    1070 
    +  (defparameter *buffer-read-polling-time* 0.01)
    1071 
    +  (defun buffer-input-wait-default (display timeout)
    1072 
    +    (declare (type display display)
    1073 
    +             (type (or null (real 0 *)) timeout))
    1074 
    +    (declare (clx-values timeout))
    1075 
    +    (let ((stream (display-input-stream display)))
    1076 
    +      (declare (type (or null stream) stream))
    1077 
    +      (cond ((null stream))
    1078 
    +            ((listen stream) nil)
    1079 
    +            ((and timeout (= timeout 0)) :timeout)
    1080 
    +            ((not (null timeout))
    1081 
    +             (multiple-value-bind (npoll fraction)
    1082 
    +                 (truncate timeout *buffer-read-polling-time*)
    1083 
    +               (dotimes (i npoll)        ; Sleep for a time, then listen again
    1084 
    +                 (sleep *buffer-read-polling-time*)
    1085 
    +                 (when (listen stream)
    1086 
    +                   (return-from buffer-input-wait-default nil)))
    1087 
    +               (when (plusp fraction)
    1088 
    +                 (sleep fraction)        ; Sleep a fraction of a second
    1089 
    +                 (when (listen stream)   ; and listen one last time
    1090 
    +                   (return-from buffer-input-wait-default nil)))
    1091 
    +               :timeout))))))
    1092 
    +
    1093 
    +#+(and ecl serve-event)
    1070 1094 
     (defun buffer-input-wait-default (display timeout)
    1071 1095 
       (declare (type display display)
    1072 
    -           (type (or null (real 0 *)) timeout))
    1073 
    -  (declare (clx-values timeout))
    1074 
    -
    1096 
    +           (type (or null number) timeout))
    1075 1097 
       (let ((stream (display-input-stream display)))
    1076 1098 
         (declare (type (or null stream) stream))
    1077 1099 
         (cond ((null stream))
    1078 1100 
               ((listen stream) nil)
    1079 
    -          ((and timeout (= timeout 0)) :timeout)
    1080 
    -          ((not (null timeout))
    1081 
    -           (multiple-value-bind (npoll fraction)
    1082 
    -               (truncate timeout *buffer-read-polling-time*)
    1083 
    -             (dotimes (i npoll)			; Sleep for a time, then listen again
    1084 
    -               (sleep *buffer-read-polling-time*)
    1085 
    -               (when (listen stream)
    1086 
    -                 (return-from buffer-input-wait-default nil)))
    1087 
    -             (when (plusp fraction)
    1088 
    -               (sleep fraction)			; Sleep a fraction of a second
    1089 
    -               (when (listen stream)		; and listen one last time
    1090 
    -                 (return-from buffer-input-wait-default nil)))
    1091 
    -             :timeout)))))
    1092 
    -
    1093 
    -#+(or CMU sbcl clisp)
    1101 
    +          ((eql timeout 0) :timeout)
    1102 
    +          (T (flet ((usable! (fd)
    1103 
    +                      (declare (ignore fd))
    1104 
    +                      (return-from buffer-input-wait-default)))
    1105 
    +               (serve-event:with-fd-handler ((ext:file-stream-fd
    1106 
    +                                              (typecase stream
    1107 
    +                                                (two-way-stream (two-way-stream-input-stream stream))
    1108 
    +                                                (otherwise stream)))
    1109 
    +                                             :input #'usable!)
    1110 
    +                 (serve-event:serve-event timeout)))
    1111 
    +             :timeout))))
    1112 
    +
    1113 
    +#+(or cmu sbcl clisp)
    1094 1114 
     (defun buffer-input-wait-default (display timeout)
    1095 1115 
       (declare (type display display)
    1096 1116 
                (type (or null number) timeout))
    ... ... @@ -1099,18 +1119,14 @@
    1099 1119 
         (cond ((null stream))
    1100 1120 
               ((listen stream) nil)
    1101 1121 
               ((eql timeout 0) :timeout)
    1102 
    -          (t
    1103 
    -           (if #+sbcl (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream)
    1104 
    -                                                   :input timeout)
    1105 
    -               #+mp (mp:process-wait-until-fd-usable
    1106 
    -                     (system:fd-stream-fd stream) :input timeout)
    1122 
    +          ;; MP package protocol may be shared between clisp and cmu.
    1123 
    +          ((or #+sbcl (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream) :input timeout)
    1124 
    +               #+mp (mp:process-wait-until-fd-usable (system:fd-stream-fd stream) :input timeout)
    1107 1125 
                    #+clisp (multiple-value-bind (sec usec) (floor (or timeout 0))
    1108 
    -                         (ext:socket-status stream (and timeout sec)
    1109 
    -                                            (round usec 1d-6)))
    1110 
    -               #-(or sbcl mp clisp) (system:wait-until-fd-usable
    1111 
    -                                     (system:fd-stream-fd stream) :input timeout)
    1112 
    -               nil
    1113 
    -               :timeout)))))
    1126 
    +                         (ext:socket-status stream (and timeout sec) (round usec 1d-6)))
    1127 
    +               #+cmu (system:wait-until-fd-usable (system:fd-stream-fd stream) :input timeout))
    1128 
    +           nil)
    1129 
    +          (T :timeout))))
    1114 1130
    1115 1131 
     ;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the
    1116 1132 
     ;;; buffer. This should never block, so it can be called from the scheduler.

  • src/clx/provide.lisp
    ... ... @@ -17,35 +17,3 @@
    17 17 
     (in-package :common-lisp-user)
    18 18
    19 19 
     (provide :clx)
    20 
    -
    21 
    -(defvar *clx-source-pathname*
    22 
    -	(pathname "/src/local/clx/*.l"))
    23 
    -
    24 
    -(defvar *clx-binary-pathname*
    25 
    -	(let ((lisp
    26 
    -		(or #+lucid "lucid"
    27 
    -		    #+akcl  "akcl"
    28 
    -		    #+kcl   "kcl"
    29 
    -		    #+ibcl  "ibcl"
    30 
    -		    (error "Can't provide CLX for this lisp.")))
    31 
    -	      (architecture
    32 
    -		(or #+(or sun3 (and sun (or mc68000 mc68020))) "sun3"
    33 
    -		    #+(or sun4 sparc) "sparc"
    34 
    -		    #+(and hp (or mc68000 mc68020)) "hp9000s300"
    35 
    -		    #+vax "vax"
    36 
    -		    #+prime "prime"
    37 
    -		    #+sunrise "sunrise"
    38 
    -		    #+ibm-rt-pc "ibm-rt-pc"
    39 
    -		    #+mips "mips"
    40 
    -		    #+prism "prism"
    41 
    -		    (error "Can't provide CLX for this architecture."))))
    42 
    -	  (pathname (format nil "/src/local/clx/~A.~A/" lisp architecture))))
    43 
    -
    44 
    -(defvar *compile-clx*
    45 
    -	nil)
    46 
    -
    47 
    -(load (merge-pathnames "defsystem" *clx-source-pathname*))
    48 
    -
    49 
    -(if *compile-clx*
    50 
    -    (compile-clx *clx-source-pathname* *clx-binary-pathname*)
    51 
    -  (load-clx *clx-binary-pathname*))

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.common-lisp.net. If you'd like to receive fewer emails, you can adjust your notification settings.