mcclim-cvs July 2006

mcclim-cvs@common-lisp.net

2 participants
9 discussions

[mcclim-cvs] CVS mcclim
by rschlatte 24 Jul '06

24 Jul '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv19952 Modified Files: INSTALL Log Message: documentation fix (thanks to Willem Broekema) --- /project/mcclim/cvsroot/mcclim/INSTALL 2006/03/23 16:44:58 1.8 +++ /project/mcclim/cvsroot/mcclim/INSTALL 2006/07/24 04:20:21 1.9 @@ -70,37 +70,14 @@ ================= McCLIM comes with some interesting demo programs and applications: - - address-book - The classic CLIM demo: - - (asdf:oos 'asdf:load :clim-examples) - (in-package :clim-demo) - (run-frame-top-level (make-application-frame 'address-book) - - The Examples directory includes other demo programs that might be - of interest. Many of these are quite old and were written before - large parts of the CLIM specification were implemented; for good + address-book - The classic CLIM demo: (asdf:oos 'asdf:load-op :clim-examples) (in-package :clim-demo) (run-frame-top-level (make-application-frame 'address-book)) The Examples directory includes other demo programs that might be of interest. Many of these are quite old and were written before large parts of the CLIM specification were implemented; for good examples of CLIM style it is best to look elsewhere. clim-listener - a Lisp 'listener' or top-level loop with many goodies for examining directories, CLOS classes, etc. Printed - results are mouse-sensitive and in supported implementations - (currently OpenMCL) can be used directly as arguments in Lisp expressions: - - (asdf:oos 'asdf:load :clim-listener) - (clim-listener:run-listener) - - - functional-geometry - Frank Buss' and Rainer Joswig's functional - geometry explorer, implemented on top of clim-listener: - - (load "Apps/Functional-Geometry/functional-geometry.asd") - (asdf:oos 'asdf:load :functional-geometry) - (functional-geometry::run-functional-geometry) - - -Installation Notes for Implementations + results are mouse-sensitive and in supported implementations (currently OpenMCL) can be used directly as arguments in Lisp expressions: (asdf:oos 'asdf:load-op :clim-listener) (clim-listener:run-listener) functional-geometry - Frank Buss' and Rainer Joswig's functional + geometry explorer, implemented on top of clim-listener: (load "Apps/Functional-Geometry/functional-geometry.asd") (asdf:oos 'asdf:load-op :functional-geometry) (functional-geometry::run-functional-geometry) Installation Notes for Implementations ====================================== Notes about bugs or gotchas in specific Common Lisp implementations

1 0

[mcclim-cvs] CVS mcclim
by ahefner 09 Jul '06

09 Jul '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv6218 Modified Files: input.lisp panes.lisp Log Message: Move scroll wheel code to panes.lisp, since it has nothing to do with event queues. --- /project/mcclim/cvsroot/mcclim/input.lisp 2006/07/08 16:58:36 1.36 +++ /project/mcclim/cvsroot/mcclim/input.lisp 2006/07/09 06:23:22 1.37 @@ -521,42 +521,3 @@ (defclass clim-sheet-input-mixin (standard-sheet-input-mixin) ()) - -;;; Mixin for panes which want the mouse wheel to scroll vertically - -(defclass mouse-wheel-scroll-mixin () ()) - -(defparameter *mouse-scroll-distance* 4 - "Number of lines by which to scroll the window in response to the scroll wheel") - -(defgeneric scroll-quantum (pane) - (:documentation "Returns the number of pixels respresenting a 'line', used -to computed distance to scroll in response to mouse wheel events.")) - -(defmethod scroll-quantum (pane) 10) - -(defun scroll-sheet (sheet vertical horizontal) - (with-bounding-rectangle* (vx0 vy0 vx1 vy1) (pane-viewport-region sheet) - (with-bounding-rectangle* (sx0 sy0 sx1 sy1) (sheet-region sheet) - (let ((viewport-height (- vy1 vy0)) - (viewport-width (- vx1 vx0)) - (delta (* *mouse-scroll-distance* - (scroll-quantum sheet)))) - ;; The coordinates (x,y) of the new upper-left corner of the viewport - ;; must be "sx0 < x < sx1 - viewport-width" and - ;; "sy0 < y < sy1 - viewport-height" - (scroll-extent sheet - (max sx0 (min (- sx1 viewport-width) (+ vx0 (* delta horizontal)))) - (max sy0 (min (- sy1 viewport-height) (+ vy0 (* delta vertical))))))))) - -(defmethod dispatch-event :around ((sheet mouse-wheel-scroll-mixin) - (event pointer-button-press-event)) - (if (pane-viewport sheet) - (let ((button (pointer-event-button event))) - (cond - ((eq button +pointer-wheel-up+) (scroll-sheet sheet -1 0)) - ((eq button +pointer-wheel-down+) (scroll-sheet sheet 1 0)) - ((eq button +pointer-wheel-left+) (scroll-sheet sheet 0 -1)) - ((eq button +pointer-wheel-right+) (scroll-sheet sheet 0 1)) - (t (call-next-method)))) ; not a scroll wheel button - (call-next-method))) ; no viewport --- /project/mcclim/cvsroot/mcclim/panes.lisp 2006/03/29 10:43:37 1.169 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2006/07/09 06:23:22 1.170 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.169 2006/03/29 10:43:37 tmoore Exp $ +;;; $Id: panes.lisp,v 1.170 2006/07/09 06:23:22 ahefner Exp $ (in-package :clim-internals) @@ -2326,6 +2326,44 @@ (defgeneric* (setf window-viewport-position) (x y clim-stream-pane)) +;;; Mixin for panes which want the mouse wheel to scroll vertically + +(defclass mouse-wheel-scroll-mixin () ()) + +(defparameter *mouse-scroll-distance* 4 + "Number of lines by which to scroll the window in response to the scroll wheel") + +(defgeneric scroll-quantum (pane) + (:documentation "Returns the number of pixels respresenting a 'line', used +to computed distance to scroll in response to mouse wheel events.")) + +(defmethod scroll-quantum (pane) 10) + +(defun scroll-sheet (sheet vertical horizontal) + (with-bounding-rectangle* (vx0 vy0 vx1 vy1) (pane-viewport-region sheet) + (with-bounding-rectangle* (sx0 sy0 sx1 sy1) (sheet-region sheet) + (let ((viewport-height (- vy1 vy0)) + (viewport-width (- vx1 vx0)) + (delta (* *mouse-scroll-distance* + (scroll-quantum sheet)))) + ;; The coordinates (x,y) of the new upper-left corner of the viewport + ;; must be "sx0 < x < sx1 - viewport-width" and + ;; "sy0 < y < sy1 - viewport-height" + (scroll-extent sheet + (max sx0 (min (- sx1 viewport-width) (+ vx0 (* delta horizontal)))) + (max sy0 (min (- sy1 viewport-height) (+ vy0 (* delta vertical))))))))) + +(defmethod dispatch-event :around ((sheet mouse-wheel-scroll-mixin) + (event pointer-button-press-event)) + (if (pane-viewport sheet) + (let ((button (pointer-event-button event))) + (cond + ((eq button +pointer-wheel-up+) (scroll-sheet sheet -1 0)) + ((eq button +pointer-wheel-down+) (scroll-sheet sheet 1 0)) + ((eq button +pointer-wheel-left+) (scroll-sheet sheet 0 -1)) + ((eq button +pointer-wheel-right+) (scroll-sheet sheet 0 1)) + (t (call-next-method)))) ; not a scroll wheel button + (call-next-method))) ; no viewport ;;; ;;; 29.4 CLIM Stream Panes

1 0

[mcclim-cvs] CVS mcclim/Examples
by ahefner 08 Jul '06

08 Jul '06

Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv6896 Modified Files: logic-cube.lisp Log Message: Use text size of :huge, since not all X servers supply a reasonable font at size 50. --- /project/mcclim/cvsroot/mcclim/Examples/logic-cube.lisp 2006/07/03 04:58:41 1.1 +++ /project/mcclim/cvsroot/mcclim/Examples/logic-cube.lisp 2006/07/08 18:27:10 1.2 @@ -390,7 +390,7 @@ (defun won-logic-cube (pane) (let ((start-time (get-internal-real-time)) (spin-start-time 0.3) - (text-style (make-text-style :serif :bold 50)) + (text-style (make-text-style :serif :bold :huge)) (start-yaw (yaw pane)) (win-message (elt '("Great Success!" "You Win!" "Completed!" "Vanquished!" "Terminated!" "Good job!" "Boom!")

1 0

[mcclim-cvs] CVS mcclim
by ahefner 08 Jul '06

08 Jul '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv26500 Modified Files: input.lisp Log Message: Fix event compression on single-process lisps. This consists of two changes: 1) Don't use immediate-sheet-input-mixin, and 2) When reading events from the backend, read all available events in a nonblocking fashion, so that events which have accumulated since we last checked can be compressed. This requires the backend 'get-next-event' to support :timeout 0. Currently CLX and Beagle appear to do so, while Gtkairo does not. --- /project/mcclim/cvsroot/mcclim/input.lisp 2006/01/16 13:16:38 1.35 +++ /project/mcclim/cvsroot/mcclim/input.lisp 2006/07/08 16:58:36 1.36 @@ -519,7 +519,7 @@ ;;; Class actually used by panes. -(defclass clim-sheet-input-mixin (#+clim-mp standard-sheet-input-mixin #-clim-mp immediate-sheet-input-mixin) +(defclass clim-sheet-input-mixin (standard-sheet-input-mixin) ()) ;;; Mixin for panes which want the mouse wheel to scroll vertically

1 0

[mcclim-cvs] CVS mcclim/Lisp-Dep
by ahefner 08 Jul '06

08 Jul '06

Update of /project/mcclim/cvsroot/mcclim/Lisp-Dep In directory clnet:/tmp/cvs-serv26500/Lisp-Dep Modified Files: mp-nil.lisp Log Message: Fix event compression on single-process lisps. This consists of two changes: 1) Don't use immediate-sheet-input-mixin, and 2) When reading events from the backend, read all available events in a nonblocking fashion, so that events which have accumulated since we last checked can be compressed. This requires the backend 'get-next-event' to support :timeout 0. Currently CLX and Beagle appear to do so, while Gtkairo does not. --- /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-nil.lisp 2004/05/12 12:46:49 1.6 +++ /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-nil.lisp 2006/07/08 16:58:36 1.7 @@ -125,7 +125,10 @@ (declare (ignore lock)) (flet ((wait-func () (loop for port in climi::*all-ports* ;; this is dubious - do (process-next-event port)) + do (loop as this-event = (process-next-event port :timeout 0) + for got-events = this-event then (or got-events this-event) + while this-event + finally (unless got-events (process-next-event port)))) (car cv))) (setf (car cv) nil) (if timeout

1 0

[mcclim-cvs] CVS mcclim
by ahefner 03 Jul '06

03 Jul '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv13277 Modified Files: mcclim.asd Log Message: Add "Logic Cube" example. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/06/10 18:20:22 1.22 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/07/03 04:58:41 1.23 @@ -345,7 +345,8 @@ (:file "dragndrop-translator") (:file "draggable-graph") (:file "text-size-test") - (:file "drawing-benchmark"))) + (:file "drawing-benchmark") + (:file "logic-cube"))) (:module "Goatee" :components ((:file "goatee-test")))))

1 0

[mcclim-cvs] CVS mcclim/Examples
by ahefner 03 Jul '06

03 Jul '06

Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv13277/Examples Modified Files: demodemo.lisp Added Files: logic-cube.lisp Log Message: Add "Logic Cube" example. --- /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/05/12 22:40:51 1.12 +++ /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/07/03 04:58:41 1.13 @@ -61,6 +61,7 @@ (make-demo-button "Method Browser" 'method-browser) (make-demo-button "Address Book" 'address-book) (make-demo-button "Puzzle" 'puzzle) + (make-demo-button "Logic Cube" 'logic-cube) (make-demo-button "Gadget Test" 'gadget-test) (make-demo-button "Drag and Drop" 'dragndrop) (make-demo-button "Colorslider" 'colorslider) --- /project/mcclim/cvsroot/mcclim/Examples/logic-cube.lisp 2006/07/03 04:58:41 NONE +++ /project/mcclim/cvsroot/mcclim/Examples/logic-cube.lisp 2006/07/03 04:58:41 1.1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-DEMO; -*- ;;; 3D Logic Cube flash game (http://www.newgrounds.com/portal/view/315702), ;;; translated into CL/McCLIM. ;;; (C) Copyright 2006 by Andy Hefner (ahefner(a)gmail.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) ;; TODO: Improved puzzle generator. The puzzles currently generated by ;; "Random Puzzle" are all extremely easy to solve. I'm not admitting ;; defeat here, but I refuse to waste any more time on this program. ;; FIXME: When shrinking polygons during the victory animation, why ;; does their shape appear to distort? Look at the Z of the transformed ;; coordinates.. ;; Pane definition and puzzle generator (defclass logic-cube-pane (basic-gadget) ((background :initform (make-rgb-color 0.35 0.35 0.46) :reader background-color) (pitch :initform 0.0 :accessor pitch) (yaw :initform 0.0 :accessor yaw) (density :initform 5 :accessor density) (playfield :reader playfield) (drag-color :initform nil :accessor drag-color) (dragging :initform nil :accessor dragging) (squeeze :initform nil :accessor squeeze) ; For victory animation (flyaway :initform 0.0 :accessor flyaway) ; For victory animation (decorator :initform nil :accessor decorator))) ; Hook for victory text (defun reset-logic-cube (cube new-density) (with-slots (density playfield squeeze drag-color dragging flyaway decorator) cube (setf density new-density dragging nil decorator nil drag-color nil flyaway 0.0 squeeze nil playfield (make-array (list 3 density density) :initial-element (list nil nil))))) ;; Playfield squares are a pair of color and {nil, t, terminal} (defun scrub-square (square) (if (second square) square (list nil nil))) (defun cleanup-cube (cube) (apply-to-hemicube-faces (density cube) (lambda (side i j &rest points) (declare (ignore points)) (symbol-macrolet ((square (aref (playfield cube) side i j))) (setf square (scrub-square square)))))) (defparameter *logic-cube-colors* (list +red+ +yellow+ +blue+ +green+ +orange+ +purple+)) ; Produce crappy, trivial puzzles, slowly. (defun generate-cube-puzzle (cube &optional (num-colors 6)) (reset-logic-cube cube 5) (labels ((sq (s i j) (first (aref (playfield cube) s i j))) (sql (indices) (apply #'sq indices)) (set-playfield (indices square) (destructuring-bind (s i j) indices (setf (aref (playfield cube) s i j) square))) (satisfying (pred) (loop for tries from 0 by 1 as s = (random 3) as i = (random (density cube)) as j = (random (density cube)) as result = (funcall pred (sq s i j) s i j) while (< tries (expt (density cube) 4)) ; ^_^ when result return result))) (let ((iterators (loop for color-index from 0 below num-colors collect (destructuring-bind (root iterator) (satisfying (lambda (color &rest root-indices) (let ((our-color (elt *logic-cube-colors* color-index)) (current-head root-indices)) (when (null color) (labels ((find-new-head () (satisfying ;; Obviously I should not use 'satisfying' here.. (lambda (head-color &rest head-indices) (and (null head-color) ;; .. but computers are very fast. (not (equal head-indices current-head)) (member head-indices (apply #'adjacent-squares cube current-head) :test #'equal) (>= 1 (count-if (lambda (c) (eql c our-color)) (apply #'adjacent-squares cube head-indices) :key #'sql)) head-indices)))) (choose-new-head () (let ((new-head (find-new-head))) (if new-head (set-playfield new-head (list our-color nil)) (unless (equal current-head root-indices) (set-playfield current-head (list our-color 'terminal)))) (setf current-head new-head) (and new-head #'choose-new-head)))) (choose-new-head) (and current-head (list root-indices #'choose-new-head))))))) (set-playfield root (list (elt *logic-cube-colors* color-index) 'terminal)) iterator)))) (loop for i from 0 by 1 while (and iterators (< i 100)) do (setf iterators (remove nil (mapcar #'funcall iterators)))) (apply-to-hemicube-faces (density cube) (lambda (side i j &rest points) (declare (ignore points)) (when (and (null (sq side i j)) (< (random 1.0) 0.65)) (set-playfield (list side i j) (list nil t)))))))) ;; The puzzles coming out of the above were so bad that I threw this together to ;; reject some of the obviously awful ones. (defun generate-better-cube-puzzle (cube &optional (num-colors 6)) (loop for i from 0 below 100 do (generate-cube-puzzle cube num-colors) (multiple-value-bind (solvable min-path-length) (check-victory cube) (assert solvable) (when (>= min-path-length 6) (return-from generate-better-cube-puzzle)))) (format *trace-output* "~&Settling for lousy puzzle..~%")) (defmethod initialize-instance :after ((pane logic-cube-pane) &rest args) (declare (ignore args)) (generate-better-cube-puzzle pane 6) (cleanup-cube pane)) (defmethod compose-space ((pane logic-cube-pane) &key width height) (declare (ignore width height)) ;; Hmm. How does one constrain the aspect ratio of a pane? (make-space-requirement :min-width 200 :min-height 200 :width 550 :height 550)) ;; Math utilities (defun lc-scaling-matrix (scale) (let ((matrix (make-array '(3 3) :initial-element 0.0))) (dotimes (i 3) (setf (aref matrix i i) scale)) matrix)) (defun lc-m3xv3 (a b) ; multiply 3x3 matrix by vector (flet ((f (i) (loop for j from 0 below 3 sum (* (aref a i j) (elt b j))))) (vector (f 0) (f 1) (f 2)))) (defun lc-m3xm3 (a b) ; multiply two 3x3 matrices (let ((matrix (make-array '(3 3) :initial-element 0.0))) (dotimes (row 3) (dotimes (col 3) (dotimes (i 3) (incf (aref matrix row col) (* (aref a row i) (aref b i col)))))) matrix)) (defun lc-rotation-matrix (theta axis-a axis-b) (let ((matrix (lc-scaling-matrix 1.0))) (setf (aref matrix axis-a axis-a) (cos theta) (aref matrix axis-a axis-b) (sin theta) (aref matrix axis-b axis-a) (- (sin theta)) (aref matrix axis-b axis-b) (cos theta)) matrix)) (defun lc-v+ (a b) (map 'vector #'+ a b)) ; 3-vector addition a+b (defun lc-v- (a b) (map 'vector #'- a b)) ; 3-vector subtract a-b (defun lc-scale (a s) (map 'vector (lambda (x) (* x s)) a)) ; 3-vector multiply by scalar (defun lc-cross (a b) ; 3-vector cross product (macrolet ((woo (p q) `(- (* (elt a ,p) (elt b ,q )) (* (elt a ,q) (elt b ,p))))) (vector (woo 1 2) (woo 2 0) (woo 0 1)))) ;; Corner of hemicube is at origin. ;; Sides: 0=XY 1=XZ 2=YZ (defun apply-to-hemicube-faces (n fn) (let ((size (/ n))) (dotimes (d 3) (flet ((permute (x y) ; SBCL warns (erroneously?) below, but the code works. (flet ((f (i) (elt (vector x y 0) (mod (+ d i) 3)))) (vector (f 0) (f 1) (f 2))))) (dotimes (i n) (dotimes (j n) (let ((base-x (* i size)) (base-y (* j size))) (funcall fn d i j (permute base-x base-y) (permute (+ base-x size) base-y) (permute (+ base-x size) (+ base-y size)) (permute base-x (+ base-y size)))))))))) (defun lc-point-transformer (view-matrix) (lambda (point) (setf point (map 'vector (lambda (x) (- x 0.5)) point)) (setf point (lc-m3xv3 view-matrix point)) (let ((z (+ 2.0 (elt point 2))) (zoom 2.0)) (vector (* zoom (/ (elt point 0) z)) (* zoom (/ (elt point 1) z)) z)))) (defun lc-scale-polygon (polygon amount) (let ((center (reduce (lambda (a b) (lc-v+ a (lc-scale b (/ (length polygon))))) polygon :initial-value #(0.0 0.0 0.0)))) (mapcar (lambda (v) (lc-v+ center (lc-scale (lc-v- v center) amount))) polygon))) (defun draw-polygon-3d (pane points &rest polygon-args) (apply #'draw-polygon pane (mapcar (lambda (p) (make-point (elt p 0) (elt p 1))) points) polygon-args)) (defun apply-to-transformed-faces (pane continuation) (let ((transformer (lc-point-transformer (lc-m3xm3 (lc-scaling-matrix (- 1.0 (flyaway pane))) (lc-m3xm3 (lc-rotation-matrix (pitch pane) 1 2) (lc-rotation-matrix (yaw pane) 0 2)))))) (apply-to-hemicube-faces (density pane) (lambda (side i j &rest points) (apply continuation side i j (mapcar transformer points)))))) (defun lc-face-normal (points) (lc-cross (lc-v- (elt points 2) (elt points 1)) (lc-v- (elt points 0) (elt points 1)))) (defun backface-p (points) (<= (elt (lc-face-normal points) 2) 0)) (defun face-light (color side) (compose-over (compose-in color (make-opacity 0.65)) (elt (vector +gray30+ +white+ color) side))) (defun polygon-edges (points) (maplist (lambda (list) (lc-v- (or (second list) (first points)) (first list))) points)) (defun draw-polygon-outline-3d (pane a b &rest polygon-args) (maplist (lambda (a* b*) (apply #'draw-polygon-3d pane (list (first a*) (first b*) (or (second b*) (first b)) (or (second a*) (first a))) polygon-args)) a b)) (defun draw-logic-cube (pane) (apply-to-transformed-faces pane (lambda (side i j &rest camera-points) (unless (backface-p camera-points) (when (squeeze pane) (setf camera-points (lc-scale-polygon camera-points (squeeze pane)))) (destructuring-bind (color type) (aref (playfield pane) side i j) (cond ((null type) (draw-polygon-3d pane (lc-scale-polygon camera-points 0.8) :filled t :ink (face-light (or color +gray80+) side))) ((eql type 'terminal) (let ((selected (eql color (drag-color pane)))) (when selected (draw-polygon-3d pane camera-points :filled t :ink color)) (draw-polygon-outline-3d pane camera-points (lc-scale-polygon camera-points 0.7) :filled t :ink (if selected +white+ (face-light (or color +gray80+) side))))))))))) (defun invoke-in-lc-space (pane continuation) ; "logic-cube space" =p (let* ((width (bounding-rectangle-width pane)) (height (bounding-rectangle-height pane)) (radius (/ (min width height) 2))) (with-translation (pane (/ width 2) (/ height 2)) (with-scaling (pane radius) (funcall continuation pane))))) (defmethod handle-repaint ((pane logic-cube-pane) region) (with-bounding-rectangle* (x0 y0 x1 y1) (sheet-region pane) (climi::with-double-buffering ((pane x0 y0 x1 y1) (wtf-wtf-wtf)) (declare (ignore wtf-wtf-wtf)) (draw-rectangle* pane x0 y0 x1 y1 :filled t :ink (background-color pane)) (invoke-in-lc-space pane #'draw-logic-cube) (when (decorator pane) (funcall (decorator pane)))))) ;;; Locating the face under the pointer: (defun square (x) (* x x)) (defun point-in-poly-p (x y points) (every (lambda (point edge) (let* ((edge-length (sqrt (+ (square (elt edge 0)) (square (elt edge 1))))) (nx (/ (- (elt edge 1)) edge-length)) (ny (/ (elt edge 0) edge-length)) (c (+ (* nx (elt point 0)) (* ny (elt point 1))))) (< c (+ (* nx x) (* ny y))))) points (polygon-edges points))) (defun xy-to-viewport-coordinates (pane x y) (let* ((width (bounding-rectangle-width pane)) ; .. (height (bounding-rectangle-height pane)) (radius (/ (min width height) 2))) (values (/ (- x (/ width 2)) radius) (/ (- y (/ height 2)) radius)))) (defun find-poly-under-point (pane x y) (apply-to-transformed-faces pane (lambda (side i j &rest points) (unless (backface-p points) (when (point-in-poly-p x y points) (return-from find-poly-under-point (values side i j)))))) (values nil nil nil)) ;;; Game interaction: (defmethod handle-event ((pane logic-cube-pane) (event pointer-exit-event)) (setf (dragging pane) nil)) (defmethod handle-event ((pane logic-cube-pane) (event pointer-button-release-event)) (setf (dragging pane) nil)) (defun square+ (pane side i j di dj) (let ((ni (+ i di)) (nj (+ j dj))) (if (or (> 0 ni) (> 0 nj) (>= ni (density pane)) (>= nj (density pane))) nil (list side ni nj)))) (defun adjacent-squares (pane side i j) (remove nil ; Ouch.. (list (square+ pane side i j 1 0) (square+ pane side i j 0 1) (or (square+ pane side i j -1 0) (and (= side 2) (list 1 j 0)) (and (= side 0) (list 2 j 0)) (and (= side 1) (list 0 j 0))) (or (square+ pane side i j 0 -1) (and (= side 2) (list 0 0 i)) (and (= side 1) (list 2 0 i)) (and (= side 0) (list 1 0 i)))))) (defun check-victory (pane) (let ((success t) (min-path-length nil)) (apply-to-hemicube-faces (density pane) (lambda (side i j &rest points) (declare (ignore points)) (when (eql 'terminal (second (aref (playfield pane) side i j))) (let ((coverage (make-hash-table :test 'equal)) (color (first (aref (playfield pane) side i j)))) (labels ((searching (path-length &rest indices) (setf (gethash indices coverage) t) (some (lambda (indices) (destructuring-bind (color-2 type) (apply #'aref (playfield pane) indices) (and (eql color color-2) (not (gethash indices coverage)) (or (and (eql type 'terminal) (setf min-path-length (if min-path-length (min min-path-length path-length) path-length))) (apply #'searching (1+ path-length) indices))))) (apply #'adjacent-squares pane indices)))) (unless (searching 1 side i j) (setf success nil))))))) (values success min-path-length))) ; Successful if no unconnected roots remained (defun won-logic-cube (pane) [82 lines skipped]

1 0

[mcclim-cvs] CVS mcclim
by ahefner 01 Jul '06

01 Jul '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv9497 Modified Files: ports.lisp Log Message: Fix destroy-port in the case where the backend method causes an error. The work seems to be done using :before methods (why??) both in McCLIM and the backends. If one of these errs, the primary method which removes the port from *all-ports* never runs. Fix this by using an :around method with an unwind-protect to ensure removal from *all-ports*. --- /project/mcclim/cvsroot/mcclim/ports.lisp 2006/04/17 18:40:27 1.52 +++ /project/mcclim/cvsroot/mcclim/ports.lisp 2006/07/01 21:31:41 1.53 @@ -230,8 +230,12 @@ nil) (defmethod destroy-port ((port basic-port)) - (reset-watcher port :destroy) - (setf *all-ports* (remove port *all-ports*))) + (reset-watcher port :destroy)) + +(defmethod destroy-port :around ((port basic-port)) + (unwind-protect + (call-next-method) + (setf *all-ports* (remove port *all-ports*)))) (defmethod add-watcher ((port basic-port) watcher) (declare (ignore watcher))

1 0

[mcclim-cvs] CVS mcclim
by ahefner 01 Jul '06

01 Jul '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv5802 Modified Files: frames.lisp Log Message: Fix command menus in frames with no interactor (or application-pane?) by making read-frame-command handle the case :stream nil by calling the simple event loop. Changed the default top level to call read-frame-command with a null stream rather than calling the simple event loop directly. Previously the command menu would throw a menu-item, but because the receiving code is in the :around method on read-frame-command (and thus not executed), the menu selection was ignored. Metaphorically, the "read a command" operation should be applicable even when the textual command parser is not invoked. --- /project/mcclim/cvsroot/mcclim/frames.lisp 2006/05/05 10:24:02 1.119 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2006/07/01 21:00:31 1.120 @@ -459,11 +459,10 @@ (redisplay-frame-panes frame :force-p first-time) (setq first-time nil) (if query-io - ;; We don't need to turn the cursor on here, as Goatee has its own - ;; cursor which will appear. In fact, leaving it on causes much - ;; bit flipping and slows command output somewhat. So, leave it - ;; off by default, and hope this doesn't violate the spec. + ;; For frames with an interactor: (progn + ;; Hide cursor, so we don't need to toggle it during + ;; command output. (setf (cursor-visibility (stream-text-cursor *query-io*)) nil) (when (and prompt interactorp) @@ -480,7 +479,9 @@ (execute-frame-command frame command)) (when interactorp (fresh-line *query-io*)))) - (simple-event-loop))) + ;; Frames without an interactor: + (let ((command (read-frame-command frame :stream nil))) + (when command (execute-frame-command frame command))))) (abort () :report "Return to application command loop" (if interactorp @@ -488,7 +489,7 @@ (beep)))))))) (defmethod read-frame-command :around ((frame application-frame) - &key (stream *standard-input*)) + &key (stream *standard-input*)) (with-input-context ('menu-item) (object) (call-next-method) @@ -510,7 +511,9 @@ ;; If we do things as the spec says, command accelerators will ;; appear to not work, confusing new users. #+NIL (read-command (frame-command-table frame) :use-keystrokes nil :stream stream) - (read-command (frame-command-table frame) :use-keystrokes t :stream stream)) + (if stream + (read-command (frame-command-table frame) :use-keystrokes t :stream stream) + (simple-event-loop frame))) (define-event-class execute-command-event (window-manager-event) ((sheet :initarg :sheet :reader event-sheet) @@ -1297,10 +1300,10 @@ input-context) (frame-update-pointer-documentation frame input-context stream event)) -(defun simple-event-loop () +(defun simple-event-loop (&optional (frame *application-frame*)) "An simple event loop for applications that want all events to be handled by handle-event methods" - (let ((queue (frame-event-queue *application-frame*))) + (let ((queue (frame-event-queue frame))) (loop for event = (event-queue-read queue) ;; EVENT-QUEUE-READ in single-process mode calls PROCESS-NEXT-EVENT itself. do (handle-event (event-sheet event) event))))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs July 2006