From rstrandh at common-lisp.net Mon Dec 7 08:41:37 2009 From: rstrandh at common-lisp.net (rstrandh) Date: Mon, 07 Dec 2009 03:41:37 -0500 Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: Update of /project/mcclim/cvsroot/mcclim/Examples In directory cl-net:/tmp/cvs-serv801 Removed Files: fire.lisp Log Message: This file was old, and has been replaced by traffic-lights.lisp. From rstrandh at common-lisp.net Mon Dec 7 08:47:04 2009 From: rstrandh at common-lisp.net (rstrandh) Date: Mon, 07 Dec 2009 03:47:04 -0500 Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: Update of /project/mcclim/cvsroot/mcclim/Examples In directory cl-net:/tmp/cvs-serv2588 Modified Files: traffic-lights.lisp Log Message: Removed dead code. Added my copyright. Fixed some comments. --- /project/mcclim/cvsroot/mcclim/Examples/traffic-lights.lisp 2002/07/29 06:04:02 1.6 +++ /project/mcclim/cvsroot/mcclim/Examples/traffic-lights.lisp 2009/12/07 08:47:04 1.7 @@ -2,6 +2,8 @@ ;;; (c) copyright 2001 by ;;; Julien Boninfante (boninfan at emi.u-bordeaux.fr) +;;; (c) copyright 2009 by +;;; Robert Strandh (strandh at labri.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -29,26 +31,18 @@ (in-package :clim-internals) -;; example gadget definition +;;; example gadget definition (defclass light-pane (standard-gadget) ()) -#+nil -(defmethod dispatch-repaint ((pane light-pane) region) - (repaint-sheet pane region)) - (defmethod handle-repaint ((pane light-pane) region) (declare (ignore region)) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region pane)) - (display-gadget-background pane (gadget-current-color pane) 0 0 (- x2 x1) (- y2 y1)))) - -#+nil -(defmethod handle-event ((pane light-pane) (event window-repaint-event)) - (declare (ignorable event)) - (dispatch-repaint pane (sheet-region pane))) + (display-gadget-background + pane (gadget-current-color pane) 0 0 (- x2 x1) (- y2 y1)))) (in-package :clim-demo) -;; callback functions +;;; callback functions (defmethod handle-event :after ((pane clim-internals::light-pane) (event pointer-event)) (declare (ignorable event)) @@ -95,7 +89,7 @@ (setf (clim-internals::gadget-current-color (slot-value *application-frame* 'light)) (clim-internals::gadget-pushed-and-highlighted-color (slot-value *application-frame* 'light))))) -;; test functions +;;; test functions (defun traffic-lights () (loop for port in climi::*all-ports* From rstrandh at common-lisp.net Mon Dec 7 14:04:39 2009 From: rstrandh at common-lisp.net (rstrandh) Date: Mon, 07 Dec 2009 09:04:39 -0500 Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: Update of /project/mcclim/cvsroot/mcclim/Examples In directory cl-net:/tmp/cvs-serv24077 Modified Files: sliderdemo.lisp Log Message: Fixed a bug that made this demo not work (thanks to "lhz" on #lisp). Improved the code somewhat to avoid too much code duplication. It could be made better still. On the other hand, this demo should probably be redone or removed, since it involves the calculator as well, which doesn't seem reasonable. --- /project/mcclim/cvsroot/mcclim/Examples/sliderdemo.lisp 2006/12/19 04:08:58 1.5 +++ /project/mcclim/cvsroot/mcclim/Examples/sliderdemo.lisp 2009/12/07 14:04:39 1.6 @@ -24,10 +24,7 @@ (defparameter calc '(0)) (defvar *text-field* nil) -(defun slidertest () - (loop for port in climi::*all-ports* - do (destroy-port port)) - (setq climi::*all-ports* nil) +(defun sliderdemo () (let ((frame (make-application-frame 'sliderdemo))) (run-frame-top-level frame))) @@ -38,7 +35,8 @@ (if (numberp last-item) (setf (car (last calc)) (+ (* 10 last-item) ,int)) (setf calc (nconc calc (list ,int)))) - (setf (gadget-value *text-field*) (princ-to-string (first (last calc))))))) + (setf (gadget-value *text-field*) + (princ-to-string (first (last calc))))))) (defmacro queue-operator (operator) `(lambda (gadget) @@ -76,100 +74,69 @@ (defun find-text-field (frame) (first (member-if #'(lambda (gadget) (typep gadget 'text-field)) - (frame-panes frame)))) + (frame-current-panes frame)))) -(defmethod sliderdemo-frame-top-level ((frame application-frame) - &key (command-parser 'command-line-command-parser) - (command-unparser 'command-line-command-unparser) - (partial-command-parser - 'command-line-read-remaining-arguments-for-partial-command) - (prompt "Command: ")) +(defmethod sliderdemo-frame-top-level + ((frame application-frame) + &key (command-parser 'command-line-command-parser) + (command-unparser 'command-line-command-unparser) + (partial-command-parser + 'command-line-read-remaining-arguments-for-partial-command) + (prompt "Command: ")) (declare (ignore command-parser command-unparser partial-command-parser prompt)) (setf *text-field* (find-text-field frame)) (clim-extensions:simple-event-loop)) -(define-application-frame sliderdemo () () - (:panes - (plus :push-button - :space-requirement (make-space-requirement :width 50 :height 50) - :label "+" - :activate-callback (queue-operator #'+)) - (dash :push-button - :space-requirement (make-space-requirement :width 50 :height 50) - :label "-" - :activate-callback (queue-operator #'-)) - (multiplicate :push-button - :space-requirement (make-space-requirement :width 50 :height 50) - :label "*" - :activate-callback (queue-operator #'*)) - (divide :push-button - :space-requirement (make-space-requirement :width 50 :height 50) - :label "/" - :activate-callback (queue-operator #'round)) - (result :push-button - :space-requirement (make-space-requirement :width 50 :height 50) - :label "=" - :activate-callback #'do-operation) - (one :push-button - :space-requirement (make-space-requirement :width 50 :height 50) - :label "1" - :activate-callback (queue-number 1)) - (two :push-button - :space-requirement (make-space-requirement :width 50 :height 50) - :label "2" - :activate-callback (queue-number 2)) - (three :push-button - :space-requirement (make-space-requirement :width 50 :height 50) - :label "3" - :activate-callback (queue-number 3)) - (four :push-button - :space-requirement (make-space-requirement :width 50 :height 50) - :label "4" - :activate-callback (queue-number 4)) - (five :push-button - :space-requirement (make-space-requirement :width 50 :height 50) - :label "5" - :activate-callback (queue-number 5)) - (six :push-button - :space-requirement (make-space-requirement :width 50 :height 50) - :label "6" - :activate-callback (queue-number 6)) - (seven :push-button - :space-requirement (make-space-requirement :width 50 :height 50) - :label "7" - :activate-callback (queue-number 7)) - (eight :push-button - :space-requirement (make-space-requirement :width 50 :height 50) - :label "8" - :activate-callback (queue-number 8)) - (nine :push-button - :space-requirement (make-space-requirement :width 50 :height 50) - :label "9" - :activate-callback (queue-number 9)) - (zero :push-button - :space-requirement (make-space-requirement :width 50 :height 50) - :label "0" - :activate-callback (queue-number 0)) - (screen :text-field - :value "0" - :space-requirement (make-space-requirement :width 200 :height 50)) - (ac :push-button - :space-requirement (make-space-requirement :width 50 :height 50) - :label "AC" - :activate-callback #'initac) - (ce :push-button - :space-requirement (make-space-requirement :width 50 :height 50) - :label "CE" - :activate-callback #'initce) - (slider :slider - :value-changed-callback #'slide - :min-value 0 - :max-value 100 - :value 0 - :normal +white+ - :highlighted +cyan+ - :pushed-and-highlighted +blue+)) +(eval-when (:compile-toplevel) + (defun make-operator-button-form (name label operator) + `(,name :push-button + :space-requirement (make-space-requirement + :width 50 :height 50) + :label ,label + :activate-callback (queue-operator #',operator))) + + (defun make-number-button-form (name label number) + `(,name :push-button + :space-requirement (make-space-requirement + :width 50 :height 50) + :label ,label + :activate-callback (queue-number ,number)))) +(define-application-frame sliderdemo () () + (:panes #.(make-operator-button-form 'plus "+" '+) + #.(make-operator-button-form 'dash "-" '-) + #.(make-operator-button-form 'multiply "*" '*) + #.(make-operator-button-form 'divide "/" 'round) + #.(make-operator-button-form 'result "=" 'do-operation) + #.(make-number-button-form 'one "1" 1) + #.(make-number-button-form 'two "2" 2) + #.(make-number-button-form 'three "3" 3) + #.(make-number-button-form 'four "4" 4) + #.(make-number-button-form 'five "5" 5) + #.(make-number-button-form 'six "6" 6) + #.(make-number-button-form 'seven "7" 7) + #.(make-number-button-form 'eight "8" 8) + #.(make-number-button-form 'nine "9" 9) + #.(make-number-button-form 'zero "0" 0) + (screen :text-field + :value "0" + :space-requirement (make-space-requirement :width 200 :height 50)) + (ac :push-button + :space-requirement (make-space-requirement :width 50 :height 50) + :label "AC" + :activate-callback #'initac) + (ce :push-button + :space-requirement (make-space-requirement :width 50 :height 50) + :label "CE" + :activate-callback #'initce) + (slider :slider + :value-changed-callback #'slide + :min-value 0 + :max-value 100 + :value 0 + :normal +white+ + :highlighted +cyan+ + :pushed-and-highlighted +blue+)) (:layouts (defaults (horizontally () (vertically () @@ -178,7 +145,7 @@ (tabling () (list one two plus) (list three four dash) - (list five six multiplicate) + (list five six multiply) (list seven eight divide) (list nine zero result))) slider))) From rstrandh at common-lisp.net Tue Dec 8 05:26:29 2009 From: rstrandh at common-lisp.net (rstrandh) Date: Tue, 08 Dec 2009 00:26:29 -0500 Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: Update of /project/mcclim/cvsroot/mcclim/Examples In directory cl-net:/tmp/cvs-serv32548 Modified Files: font-selector.lisp Log Message: Fixed the font-selector demo so that it doesn't crash. The problem was that when the family changes, it tries to initialize the face to one with the same name as the selected one in the old family. When there is no such face in the new family, it got initialized to nil. However, the demo is still not working properly. Sometimes a displayed face becomes non-clickable, and sometimes two faces are highlighted simultaneously. --- /project/mcclim/cvsroot/mcclim/Examples/font-selector.lisp 2008/01/21 01:08:58 1.2 +++ /project/mcclim/cvsroot/mcclim/Examples/font-selector.lisp 2009/12/08 05:26:29 1.3 @@ -99,10 +99,11 @@ (reset-list-pane face-list new-faces) (when old-face (setf (gadget-value face-list :invoke-callback t) - (find (font-face-name old-face) - new-faces - :key #'font-face-name - :test #'equal))))) + (or (find (font-face-name old-face) + new-faces + :key #'font-face-name + :test #'equal) + (first new-faces)))))) (defun face-changed (pane value) (declare (ignore pane)) From rstrandh at common-lisp.net Wed Dec 16 13:15:39 2009 From: rstrandh at common-lisp.net (rstrandh) Date: Wed, 16 Dec 2009 08:15:39 -0500 Subject: [mcclim-cvs] CVS mcclim Message-ID: Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv9620 Modified Files: presentations.lisp Log Message: Fixed a typo. Thanks to Stas Boukarev. --- /project/mcclim/cvsroot/mcclim/presentations.lisp 2008/02/01 17:02:55 1.85 +++ /project/mcclim/cvsroot/mcclim/presentations.lisp 2009/12/16 13:15:38 1.86 @@ -71,7 +71,7 @@ `(flet ((,continuation () , at decls , at with-body)) - (declare (dynamic-extent #'continuation)) + (declare (dynamic-extent #',continuation)) (if (and (output-recording-stream-p ,stream) *allow-sensitive-inferiors*) (with-new-output-record