From ahefner at common-lisp.net Tue Feb 1 01:47:37 2005 From: ahefner at common-lisp.net (Andy Hefner) Date: Mon, 31 Jan 2005 17:47:37 -0800 (PST) Subject: [mcclim-cvs] CVS update: mcclim/Examples/stream-test.lisp Message-ID: <20050201014737.D4F0288029@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory common-lisp.net:/tmp/cvs-serv20492 Modified Files: stream-test.lisp Log Message: Change run-test to not destroy all active ports before running the demo. Date: Mon Jan 31 17:47:36 2005 Author: ahefner Index: mcclim/Examples/stream-test.lisp diff -u mcclim/Examples/stream-test.lisp:1.3 mcclim/Examples/stream-test.lisp:1.4 --- mcclim/Examples/stream-test.lisp:1.3 Sat Jul 26 10:37:57 2003 +++ mcclim/Examples/stream-test.lisp Mon Jan 31 17:47:36 2005 @@ -58,9 +58,9 @@ (default (vertically () tester)))) (defun run-test (name) - (loop for port in climi::*all-ports* - do (destroy-port port)) - (setq climi::*all-ports* nil) +; (loop for port in climi::*all-ports* +; do (destroy-port port)) +; (setq climi::*all-ports* nil) (when name (run-frame-top-level (make-application-frame name)))) From ahefner at common-lisp.net Tue Feb 1 03:08:29 2005 From: ahefner at common-lisp.net (Andy Hefner) Date: Mon, 31 Jan 2005 19:08:29 -0800 (PST) Subject: [mcclim-cvs] CVS update: mcclim/panes.lisp Message-ID: <20050201030829.A476088029@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv24645 Modified Files: panes.lisp Log Message: Attempt to remedy bit rot in grid-pane. Date: Mon Jan 31 19:08:28 2005 Author: ahefner Index: mcclim/panes.lisp diff -u mcclim/panes.lisp:1.148 mcclim/panes.lisp:1.149 --- mcclim/panes.lisp:1.148 Fri Jan 21 03:01:37 2005 +++ mcclim/panes.lisp Mon Jan 31 19:08:27 2005 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.148 2005/01/21 11:01:37 ahefner Exp $ +;;; $Id: panes.lisp,v 1.149 2005/02/01 03:08:27 ahefner Exp $ (in-package :clim-internals) @@ -1371,7 +1371,7 @@ (with-slots (array) pane (setf array (make-array (list nrows ncols) :initial-element nil)) - (loop for row in contents + (loop for row in contents for i from 0 do (loop for cell in row for j from 0 do @@ -1542,39 +1542,43 @@ (defmethod compose-space ((grid grid-pane) &key width height) (declare (ignore width height)) (mapc #'compose-space (sheet-children grid)) - (loop with nb-children-pl = (table-pane-number grid) - with nb-children-pc = (/ (length (sheet-children grid)) nb-children-pl) - for child in (sheet-children grid) - and width = 0 then (max width (sr-width child)) - and height = 0 then (max height (sr-height child)) - and max-width = 5000000 then (min max-width (sr-min-width child)) - and max-height = 5000000 then (min max-height (sr-max-height child)) - and min-width = 0 then (max min-width (sr-min-width child)) - and min-height = 0 then (max min-height (sr-min-height child)) - finally (return - (make-space-requirement - :width (* width nb-children-pl) - :height (* height nb-children-pc) - :max-width (* width nb-children-pl) - :max-height (* max-height nb-children-pc) - :min-width (* min-width nb-children-pl) - :min-height (* min-height nb-children-pc))))) + (with-slots (array) grid + (loop with nb-children-pl = (array-dimension array 1) ;(table-pane-number grid) + with nb-children-pc = (array-dimension array 0) ;(/ (length (sheet-children grid)) nb-children-pl) + for child in (sheet-children grid) + and width = 0 then (max width (sr-width child)) + and height = 0 then (max height (sr-height child)) + and max-width = 5000000 then (min max-width (sr-min-width child)) + and max-height = 5000000 then (min max-height (sr-max-height child)) + and min-width = 0 then (max min-width (sr-min-width child)) + and min-height = 0 then (max min-height (sr-min-height child)) + finally (return + (make-space-requirement + :width (* width nb-children-pl) + :height (* height nb-children-pc) + :max-width (* width nb-children-pl) + :max-height (* max-height nb-children-pc) + :min-width (* min-width nb-children-pl) + :min-height (* min-height nb-children-pc)))))) (defmethod allocate-space ((grid grid-pane) width height) - (loop with nb-kids-p-l = (table-pane-number grid) - with nb-kids-p-c = (/ (length (sheet-children grid)) nb-kids-p-l) - for children in (format-children grid) - for c from nb-kids-p-c downto 1 - for tmp-height = height then (decf tmp-height new-height) - for new-height = (/ tmp-height c) - for y = 0 then (+ y new-height) - do (loop for child in children - for l from nb-kids-p-l downto 1 - for tmp-width = width then (decf tmp-width new-width) - for new-width = (/ tmp-width l) - for x = 0 then (+ x new-width) - do (move-sheet child x y) - (allocate-space child (round new-width) (round new-height))))) + (with-slots (array) grid + (loop with nb-kids-p-l = (array-dimension array 1) ;(table-pane-number grid) + with nb-kids-p-c = (array-dimension array 0) ;(/ (length (sheet-children grid)) nb-kids-p-l) + for c from nb-kids-p-c downto 1 + for row-index from 0 by 1 + for tmp-height = height then (decf tmp-height new-height) + for new-height = (/ tmp-height c) + for y = 0 then (+ y new-height) + do (loop + for col-index from 0 by 1 + for l from nb-kids-p-l downto 1 + for child = (aref array row-index col-index) + for tmp-width = width then (decf tmp-width new-width) + for new-width = (/ tmp-width l) + for x = 0 then (+ x new-width) + do (move-sheet child x y) + (allocate-space child (round new-width) (round new-height)))))) ;;; SPACING PANE @@ -2557,7 +2561,7 @@ (eq (frame-state frame) :shrunk)) (enable-frame frame)) ;; Start a new thread to run the event loop, if necessary. - #+CLIM-MP + #+clim-mp (unless input-buffer (clim-sys:make-process (lambda () (let ((*application-frame* frame)) (standalone-event-loop))))) From ahefner at common-lisp.net Tue Feb 1 03:11:43 2005 From: ahefner at common-lisp.net (Andy Hefner) Date: Mon, 31 Jan 2005 19:11:43 -0800 (PST) Subject: [mcclim-cvs] CVS update: mcclim/Examples/calculator.lisp Message-ID: <20050201031143.B4D4388029@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory common-lisp.net:/tmp/cvs-serv24691 Modified Files: calculator.lisp Log Message: Minor revisions to calculator example - use grid-pane rather than table-pane to equalize button sizes, adjust default text style. Date: Mon Jan 31 19:11:40 2005 Author: ahefner Index: mcclim/Examples/calculator.lisp diff -u mcclim/Examples/calculator.lisp:1.17 mcclim/Examples/calculator.lisp:1.18 --- mcclim/Examples/calculator.lisp:1.17 Fri Mar 21 13:37:00 2003 +++ mcclim/Examples/calculator.lisp Mon Jan 31 19:11:39 2005 @@ -22,7 +22,11 @@ (in-package :clim-demo) +(defparameter *calculator-text-style* + (make-text-style :sans-serif :roman :large)) + (defun calculator () + #+nil (progn (loop for port in climi::*all-ports* do (destroy-port port)) @@ -88,6 +92,7 @@ (make-pane 'push-button-pane :label label :activate-callback operator + :text-style *calculator-text-style* :width width :height height :max-width max-width :min-width min-width :max-height max-height :min-height min-height)) @@ -111,7 +116,7 @@ (eight (make-button "8" (queue-number 8))) (nine (make-button "9" (queue-number 9))) (zero (make-button "0" (queue-number 0))) - (screen :text-field :value "0") + (screen :text-field :value "0" :text-style *calculator-text-style*) (ac (make-button "AC" #'initac)) (ce (make-button "CE" #'initce))) @@ -121,7 +126,7 @@ (vertically (:width 150 :max-width 500) (setf text-field screen) (horizontally (:height 50) ac ce) - (tabling () + (tabling (:grid t) (list one two plus) (list three four dash) (list five six multiply) From ahefner at common-lisp.net Tue Feb 1 03:28:54 2005 From: ahefner at common-lisp.net (Andy Hefner) Date: Mon, 31 Jan 2005 19:28:54 -0800 (PST) Subject: [mcclim-cvs] CVS update: mcclim/Examples/menutest.lisp Message-ID: <20050201032854.2C78988029@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory common-lisp.net:/tmp/cvs-serv25606 Modified Files: menutest.lisp Log Message: Minor fixes to menutest - Define commands within the menutest command so that they are not shown as disabled in the menus. Direct output to the CLIM window rather than *error-output*, and set the text style to sans-serif. Date: Mon Jan 31 19:28:52 2005 Author: ahefner Index: mcclim/Examples/menutest.lisp diff -u mcclim/Examples/menutest.lisp:1.10 mcclim/Examples/menutest.lisp:1.11 --- mcclim/Examples/menutest.lisp:1.10 Fri Mar 21 13:37:00 2003 +++ mcclim/Examples/menutest.lisp Mon Jan 31 19:28:51 2005 @@ -23,42 +23,43 @@ (in-package :menutest) (defun menutest () - (loop for port in climi::*all-ports* - do (destroy-port port)) - (setq climi::*all-ports* nil) (let ((frame (make-application-frame 'menutest))) (run-frame-top-level frame) frame)) -(define-command com-file () - (format *error-output* "you pressed the File button~%") - (finish-output *error-output*)) - -(define-command com-hello () - (format *error-output* "you pressed the Hello button~%") - (finish-output *error-output*)) - -(define-command com-hi () - (format *error-output* "you pressed the Hi button~%") - (finish-output *error-output*)) +(define-application-frame menutest () + () + (:menu-bar menubar-command-table) + (:panes + (screen :application + :display-time nil + :text-style (make-text-style :sans-serif :roman :normal))) + (:layouts + (defaults (vertically () screen))) + #+nil + (:top-level (menutest-frame-top-level))) + +(define-menutest-command com-file () + (format *standard-output* "You pressed the File button.~%") + (finish-output *standard-output*)) + +(define-menutest-command com-hello () + (format *standard-output* "You pressed the Hello button.~%") + (finish-output *standard-output*)) + +(define-menutest-command com-hi () + (format *standard-output* "You pressed the Hi button.~%") + (finish-output *standard-output*)) (make-command-table 'buffer-command-table :errorp nil :menu '(("Hello there" :command com-hello) - ("Hi there" :command com-hi))) + ("Hi there" :command com-hi))) (make-command-table 'menubar-command-table :errorp nil :menu '(("Buffer" :menu buffer-command-table) - ("File" :command com-file))) + ("File" :command com-file))) + -(define-application-frame menutest () - () - (:menu-bar menubar-command-table) - (:panes - (screen :application)) - (:layouts - (defaults (vertically () screen))) - #+nil - (:top-level (menutest-frame-top-level))) From ahefner at common-lisp.net Tue Feb 1 03:44:01 2005 From: ahefner at common-lisp.net (Andy Hefner) Date: Mon, 31 Jan 2005 19:44:01 -0800 (PST) Subject: [mcclim-cvs] CVS update: mcclim/Examples/colorslider.lisp Message-ID: <20050201034401.0673988029@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory common-lisp.net:/tmp/cvs-serv26351 Modified Files: colorslider.lisp Log Message: Comment out archaic futzing with port and frame manager, which seemed to cause a problem with closing the colorslider window. Date: Mon Jan 31 19:44:00 2005 Author: ahefner Index: mcclim/Examples/colorslider.lisp diff -u mcclim/Examples/colorslider.lisp:1.18 mcclim/Examples/colorslider.lisp:1.19 --- mcclim/Examples/colorslider.lisp:1.18 Fri Oct 15 06:23:20 2004 +++ mcclim/Examples/colorslider.lisp Mon Jan 31 19:44:00 2005 @@ -59,18 +59,18 @@ ;; test functions (defun colorslider () - (declare (special frame fm port pane medium graft)) - (loop for port in climi::*all-ports* - do (destroy-port port)) - (setq climi::*all-ports* nil) - (setq fm (find-frame-manager)) - (setq frame (make-application-frame 'colorslider - :frame-manager fm)) - (setq port (climi::frame-manager-port fm)) - (setq pane (frame-panes frame)) - (setq medium (sheet-medium pane)) - (setq graft (graft frame)) - (run-frame-top-level frame)) +; (declare (special frame fm port pane medium graft)) +; (loop for port in climi::*all-ports* +; do (destroy-port port)) +; (setq climi::*all-ports* nil) +; (setq fm (find-frame-manager)) +; (setq frame (make-application-frame 'colorslider +; :frame-manager fm)) +; (setq port (climi::frame-manager-port fm)) +; (setq pane (frame-panes frame)) +; (setq medium (sheet-medium pane)) +; (setq graft (graft frame)) + (run-frame-top-level (make-application-frame 'colorslider))) (defmethod slidertest-frame-top-level ((frame application-frame) From ahefner at common-lisp.net Tue Feb 1 04:30:22 2005 From: ahefner at common-lisp.net (Andy Hefner) Date: Mon, 31 Jan 2005 20:30:22 -0800 (PST) Subject: [mcclim-cvs] CVS update: mcclim/Examples/puzzle.lisp Message-ID: <20050201043022.847878802D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory common-lisp.net:/tmp/cvs-serv28930 Modified Files: puzzle.lisp Log Message: Very tiny changes to get puzzle running so we can put it back in the examples system. Date: Mon Jan 31 20:30:21 2005 Author: ahefner Index: mcclim/Examples/puzzle.lisp diff -u mcclim/Examples/puzzle.lisp:1.2 mcclim/Examples/puzzle.lisp:1.3 --- mcclim/Examples/puzzle.lisp:1.2 Fri Mar 21 07:15:09 2003 +++ mcclim/Examples/puzzle.lisp Mon Jan 31 20:30:20 2005 @@ -2,7 +2,7 @@ ;; $fiHeader: puzzle.lisp,v 1.23 1993/07/27 01:46:05 colin Exp $ -(in-package :clim) +(in-package :clim-demo) "Copyright (c) 1989, 1990, 1991, 1992 Symbolics, Inc. All rights reserved." @@ -46,7 +46,8 @@ (define-presentation-method highlight-presentation ((type puzzle-cell) record stream state) state (multiple-value-bind (xoff yoff) - (convert-from-relative-to-absolute-coordinates + (#+mcclim climi::convert-from-relative-to-absolute-coordinates ;; Legacy CLIM 1.0 function.. + #-mcclim clim:convert-from-relative-to-absolute-coordinates stream (output-record-parent record)) (with-bounding-rectangle* (left top right bottom) record (draw-rectangle* stream From ahefner at common-lisp.net Tue Feb 1 05:35:30 2005 From: ahefner at common-lisp.net (Andy Hefner) Date: Mon, 31 Jan 2005 21:35:30 -0800 (PST) Subject: [mcclim-cvs] CVS update: mcclim/system.lisp Message-ID: <20050201053530.BD1E18864B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv568 Modified Files: system.lisp Log Message: Add puzzle, demodemo, and dragndrop to the examples system. Date: Mon Jan 31 21:35:29 2005 Author: ahefner Index: mcclim/system.lisp diff -u mcclim/system.lisp:1.110 mcclim/system.lisp:1.111 --- mcclim/system.lisp:1.110 Sun Jan 30 22:24:58 2005 +++ mcclim/system.lisp Mon Jan 31 21:35:29 2005 @@ -204,12 +204,14 @@ "Examples/traffic-lights" "Examples/clim-fig" "Examples/postscript-test" - ;; "Examples/puzzle" + "Examples/puzzle" "Examples/transformations-test" ;; "Examples/sliderdemo" + "Examples/demodemo" "Examples/stream-test" "Examples/presentation-test" - #+clx "Examples/gadget-test" + "Examples/dragndrop" + "Examples/gadget-test" "Examples/method-browser" "Goatee/goatee-test" "Examples/accepting-values") From ahefner at common-lisp.net Tue Feb 1 05:35:32 2005 From: ahefner at common-lisp.net (Andy Hefner) Date: Mon, 31 Jan 2005 21:35:32 -0800 (PST) Subject: [mcclim-cvs] CVS update: mcclim/Examples/demodemo.lisp mcclim/Examples/fire.lisp Message-ID: <20050201053532.4C7268864B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory common-lisp.net:/tmp/cvs-serv568/Examples Modified Files: demodemo.lisp fire.lisp Log Message: Add puzzle, demodemo, and dragndrop to the examples system. Date: Mon Jan 31 21:35:30 2005 Author: ahefner Index: mcclim/Examples/demodemo.lisp diff -u mcclim/Examples/demodemo.lisp:1.6 mcclim/Examples/demodemo.lisp:1.7 --- mcclim/Examples/demodemo.lisp:1.6 Wed Jan 21 00:59:13 2004 +++ mcclim/Examples/demodemo.lisp Mon Jan 31 21:35:30 2005 @@ -47,7 +47,7 @@ (default (vertically (:equalize-width t) (progn ;;spacing (:thickness 10) - (labelling (:label "FreeCLIM Demos" + (labelling (:label "McCLIM Demos" :text-style (make-text-style :sans-serif :roman :huge) :align-x :center))) (progn ;; spacing (:thickness 10) @@ -55,8 +55,15 @@ ;; '+fill+ (labelling (:label "Demos") (vertically (:equalize-width t) + (make-demo-button "CLIM-Fig" 'clim-fig) + (make-demo-button "Calculator" 'calculator) + (make-demo-button "Method Browser" 'method-browser) + (make-demo-button "Address Book" 'address-book) + (make-demo-button "Puzzle" 'puzzle) + (make-demo-button "Gadget Test" 'gadget-test) + (make-demo-button "Drag and Drop" 'dragndrop) (make-demo-button "Colorslider" 'colorslider) - (make-demo-button "Calculator" 'calculator))) + (make-demo-button "Goatee Test" 'goatee::goatee-test))) (labelling (:label "Tests") (vertically (:equalize-width t) (make-demo-button "Label Test" 'label-test) @@ -66,6 +73,7 @@ (make-demo-button "HBOX Test" 'hbox-test))))))))) (defun demodemo () + #+nil (loop for port in climi::*all-ports* do (destroy-port port)) (run-frame-top-level (make-application-frame 'demodemo))) Index: mcclim/Examples/fire.lisp diff -u mcclim/Examples/fire.lisp:1.3 mcclim/Examples/fire.lisp:1.4 --- mcclim/Examples/fire.lisp:1.3 Wed Mar 12 22:55:27 2003 +++ mcclim/Examples/fire.lisp Mon Jan 31 21:35:30 2005 @@ -52,8 +52,10 @@ (defmethod handle-event :after ((pane clim-internals::fire-pane) (event pointer-event)) (declare (ignorable event)) + (hef:debugf pane event) + #+nil (let ((label (clim-internals::gadget-label (clim-internals::radio-box-current-selection - (slot-value *application-frame* 'radio-box))))) + (find-pane-named *application-frame* 'radio-box))))) (cond ((string= label "O") (progn (sleep 3) @@ -73,20 +75,20 @@ (defun callback-red (gadget value) (declare (ignorable gadget)) (when value - (setf (clim-internals::gadget-current-color (slot-value *application-frame* 'fire)) - (clim-internals::gadget-normal-color (slot-value *application-frame* 'fire))))) + (setf (clim-internals::gadget-current-color (find-pane-named *application-frame* 'fire)) + (clim-internals::gadget-normal-color (find-pane-named *application-frame* 'fire))))) (defun callback-orange (gadget value) (declare (ignore gadget)) (when value - (setf (clim-internals::gadget-current-color (slot-value *application-frame* 'fire)) - (clim-internals::gadget-highlighted-color (slot-value *application-frame* 'fire))))) + (setf (clim-internals::gadget-current-color (find-pane-named *application-frame* 'fire)) + (clim-internals::gadget-highlighted-color (find-pane-named *application-frame* 'fire))))) (defun callback-green (gadget value) (declare (ignore gadget)) (when value - (setf (clim-internals::gadget-current-color (slot-value *application-frame* 'fire)) - (clim-internals::gadget-pushed-and-highlighted-color (slot-value *application-frame* 'fire))))) + (setf (clim-internals::gadget-current-color (find-pane-named *application-frame* 'fire)) + (clim-internals::gadget-pushed-and-highlighted-color (find-pane-named *application-frame* 'fire))))) ;; test functions @@ -97,13 +99,13 @@ (run-frame-top-level (make-application-frame 'firelights))) (defmethod fire-frame-top-level ((frame application-frame)) - (setf (slot-value *application-frame* 'fire) (car (last (frame-panes *application-frame*))) - (slot-value *application-frame* 'radio-box) - (with-radio-box () - (first (frame-panes *application-frame*)) - (second (frame-panes *application-frame*)) - (radio-box-current-selection (third (frame-panes *application-frame*))))) - (loop (event-read (frame-pane frame)))) + (with-look-and-feel-realization ((frame-manager frame) frame) + (setf (slot-value *application-frame* 'radio-box) + (with-radio-box (:name 'radio-box) + (first (frame-panes *application-frame*)) + (second (frame-panes *application-frame*)) + (radio-box-current-selection (third (frame-panes *application-frame*))))) + (loop (event-read (find-pane-named frame 'fire))))) (define-application-frame firelights () ((radio-box :initform nil) @@ -141,4 +143,4 @@ :value-changed-callback 'callback-orange)) (:layouts (default (horizontally () (vertically () red-fire orange-fire green-fire) fire))) - (:top-level (fire-frame-top-level . nil))) + #+NIL (:top-level (fire-frame-top-level . nil))) From ahefner at gmail.com Tue Feb 1 05:41:17 2005 From: ahefner at gmail.com (Andy Hefner) Date: Tue, 1 Feb 2005 00:41:17 -0500 Subject: [mcclim-cvs] CVS update: mcclim/Examples/demodemo.lisp mcclim/Examples/fire.lisp In-Reply-To: <20050201053532.4C7268864B@common-lisp.net> References: <20050201053532.4C7268864B@common-lisp.net> Message-ID: <31ffd3c4050131214130c026a7@mail.gmail.com> Oops, committed more than I intended. Comments for these two files: * demodemo.lisp: Added a number of working demos to the menu in demodemo. * fire.lisp: Didn't intend to commit changes to this file. Summary of changes: Broken before, still broken now. May run, but doesn't do anything interesting. On Mon, 31 Jan 2005 21:35:32 -0800 (PST), Andy Hefner wrote: > Update of /project/mcclim/cvsroot/mcclim/Examples > In directory common-lisp.net:/tmp/cvs-serv568/Examples > > Modified Files: > demodemo.lisp fire.lisp > Log Message: > Add puzzle, demodemo, and dragndrop to the examples system. From ahefner at common-lisp.net Wed Feb 2 06:32:33 2005 From: ahefner at common-lisp.net (Andy Hefner) Date: Wed, 2 Feb 2005 07:32:33 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Examples/fire.lisp Message-ID: <20050202063233.818D98802C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory common-lisp.net:/tmp/cvs-serv15028 Modified Files: fire.lisp Log Message: Remove debugging code from (broken) fire example. Date: Wed Feb 2 07:32:32 2005 Author: ahefner Index: mcclim/Examples/fire.lisp diff -u mcclim/Examples/fire.lisp:1.4 mcclim/Examples/fire.lisp:1.5 --- mcclim/Examples/fire.lisp:1.4 Tue Feb 1 06:35:30 2005 +++ mcclim/Examples/fire.lisp Wed Feb 2 07:32:32 2005 @@ -52,7 +52,6 @@ (defmethod handle-event :after ((pane clim-internals::fire-pane) (event pointer-event)) (declare (ignorable event)) - (hef:debugf pane event) #+nil (let ((label (clim-internals::gadget-label (clim-internals::radio-box-current-selection (find-pane-named *application-frame* 'radio-box))))) From tmoore at common-lisp.net Wed Feb 2 09:33:53 2005 From: tmoore at common-lisp.net (Timothy Moore) Date: Wed, 2 Feb 2005 10:33:53 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/clouseau.asd mcclim/Apps/Inspector/inspector.lisp mcclim/Apps/Inspector/inspector.asd Message-ID: <20050202093353.A7D7A8802C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv24562 Modified Files: inspector.lisp Added Files: clouseau.asd Removed Files: inspector.asd Log Message: Changed name of inspector system and package to clouseau in order to avoid conflicts with system inspectors. Date: Wed Feb 2 10:33:49 2005 Author: tmoore Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.7 mcclim/Apps/Inspector/inspector.lisp:1.8 --- mcclim/Apps/Inspector/inspector.lisp:1.7 Sun Jan 30 07:02:56 2005 +++ mcclim/Apps/Inspector/inspector.lisp Wed Feb 2 10:33:49 2005 @@ -22,7 +22,7 @@ ;;; CLIM inspector application -(in-package :inspector) +(in-package :clouseau) (define-application-frame inspector () ((dico :initform (make-hash-table) :reader dico) From tmoore at common-lisp.net Wed Feb 2 10:16:59 2005 From: tmoore at common-lisp.net (Timothy Moore) Date: Wed, 2 Feb 2005 11:16:59 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp Message-ID: <20050202101659.004C88864B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv27047 Modified Files: inspector.lisp Log Message: Peter Scott's patch to use clim-mop in the inspector Date: Wed Feb 2 11:16:59 2005 Author: tmoore Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.8 mcclim/Apps/Inspector/inspector.lisp:1.9 --- mcclim/Apps/Inspector/inspector.lisp:1.8 Wed Feb 2 10:33:49 2005 +++ mcclim/Apps/Inspector/inspector.lisp Wed Feb 2 11:16:59 2005 @@ -81,35 +81,6 @@ (pane object (presentation-type-of object)) (print object pane))) -(defun class-slots (class) - #+sbcl (sb-mop:class-slots class) - #+openmcl (ccl:class-slots class) - #-(or sbcl openmcl) (error "no MOP")) - -(defun slot-definition-name (slot) - #+sbcl (sb-mop:slot-definition-name slot) - #+openmcl (ccl:slot-definition-name slot) - #-(or sbcl openmcl) (error "no MOP")) - -(defun generic-function-name (generic-function) - #+sbcl (sb-mop:generic-function-name generic-function) - #+openmcl (ccl:generic-function-name generic-function) - #-(or sbcl openmcl) (error "no MOP")) - -(defun generic-function-methods (generic-function) - #+sbcl (sb-mop:generic-function-methods generic-function) - #+openmcl (ccl:generic-function-methods generic-function) - #-(or sbcl openmcl) (error "no MOP")) - -(defun method-specializers (method) - #+sbcl (sb-mop:method-specializers method) - #+openmcl (ccl:method-specializers method) - #-(or sbcl openmcl) (error "no MOP")) - -(defun method-generic-function (method) - #+sbcl (sb-mop:method-generic-function method) - #+openmcl (ccl:method-generic-function method) - #-(or sbcl openmcl) (error "no MOP")) (define-presentation-type settable-slot () :inherit-from t) @@ -148,8 +119,8 @@ (let ((class (class-of object))) (inspector-table (print (class-name class) pane) - (loop for slot in (reverse (class-slots class)) - do (let ((slot-name (slot-definition-name slot))) + (loop for slot in (reverse (clim-mop:class-slots class)) + do (let ((slot-name (clim-mop:slot-definition-name slot))) (inspector-table-row (with-output-as-presentation (pane (cons object slot-name) 'settable-slot) @@ -202,14 +173,15 @@ (defmethod inspect-object ((object generic-function) pane) (inspector-table - (format pane "Generic Function: ~s" (generic-function-name object)) - (loop for method in (generic-function-methods object) + (format pane "Generic Function: ~s" + (clim-mop:generic-function-name object)) + (loop for method in (clim-mop:generic-function-methods object) do (with-output-as-presentation (pane method (presentation-type-of method)) (formatting-row (pane) (formatting-cell (pane) (print (method-qualifiers method))) - (loop for specializer in (method-specializers method) + (loop for specializer in (clim-mop:method-specializers method) do (formatting-cell (pane) (format pane "~s " (class-name specializer))))))))) @@ -335,7 +307,7 @@ (define-inspector-command (com-remove-method :name t) ((obj 'method :gesture :delete :prompt "Remove method")) - (remove-method (method-generic-function obj) obj)) + (remove-method (clim-mop:method-generic-function obj) obj)) (define-inspector-command (com-set-slot :name t) ((slot 'settable-slot :gesture :select :prompt "Set slot")) From tmoore at common-lisp.net Wed Feb 2 10:18:59 2005 From: tmoore at common-lisp.net (Timothy Moore) Date: Wed, 2 Feb 2005 11:18:59 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/transforms.lisp Message-ID: <20050202101859.C69AF8864B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv27090 Modified Files: transforms.lisp Log Message: comments from the peanut gallery Date: Wed Feb 2 11:18:59 2005 Author: tmoore Index: mcclim/transforms.lisp diff -u mcclim/transforms.lisp:1.28 mcclim/transforms.lisp:1.29 --- mcclim/transforms.lisp:1.28 Wed Oct 6 14:03:56 2004 +++ mcclim/transforms.lisp Wed Feb 2 11:18:58 2005 @@ -4,7 +4,7 @@ ;;; Created: 1998-09-29 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). -;;; $Id: transforms.lisp,v 1.28 2004/10/06 12:03:56 moore Exp $ +;;; $Id: transforms.lisp,v 1.29 2005/02/02 10:18:58 tmoore Exp $ ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 1998,1999,2003 by Gilbert Baumann ;;; (c) copyright 2000 by @@ -434,8 +434,13 @@ ;; transformation. To use WITH-DRAWING-OPTIONS which concatenates the the ;; transformation given to the existing one we just pass the inverse. ;; - ;; Further we don't use LETF since it is a pretty much broken idea in case - ;; of multithreading. + ;; "Further we don't use LETF since it is a pretty much broken idea in case + ;; of multithreading." -- gilbert + ;; + ;; "That may be, but all of the transformation functions/macros are + ;; going to set the medium state at some point (see + ;; with-drawing-options), and that's not thread-safe either. So I + ;; say, 'just use LETF.'" -- moore ;; ;; Q: Do we want a invoke-with-identity-transformation? ;; From tmoore at common-lisp.net Wed Feb 2 11:34:02 2005 From: tmoore at common-lisp.net (Timothy Moore) Date: Wed, 2 Feb 2005 12:34:02 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/decls.lisp mcclim/frames.lisp mcclim/graphics.lisp mcclim/recording.lisp mcclim/stream-output.lisp mcclim/utils.lisp Message-ID: <20050202113402.A005A88656@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv31595 Modified Files: decls.lisp frames.lisp graphics.lisp recording.lisp stream-output.lisp utils.lisp Log Message: Hammered on with-room-for-graphics. It should now leave the cursor in the right place and do the right thing with respect to recording options. Changed with-drawing-options to not rebind its medium argument at all. Added :label and :scroll-bars arguments to with-menu which are currently ignored. Date: Wed Feb 2 12:33:59 2005 Author: tmoore Index: mcclim/decls.lisp diff -u mcclim/decls.lisp:1.30 mcclim/decls.lisp:1.31 --- mcclim/decls.lisp:1.30 Thu Dec 30 11:09:40 2004 +++ mcclim/decls.lisp Wed Feb 2 12:33:58 2005 @@ -111,6 +111,13 @@ (defgeneric invoke-with-drawing-options (medium continuation &rest drawing-options &key &allow-other-keys)) +;;;; 10.2.1 +(defgeneric invoke-with-identity-transformation (medium continuation)) + +;;;; 10.2.2 +(defgeneric invoke-with-local-coordinates (medium continuation x y)) + +(defgeneric invoke-with-first-quadrant-coordinates (medium continuation x y)) ;;;; 14.5 (defgeneric draw-design Index: mcclim/frames.lisp diff -u mcclim/frames.lisp:1.104 mcclim/frames.lisp:1.105 --- mcclim/frames.lisp:1.104 Tue Jan 11 14:14:18 2005 +++ mcclim/frames.lisp Wed Feb 2 12:33:58 2005 @@ -1394,6 +1394,37 @@ (frob pointer-button-press-event presentation-button-press-handler) (frob pointer-button-release-event presentation-button-release-handler)) +(defun make-drag-bounding (old-highlighting new-highlighting + old-presentation new-presentation) + (let (x1 y1 x2 y2) + (flet ((union-with-bounds (rect) + (cond ((null rect) + nil) + ((null x1) + (setf (values x1 y1 x2 y2) (bounding-rectangle* rect))) + (t (with-bounding-rectangle* (r-x1 r-y1 r-x2 r-y2) + rect + (setf (values x1 y1 x2 y2) + (bound-rectangles x1 y1 x2 y2 + r-x1 r-y1 r-x2 r-y2))))))) + (union-with-bounds old-highlighting) + (union-with-bounds new-highlighting) + (union-with-bounds old-presentation) + (union-with-bounds new-presentation) + (values x1 y1 x2 y2)))) + +(defun make-drag-and-drop-feedback-function (from-presentation) + (multiple-value-bind (record-x record-y) + (output-record-position from-presentation) + (let ((current-to-presentation nil) + (current-from-higlighting nil)) + (lambda (frame from-presentation to-presentation initial-x initial-y + x y event) + (let ((dx (- record-x initial-x)) + (dy (- record-y initial-y))) + (typecase event + (null + ()))))))) (defun frame-drag (translator-name command-table object presentation context-type frame event window x y) @@ -1416,5 +1447,5 @@ (tracking-pointer (window :context-type drag-c-type :highlight nil) (:pointer-motion (&key event x y) (multiple-value-bind (presentation translator) - (find-innermost-presentation-context drag-context window - x y :event event))))))) + (find-innermost-presentation-match drag-context window + x y :event event))))))) Index: mcclim/graphics.lisp diff -u mcclim/graphics.lisp:1.49 mcclim/graphics.lisp:1.50 --- mcclim/graphics.lisp:1.49 Tue Jan 11 14:35:18 2005 +++ mcclim/graphics.lisp Wed Feb 2 12:33:58 2005 @@ -20,6 +20,38 @@ (in-package :clim-internals) +;;; Work in progress that reduces consing of rest arguments and keyword +;;; processing. +(defmacro with-medium-and-options ((sheet + &key ink clipping-region transformation + line-unit line-thickness + line-style line-style-p + line-dashes dashes-p + line-joint-shape line-cap-shape + text-style text-style-p + text-family text-family-p + text-face text-face-p + text-size text-size-p) + (medium) + &body body) + (with-gensyms (continuation sheet-medium) + `(flet ((,continuation (,medium) + , at body)) + (declare (dynamic-extent #',continuation)) + (with-sheet-medium (,sheet-medium ,sheet) + (do-graphics-with-options-internal-1 + ,sheet-medium #'continuation + ,ink ,clipping-region ,transformation + ,line-unit ,line-thickness + ,line-style ,line-style-p + ,line-dashes ,dashes-p + ,line-joint-shape ,line-cap-shape + ,text-style ,text-style-p + ,text-family ,text-family-p + ,text-face ,text-face-p + ,text-size ,text-size-p)))) + ) + (defmethod do-graphics-with-options ((sheet sheet) func &rest options) (with-sheet-medium (medium sheet) (apply #'do-graphics-with-options-internal medium sheet func options))) @@ -130,15 +162,15 @@ (apply #'do-graphics-with-options ,sheet #'graphics-op ,args))) (defmacro with-drawing-options ((medium &rest drawing-options) &body body) - (when (eq medium t) - (setq medium '*standard-output*)) - (check-type medium symbol) - (let ((gcontinuation (gensym))) - `(flet ((,gcontinuation (,medium) - , at body)) - #-clisp (declare (dynamic-extent #',gcontinuation)) - (apply #'invoke-with-drawing-options - ,medium #',gcontinuation (list , at drawing-options))))) + (setq medium (stream-designator-symbol medium '*standard-output*)) + (with-gensyms (gcontinuation cont-arg) + `(flet ((,gcontinuation (,cont-arg) + (declare (ignore ,cont-arg)) + , at body)) + #-clisp (declare (dynamic-extent #',gcontinuation)) + (apply #'invoke-with-drawing-options + ,medium #',gcontinuation (list , at drawing-options))))) + (defmethod invoke-with-drawing-options ((medium medium) continuation &rest drawing-options @@ -151,8 +183,8 @@ (defmethod invoke-with-drawing-options ((sheet sheet) continuation &rest drawing-options) (with-sheet-medium (medium sheet) - (with-medium-options (medium drawing-options) - (funcall continuation sheet)))) + (with-medium-options (medium drawing-options) + (funcall continuation medium)))) ;;; Compatibility with real CLIM (defmethod invoke-with-drawing-options ((sheet t) continuation @@ -160,11 +192,23 @@ (declare (ignore drawing-options)) (funcall continuation sheet)) -(defmethod invoke-with-identity-transformation (medium cont) - (with-drawing-options (medium - :transformation (invert-transformation - (medium-transformation medium))) - (funcall cont medium))) +(defmethod invoke-with-identity-transformation + ((sheet sheet) continuation) + (with-sheet-medium (medium sheet) + (letf (((medium-transformation medium) +identity-transformation+)) + (funcall continuation sheet)))) + + +(defmethod invoke-with-identity-transformation + ((destination pixmap) continuation) + (with-pixmap-medium (medium destination) + (letf (((medium-transformation medium) +identity-transformation+)) + (funcall continuation destination)))) + +(defmethod invoke-with-identity-transformation + ((medium medium) continuation) + (letf (((medium-transformation medium) +identity-transformation+)) + (funcall continuation medium))) (defmethod invoke-with-local-coordinates (medium cont x y) ;; For now we do as real CLIM does. @@ -653,6 +697,13 @@ (copy-area (sheet-medium stream) from-x from-y width height to-x to-y) (error "COPY-AREA on a stream is not implemented"))) +;;; XXX The modification of the sheet argument to hold the pixmap medium seems +;;; completely incorrect here; the description of the macro in the spec says +;;; nothing about that. On the other hand, the spec talks about "medium-var" +;;; when that is clearly meant to be a stream (and an output-recording stream +;;; at that, if the example in the Franz user guide is to be believed). What a +;;; mess. I think we need a pixmap output recording stream in order to do this +;;; right. -- moore (defmacro with-output-to-pixmap ((medium-var sheet &key width height) &body body) `(let* ((pixmap (allocate-pixmap ,sheet ,width ,height)) ; XXX size might be unspecified -- APD (,medium-var (make-medium (port ,sheet) pixmap)) Index: mcclim/recording.lisp diff -u mcclim/recording.lisp:1.115 mcclim/recording.lisp:1.116 --- mcclim/recording.lisp:1.115 Thu Oct 14 08:30:11 2004 +++ mcclim/recording.lisp Wed Feb 2 12:33:58 2005 @@ -2190,43 +2190,62 @@ (call-next-method))) ;;; ---------------------------------------------------------------------------- - +;;; Complicated, underspecified... +;;; +;;; From examining old Genera documentation, I believe that +;;; with-room-for-graphics is supposed to set the medium transformation to +;;; give the desired coordinate system; i.e., it doesn't preserve any +;;; rotation, scaling or translation in the current medium transformation. (defmethod invoke-with-room-for-graphics (cont stream - &key (first-quadrant t) - height - (move-cursor t) - (record-type 'standard-sequence-output-record)) + &key (first-quadrant t) + height + (move-cursor t) + (record-type + 'standard-sequence-output-record)) ;; I am not sure what exactly :height should do. ;; --GB 2003-05-25 ;; The current behavior is consistent with 'classic' CLIM ;; --Hefner 2004-06-19 + ;; Don't know if it still is :) + ;; -- Moore 2005-01-26 (multiple-value-bind (cx cy) (stream-cursor-position stream) - (let ((record - (with-output-recording-options (stream :draw nil :record t) - (with-new-output-record (stream record-type) - (with-drawing-options - (stream :transformation - (if first-quadrant - (make-scaling-transformation 1 -1) - +identity-transformation+)) - (funcall cont stream)))))) - (cond ((null height) - (setf (output-record-position record) - (values cx cy))) - (t - (setf (output-record-position record) - (values cx - (- cy (- (bounding-rectangle-height record) height)))))) - (with-output-recording-options (stream :draw t :record nil) - (replay-output-record record stream)) - (cond (move-cursor - (setf (stream-cursor-position stream) - (values (bounding-rectangle-max-x record) - (bounding-rectangle-max-y record)))) - (t - (setf (stream-cursor-position stream) - (values cx cy))))))) + (with-sheet-medium (medium stream) + (letf (((medium-transformation medium) + (if first-quadrant + (make-scaling-transformation 1 -1) + +identity-transformation+))) + (let ((record (with-output-to-output-record (stream record-type) + (funcall cont stream)))) + ;; Bounding rectangle is in sheet coordinates! + (with-bounding-rectangle* (x1 y1 x2 y2) + record + (declare (ignore x2)) + (if first-quadrant + (setf (output-record-position record) + (values (max cx (+ cx x1)) + (if height + (max cy (+ cy (- height (- y2 y1)))) + cy))) + (setf (output-record-position record) + (values (max cx (+ cx x1)) (max cy (+ cy y1))))) + (when (stream-recording-p stream) + (stream-add-output-record stream record)) + (when (stream-drawing-p stream) + (replay record stream)) + (if move-cursor + (let ((record-height (- y2 y1))) + (setf (stream-cursor-position stream) + (values cx + (if first-quadrant + (+ cy (max (- y1) + (or height 0) + record-height)) + (+ cy (max (or height 0) + record-height)))))) + (setf (stream-cursor-position stream) (values cx cy))) + record)))))) + (defmethod repaint-sheet ((sheet output-recording-stream) region) Index: mcclim/stream-output.lisp diff -u mcclim/stream-output.lisp:1.52 mcclim/stream-output.lisp:1.53 --- mcclim/stream-output.lisp:1.52 Sun Oct 31 02:46:31 2004 +++ mcclim/stream-output.lisp Wed Feb 2 12:33:59 2005 @@ -426,6 +426,7 @@ non-nil, that is used as the width where needed; otherwise STREAM-STRING-WIDTH will be called.")) +;;; The cursor is in stream coordinates. (defmethod stream-write-output (stream line string-width &optional (start 0) end) (declare (ignore string-width)) @@ -433,6 +434,7 @@ (multiple-value-bind (cx cy) (stream-cursor-position stream) (draw-text* (sheet-medium stream) line cx (+ cy baseline) + :transformation +identity-transformation+ :start start :end end)))) (defmethod stream-write-char ((stream standard-extended-output-stream) char) Index: mcclim/utils.lisp diff -u mcclim/utils.lisp:1.39 mcclim/utils.lisp:1.40 --- mcclim/utils.lisp:1.39 Mon Dec 20 16:50:22 2004 +++ mcclim/utils.lisp Wed Feb 2 12:33:59 2005 @@ -452,7 +452,7 @@ (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols)))) (defun stream-designator-symbol (symbol default) - "Maps T to *standard-output*, barfs if argument does not look good. + "Maps T to DEFAULT, barfs if argument does not look good. To be used in the various WITH-... macros." (cond ((eq symbol 't) default) From tmoore at common-lisp.net Wed Feb 2 11:34:06 2005 From: tmoore at common-lisp.net (Timothy Moore) Date: Wed, 2 Feb 2005 12:34:06 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Experimental/menu-choose.lisp Message-ID: <20050202113406.6587488658@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental In directory common-lisp.net:/tmp/cvs-serv31595/Experimental Modified Files: menu-choose.lisp Log Message: Hammered on with-room-for-graphics. It should now leave the cursor in the right place and do the right thing with respect to recording options. Changed with-drawing-options to not rebind its medium argument at all. Added :label and :scroll-bars arguments to with-menu which are currently ignored. Date: Wed Feb 2 12:34:02 2005 Author: tmoore Index: mcclim/Experimental/menu-choose.lisp diff -u mcclim/Experimental/menu-choose.lisp:1.16 mcclim/Experimental/menu-choose.lisp:1.17 --- mcclim/Experimental/menu-choose.lisp:1.16 Wed Jan 26 05:29:06 2005 +++ mcclim/Experimental/menu-choose.lisp Wed Feb 2 12:34:02 2005 @@ -137,7 +137,7 @@ (defmacro with-menu ((menu &optional associated-window - &key (deexpose t)) + &key (deexpose t) label scroll-bars) &body body) (check-type menu symbol) (with-gensyms (with-menu-cont) @@ -146,10 +146,13 @@ (declare (dynamic-extent #',with-menu-cont)) (invoke-with-menu #',with-menu-cont ,associated-window ; XXX - ',deexpose)))) ; XXX!!! + ',deexpose ; XXX!!! + ,label + ,scroll-bars)))) -(defun invoke-with-menu (continuation associated-window deexpose) - (declare (ignore deexpose)) ; FIXME!!! +(defun invoke-with-menu (continuation associated-window deexpose + label scroll-bars) + (declare (ignore deexpose label scroll-bars)) ; FIXME!!! (let* ((associated-frame (if associated-window (pane-frame associated-window) *application-frame*)) From varkesteijn at common-lisp.net Thu Feb 3 18:47:20 2005 From: varkesteijn at common-lisp.net (Vincent Arkesteijn) Date: Thu, 3 Feb 2005 19:47:20 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/INSTALL Message-ID: <20050203184720.5CC3388669@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv1400 Modified Files: INSTALL Log Message: Updated INSTALL file to reflect the change of system and package name. (thanks Paolo Amoroso) Date: Thu Feb 3 19:47:18 2005 Author: varkesteijn Index: mcclim/Apps/Inspector/INSTALL diff -u mcclim/Apps/Inspector/INSTALL:1.1 mcclim/Apps/Inspector/INSTALL:1.2 --- mcclim/Apps/Inspector/INSTALL:1.1 Sat Jan 29 13:10:54 2005 +++ mcclim/Apps/Inspector/INSTALL Thu Feb 3 19:47:18 2005 @@ -1,11 +1,11 @@ 1. Start your Lisp system and make sure you have ASDF and McCLIM in your core file. -2. (asdf:operate 'asdf:load-op :inspector) +2. (asdf:operate 'asdf:load-op :clouseau) 3. Try something like: - (inspector::inspector (clim:make-application-frame 'inspector::inspector :obj 20)) + (clouseau::inspector (clim:make-application-frame 'clouseau::inspector :obj 20)) in order to inspect the inspector pane. From pscott at common-lisp.net Thu Feb 3 20:14:58 2005 From: pscott at common-lisp.net (Peter Scott) Date: Thu, 3 Feb 2005 21:14:58 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp Message-ID: <20050203201458.EFB9788669@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv5675 Modified Files: inspector.lisp Log Message: Added class-like inspection of structures, characters are inspected non-annoyingly, documentation strings are displayed where possible, the source code has been commented and documented more, and some other features and bug fixes have been added. Date: Thu Feb 3 21:14:57 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.9 mcclim/Apps/Inspector/inspector.lisp:1.10 --- mcclim/Apps/Inspector/inspector.lisp:1.9 Wed Feb 2 11:16:59 2005 +++ mcclim/Apps/Inspector/inspector.lisp Thu Feb 3 21:14:57 2005 @@ -24,8 +24,11 @@ (in-package :clouseau) +(define-modify-macro togglef () not) + (define-application-frame inspector () ((dico :initform (make-hash-table) :reader dico) + (cons-cell-dico :initform (make-hash-table) :reader cons-cell-dico) (obj :initarg :obj :reader obj)) (:pointer-documentation t) (:panes @@ -55,16 +58,23 @@ (run-frame-top-level (make-application-frame 'inspector :obj obj)))) -(defparameter *inspected-objects* '()) +(defparameter *inspected-objects* '() + "A list of objects which are currently being inspected with +INSPECT-OBJECT") + +(defgeneric inspect-object-briefly (object pane) + (:documentation "Inspect an object in a short form, displaying this +on PANE. For example, rather than displaying all the slots of a class, +only the class name would be shown.")) -(defgeneric inspect-object-briefly (object pane)) -(defgeneric inspect-object (object pane)) +(defgeneric inspect-object (object pane) + (:documentation "Inspect an object, displaying it on PANE")) (defmethod inspect-object :around (object pane) (cond ((member object *inspected-objects*) (with-output-as-presentation (pane object (presentation-type-of object)) - (princ "==="))) + (princ "==="))) ; Prevent infinite loops ((not (gethash object (dico *application-frame*))) (inspect-object-briefly object pane)) (t @@ -84,6 +94,8 @@ (define-presentation-type settable-slot () :inherit-from t) +(define-presentation-type cons () + :inherit-from t) (define-presentation-method present (object (type settable-slot) stream @@ -93,6 +105,11 @@ (format stream "~s" (cdr object))) (defmacro inspector-table (header &body body) + "Present OBJECT (captured from environment) in tabular form, with +HEADER printed in a box at the top. BODY should output the rows of the +table using INSPECTOR-TABLE-ROW. Also capured from the macro's +environment is PANE, which is the pane on which the table will be +drawn." `(with-output-as-presentation (pane object (presentation-type-of object)) (formatting-table (pane) @@ -102,32 +119,54 @@ ,header)) (formatting-cell (pane) (formatting-table (pane) - , at body)))))) + , at body)))) + (print-documentation object pane))) (defmacro inspector-table-row (left right) + "Output a table row with two items, LEFT and RIGHT, in the +environment created by INSPECTOR-TABLE." `(formatting-row (pane) (formatting-cell (pane :align-x :right) ,left) (formatting-cell (pane) ,right))) +(defun print-documentation (object pane) + "Print OBJECT's documentation, if any, to PANE" + (when (handler-bind ((warning #'muffle-warning)) + (documentation object t)) + (format pane "~&Documentation: ~A" (documentation object t)))) + +(defun inspect-structure-or-object (object pane) + "Inspect a structure or an object. Since both can be inspected in +roughly the same way, the common code is in this function, which is +called by the INSPECT-OBJECT methods for both standard objects and +structure objects." + (let ((class (class-of object))) + (inspector-table + (print (class-name class) pane) + (loop for slot in (reverse (clim-mop:class-slots class)) + do (let ((slot-name (clim-mop:slot-definition-name slot))) + (inspector-table-row + (with-output-as-presentation + (pane (cons object slot-name) 'settable-slot) + (format pane "~a:" slot-name)) + (inspect-object (slot-value object slot-name) pane))))))) + (defmethod inspect-object-briefly ((object standard-object) pane) (with-output-as-presentation (pane object (presentation-type-of object)) (format pane "instance of ~S" (class-name (class-of object))))) (defmethod inspect-object ((object standard-object) pane) - (let ((class (class-of object))) - (inspector-table - (print (class-name class) pane) - (loop for slot in (reverse (clim-mop:class-slots class)) - do (let ((slot-name (clim-mop:slot-definition-name slot))) - (inspector-table-row - (with-output-as-presentation - (pane (cons object slot-name) 'settable-slot) - (format pane "~a:" slot-name)) - (inspect-object (slot-value object slot-name) pane))))))) + (inspect-structure-or-object object pane)) -(defmethod inspect-object ((object cons) pane) +(defmethod inspect-object ((object structure-object) pane) + (inspect-structure-or-object object pane)) + +(defun inspect-cons-as-cells (object pane) + "Inspect a cons cell in a fancy graphical way. The inconvenient part +is that this necessarily involves quite a bit of clicking to show a +moderately-sized list." (if (null (cdr object)) (formatting-table (pane) (formatting-column (pane) @@ -157,6 +196,44 @@ (formatting-cell (pane) (inspect-object (cdr object) pane)))))) +(defun inspect-cons-as-list (object pane) + "Inspect a cons cell in a traditional, plain-text format. The only +difference between this and simply using the Lisp printer is that this +code takes advantage of CLIM's tables and presentations to make the +list as interactive as you would expect." + (with-output-as-presentation + (pane object 'cons) + (formatting-table (pane) + (formatting-row (pane) + (formatting-cell (pane) + (princ "(" pane)) + (do + ((length 0 (1+ length)) + (cdr (cdr object) (cdr cdr)) + (car (car object) (car cdr))) + ((cond ((eq nil cdr) + (formatting-cell (pane) (inspect-object car pane)) + (formatting-cell (pane) (princ ")" pane)) + t) + ((not (consp cdr)) + (formatting-cell (pane) (inspect-object car pane)) + (formatting-cell (pane) (princ "." pane)) + (formatting-cell (pane) (inspect-object cdr pane)) + (formatting-cell (pane) (princ ")" pane)) + t) + ((>= length *print-length*) + (formatting-cell (pane) (inspect-object car pane)) + (formatting-cell (pane) (princ "..." pane)) + t) + (t nil))) + (formatting-cell (pane) (inspect-object car pane))))))) + +(defmethod inspect-object ((object cons) pane) + (if (gethash object (cons-cell-dico *application-frame*)) + (inspect-cons-as-cells object pane) + (inspect-cons-as-list object pane))) + + (defmethod inspect-object-briefly ((object hash-table) pane) (with-output-as-presentation (pane object (presentation-type-of object)) @@ -185,6 +262,33 @@ do (formatting-cell (pane) (format pane "~s " (class-name specializer))))))))) +(defun pretty-print-function (fun) + "Print a function in a readable way, returning a string. On most +implementations this just uses the standard Lisp printer, but it can +use implementation-specific functions to be more informative." + (flet ((generic-print (fun) + (with-output-to-string (string) + (prin1 fun string)))) + ;; If we have SBCL, try to do fancy formatting. If anything goes + ;; wrong with that, fall back on ugly standard PRIN1. + #+sbcl (handler-case (format nil "~A ~S" + (sb-impl::%simple-fun-name fun) + (sb-impl::%simple-fun-arglist fun)) + (error () (generic-print fun))) + ;; FIXME: Other Lisp implementations have ways of getting this + ;; information. If you want a better inspector on a non-SBCL Lisp, + ;; please add code for it and send patches. + #-sbcl (generic-print fun))) + +(defmethod inspect-object ((object function) pane) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (format pane "Function: ~A" + (pretty-print-function object)) + #+sbcl (format pane "~&Type: ~A" + (sb-impl::%simple-fun-type object)) + (print-documentation object pane))) + (defmethod inspect-object-briefly ((object package) pane) (with-output-as-presentation (pane object (presentation-type-of object)) @@ -231,7 +335,10 @@ (pane object (presentation-type-of object)) (print object))) -(defmethod inspect-object ((object complex) pane) +(defun inspect-complex (object pane) + "Inspect a complex number. Since complex numbers should be inspected +the same way briefly and fully, this function can be called by both of +them." (with-output-as-presentation (pane object (presentation-type-of object)) (formatting-table (pane) @@ -245,6 +352,12 @@ (formatting-cell (pane) (princ ")" pane)))))) +(defmethod inspect-object-briefly ((object complex) pane) + (inspect-complex object pane)) + +(defmethod inspect-object ((object complex) pane) + (inspect-complex object pane)) + (defmethod inspect-object ((object float) pane) (inspector-table (format pane "float ~S" object) @@ -267,6 +380,7 @@ (with-output-as-presentation (pane object (presentation-type-of object)) (print object))) + (defmethod inspect-object ((object symbol) pane) (inspector-table (format pane "Symbol ~S" (symbol-name object)) @@ -287,8 +401,17 @@ (princ "propery list:") (dolist (property (symbol-plist object)) (inspect-object property pane))))) +(make-instance 'packrat) +;; Characters are so short that displaying them as "..." takes almost +;; as much space as just showing them, and this way is more +;; informative. +(defmethod inspect-object-briefly ((object character) pane) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (print object pane))) (defun display-app (frame pane) + "Display the APP frame of the inspector" (inspect-object (obj frame) pane)) (define-inspector-command (com-quit :name t) () @@ -297,13 +420,16 @@ (define-inspector-command (com-inspect :name t) () (let ((obj (accept t :prompt "Select an object"))) (clim-sys:make-process #'(lambda () (inspector obj)) - :name "inspector"))) + :name "Inspector Clouseau"))) + +(define-inspector-command (com-toggle-show-list-cells :name t) + ((obj 'cons :gesture :select :prompt "Select a cons or list")) + (togglef (gethash obj (cons-cell-dico *application-frame*)))) (define-inspector-command (com-toggle-inspect :name t) ((obj t :gesture :select :prompt "Select an object")) (unless (eq obj (obj *application-frame*)) - (setf (gethash obj (dico *application-frame*)) - (not (gethash obj (dico *application-frame*)))))) + (togglef (gethash obj (dico *application-frame*))))) (define-inspector-command (com-remove-method :name t) ((obj 'method :gesture :delete :prompt "Remove method")) @@ -313,3 +439,33 @@ ((slot 'settable-slot :gesture :select :prompt "Set slot")) (setf (slot-value (car slot) (cdr slot)) (accept t :prompt "New slot value"))) + +(defun slot-documentation (class slot) + "Returns the documentation of a slot of a class, or nil. There is, +unfortunately, no portable way to do this, but the MOP is +semi-portable and we can use it. To complicate things even more, some +implementations have unpleasant oddities in the way they store slot +documentation. For example, in SBCL slot documentation is only +available in direct slots." + (let ((slot-object (find slot (clim-mop:class-direct-slots class) + :key #'clim-mop:slot-definition-name))) + (if slot-object + (documentation slot-object t) + (when (clim-mop:class-direct-superclasses class) + (find-if #'identity + (mapcar #'(lambda (class) + (slot-documentation class slot)) + (clim-mop:class-direct-superclasses class))))))) + +(define-inspector-command (com-describe-slot :name t) + ((slot 'settable-slot :gesture :describe :prompt "Describe slot")) + (destructuring-bind (object . slot-name) slot + (let* ((stream (get-frame-pane *application-frame* 'int)) + (class (class-of object)) + (documentation (slot-documentation class slot-name)) + (slot-object (find slot-name (clim-mop:class-slots class) + :key #'clim-mop:slot-definition-name))) + (when documentation + (format stream "~&Documentation: ~A~%" documentation)) + (format stream "~&Type: ~S~%" + (clim-mop:slot-definition-type slot-object))))) \ No newline at end of file From pscott at common-lisp.net Thu Feb 3 22:15:22 2005 From: pscott at common-lisp.net (Peter Scott) Date: Thu, 3 Feb 2005 23:15:22 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp Message-ID: <20050203221522.4279588669@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv12283 Modified Files: inspector.lisp Log Message: Applied quick and dirty fix to bug with generic function inspection's display of EQL specializers. Added display of superclasses and subclasses to objects. Some miscellaneous bug fixes. Improved printing of object instances. Date: Thu Feb 3 23:15:21 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.10 mcclim/Apps/Inspector/inspector.lisp:1.11 --- mcclim/Apps/Inspector/inspector.lisp:1.10 Thu Feb 3 21:14:57 2005 +++ mcclim/Apps/Inspector/inspector.lisp Thu Feb 3 23:15:21 2005 @@ -145,6 +145,18 @@ (let ((class (class-of object))) (inspector-table (print (class-name class) pane) + (when (clim-mop:class-direct-superclasses class) + (inspector-table-row + (format pane "Superclasses") + (dolist (superclass (clim-mop:class-direct-superclasses class)) + (inspect-object superclass pane) + (terpri pane)))) + (when (clim-mop:class-direct-subclasses class) + (inspector-table-row + (format pane "Subclasses") + (dolist (subclass (clim-mop:class-direct-subclasses class)) + (inspect-object subclass pane) + (terpri pane)))) (loop for slot in (reverse (clim-mop:class-slots class)) do (let ((slot-name (clim-mop:slot-definition-name slot))) (inspector-table-row @@ -153,10 +165,21 @@ (format pane "~a:" slot-name)) (inspect-object (slot-value object slot-name) pane))))))) +(defparameter *object-representation-max-length* 60 + "Maximum number of characters of an object's textual representation +that are allowed before abbreviation kicks in") + +;; Try to print the normal, textual representation of an object, but +;; if that's too long, make an abbreviated "instance of ~S" version. (defmethod inspect-object-briefly ((object standard-object) pane) (with-output-as-presentation (pane object (presentation-type-of object)) - (format pane "instance of ~S" (class-name (class-of object))))) + (let ((representation (with-output-to-string (string) + (prin1 object string)))) + (if (< (length representation) *object-representation-max-length*) + (princ representation pane) + (format pane "instance of ~S" (class-name (class-of object))))))) + (defmethod inspect-object ((object standard-object) pane) (inspect-structure-or-object object pane)) @@ -172,7 +195,7 @@ (formatting-column (pane) (formatting-cell (pane) (with-output-as-presentation - (pane object (presentation-type-of object)) + (pane object 'cons) (draw-rectangle* pane 0 0 20 10 :filled nil)) (draw-line* pane 10 0 10 10) (draw-arrow* pane 5 5 5 30) @@ -186,7 +209,7 @@ (formatting-column (pane) (formatting-cell (pane) (with-output-as-presentation - (pane object (presentation-type-of object)) + (pane object 'cons) (draw-rectangle* pane 0 0 20 10 :filled nil)) (draw-line* pane 10 0 10 10) (draw-arrow* pane 5 5 5 30) @@ -260,7 +283,11 @@ (print (method-qualifiers method))) (loop for specializer in (clim-mop:method-specializers method) do (formatting-cell (pane) - (format pane "~s " (class-name specializer))))))))) + (format pane "~a " + (if (typep specializer + 'clim-mop:eql-specializer) + "EQL specializer" ; FIXME: says nothing + (class-name specializer)))))))))) (defun pretty-print-function (fun) "Print a function in a readable way, returning a string. On most @@ -401,7 +428,7 @@ (princ "propery list:") (dolist (property (symbol-plist object)) (inspect-object property pane))))) -(make-instance 'packrat) + ;; Characters are so short that displaying them as "..." takes almost ;; as much space as just showing them, and this way is more ;; informative. @@ -437,8 +464,11 @@ (define-inspector-command (com-set-slot :name t) ((slot 'settable-slot :gesture :select :prompt "Set slot")) - (setf (slot-value (car slot) (cdr slot)) - (accept t :prompt "New slot value"))) + (handler-case (setf (slot-value (car slot) (cdr slot)) + (accept t :prompt "New slot value")) + (simple-parse-error () + (format (get-frame-pane *application-frame* 'int) + "~&Command canceled; slot value not set~%")))) (defun slot-documentation (class slot) "Returns the documentation of a slot of a class, or nil. There is, @@ -462,7 +492,8 @@ (destructuring-bind (object . slot-name) slot (let* ((stream (get-frame-pane *application-frame* 'int)) (class (class-of object)) - (documentation (slot-documentation class slot-name)) + (documentation (handler-bind ((warning #'muffle-warning)) + (slot-documentation class slot-name))) (slot-object (find slot-name (clim-mop:class-slots class) :key #'clim-mop:slot-definition-name))) (when documentation From pscott at common-lisp.net Fri Feb 4 20:17:44 2005 From: pscott at common-lisp.net (Peter Scott) Date: Fri, 4 Feb 2005 21:17:44 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp mcclim/Apps/Inspector/clouseau.asd Message-ID: <20050204201744.5D4D4880A8@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv18302 Modified Files: inspector.lisp clouseau.asd Log Message: Added :new-process argument to INSPECTOR, and changed this to do it properly as suggested by Paolo Amoroso. Exported INSPECT-OBJECT and INSPECT-OBJECT-BRIEFLY to make extending the inspector easier for users. Made EQL specializers show up informatively. Date: Fri Feb 4 21:17:43 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.11 mcclim/Apps/Inspector/inspector.lisp:1.12 --- mcclim/Apps/Inspector/inspector.lisp:1.11 Thu Feb 3 23:15:21 2005 +++ mcclim/Apps/Inspector/inspector.lisp Fri Feb 4 21:17:42 2005 @@ -52,11 +52,17 @@ pane :height (bounding-rectangle-height (stream-output-history pane)))) -(defun inspector (obj) - (let ((*print-length* 10) - (*print-level* 10)) - (run-frame-top-level - (make-application-frame 'inspector :obj obj)))) +(defun inspector (obj &key (new-process nil)) + (flet ((run () + (let ((*print-length* 10) + (*print-level* 10)) + (run-frame-top-level + (make-application-frame 'inspector :obj obj))))) + (if new-process + (clim-sys:make-process #'run + :name (format nil "Inspector Clouseau: ~S" + obj)) + (run)))) (defparameter *inspected-objects* '() "A list of objects which are currently being inspected with @@ -286,7 +292,9 @@ (format pane "~a " (if (typep specializer 'clim-mop:eql-specializer) - "EQL specializer" ; FIXME: says nothing + (format nil "(EQL ~S)" + (clim-mop:eql-specializer-object + specializer)) (class-name specializer)))))))))) (defun pretty-print-function (fun) @@ -446,8 +454,7 @@ (define-inspector-command (com-inspect :name t) () (let ((obj (accept t :prompt "Select an object"))) - (clim-sys:make-process #'(lambda () (inspector obj)) - :name "Inspector Clouseau"))) + (inspector obj :new-process t))) (define-inspector-command (com-toggle-show-list-cells :name t) ((obj 'cons :gesture :select :prompt "Select a cons or list")) Index: mcclim/Apps/Inspector/clouseau.asd diff -u mcclim/Apps/Inspector/clouseau.asd:1.1 mcclim/Apps/Inspector/clouseau.asd:1.2 --- mcclim/Apps/Inspector/clouseau.asd:1.1 Wed Feb 2 10:33:49 2005 +++ mcclim/Apps/Inspector/clouseau.asd Fri Feb 4 21:17:42 2005 @@ -22,7 +22,9 @@ (defpackage :clouseau (:use :clim-lisp :clim) - (:export #:inspector)) + (:export #:inspector + #:inspect-object + #:inspect-object-briefly)) (asdf::defsystem clouseau :serial t From pscott at common-lisp.net Fri Feb 4 22:37:22 2005 From: pscott at common-lisp.net (Peter Scott) Date: Fri, 4 Feb 2005 23:37:22 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp mcclim/Apps/Inspector/clouseau.asd Message-ID: <20050204223722.96CCD880A8@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv26011 Modified Files: inspector.lisp clouseau.asd Log Message: Exported DEFINE-INSPECTOR-COMMAND and changed the presentation type for vectors to 'VECTOR. This makes it easier to extend the inspector in application-specific ways. Date: Fri Feb 4 23:37:21 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.12 mcclim/Apps/Inspector/inspector.lisp:1.13 --- mcclim/Apps/Inspector/inspector.lisp:1.12 Fri Feb 4 21:17:42 2005 +++ mcclim/Apps/Inspector/inspector.lisp Fri Feb 4 23:37:21 2005 @@ -1,4 +1,4 @@ -;;; -*- Mode: Lisp; Package: INSPECTOR -*- +;;; -*- Mode: Lisp; Package: CLOUSEAU -*- ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh at labri.fr) @@ -348,8 +348,10 @@ (inspect-object uses pane))))) (defmethod inspect-object ((object vector) pane) + ;; Using 'vector as the presentation type may be nonstandard, but it + ;; is more useful than the default. (with-output-as-presentation - (pane object (presentation-type-of object)) + (pane object 'vector) (formatting-table (pane) (formatting-row (pane) (formatting-cell (pane) Index: mcclim/Apps/Inspector/clouseau.asd diff -u mcclim/Apps/Inspector/clouseau.asd:1.2 mcclim/Apps/Inspector/clouseau.asd:1.3 --- mcclim/Apps/Inspector/clouseau.asd:1.2 Fri Feb 4 21:17:42 2005 +++ mcclim/Apps/Inspector/clouseau.asd Fri Feb 4 23:37:21 2005 @@ -24,7 +24,8 @@ (:use :clim-lisp :clim) (:export #:inspector #:inspect-object - #:inspect-object-briefly)) + #:inspect-object-briefly + #:define-inspector-command)) (asdf::defsystem clouseau :serial t From tmoore at common-lisp.net Fri Feb 4 23:23:51 2005 From: tmoore at common-lisp.net (Timothy Moore) Date: Sat, 5 Feb 2005 00:23:51 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/input-editing.lisp Message-ID: <20050204232351.398EB880A8@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv28404 Modified Files: input-editing.lisp Log Message: Changed invoke-empty-input and handle-empty-input to use the activation/completion gesture typed by the user in deciding which empty input continuation to invoke. This avoids bailing out of a call to accept from within an inner (recursive) call to accept when the user types a delimiter gesture for the inner call in an attempt to get its default value. Date: Sat Feb 5 00:23:50 2005 Author: tmoore Index: mcclim/input-editing.lisp diff -u mcclim/input-editing.lisp:1.42 mcclim/input-editing.lisp:1.43 --- mcclim/input-editing.lisp:1.42 Sun Oct 24 17:47:02 2004 +++ mcclim/input-editing.lisp Sat Feb 5 00:23:49 2005 @@ -761,22 +761,28 @@ ;;; to supply a default. ;;; continuation = (stream scan-pointer +;;; activation-gestures delimiter gestures) (defvar *empty-input-continuations* nil) (defun invoke-empty-input (stream gesture) - "Invoke the continuation of the empty accept before the first non-empty - accept." + "Invoke the continuation of the empty `accept' before the first non-empty + accept `gesture' must be a member of that `accept''s activation or continuation + gestures." (let ((scan-pointer (1- (stream-scan-pointer stream)))) (loop - with active-continuation = nil + with active-continuation-function = nil for continuation in *empty-input-continuations* - for (cont-stream cont-scan-pointer) = continuation + for (cont-stream cont-scan-pointer func activations delimeters) + = continuation while (and (eq stream cont-stream) (eql scan-pointer cont-scan-pointer)) - do (setq active-continuation continuation) - finally (when active-continuation + when (or (gesture-match gesture activations) + (gesture-match gesture delimeters)) + do (setq active-continuation-function func) + end + finally (when active-continuation-function (unread-char gesture stream) - (funcall (caddr active-continuation)))) + (funcall active-continuation-function))) t)) (defmethod stream-read-gesture :around ((stream empty-input-mixin) @@ -815,7 +821,9 @@ (cons (list ,stream (stream-scan-pointer ,stream) #'(lambda () - (return-from ,context-block))) + (return-from ,context-block)) + *activation-gestures* + *delimiter-gestures*) *empty-input-continuations*))) (return-from ,return-block ,input-form))) , at handler-forms))) From varkesteijn at common-lisp.net Sat Feb 5 14:40:57 2005 From: varkesteijn at common-lisp.net (Vincent Arkesteijn) Date: Sat, 5 Feb 2005 15:40:57 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp Message-ID: <20050205144057.4CBA18869A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv12440 Modified Files: inspector.lisp Log Message: Added an inspect-object method for characters. Date: Sat Feb 5 15:40:56 2005 Author: varkesteijn Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.13 mcclim/Apps/Inspector/inspector.lisp:1.14 --- mcclim/Apps/Inspector/inspector.lisp:1.13 Fri Feb 4 23:37:21 2005 +++ mcclim/Apps/Inspector/inspector.lisp Sat Feb 5 15:40:55 2005 @@ -446,6 +446,18 @@ (with-output-as-presentation (pane object (presentation-type-of object)) (print object pane))) +(defmethod inspect-object ((object character) pane) + (inspector-table + (format pane "Character ~S" object) + (inspector-table-row + (princ "code:" pane) + (inspect-object (char-code object) pane)) + (inspector-table-row + (princ "int:" pane) + (inspect-object (char-int object) pane)) + (inspector-table-row + (princ "name:" pane) + (inspect-object (char-name object) pane)))) (defun display-app (frame pane) "Display the APP frame of the inspector" From pscott at common-lisp.net Sat Feb 5 17:28:02 2005 From: pscott at common-lisp.net (Peter Scott) Date: Sat, 5 Feb 2005 18:28:02 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp Message-ID: <20050205172802.278BE8868F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv21501 Modified Files: inspector.lisp Log Message: Removed bad decision to use 'vector presentation type, extended abbreviation threshold, changed abbreviation syntax to be less surprising. Date: Sat Feb 5 18:28:00 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.14 mcclim/Apps/Inspector/inspector.lisp:1.15 --- mcclim/Apps/Inspector/inspector.lisp:1.14 Sat Feb 5 15:40:55 2005 +++ mcclim/Apps/Inspector/inspector.lisp Sat Feb 5 18:28:00 2005 @@ -171,7 +171,8 @@ (format pane "~a:" slot-name)) (inspect-object (slot-value object slot-name) pane))))))) -(defparameter *object-representation-max-length* 60 +;; FIXME: should this be removed? It's really ugly. +(defparameter *object-representation-max-length* 300 "Maximum number of characters of an object's textual representation that are allowed before abbreviation kicks in") @@ -184,7 +185,7 @@ (prin1 object string)))) (if (< (length representation) *object-representation-max-length*) (princ representation pane) - (format pane "instance of ~S" (class-name (class-of object))))))) + (format pane "#<~S ...>" (class-name (class-of object))))))) (defmethod inspect-object ((object standard-object) pane) (inspect-structure-or-object object pane)) @@ -348,10 +349,8 @@ (inspect-object uses pane))))) (defmethod inspect-object ((object vector) pane) - ;; Using 'vector as the presentation type may be nonstandard, but it - ;; is more useful than the default. (with-output-as-presentation - (pane object 'vector) + (pane object (presentation-type-of object)) (formatting-table (pane) (formatting-row (pane) (formatting-cell (pane) From pscott at common-lisp.net Mon Feb 7 21:05:49 2005 From: pscott at common-lisp.net (Peter Scott) Date: Mon, 7 Feb 2005 22:05:49 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp Message-ID: <20050207210549.C73B188692@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv26943 Modified Files: inspector.lisp Log Message: Made symbols in generic function display inspectable. Added :allocation printing in slot descriptions, along with experimental :readers and :writers printing which doesn't seem to do anything in SBCL 0.8.16 for some reason. Added my name to the copyright area at the top, as suggested by Vincent Arkesteijn. Date: Mon Feb 7 22:05:47 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.15 mcclim/Apps/Inspector/inspector.lisp:1.16 --- mcclim/Apps/Inspector/inspector.lisp:1.15 Sat Feb 5 18:28:00 2005 +++ mcclim/Apps/Inspector/inspector.lisp Mon Feb 7 22:05:47 2005 @@ -4,6 +4,8 @@ ;;; Robert Strandh (strandh at labri.fr) ;;; (c) copyright 2005 by ;;; Vincent Arkesteijn +;;; (c) copyright 2005 by +;;; Peter Scott (sketerpot at gmail.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -74,7 +76,9 @@ only the class name would be shown.")) (defgeneric inspect-object (object pane) - (:documentation "Inspect an object, displaying it on PANE")) + (:documentation "Inspect an object, displaying it on PANE. This can +be as verbose as you like; the important thing is that all the +information is present.")) (defmethod inspect-object :around (object pane) (cond ((member object *inspected-objects*) @@ -87,6 +91,11 @@ (let ((*inspected-objects* (cons object *inspected-objects*))) (call-next-method))))) +;; This behavior should be overridden by methods for specific object +;; types that have a more informative short representation. For +;; example, the symbol FOO would be printed as "FOO" instead of "...", +;; since that's just as short and more informative. When it's clicked +;; on, it can then go to a more verbose view. (defmethod inspect-object-briefly (object pane) (with-output-as-presentation (pane object (presentation-type-of object)) @@ -290,13 +299,16 @@ (print (method-qualifiers method))) (loop for specializer in (clim-mop:method-specializers method) do (formatting-cell (pane) - (format pane "~a " - (if (typep specializer - 'clim-mop:eql-specializer) - (format nil "(EQL ~S)" - (clim-mop:eql-specializer-object - specializer)) - (class-name specializer)))))))))) + (if (typep specializer 'clim-mop:eql-specializer) + (progn + (princ "(EQL " pane) + (inspect-object + (clim-mop:eql-specializer-object + specializer) + pane) + (princ ")" pane)) + (inspect-object (class-name specializer) + pane))))))))) (defun pretty-print-function (fun) "Print a function in a readable way, returning a string. On most @@ -415,7 +427,7 @@ (defmethod inspect-object-briefly ((object symbol) pane) (with-output-as-presentation (pane object (presentation-type-of object)) - (print object))) + (prin1 object))) (defmethod inspect-object ((object symbol) pane) (inspector-table @@ -519,4 +531,17 @@ (when documentation (format stream "~&Documentation: ~A~%" documentation)) (format stream "~&Type: ~S~%" - (clim-mop:slot-definition-type slot-object))))) \ No newline at end of file + (clim-mop:slot-definition-type slot-object)) + (format stream "~&Allocation: ~S~%" + (clim-mop:slot-definition-allocation slot-object)) + ;; FIXME: This should show readers and writers, but it doesn't + ;; work on SBCL 0.8.16 for me. Is this an SBCL-specific problem? + ;; Is the code broken? + (when (clim-mop:slot-definition-readers slot-object) + (format stream "~&Readers: ") + (format-textual-list (clim-mop:slot-definition-readers slot-object) + #'inspect-object)) + (when (clim-mop:slot-definition-writers slot-object) + (format stream "~&Writers: ") + (format-textual-list (clim-mop:slot-definition-writers slot-object) + #'inspect-object))))) \ No newline at end of file From tmoore at common-lisp.net Mon Feb 7 21:17:00 2005 From: tmoore at common-lisp.net (Timothy Moore) Date: Mon, 7 Feb 2005 22:17:00 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Lisp-Dep/fix-acl.lisp Message-ID: <20050207211700.AEF3F88692@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Lisp-Dep In directory common-lisp.net:/tmp/cvs-serv27742 Modified Files: fix-acl.lisp Log Message: Complete enumeration of MOP symbols from Robert P. Goldman Date: Mon Feb 7 22:16:59 2005 Author: tmoore Index: mcclim/Lisp-Dep/fix-acl.lisp diff -u mcclim/Lisp-Dep/fix-acl.lisp:1.9 mcclim/Lisp-Dep/fix-acl.lisp:1.10 --- mcclim/Lisp-Dep/fix-acl.lisp:1.9 Fri Mar 21 16:15:09 2003 +++ mcclim/Lisp-Dep/fix-acl.lisp Mon Feb 7 22:16:58 2005 @@ -5,15 +5,117 @@ ;;; Needed to keep ACL from issuing warnings about toplevel (shadow ...) forms (setq comp:*cltl1-compile-file-toplevel-compatibility-p* nil) -(require :loop) +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :loop) + (require :mop)) (defpackage :clim-mop - (:use :clos)) - - -(eval-when (:compile-toplevel :load-toplevel :execute) - (do-external-symbols (sym :clos) - (export sym :clim-mop))) + (:use :clos :common-lisp) + (:export "ACCESSOR-METHOD-SLOT-DEFINITION" + "ADD-DEPENDENT" + "ADD-DIRECT-METHOD" + "ADD-DIRECT-SUBCLASS" + "ADD-METHOD" + "ALLOCATE-INSTANCE" + "BUILT-IN-CLASS" + "CLASS" + "CLASS-DEFAULT-INITARGS" + "CLASS-DIRECT-DEFAULT-INITARGS" + "CLASS-DIRECT-SLOTS" + "CLASS-DIRECT-SUBCLASSES" + "CLASS-DIRECT-SUPERCLASSES" + "CLASS-FINALIZED-P" + "CLASS-NAME" + "CLASS-PRECEDENCE-LIST" + "CLASS-PROTOTYPE" + "CLASS-SLOTS" + "COMPUTE-APPLICABLE-METHODS" + "COMPUTE-APPLICABLE-METHODS-USING-CLASSES" + "COMPUTE-CLASS-PRECEDENCE-LIST" + "COMPUTE-DEFAULT-INITARGS" + "COMPUTE-DISCRIMINATING-FUNCTION" + "COMPUTE-EFFECTIVE-METHOD" + "COMPUTE-EFFECTIVE-SLOT-DEFINITION" + "COMPUTE-SLOTS" + "DIRECT-SLOT-DEFINITION" + "DIRECT-SLOT-DEFINITION-CLASS" + "EFFECTIVE-SLOT-DEFINITION" + "EFFECTIVE-SLOT-DEFINITION-CLASS" + "ENSURE-CLASS" + "ENSURE-CLASS-USING-CLASS" + "ENSURE-GENERIC-FUNCTION" + "ENSURE-GENERIC-FUNCTION-USING-CLASS" + "EQL-SPECIALIZER" + "EQL-SPECIALIZER-OBJECT" + "EXTRACT-LAMBDA-LIST" + "EXTRACT-SPECIALIZER-NAMES" + "FINALIZE-INHERITANCE" + "FIND-METHOD-COMBINATION" + "FORWARD-REFERENCED-CLASS" + "FUNCALLABLE-STANDARD-CLASS" + "FUNCALLABLE-STANDARD-INSTANCE-ACCESS" + "FUNCALLABLE-STANDARD-OBJECT" + "FUNCTION" + "GENERIC-FUNCTION" + "GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER" + "GENERIC-FUNCTION-DECLARATIONS" + "GENERIC-FUNCTION-LAMBDA-LIST" + "GENERIC-FUNCTION-METHOD-CLASS" + "GENERIC-FUNCTION-METHOD-COMBINATION" + "GENERIC-FUNCTION-METHODS" + "GENERIC-FUNCTION-NAME" + "INTERN-EQL-SPECIALIZER" + "MAKE-INSTANCE" + "MAKE-METHOD-LAMBDA" + "MAP-DEPENDENTS" + "METAOBJECT" + "METHOD" + "METHOD-COMBINATION" + "METHOD-FUNCTION" + "METHOD-GENERIC-FUNCTION" + "METHOD-LAMBDA-LIST" + "METHOD-QUALIFIERS" + "METHOD-SPECIALIZERS" + "READER-METHOD-CLASS" + "REMOVE-DEPENDENT" + "REMOVE-DIRECT-METHOD" + "REMOVE-DIRECT-SUBCLASS" + "REMOVE-METHOD" + "SET-FUNCALLABLE-INSTANCE-FUNCTION" + "SLOT-BOUNDP-USING-CLASS" + "SLOT-DEFINITION" + "SLOT-DEFINITION-ALLOCATION" + "SLOT-DEFINITION-INITARGS" + "SLOT-DEFINITION-INITFORM" + "SLOT-DEFINITION-INITFUNCTION" + "SLOT-DEFINITION-LOCATION" + "SLOT-DEFINITION-NAME" + "SLOT-DEFINITION-READERS" + "SLOT-DEFINITION-TYPE" + "SLOT-DEFINITION-WRITERS" + "SLOT-MAKUNBOUND-USING-CLASS" + "SLOT-VALUE-USING-CLASS" + "SPECIALIZER" + "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS" + "SPECIALIZER-DIRECT-METHODS" + "STANDARD-ACCESSOR-METHOD" + "STANDARD-CLASS" + "STANDARD-DIRECT-SLOT-DEFINITION" + "STANDARD-EFFECTIVE-SLOT-DEFINITION" + "STANDARD-GENERIC-FUNCTION" + "STANDARD-INSTANCE-ACCESS" + "STANDARD-METHOD" + "STANDARD-OBJECT" + "STANDARD-READER-METHOD" + "STANDARD-SLOT-DEFINITION" + "STANDARD-WRITER-METHOD" + "UPDATE-DEPENDENT" + "VALIDATE-SUPERCLASS" + "WRITER-METHOD-CLASS")) + +;;;(eval-when (:compile-toplevel :load-toplevel :execute) +;;; (do-external-symbols (sym :clos) +;;; (export sym :clim-mop))) (eval-when (:compile-toplevel :load-toplevel :execute) (export '(clim-lisp-patch::defclass) @@ -63,4 +165,3 @@ .args.)))))) (t `(defun ,fun ,args , at body)))) ) - From pscott at common-lisp.net Tue Feb 8 20:37:40 2005 From: pscott at common-lisp.net (Peter Scott) Date: Tue, 8 Feb 2005 21:37:40 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp Message-ID: <20050208203740.BD1998864C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv4973 Modified Files: inspector.lisp Log Message: Applied patch from Christophe Rhodes which: * deals with unbound slots; * defines a brief method for structure objects and conditions; * defines a normal method for conditions; * fixes the inspection of functions. Date: Tue Feb 8 21:37:36 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.16 mcclim/Apps/Inspector/inspector.lisp:1.17 --- mcclim/Apps/Inspector/inspector.lisp:1.16 Mon Feb 7 22:05:47 2005 +++ mcclim/Apps/Inspector/inspector.lisp Tue Feb 8 21:37:34 2005 @@ -178,23 +178,38 @@ (with-output-as-presentation (pane (cons object slot-name) 'settable-slot) (format pane "~a:" slot-name)) - (inspect-object (slot-value object slot-name) pane))))))) + (if (slot-boundp object slot-name) + (inspect-object (slot-value object slot-name) pane) + (format pane "#")))))))) ;; FIXME: should this be removed? It's really ugly. (defparameter *object-representation-max-length* 300 "Maximum number of characters of an object's textual representation that are allowed before abbreviation kicks in") +(defun inspect-structure-or-object-briefly (object pane) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (handler-case + (let ((representation (with-output-to-string (string) + (prin1 object string)))) + (if (< (length representation) *object-representation-max-length*) + (princ representation pane) + (format pane "#<~S ...>" (class-name (class-of object))))) + (error () + (format pane "#" (class-name (class-of object))))))) + ;; Try to print the normal, textual representation of an object, but ;; if that's too long, make an abbreviated "instance of ~S" version. + (defmethod inspect-object-briefly ((object standard-object) pane) - (with-output-as-presentation - (pane object (presentation-type-of object)) - (let ((representation (with-output-to-string (string) - (prin1 object string)))) - (if (< (length representation) *object-representation-max-length*) - (princ representation pane) - (format pane "#<~S ...>" (class-name (class-of object))))))) + (inspect-structure-or-object-briefly object pane)) + +(defmethod inspect-object-briefly ((object structure-object) pane) + (inspect-structure-or-object-briefly object pane)) + +(defmethod inspect-object-briefly ((object condition) pane) + (inspect-structure-or-object-briefly object pane)) (defmethod inspect-object ((object standard-object) pane) (inspect-structure-or-object object pane)) @@ -202,6 +217,9 @@ (defmethod inspect-object ((object structure-object) pane) (inspect-structure-or-object object pane)) +(defmethod inspect-object ((object condition) pane) + (inspect-structure-or-object object pane)) + (defun inspect-cons-as-cells (object pane) "Inspect a cons cell in a fancy graphical way. The inconvenient part is that this necessarily involves quite a bit of clicking to show a @@ -319,10 +337,13 @@ (prin1 fun string)))) ;; If we have SBCL, try to do fancy formatting. If anything goes ;; wrong with that, fall back on ugly standard PRIN1. - #+sbcl (handler-case (format nil "~A ~S" - (sb-impl::%simple-fun-name fun) - (sb-impl::%simple-fun-arglist fun)) - (error () (generic-print fun))) + #+sbcl + (unless (typep fun 'generic-function) + (let ((fun (sb-kernel:%closure-fun fun))) + (handler-case (format nil "~A ~S" + (sb-kernel:%simple-fun-name fun) + (sb-kernel:%simple-fun-arglist fun)) + (error () (generic-print fun))))) ;; FIXME: Other Lisp implementations have ways of getting this ;; information. If you want a better inspector on a non-SBCL Lisp, ;; please add code for it and send patches. @@ -333,8 +354,10 @@ (pane object (presentation-type-of object)) (format pane "Function: ~A" (pretty-print-function object)) - #+sbcl (format pane "~&Type: ~A" - (sb-impl::%simple-fun-type object)) + #+sbcl + (unless (typep object 'generic-function) + (format pane "~&Type: ~A" + (sb-kernel:%simple-fun-type (sb-kernel:%closure-fun object)))) (print-documentation object pane))) (defmethod inspect-object-briefly ((object package) pane) @@ -534,9 +557,10 @@ (clim-mop:slot-definition-type slot-object)) (format stream "~&Allocation: ~S~%" (clim-mop:slot-definition-allocation slot-object)) - ;; FIXME: This should show readers and writers, but it doesn't - ;; work on SBCL 0.8.16 for me. Is this an SBCL-specific problem? - ;; Is the code broken? + ;; FIXME: This should show readers and writers for object slots + ;; (but not structure slots), but it doesn't work on SBCL 0.8.16 + ;; for me. Is this an SBCL-specific problem? Is the code + ;; broken? (when (clim-mop:slot-definition-readers slot-object) (format stream "~&Readers: ") (format-textual-list (clim-mop:slot-definition-readers slot-object) From pscott at common-lisp.net Tue Feb 8 21:08:41 2005 From: pscott at common-lisp.net (Peter Scott) Date: Tue, 8 Feb 2005 22:08:41 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp Message-ID: <20050208210841.0182C8864C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv6579 Modified Files: inspector.lisp Log Message: Added patch from Peter Wilson to increase *print-length* for long lists upon request. It's pretty simple, and it works smoothly. The only problem I can see is that the user might want to do something other than increasing *print-length* by 10. This is, sadly, not yet supported. Date: Tue Feb 8 22:08:40 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.17 mcclim/Apps/Inspector/inspector.lisp:1.18 --- mcclim/Apps/Inspector/inspector.lisp:1.17 Tue Feb 8 21:37:34 2005 +++ mcclim/Apps/Inspector/inspector.lisp Tue Feb 8 22:08:39 2005 @@ -31,6 +31,7 @@ (define-application-frame inspector () ((dico :initform (make-hash-table) :reader dico) (cons-cell-dico :initform (make-hash-table) :reader cons-cell-dico) + (print-length :initform (make-hash-table) :reader print-length) (obj :initarg :obj :reader obj)) (:pointer-documentation t) (:panes @@ -88,7 +89,10 @@ ((not (gethash object (dico *application-frame*))) (inspect-object-briefly object pane)) (t - (let ((*inspected-objects* (cons object *inspected-objects*))) + (let ((*inspected-objects* (cons object *inspected-objects*)) + (*print-length* (or (gethash object (print-length + *application-frame*)) + *print-length*))) (call-next-method))))) ;; This behavior should be overridden by methods for specific object @@ -111,6 +115,7 @@ :inherit-from t) (define-presentation-type cons () :inherit-from t) +(define-presentation-type long-list-tail () :inherit-from t) (define-presentation-method present (object (type settable-slot) stream @@ -278,9 +283,9 @@ (formatting-cell (pane) (inspect-object cdr pane)) (formatting-cell (pane) (princ ")" pane)) t) - ((>= length *print-length*) - (formatting-cell (pane) (inspect-object car pane)) - (formatting-cell (pane) (princ "..." pane)) + ((and *print-length* (>= length *print-length*)) + (with-output-as-presentation (pane object 'long-list-tail) + (formatting-cell (pane) (princ "...)" pane))) t) (t nil))) (formatting-cell (pane) (inspect-object car pane))))))) @@ -505,8 +510,15 @@ (inspector obj :new-process t))) (define-inspector-command (com-toggle-show-list-cells :name t) - ((obj 'cons :gesture :select :prompt "Select a cons or list")) + ((obj 'cons :gesture :select :prompt "Select a cons or list")) (togglef (gethash obj (cons-cell-dico *application-frame*)))) + +(define-inspector-command (com-show-10-more-items :name t) + ((obj 'long-list-tail :gesture :select :prompt "Select a truncated list")) + (if (gethash obj (print-length *application-frame*)) + (incf (gethash obj (print-length *application-frame*)) 10) + (setf (gethash obj (print-length *application-frame*)) + (+ 10 *print-length*)))) (define-inspector-command (com-toggle-inspect :name t) ((obj t :gesture :select :prompt "Select an object")) From pscott at common-lisp.net Tue Feb 8 22:00:37 2005 From: pscott at common-lisp.net (Peter Scott) Date: Tue, 8 Feb 2005 23:00:37 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp Message-ID: <20050208220037.9DA708864C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv9276 Modified Files: inspector.lisp Log Message: Fixed glitch in formatting of hash tables. Somtimes "=" got wrapped down to the next row but nothing else did. This no longer occurs since the "=" is put in its own cell, rather than being jammed in the left cell along with the key. Made it impossible to toggle inspection of nil. I've found that any attempt to toggle the inspection of nil is almost always a mistake, and an annoying one at that. If you want to inspect nil for some reason, you can always make a new inspector or use com-inspect. Date: Tue Feb 8 23:00:36 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.18 mcclim/Apps/Inspector/inspector.lisp:1.19 --- mcclim/Apps/Inspector/inspector.lisp:1.18 Tue Feb 8 22:08:39 2005 +++ mcclim/Apps/Inspector/inspector.lisp Tue Feb 8 23:00:36 2005 @@ -31,8 +31,11 @@ (define-application-frame inspector () ((dico :initform (make-hash-table) :reader dico) (cons-cell-dico :initform (make-hash-table) :reader cons-cell-dico) - (print-length :initform (make-hash-table) :reader print-length) - (obj :initarg :obj :reader obj)) + (print-length :initform (make-hash-table) :reader print-length + :documentation "A hash table mapping list objects to +their specific print lengths, if they have one.") + (obj :initarg :obj :reader obj + :documentation "The object being inspected")) (:pointer-documentation t) (:panes (app :application :width 600 :height 500 @@ -115,7 +118,8 @@ :inherit-from t) (define-presentation-type cons () :inherit-from t) -(define-presentation-type long-list-tail () :inherit-from t) +(define-presentation-type long-list-tail () + :inherit-from t) (define-presentation-method present (object (type settable-slot) stream @@ -304,11 +308,12 @@ (inspector-table (format pane "~A (test: ~A)" 'hash-table (hash-table-test object)) (loop for key being the hash-keys of object - do (inspector-table-row - (formatting-cell (pane) - (inspect-object key pane) - (princ "=" pane)) - (inspect-object (gethash key object) pane))))) + do (formatting-row (pane) + (formatting-cell (pane :align-x :right) + (inspect-object key pane)) + (formatting-cell (pane) (princ "=" pane)) + (formatting-cell (pane) + (inspect-object (gethash key object) pane)))))) (defmethod inspect-object ((object generic-function) pane) (inspector-table @@ -522,8 +527,9 @@ (define-inspector-command (com-toggle-inspect :name t) ((obj t :gesture :select :prompt "Select an object")) - (unless (eq obj (obj *application-frame*)) - (togglef (gethash obj (dico *application-frame*))))) + (unless (or (eq obj (obj *application-frame*)) + (null obj)) + (togglef (gethash obj (dico *application-frame*))))) (define-inspector-command (com-remove-method :name t) ((obj 'method :gesture :delete :prompt "Remove method")) From varkesteijn at common-lisp.net Tue Feb 8 22:14:02 2005 From: varkesteijn at common-lisp.net (Vincent Arkesteijn) Date: Tue, 8 Feb 2005 23:14:02 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/INSTALL mcclim/Apps/Inspector/inspector.lisp Message-ID: <20050208221402.703188864C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv9766 Modified Files: INSTALL inspector.lisp Log Message: * Fixed the command Describe Slot to correctly list the reader and writer functions, when available. * Removed two colons from INSTALL file to reflect the exported status of clouseau:inspector. Date: Tue Feb 8 23:14:01 2005 Author: varkesteijn Index: mcclim/Apps/Inspector/INSTALL diff -u mcclim/Apps/Inspector/INSTALL:1.2 mcclim/Apps/Inspector/INSTALL:1.3 --- mcclim/Apps/Inspector/INSTALL:1.2 Thu Feb 3 19:47:18 2005 +++ mcclim/Apps/Inspector/INSTALL Tue Feb 8 23:14:01 2005 @@ -5,7 +5,7 @@ 3. Try something like: - (clouseau::inspector (clim:make-application-frame 'clouseau::inspector :obj 20)) + (clouseau:inspector (clim:make-application-frame 'clouseau:inspector :obj 20)) in order to inspect the inspector pane. Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.19 mcclim/Apps/Inspector/inspector.lisp:1.20 --- mcclim/Apps/Inspector/inspector.lisp:1.19 Tue Feb 8 23:00:36 2005 +++ mcclim/Apps/Inspector/inspector.lisp Tue Feb 8 23:14:01 2005 @@ -567,23 +567,24 @@ (class (class-of object)) (documentation (handler-bind ((warning #'muffle-warning)) (slot-documentation class slot-name))) - (slot-object (find slot-name (clim-mop:class-slots class) - :key #'clim-mop:slot-definition-name))) + (slot-object (or (find slot-name (clim-mop:class-direct-slots class) + :key #'clim-mop:slot-definition-name) + (find slot-name (clim-mop:class-slots class) + :key #'clim-mop:slot-definition-name)))) (when documentation (format stream "~&Documentation: ~A~%" documentation)) (format stream "~&Type: ~S~%" (clim-mop:slot-definition-type slot-object)) (format stream "~&Allocation: ~S~%" (clim-mop:slot-definition-allocation slot-object)) - ;; FIXME: This should show readers and writers for object slots - ;; (but not structure slots), but it doesn't work on SBCL 0.8.16 - ;; for me. Is this an SBCL-specific problem? Is the code - ;; broken? - (when (clim-mop:slot-definition-readers slot-object) - (format stream "~&Readers: ") - (format-textual-list (clim-mop:slot-definition-readers slot-object) - #'inspect-object)) - (when (clim-mop:slot-definition-writers slot-object) - (format stream "~&Writers: ") - (format-textual-list (clim-mop:slot-definition-writers slot-object) - #'inspect-object))))) \ No newline at end of file + ;; slot-definition-{readers,writers} only works for direct slot + ;; definitions + (let ((readers (clim-mop:slot-definition-readers slot-object))) + (when readers + (format stream "~&Readers: ") + (present readers (presentation-type-of readers) :stream stream))) + (let ((writers (clim-mop:slot-definition-writers slot-object))) + (when writers + (format stream "~&Writers: ") + (present writers (presentation-type-of writers) :stream stream)))))) + From pscott at common-lisp.net Tue Feb 8 22:23:13 2005 From: pscott at common-lisp.net (Peter Scott) Date: Tue, 8 Feb 2005 23:23:13 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/INSTALL Message-ID: <20050208222313.AE67E8864C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv10645 Modified Files: INSTALL Log Message: Fixed typos, changed clouseau::inspector to clouseau:inspector, added Usage and Threading sections with examples to get people off to a quick start, and put in a bigger example of inspecting a running inspector. Date: Tue Feb 8 23:23:12 2005 Author: pscott Index: mcclim/Apps/Inspector/INSTALL diff -u mcclim/Apps/Inspector/INSTALL:1.3 mcclim/Apps/Inspector/INSTALL:1.4 --- mcclim/Apps/Inspector/INSTALL:1.3 Tue Feb 8 23:14:01 2005 +++ mcclim/Apps/Inspector/INSTALL Tue Feb 8 23:23:12 2005 @@ -1,3 +1,6 @@ +Quick start +=========== + 1. Start your Lisp system and make sure you have ASDF and McCLIM in your core file. @@ -5,9 +8,50 @@ 3. Try something like: - (clouseau:inspector (clim:make-application-frame 'clouseau:inspector :obj 20)) + (clouseau:inspector (clim:make-application-frame + 'clouseau:inspector :obj 20)) in order to inspect the inspector pane. -4. Lef-click on occurrences of objects or of "...". +4. Left-click on occurrences of objects or of "...". + + +Usage +===== + +The inspector is invoked like this: + +(clouseau:inspector object) + +To get a feel for what the inspector can do, try these: + +(clouseau:inspector #'write-string) +(clouseau:inspector #'documentation) +(clouseau:inspector 'documentation) +(clouseau:inspector '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)) + +Click on things. See what happens. + + +Threading +========= + +If you have a multithreaded Lisp implementation, you can start an +inspector in a new process like this: + +(clouseau:inspector object :new-process t) + +For example, if you want to get really fancy and inspect a running +inspector, this ugly hack should do the job: +(let ((*print-length* 10) + (*print-level* 10) + inspected-inspector) + (setf inspected-inspector + (clim:make-application-frame 'clouseau::inspector + :obj (clim:make-application-frame + 'clouseau::inspector :obj 20))) + (clim-sys:make-process #'(lambda () + (clim:run-frame-top-level inspected-inspector)) + :name "Inspector Clouseau (being inspected)") + (clouseau:inspector inspected-inspector :new-process t)) \ No newline at end of file From crhodes at common-lisp.net Thu Feb 10 09:54:28 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Thu, 10 Feb 2005 10:54:28 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/text-selection.lisp Message-ID: <20050210095428.45F4E88692@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv25133 Modified Files: text-selection.lisp Log Message: encouraged by IRC feedback, commit fixes from conversation with myself on mcclim-devel regarding ICCCM X compliance in the SetInputFocus and selection ownership areas. Date: Thu Feb 10 10:54:26 2005 Author: crhodes Index: mcclim/text-selection.lisp diff -u mcclim/text-selection.lisp:1.2 mcclim/text-selection.lisp:1.3 --- mcclim/text-selection.lisp:1.2 Sun Jan 2 06:31:32 2005 +++ mcclim/text-selection.lisp Thu Feb 10 10:54:26 2005 @@ -243,9 +243,8 @@ (make-instance 'selection-clear-event :sheet owner :selection :primary)))) - (bind-selection (port pane) pane (event-timestamp event)) - ;; FIXME: check that we get it ... (how?) - (setf (selection-owner (port pane)) pane) + (when (bind-selection (port pane) pane (event-timestamp event)) + (setf (selection-owner (port pane)) pane)) ;; ))) From crhodes at common-lisp.net Thu Feb 10 09:54:32 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Thu, 10 Feb 2005 10:54:32 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Backends/CLX/port.lisp Message-ID: <20050210095432.40C888869C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv25133/Backends/CLX Modified Files: port.lisp Log Message: encouraged by IRC feedback, commit fixes from conversation with myself on mcclim-devel regarding ICCCM X compliance in the SetInputFocus and selection ownership areas. Date: Thu Feb 10 10:54:28 2005 Author: crhodes Index: mcclim/Backends/CLX/port.lisp diff -u mcclim/Backends/CLX/port.lisp:1.105 mcclim/Backends/CLX/port.lisp:1.106 --- mcclim/Backends/CLX/port.lisp:1.105 Fri Jan 14 13:47:47 2005 +++ mcclim/Backends/CLX/port.lisp Thu Feb 10 10:54:27 2005 @@ -813,12 +813,16 @@ :timestamp time)) (defmethod port-wm-protocols-message (sheet time (message (eql :wm_take_focus)) data) - (declare (ignore data)) + (when time + (format *trace-output* "~&;; In :WM_TAKE_FOCUS, TIME is not NIL: ~S" time)) (let* ((frame (pane-frame sheet)) - (focus (climi::keyboard-input-focus frame))) + (focus (climi::keyboard-input-focus frame)) + ;; FIXME: Do I really have to use ELT here? The CLX manual + ;; says (sequence integer), so I suppose I do. + (timestamp (elt data 1))) (when (and focus (sheet-mirror focus)) (xlib:set-input-focus (clx-port-display *clx-port*) - (sheet-mirror focus) :parent time) + (sheet-mirror focus) :parent timestamp) nil))) (defmethod port-wm-protocols-message (sheet time (message t) data) @@ -1368,13 +1372,16 @@ (defmethod bind-selection ((port clx-port) window &optional time) (xlib:set-selection-owner (xlib:window-display (sheet-direct-mirror window)) - :primary (sheet-direct-mirror window))) + :primary (sheet-direct-mirror window) time) + (eq (xlib:selection-owner + (xlib:window-display (sheet-direct-mirror window)) + :primary) + (sheet-direct-mirror window))) (defmethod release-selection ((port clx-port) &optional time) (xlib:set-selection-owner (clim-clx::clx-port-display port) - :primary nil - time) + :primary nil time) (setf (selection-owner port) nil)) (defmethod request-selection ((port clx-port) requestor time) From tmoore at common-lisp.net Fri Feb 11 09:10:38 2005 From: tmoore at common-lisp.net (Timothy Moore) Date: Fri, 11 Feb 2005 10:10:38 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/decls.lisp mcclim/recording.lisp mcclim/regions.lisp Message-ID: <20050211091038.574AC8864C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv2906 Modified Files: decls.lisp recording.lisp regions.lisp Log Message: Changed the representation of STANDARD-RECTANGLE from slots for the coordinates to an array of coordinates. This should enable opportunities for hashing the coordinates in interesting, inexpensive ways. Introduced the macros WITH-STANDARD-RECTANGLE and WITH-STANDARD-RECTANGLE* to provide convenient access to the coordinates. Added (SETF RECTANGLE-EDGES*). This change may well break code that depends on the internal representation of output records. Date: Fri Feb 11 10:10:37 2005 Author: tmoore Index: mcclim/decls.lisp diff -u mcclim/decls.lisp:1.31 mcclim/decls.lisp:1.32 --- mcclim/decls.lisp:1.31 Wed Feb 2 12:33:58 2005 +++ mcclim/decls.lisp Fri Feb 11 10:10:36 2005 @@ -32,8 +32,26 @@ ;;; (exported) generic functions here? --GB ;;; ;;; YES! -- CSR +;;; We'll get right on it :) -- moore +;;; Whose numbers are we using here? + +;;; 3.2.1 (defgeneric point-x (point)) (defgeneric point-y (point)) + +;;; 3.2.4.1 + +(defgeneric rectangle-edges* (rectangle)) +(defgeneric rectangle-min-point (rectangle)) +(defgeneric rectangle-max-point (rectangle)) +(defgeneric rectangle-min-x (rectangle)) +(defgeneric rectangle-min-y (rectangle)) +(defgeneric rectangle-max-x (rectangle)) +(defgeneric rectangle-max-y (rectangle)) +(defgeneric rectangle-width (rectangle)) +(defgeneric rectangle-height (rectangle)) +(defgeneric rectangle-size (rectangle)) + (defgeneric transform-region (transformation region)) Index: mcclim/recording.lisp diff -u mcclim/recording.lisp:1.116 mcclim/recording.lisp:1.117 --- mcclim/recording.lisp:1.116 Wed Feb 2 12:33:58 2005 +++ mcclim/recording.lisp Fri Feb 11 10:10:36 2005 @@ -184,9 +184,14 @@ unspecified. ")) ;;; From the Franz CLIM user's guide but not in the spec... clearly necessary. -;;; What is its status? -- APD, 2002-06-14. -(defgeneric map-over-output-records - (continuation record &optional x-offset y-offset &rest continuation-args)) + +(defgeneric map-over-output-records-1 + (continuation record continuation-args)) + +(defun map-over-output-records + (continuation record &optional x-offset y-offset &rest continuation-args) + (declare (ignore x-offset y-offset)) + (map-over-output-records-1 continuation record continuation-args)) ;;; 16.2.3. Output Record Change Notification Protocol @@ -438,15 +443,14 @@ (:documentation "Implementation class for the Basic Output Record Protocol.")) (defmethod initialize-instance :after ((record basic-output-record) - &rest args - &key (x-position 0.0d0) (y-position 0.0d0)) + &key (x-position 0.0d0) + (y-position 0.0d0)) (declare (ignore args)) - (with-slots (x1 y1 x2 y2) record - (setq x1 x-position - y1 y-position - x2 x-position - y2 y-position))) + (setf (rectangle-edges* record) + (values x-position y-position x-position y-position))) +;;; XXX I'd really like to get rid of the x and y slots. They are surely +;;; redundant with the bounding rectangle coordinates. (defclass compound-output-record (basic-output-record) ((x :initarg :x-position :initform 0.0d0 @@ -463,11 +467,12 @@ (bounding-rectangle-position record)) (defmethod* (setf output-record-position) (nx ny (record basic-output-record)) - (with-slots (x1 y1 x2 y2) record + (with-standard-rectangle (x1 y1 x2 y2) + record (let ((dx (- nx x1)) (dy (- ny y1))) - (setf x1 nx y1 ny - x2 (+ x2 dx) y2 (+ y2 dy)))) + (setf (rectangle-edges* record) + (values nx ny (+ x2 dx) (+ y2 dy))))) (values nx ny)) (defmethod* (setf output-record-position) :around @@ -480,10 +485,11 @@ min-x min-y max-x max-y)))) (values nx ny)) -(defmethod* (setf output-record-position) :before - (nx ny (record compound-output-record)) - (with-slots (x1 y1 in-moving-p) record - (letf ((in-moving-p t)) +(defmethod* (setf output-record-position) + :before (nx ny (record compound-output-record)) + (with-standard-rectangle* (:x1 x1 :y1 y1) + record + (letf (((slot-value record 'in-moving-p) t)) (let ((dx (- nx x1)) (dy (- ny y1))) (map-over-output-records @@ -673,19 +679,18 @@ (when sheet (map-over-output-records #'note-output-record-lost-sheet record 0 0 sheet)))) -(defmethod clear-output-record :after ((record compound-output-record)) - (with-slots (x y x1 y1 x2 y2) record - (setf x1 x y1 y - x2 x y2 y))) +(defmethod clear-output-record :after ((record compound-output-record)) + ;; XXX banish x and y + (with-slots (x y) + record + (setf (rectangle-edges* record) (values x y x y)))) (defmethod output-record-count ((record basic-output-record)) 0) -(defmethod map-over-output-records - (function (record displayed-output-record) - &optional (x-offset 0) (y-offset 0) - &rest function-args) - (declare (ignore function x-offset y-offset function-args)) +(defmethod map-over-output-records-1 + (function (record displayed-output-record) function-args) + (declare (ignore function function-args)) nil) ;;; This needs to work in "most recently added last" order. Is this @@ -743,6 +748,7 @@ (apply function child function-args))) (output-record-children record))) +;;; XXX Dunno about this definition... -- moore (defun null-bounding-rectangle-p (bbox) (with-bounding-rectangle* (x1 y1 x2 y2) bbox (and (zerop x1) (zerop y1) @@ -751,19 +757,19 @@ ;;; 16.2.3. Output Record Change Notification Protocol (defmethod recompute-extent-for-new-child ((record compound-output-record) child) - (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record - (with-slots (parent x1 y1 x2 y2) record - (if (= 1 (output-record-count record)) - (setf (values x1 y1 x2 y2) (bounding-rectangle* child)) - (unless (null-bounding-rectangle-p child) - (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child - (minf x1 x1-child) - (minf y1 y1-child) - (maxf x2 x2-child) - (maxf y2 y2-child)))) - (when parent - (recompute-extent-for-changed-child parent record - old-x1 old-y1 old-x2 old-y2)))) + (unless (null-bounding-rectangle-p child) + (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record + (if (eql 1 (output-record-count record)) + (setf (rectangle-edges* record) (bounding-rectangle* child)) + (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) + child + (setf (rectangle-edges* record) + (values (min old-x1 x1-child) (min old-y1 y1-child) + (max old-x2 x2-child) (max old-y2 y2-child))))) + (let ((parent (output-record-parent record))) + (when parent + (recompute-extent-for-changed-child + parent record old-x1 old-y1 old-x2 old-y2))))) record) (defmethod %tree-recompute-extent* ((record compound-output-record)) @@ -787,6 +793,7 @@ (maxf new-y2 cy2)))) record) (if first-time + ;; XXX banish x y (with-slots (x y) record (values x y x y)) (values new-x1 new-y1 new-x2 new-y2)))) @@ -816,14 +823,16 @@ (maxf new-x2 cx2) (maxf new-y2 cy2)))) record) - (with-slots (x y x1 y1 x2 y2) + (with-slots (x y) record (if first-time ;No children - (values x1 y1 x2 y2) + (bounding-rectangle* record) (progn - (setf (values x y x1 y1 x2 y2) - (values new-x1 new-y1 new-x1 new-y1 new-x2 new-y2)) - (values new-x1 new-y1 new-x2 new-y2)))))) + ;; XXX banish x,y + (setf x new-x1 y new-y1) + (setf (rectangle-edges* record) + (values new-x1 new-y1 new-x2 new-y2))))))) + (defmethod recompute-extent-for-changed-child ((record compound-output-record) changed-child @@ -850,13 +859,17 @@ (values (min cx1 ox1) (min cy1 oy1) (max cx2 ox2) (max cy2 oy2))) (T (%tree-recompute-extent* record))) - - (with-slots (x y x1 y1 x2 y2 parent) record - (setf x nx1 y ny1 x1 nx1 y1 ny1 x2 nx2 y2 ny2) - (unless (or (null parent) - (and (= nx1 ox1) (= ny1 oy1) - (= nx2 ox2) (= nx2 oy2))) - (recompute-extent-for-changed-child parent record ox1 oy1 ox2 oy2)))))) + ;; XXX banish x, y + (with-slots (x y) + record + (setf x nx1 y ny1) + (setf (rectangle-edges* record) (values nx1 ny1 nx2 ny2)) + (let ((parent (output-record-parent record))) + (unless (or (null parent) + (and (= nx1 ox1) (= ny1 oy1) + (= nx2 ox2) (= nx2 oy2))) + (recompute-extent-for-changed-child parent record + ox1 oy1 ox2 oy2))))))) record) ;; There was once an :around method on recompute-extent-for-changed-child here, @@ -919,15 +932,18 @@ (defmethod output-record-count ((record standard-sequence-output-record)) (length (output-record-children record))) -(defmethod map-over-output-records - (function (record standard-sequence-output-record) - &optional (x-offset 0) (y-offset 0) - &rest function-args) +(defmethod map-over-output-records-1 + (function (record standard-sequence-output-record) function-args) "Applies FUNCTION to all children in the order they were added." (declare (ignore x-offset y-offset)) - (loop with children = (output-record-children record) - for child across children - do (apply function child function-args))) + (if function-args + (loop with children = (output-record-children record) + for child across children + do (apply function child function-args)) + (loop with children = (output-record-children record) + for child across children + do (funcall function child)))) + (defmethod map-over-output-records-containing-position (function (record standard-sequence-output-record) x y @@ -1175,11 +1191,11 @@ (ceiling (+ max-x border)) (ceiling (+ max-y border))))) -;;; x1, y1 slots must exist in class... +;;; record must be a standard-rectangle (defmethod* (setf output-record-position) :around (nx ny (record coord-seq-mixin)) - (with-slots (x1 y1) + (with-standard-rectangle* (:x1 x1 :y1 y1) record (let ((dx (- nx x1)) (dy (- ny y1)) @@ -1249,14 +1265,15 @@ ,@(when class `((defclass ,class-name (, at mixins standard-graphics-displayed-output-record) ,class-vars) - (defmethod initialize-instance :after ((graphic ,class-name) &rest args) + (defmethod initialize-instance :after ((graphic ,class-name) + &key) (declare (ignore args)) - (with-slots (x1 y1 x2 y2 - stream ink clipping-region + (with-slots (stream ink clipping-region line-style text-style , at args) graphic (let* ((medium (sheet-medium stream))) - (multiple-value-setq (x1 y1 x2 y2) (progn , at body))))))) + (setf (rectangle-edges* graphic) + (progn , at body))))))) ,(when medium-fn `(defmethod ,method-name :around ((stream output-recording-stream) , at args) ;; XXX STANDARD-OUTPUT-RECORDING-STREAM ^? @@ -1285,14 +1302,16 @@ (defmethod* (setf output-record-position) :around (nx ny (record draw-point-output-record)) - (with-slots (x1 y1 point-x point-y) - record - (let ((dx (- nx x1)) - (dy (- ny y1))) - (multiple-value-prog1 - (call-next-method) - (incf point-x dx) - (incf point-y dy))))) + (with-standard-rectangle* (:x1 x1 :y1 y1) + record + (with-slots (point-x point-y) + record + (let ((dx (- nx x1)) + (dy (- ny y1))) + (multiple-value-prog1 + (call-next-method) + (incf point-x dx) + (incf point-y dy)))))) (defrecord-predicate draw-point-output-record (point-x point-y) (and (if-supplied (point-x coordinate) @@ -1323,17 +1342,18 @@ (defmethod* (setf output-record-position) :around (nx ny (record draw-line-output-record)) - (with-slots (x1 y1 - point-x1 point-y1 point-x2 point-y2) + (with-standard-rectangle* (:x1 x1 :y1 y1) record - (let ((dx (- nx x1)) - (dy (- ny y1))) - (multiple-value-prog1 - (call-next-method) - (incf point-x1 dx) - (incf point-y1 dy) - (incf point-x2 dx) - (incf point-y2 dy))))) + (with-slots (point-x1 point-y1 point-x2 point-y2) + record + (let ((dx (- nx x1)) + (dy (- ny y1))) + (multiple-value-prog1 + (call-next-method) + (incf point-x1 dx) + (incf point-y1 dy) + (incf point-x2 dx) + (incf point-y2 dy)))))) (defrecord-predicate draw-line-output-record (point-x1 point-y1 point-x2 point-y2) @@ -1507,17 +1527,18 @@ (defmethod* (setf output-record-position) :around (nx ny (record draw-rectangle-output-record)) - (with-slots (x1 y1 - left top right bottom) + (with-standard-rectangle* (:x1 x1 :y1 y1) record - (let ((dx (- nx x1)) - (dy (- ny y1))) - (multiple-value-prog1 - (call-next-method) - (incf left dx) - (incf top dy) - (incf right dx) - (incf bottom dy))))) + (with-slots (left top right bottom) + record + (let ((dx (- nx x1)) + (dy (- ny y1))) + (multiple-value-prog1 + (call-next-method) + (incf left dx) + (incf top dy) + (incf right dx) + (incf bottom dy)))))) (defrecord-predicate draw-rectangle-output-record (left top right bottom filled) (and (if-supplied (left coordinate) @@ -1565,14 +1586,16 @@ (defmethod* (setf output-record-position) :around (nx ny (record draw-ellipse-output-record)) - (with-slots (x1 y1 center-x center-y) + (with-standard-rectangle* (:x1 x1 :y1 y1) record - (let ((dx (- nx x1)) - (dy (- ny y1))) - (multiple-value-prog1 - (call-next-method) - (incf center-x dx) - (incf center-y dy))))) + (with-slots (center-x center-y) + record + (let ((dx (- nx x1)) + (dy (- ny y1))) + (multiple-value-prog1 + (call-next-method) + (incf center-x dx) + (incf center-y dy)))))) (defrecord-predicate draw-ellipse-output-record (center-x center-y) (and (if-supplied (center-x coordinate) @@ -1591,15 +1614,18 @@ (setf (values x y) (transform-position transform x y)) (values x y (+ x width) (+ y height)))) -(defmethod* (setf output-record-position) :around (nx ny (record draw-pattern-output-record)) - (with-slots (x1 y1 x y) +(defmethod* (setf output-record-position) :around + (nx ny (record draw-pattern-output-record)) +(with-standard-rectangle* (:x1 x1 :y1 y1) + record + (with-slots (x y) record (let ((dx (- nx x1)) (dy (- ny y1))) (multiple-value-prog1 (call-next-method) (incf x dx) - (incf y dy))))) + (incf y dy)))))) (defrecord-predicate draw-pattern-output-record (x y pattern) ;; ### I am not so sure about the correct usage of DEFRECORD-PREDICATE @@ -1650,16 +1676,18 @@ (defmethod* (setf output-record-position) :around (nx ny (record draw-text-output-record)) - (with-slots (x1 y1 point-x point-y toward-x toward-y) + (with-standard-rectangle* (:x1 x1 :y1 y1) record - (let ((dx (- nx x1)) - (dy (- ny y1))) - (multiple-value-prog1 - (call-next-method) - (incf point-x dx) - (incf point-y dy) - (incf toward-x dx) - (incf toward-y dy))))) + (with-slots (point-x point-y toward-x toward-y) + record + (let ((dx (- nx x1)) + (dy (- ny y1))) + (multiple-value-prog1 + (call-next-method) + (incf point-x dx) + (incf point-y dy) + (incf toward-x dx) + (incf toward-y dy)))))) (defrecord-predicate draw-text-output-record (string start end point-x point-y align-x align-y toward-x toward-y @@ -1752,25 +1780,27 @@ (defmethod* (setf output-record-position) :around (nx ny (record standard-text-displayed-output-record)) - (with-slots (x1 y1 start-x start-y end-x end-y strings baseline) + (with-standard-rectangle* (:x1 x1 :y1 y1) record - (let ((dx (- nx x1)) - (dy (- ny y1))) - (multiple-value-prog1 - (call-next-method) - (incf start-x dx) - (incf start-y dy) - (incf end-x dx) - (incf end-y dy) - ;(incf baseline dy) - (loop for s in strings - do (incf (slot-value s 'start-x) dx)))))) + (with-slots (start-x start-y end-x end-y strings baseline) + record + (let ((dx (- nx x1)) + (dy (- ny y1))) + (multiple-value-prog1 + (call-next-method) + (incf start-x dx) + (incf start-y dy) + (incf end-x dx) + (incf end-y dy) + ;(incf baseline dy) + (loop for s in strings + do (incf (slot-value s 'start-x) dx))))))) (defmethod replay-output-record ((record standard-text-displayed-output-record) stream &optional region (x-offset 0) (y-offset 0)) (declare (ignore region x-offset y-offset)) - (with-slots (strings baseline max-height start-y wrapped x1 y1) + (with-slots (strings baseline max-height start-y wrapped) record (with-sheet-medium (medium stream) ;is sheet a sheet-with-medium-mixin? --GB ;; FIXME: @@ -1803,9 +1833,14 @@ (defmethod tree-recompute-extent ((text-record standard-text-displayed-output-record)) - (with-slots (parent x1 y1 x2 y2 width max-height) text-record - (setq x2 (coordinate (+ x1 width)) - y2 (coordinate (+ y1 max-height)))) + (with-standard-rectangle* (:x1 x1 :y1 y1) + text-record + (with-slots (width max-height) + text-record + (setf (rectangle-edges* text-record) + (values x1 y1 + (coordinate (+ x1 width)) + (coordinate (+ y1 max-height)))))) text-record) (defmethod add-character-output-to-text-record ; XXX OAOO with ADD-STRING-... Index: mcclim/regions.lisp diff -u mcclim/regions.lisp:1.28 mcclim/regions.lisp:1.29 --- mcclim/regions.lisp:1.28 Wed Mar 24 10:30:29 2004 +++ mcclim/regions.lisp Fri Feb 11 10:10:37 2005 @@ -4,7 +4,7 @@ ;;; Created: 1998-12-02 19:26 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). -;;; $Id: regions.lisp,v 1.28 2004/03/24 09:30:29 moore Exp $ +;;; $Id: regions.lisp,v 1.29 2005/02/11 09:10:37 tmoore Exp $ ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 1998,1999,2001 by Gilbert Baumann ;;; (c) copyright 2001 by Arnaud Rouanet (rouanet at emi.u-bordeaux.fr) @@ -366,10 +366,42 @@ ;; rectangle-edges* (defclass standard-rectangle (rectangle) - ((x1 :type coordinate :initarg :x1) - (y1 :type coordinate :initarg :y1) - (x2 :type coordinate :initarg :x2) - (y2 :type coordinate :initarg :y2))) + ((coordinates :initform (make-array 4 :element-type 'coordinate)))) + +(defmethod initialize-instance :after ((obj standard-rectangle) + &key (x1 0.0d0) (y1 0.0d0) + (x2 0.0d0) (y2 0.0d0)) + (let ((coords (slot-value obj 'coordinates))) + (setf (aref coords 0) x1) + (setf (aref coords 1) y1) + (setf (aref coords 2) x2) + (setf (aref coords 3) y2))) + +(defmacro with-standard-rectangle ((x1 y1 x2 y2) rectangle &body body) + (with-gensyms (coords) + `(let ((,coords (slot-value ,rectangle 'coordinates))) + (declare (type (array coordinate 4) ,coords)) + (let ((,x1 (aref ,coords 0)) + (,y1 (aref ,coords 1)) + (,x2 (aref ,coords 2)) + (,y2 (aref ,coords 3))) + (declare (type coordinate ,x1 ,y1 ,x2 ,y2)) + , at body)))) + +(defmacro with-standard-rectangle* ((&key x1 y1 x2 y2) rectangle &body body) + (with-gensyms (coords) + `(let ((,coords (slot-value ,rectangle 'coordinates))) + (declare (type (array coordinate 4) ,coords)) + (let (,@(and x1 `((,x1 (aref ,coords 0)))) + ,@(and y1 `((,y1 (aref ,coords 1)))) + ,@(and x2 `((,x2 (aref ,coords 2)))) + ,@(and y2 `((,y2 (aref ,coords 3))))) + (declare (type coordinate + ,@(and x1 `(,x1)) + ,@(and y1 `(,y1)) + ,@(and x2 `(,x2)) + ,@(and y2 `(,y2)))) + , at body)))) (defun make-rectangle (point1 point2) (make-rectangle* (point-x point1) (point-y point1) (point-x point2) (point-y point2))) @@ -378,70 +410,135 @@ (psetq x1 (coerce (min x1 x2) 'coordinate) x2 (coerce (max x1 x2) 'coordinate) y1 (coerce (min y1 y2) 'coordinate) - y2 (coerce (max y1 y2) 'coordinate)) + y2 (coerce (max y1 y2) 'coordinate)) (if (or (coordinate= x1 x2) (coordinate= y1 y2)) +nowhere+ (make-instance 'standard-rectangle :x1 x1 :x2 x2 :y1 y1 :y2 y2))) (defmethod rectangle-edges* ((rect standard-rectangle)) - (with-slots (x1 y1 x2 y2) rect + (with-standard-rectangle (x1 y1 x2 y2) + rect (values x1 y1 x2 y2))) +;;; standard-rectangles are immutable and all that, but we still need to set +;;; their positions and dimensions (in output recording) +(defgeneric* (setf rectangle-edges*) (x1 y1 x2 y2 rectangle)) + +(defmethod* (setf rectangle-edges*) + (x1 y1 x2 y2 (rectangle standard-rectangle)) + (let ((coords (slot-value rectangle 'coordinates))) + (declare (type (array coordinate 4) coords)) + (setf (aref coords 0) x1) + (setf (aref coords 1) y1) + (setf (aref coords 2) x2) + (setf (aref coords 3) y2)) + (values x1 y1 x2 y2)) + (defmethod rectangle-min-point ((rect rectangle)) (multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* rect) (declare (ignore x2 y2)) (make-point x1 y1))) +(defmethod rectangle-min-point ((rect standard-rectangle)) + (with-standard-rectangle* (:x1 x1 :y1 y1) + rect + (make-point x1 y1))) + (defmethod rectangle-max-point ((rect rectangle)) (multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* rect) (declare (ignore x1 y1)) (make-point x2 y2))) +(defmethod rectangle-max-point ((rect standard-rectangle)) + (with-standard-rectangle* (:x2 x2 :y2 y2) + rect + (make-point x2 y2))) + (defmethod rectangle-min-x ((rect rectangle)) (nth-value 0 (rectangle-edges* rect))) +(defmethod rectangle-min-x ((rect standard-rectangle)) + (with-standard-rectangle* (:x1 x1) + rect + x1)) + (defmethod rectangle-min-y ((rect rectangle)) (nth-value 1 (rectangle-edges* rect))) +(defmethod rectangle-min-y ((rect standard-rectangle)) + (with-standard-rectangle* (:y1 y1) + rect + y1)) + + (defmethod rectangle-max-x ((rect rectangle)) (nth-value 2 (rectangle-edges* rect))) +(defmethod rectangle-max-x ((rect standard-rectangle)) + (with-standard-rectangle* (:x2 x2) + rect + x2)) + (defmethod rectangle-max-y ((rect rectangle)) (nth-value 3 (rectangle-edges* rect))) +(defmethod rectangle-max-y ((rect standard-rectangle)) + (with-standard-rectangle* (:y2 y2) + rect + y2)) + (defmethod rectangle-width ((rect rectangle)) (multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* rect) (declare (ignore y1 y2)) (- x2 x1))) +(defmethod rectangle-width ((rect standard-rectangle)) + (with-standard-rectangle* (:x1 x1 :x2 x2) + rect + (- x2 x1))) + (defmethod rectangle-height ((rect rectangle)) (multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* rect) (declare (ignore x1 x2)) (- y2 y1))) +(defmethod rectangle-height ((rect standard-rectangle)) + (with-standard-rectangle* (:y1 y1 :y2 y2) + rect + (- y2 y1))) + (defmethod rectangle-size ((rect rectangle)) (multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* rect) (values (- x2 x1) (- y2 y1)))) +(defmethod rectangle-size ((rect standard-rectangle)) + (with-standard-rectangle (x1 y1 x2 y2) + rect + (values (- x2 x1) (- y2 y1)))) + ;; polyline/polygon protocol for standard-rectangle's (defmethod polygon-points ((rect standard-rectangle)) - (with-slots (x1 y1 x2 y2) rect + (with-standard-rectangle (x1 y1 x2 y2) + rect (list (make-point x1 y1) (make-point x1 y2) (make-point x2 y2) (make-point x2 y1)))) + (defmethod map-over-polygon-coordinates (fun (rect standard-rectangle)) - (with-slots (x1 y1 x2 y2) rect + (with-standard-rectangle (x1 y1 x2 y2) + rect (funcall fun x1 y1) (funcall fun x1 y2) (funcall fun x2 y2) (funcall fun x2 y1))) (defmethod map-over-polygon-segments (fun (rect standard-rectangle)) - (with-slots (x1 y1 x2 y2) rect + (with-standard-rectangle (x1 y1 x2 y2) + rect (funcall fun x1 y1 x1 y2) (funcall fun x1 y2 x2 y2) (funcall fun x2 y2 x2 y1) @@ -449,7 +546,8 @@ (defmethod transform-region (transformation (rect standard-rectangle)) (cond ((rectilinear-transformation-p transformation) - (with-slots (x1 y1 x2 y2) rect + (with-standard-rectangle (x1 y1 x2 y2) + rect (multiple-value-bind (x1* y1*) (transform-position transformation x1 y1) (multiple-value-bind (x2* y2*) (transform-position transformation x2 y2) (make-rectangle* x1* y1* x2* y2*))))) @@ -458,7 +556,8 @@ (polygon-points rect)))) )) (defmethod region-contains-position-p ((self standard-rectangle) x y) - (multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* self) + (with-standard-rectangle (x1 y1 x2 y2) + self (and (<= x1 (coerce x 'coordinate) x2) (<= y1 (coerce y 'coordinate) y2)))) @@ -2142,7 +2241,8 @@ (values (min x1 x2) (min y1 y2) (max x1 x2) (max y1 y2)))) (defmethod bounding-rectangle* ((a standard-rectangle)) - (with-slots (x1 y1 x2 y2) a + (with-standard-rectangle (x1 y1 x2 y2) + a (values x1 y1 x2 y2))) (defmethod bounding-rectangle* ((self standard-rectangle-set)) @@ -2235,11 +2335,11 @@ (defmethod set-bounding-rectangle-position ((self standard-rectangle) x y) ;;(error "DO NOT CALL ME") - (with-slots (x1 y1 x2 y2) self - (setq x2 (+ x (- x2 x1)) - y2 (+ y (- y2 y1)) - x1 x - y1 y))) + ;;Yes, but... output records are based on rectangles + (with-standard-rectangle (x1 y1 x2 y2) + self + (setf (rectangle-edges* self) + (values x y (+ x (- x2 x1)) (+ y (- y2 y1)))))) (defmethod bounding-rectangle-min-x ((self bounding-rectangle)) (nth-value 0 (bounding-rectangle* self))) @@ -2271,11 +2371,9 @@ (defmethod print-object ((self standard-rectangle) stream) (print-unreadable-object (self stream :type t :identity t) - (if (slot-boundp self 'x1) - (with-slots (x1 y1 x2 y2) self - (format stream "X ~S:~S Y ~S:~S" x1 x2 y1 y2)) - (format stream "X 0:0 Y 0:0")))) - + (with-standard-rectangle (x1 y1 x2 y2) + self + (format stream "X ~S:~S Y ~S:~S" x1 x2 y1 y2)))) ;;;; From tmoore at common-lisp.net Fri Feb 11 09:10:41 2005 From: tmoore at common-lisp.net (Timothy Moore) Date: Fri, 11 Feb 2005 10:10:41 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Goatee/clim-area.lisp Message-ID: <20050211091041.632A7886A1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Goatee In directory common-lisp.net:/tmp/cvs-serv2906/Goatee Modified Files: clim-area.lisp Log Message: Changed the representation of STANDARD-RECTANGLE from slots for the coordinates to an array of coordinates. This should enable opportunities for hashing the coordinates in interesting, inexpensive ways. Introduced the macros WITH-STANDARD-RECTANGLE and WITH-STANDARD-RECTANGLE* to provide convenient access to the coordinates. Added (SETF RECTANGLE-EDGES*). This change may well break code that depends on the internal representation of output records. Date: Fri Feb 11 10:10:40 2005 Author: tmoore Index: mcclim/Goatee/clim-area.lisp diff -u mcclim/Goatee/clim-area.lisp:1.28 mcclim/Goatee/clim-area.lisp:1.29 --- mcclim/Goatee/clim-area.lisp:1.28 Sun Oct 24 17:47:02 2004 +++ mcclim/Goatee/clim-area.lisp Fri Feb 11 10:10:38 2005 @@ -158,13 +158,19 @@ (incf (baseline record) (- ny y))))) (defmethod (setf width) :after (width (line screen-line)) - (setf (slot-value line 'climi::x2) (+ (slot-value line 'climi::x1) width))) + (climi::with-standard-rectangle* (:x1 x1 :y1 y1 :y2 y2) + line + (setf (rectangle-edges* line) (values x1 y1 (+ x1 width) y2)))) (defmethod (setf ascent) :after (ascent (line screen-line)) - (setf (slot-value line 'climi::y2) (+ (slot-value line 'climi::y1) ascent))) + (climi::with-standard-rectangle* (:x1 x1 :y1 y1 :x2 x2) + line + (setf (rectangle-edges* line) (values x1 y1 x2 (+ y1 ascent))))) (defmethod (setf descent) :after (descent (line screen-line)) - (setf (slot-value line 'climi::y2) (+ (slot-value line 'climi::y1) descent))) + (climi::with-standard-rectangle* (:x1 x1 :y1 y1 :x2 x2) + line + (setf (rectangle-edges* line) (values x1 y1 x2 (+ y1 descent))))) (defun line-contents-sans-newline (buffer-line &key destination) (let* ((contents-size (line-last-point buffer-line))) @@ -208,10 +214,9 @@ (setf (slot-value obj 'climi::y2) (+ y (ascent obj) (descent obj))) (setf (baseline obj) (+ y (ascent obj)))))) -(defmethod map-over-output-records (function (record screen-line) - &optional (x-offset 0) (y-offset 0) - &rest function-args) - (declare (ignore function x-offset y-offset function-args)) +(defmethod climi::map-over-output-records-1 (function (record screen-line) + function-args) + (declare (ignore function function-args)) nil) (defmethod map-over-output-records-overlapping-region @@ -279,13 +284,16 @@ (defmethod clear-output-record ((record simple-screen-area)) (error "clear-output-record shouldn't be called on simple-screen-area")) -(defmethod map-over-output-records (function (record simple-screen-area) - &optional (x-offset 0) (y-offset 0) - &rest function-args) +(defmethod climi::map-over-output-records-1 (function (record simple-screen-area) + function-args) (declare (ignore x-offset y-offset)) - (loop for line = (area-first-line record) then (next line) + (if function-args + (loop for line = (area-first-line record) then (next line) + while line + do (apply function line function-args)) + (loop for line = (area-first-line record) then (next line) while line - do (apply function line function-args))) + do (funcall function line)))) ;;; Since lines don't overlap, we can use the same order for ;;; map-over-output-records-containing-position and From tmoore at common-lisp.net Fri Feb 11 10:03:08 2005 From: tmoore at common-lisp.net (Timothy Moore) Date: Fri, 11 Feb 2005 11:03:08 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Goatee/clim-area.lisp Message-ID: <20050211100308.6ABA58864C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Goatee In directory common-lisp.net:/tmp/cvs-serv6008/Goatee Modified Files: clim-area.lisp Log Message: Fixes for rectangle changes that didn't make it before Date: Fri Feb 11 11:03:07 2005 Author: tmoore Index: mcclim/Goatee/clim-area.lisp diff -u mcclim/Goatee/clim-area.lisp:1.29 mcclim/Goatee/clim-area.lisp:1.30 --- mcclim/Goatee/clim-area.lisp:1.29 Fri Feb 11 10:10:38 2005 +++ mcclim/Goatee/clim-area.lisp Fri Feb 11 11:03:07 2005 @@ -208,11 +208,11 @@ (unless (slot-boundp obj 'width) (setf (width obj) (line-text-width (editable-area obj) obj))) (unless (slot-boundp obj 'baseline) - (multiple-value-bind (x y) - (output-record-position obj) - (declare (ignore x)) - (setf (slot-value obj 'climi::y2) (+ y (ascent obj) (descent obj))) - (setf (baseline obj) (+ y (ascent obj)))))) + (climi::with-standard-rectangle* (:x1 x1 :y1 y1 :x2 x2) + obj + (setf (rectangle-edges* obj) + (values x1 y1 x2 (+ y1 (ascent obj) (descent obj)))) + (setf (baseline obj) (+ y1 (ascent obj)))))) (defmethod climi::map-over-output-records-1 (function (record screen-line) function-args) From crhodes at common-lisp.net Fri Feb 11 10:05:58 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Fri, 11 Feb 2005 11:05:58 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/regions.lisp Message-ID: <20050211100558.60A728864C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv6076 Modified Files: regions.lisp Log Message: Fix the declaration of the coordinate array Date: Fri Feb 11 11:05:57 2005 Author: crhodes Index: mcclim/regions.lisp diff -u mcclim/regions.lisp:1.29 mcclim/regions.lisp:1.30 --- mcclim/regions.lisp:1.29 Fri Feb 11 10:10:37 2005 +++ mcclim/regions.lisp Fri Feb 11 11:05:57 2005 @@ -4,7 +4,7 @@ ;;; Created: 1998-12-02 19:26 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). -;;; $Id: regions.lisp,v 1.29 2005/02/11 09:10:37 tmoore Exp $ +;;; $Id: regions.lisp,v 1.30 2005/02/11 10:05:57 crhodes Exp $ ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 1998,1999,2001 by Gilbert Baumann ;;; (c) copyright 2001 by Arnaud Rouanet (rouanet at emi.u-bordeaux.fr) @@ -380,7 +380,7 @@ (defmacro with-standard-rectangle ((x1 y1 x2 y2) rectangle &body body) (with-gensyms (coords) `(let ((,coords (slot-value ,rectangle 'coordinates))) - (declare (type (array coordinate 4) ,coords)) + (declare (type (simple-array coordinate (4)) ,coords)) (let ((,x1 (aref ,coords 0)) (,y1 (aref ,coords 1)) (,x2 (aref ,coords 2)) @@ -391,7 +391,7 @@ (defmacro with-standard-rectangle* ((&key x1 y1 x2 y2) rectangle &body body) (with-gensyms (coords) `(let ((,coords (slot-value ,rectangle 'coordinates))) - (declare (type (array coordinate 4) ,coords)) + (declare (type (simple-array coordinate (4)) ,coords)) (let (,@(and x1 `((,x1 (aref ,coords 0)))) ,@(and y1 `((,y1 (aref ,coords 1)))) ,@(and x2 `((,x2 (aref ,coords 2)))) @@ -428,7 +428,7 @@ (defmethod* (setf rectangle-edges*) (x1 y1 x2 y2 (rectangle standard-rectangle)) (let ((coords (slot-value rectangle 'coordinates))) - (declare (type (array coordinate 4) coords)) + (declare (type (simple-array coordinate (4)) coords)) (setf (aref coords 0) x1) (setf (aref coords 1) y1) (setf (aref coords 2) x2) From tmoore at common-lisp.net Fri Feb 11 11:50:23 2005 From: tmoore at common-lisp.net (Timothy Moore) Date: Fri, 11 Feb 2005 12:50:23 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/incremental-redisplay.lisp Message-ID: <20050211115023.47BC588696@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv11082 Modified Files: incremental-redisplay.lisp Log Message: Exit early from COMPUTE-DIFFERENCE-SET if both the old and new trees lie outside the visible region on the screen. This fixes a problem that I believe was introduced in 1.35: COMPUTE-DIFFERENCE-SET has to run on all updating-output records in a tree, but the full difference algorithm shouldn't be invoked if nothing is or was visible. Date: Fri Feb 11 12:50:22 2005 Author: tmoore Index: mcclim/incremental-redisplay.lisp diff -u mcclim/incremental-redisplay.lisp:1.42 mcclim/incremental-redisplay.lisp:1.43 --- mcclim/incremental-redisplay.lisp:1.42 Tue Jan 18 10:16:30 2005 +++ mcclim/incremental-redisplay.lisp Fri Feb 11 12:50:22 2005 @@ -726,6 +726,8 @@ rect (make-bounding-rectangle min-x min-y max-x max-y))) +(defvar *existing-output-records* nil) + (defmethod compute-difference-set ((record standard-updating-output-record) &optional (check-overlapping t) offset-x offset-y @@ -733,7 +735,7 @@ (declare (ignore offset-x offset-y old-offset-x old-offset-y)) (when (eq (output-record-dirty record) :clean) (return-from compute-difference-set (values nil nil nil nil nil))) - (let* ((existing-output-records (make-hash-table :test #'eq)) + (let* ((existing-output-records nil) (draws nil) (moves (explicit-moves record)) (erases nil) @@ -744,6 +746,13 @@ (old-children (if (slot-boundp record 'old-children) (old-children record) nil))) + (unless (or (region-intersects-region-p visible-region record) + (and old-children + (region-intersects-region-p visible-region old-children))) + (return-from compute-difference-set (values nil nil nil nil nil))) + ;; I don't feel like adding another let and indenting this huge function + ;; some more.... + (setq existing-output-records (make-hash-table :test #'eq)) ;; XXX This means that compute-difference-set can't be called repeatedly on ;; the same tree; ugh. On the other hand, if we don't clear explicit-moves, ;; they can hang around in the tree for later passes and cause trouble. From tmoore at common-lisp.net Fri Feb 11 12:55:50 2005 From: tmoore at common-lisp.net (Timothy Moore) Date: Fri, 11 Feb 2005 13:55:50 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/incremental-redisplay.lisp Message-ID: <20050211125550.36DAD88696@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv15125 Modified Files: incremental-redisplay.lisp Log Message: In COMPUTE-DIFFERENCE-SET fix null visible-region case. Thanks to Christophe Rhodes. Date: Fri Feb 11 13:55:49 2005 Author: tmoore Index: mcclim/incremental-redisplay.lisp diff -u mcclim/incremental-redisplay.lisp:1.43 mcclim/incremental-redisplay.lisp:1.44 --- mcclim/incremental-redisplay.lisp:1.43 Fri Feb 11 12:50:22 2005 +++ mcclim/incremental-redisplay.lisp Fri Feb 11 13:55:49 2005 @@ -453,10 +453,9 @@ (defmethod print-object ((obj standard-updating-output-record) stream) (print-unreadable-object (obj stream :type t :identity t) - (when (slot-boundp obj 'x1) - (with-slots (x1 y1 x2 y2) obj - (format stream "X ~S:~S Y ~S:~S " x1 x2 y1 y2)) - (format stream "~S" (output-record-dirty obj))) + (with-standard-rectangle (x1 y1 x2 y2) + obj + (format stream "X ~S:~S Y ~S:~S " x1 x2 y1 y2)) (when (slot-boundp obj 'unique-id) (let ((*print-length* 10) (*print-level* 3)) @@ -726,6 +725,7 @@ rect (make-bounding-rectangle min-x min-y max-x max-y))) +;;; work in progress (defvar *existing-output-records* nil) (defmethod compute-difference-set ((record standard-updating-output-record) @@ -746,7 +746,8 @@ (old-children (if (slot-boundp record 'old-children) (old-children record) nil))) - (unless (or (region-intersects-region-p visible-region record) + (unless (or (null visible-region) + (region-intersects-region-p visible-region record) (and old-children (region-intersects-region-p visible-region old-children))) (return-from compute-difference-set (values nil nil nil nil nil))) From pscott at common-lisp.net Fri Feb 11 21:41:25 2005 From: pscott at common-lisp.net (Peter Scott) Date: Fri, 11 Feb 2005 22:41:25 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp Message-ID: <20050211214125.EFD0288696@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv10021 Modified Files: inspector.lisp Log Message: Added "class:" to display of symbols. This is not, strictly speaking, a property of the symbol. However, this is useful enough that I think it's worth including, since it can eliminate some minor annoyances. Date: Fri Feb 11 22:41:25 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.20 mcclim/Apps/Inspector/inspector.lisp:1.21 --- mcclim/Apps/Inspector/inspector.lisp:1.20 Tue Feb 8 23:14:01 2005 +++ mcclim/Apps/Inspector/inspector.lisp Fri Feb 11 22:41:25 2005 @@ -475,6 +475,14 @@ (if (fboundp object) (inspect-object (symbol-function object) pane) (princ "unbound"))) + ;; This is not, strictly speaking, a property of the + ;; symbol. However, this is useful enough that I think it's worth + ;; including here, since it can eliminate some minor annoyances. + (inspector-table-row + (princ "class:") + (if (find-class object nil) + (inspect-object (find-class object) pane) + (princ "unbound"))) (inspector-table-row (princ "package:") (inspect-object (symbol-package object) pane)) From crhodes at common-lisp.net Mon Feb 14 16:31:45 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Mon, 14 Feb 2005 17:31:45 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/text-selection.lisp Message-ID: <20050214163145.D1CCA88171@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv15230 Modified Files: text-selection.lisp Log Message: Fix bug reported by Paolo ("Missing CLIMI::Y2 slot error") Date: Mon Feb 14 17:31:42 2005 Author: crhodes Index: mcclim/text-selection.lisp diff -u mcclim/text-selection.lisp:1.3 mcclim/text-selection.lisp:1.4 --- mcclim/text-selection.lisp:1.3 Thu Feb 10 10:54:26 2005 +++ mcclim/text-selection.lisp Mon Feb 14 17:31:41 2005 @@ -410,7 +410,7 @@ (map nil (lambda (m) (with-slots (record styled-string start end) m - (with-slots (y1 y2) record + (with-standard-rectangle* (:y1 y1 :y2 y2) record (if (and old-y2 (>= y1 old-y2)) (progn (setf old-y2 nil) From crhodes at common-lisp.net Tue Feb 15 11:28:12 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Tue, 15 Feb 2005 12:28:12 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/recording.lisp Message-ID: <20050215112812.A17AF884E1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv10043 Modified Files: recording.lisp Log Message: Maybe fix circle/ellipse drawing in with-room-for-graphics and with-first-quadrant-coordinates. (Weirdest. Coordinate. System. Ever.) Date: Tue Feb 15 12:28:11 2005 Author: crhodes Index: mcclim/recording.lisp diff -u mcclim/recording.lisp:1.117 mcclim/recording.lisp:1.118 --- mcclim/recording.lisp:1.117 Fri Feb 11 10:10:36 2005 +++ mcclim/recording.lisp Tue Feb 15 12:28:11 2005 @@ -1570,6 +1570,8 @@ ;; will break other things. -Hefner (setf start-angle (untransform-angle transform start-angle)) (setf end-angle (untransform-angle transform end-angle)) + (when (reflection-transformation-p transform) + (rotatef start-angle end-angle)) (multiple-value-bind (min-x min-y max-x max-y) (bounding-rectangle* (make-ellipse* center-x center-y radius-1-dx radius-1-dy From pscott at common-lisp.net Tue Feb 15 23:12:11 2005 From: pscott at common-lisp.net (Peter Scott) Date: Wed, 16 Feb 2005 00:12:11 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp Message-ID: <20050215231211.CC1AE884E1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv15800 Modified Files: inspector.lisp Log Message: Major changes: Added with-heading-style macro which currently bolds its output, and changed a bunch of things to use this everywhere we have headings. This makes the inspector look *much* nicer. Minor change: turned a (loop for foo in bar do ...) into a DOLIST, which uses less indentation and is arguably clearer. Date: Wed Feb 16 00:12:08 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.21 mcclim/Apps/Inspector/inspector.lisp:1.22 --- mcclim/Apps/Inspector/inspector.lisp:1.21 Fri Feb 11 22:41:25 2005 +++ mcclim/Apps/Inspector/inspector.lisp Wed Feb 16 00:12:07 2005 @@ -128,6 +128,12 @@ (declare (ignore acceptably for-context-type)) (format stream "~s" (cdr object))) +(defmacro with-heading-style ((stream) &body body) + "Cause text output from BODY to be formatted in a heading font. This +could be boldface, or a different style, or even another font." + `(with-text-face (,stream :bold) + , at body)) + (defmacro inspector-table (header &body body) "Present OBJECT (captured from environment) in tabular form, with HEADER printed in a box at the top. BODY should output the rows of the @@ -140,7 +146,8 @@ (formatting-column (pane) (formatting-cell (pane) (surrounding-output-with-border (pane) - ,header)) + (with-heading-style (pane) + ,header))) (formatting-cell (pane) (formatting-table (pane) , at body)))) @@ -151,7 +158,8 @@ environment created by INSPECTOR-TABLE." `(formatting-row (pane) (formatting-cell (pane :align-x :right) - ,left) + (with-heading-style (pane) + ,left)) (formatting-cell (pane) ,right))) @@ -159,7 +167,9 @@ "Print OBJECT's documentation, if any, to PANE" (when (handler-bind ((warning #'muffle-warning)) (documentation object t)) - (format pane "~&Documentation: ~A" (documentation object t)))) + (with-heading-style (pane) + (format pane "~&Documentation: ")) + (princ (documentation object t) pane))) (defun inspect-structure-or-object (object pane) "Inspect a structure or an object. Since both can be inspected in @@ -171,13 +181,13 @@ (print (class-name class) pane) (when (clim-mop:class-direct-superclasses class) (inspector-table-row - (format pane "Superclasses") + (princ "Superclasses" pane) (dolist (superclass (clim-mop:class-direct-superclasses class)) (inspect-object superclass pane) (terpri pane)))) (when (clim-mop:class-direct-subclasses class) (inspector-table-row - (format pane "Subclasses") + (princ "Subclasses" pane) (dolist (subclass (clim-mop:class-direct-subclasses class)) (inspect-object subclass pane) (terpri pane)))) @@ -191,6 +201,8 @@ (inspect-object (slot-value object slot-name) pane) (format pane "#")))))))) +;; Try to print the normal, textual representation of an object, but +;; if that's too long, make an abbreviated "instance of ~S" version. ;; FIXME: should this be removed? It's really ugly. (defparameter *object-representation-max-length* 300 "Maximum number of characters of an object's textual representation @@ -208,9 +220,6 @@ (error () (format pane "#" (class-name (class-of object))))))) -;; Try to print the normal, textual representation of an object, but -;; if that's too long, make an abbreviated "instance of ~S" version. - (defmethod inspect-object-briefly ((object standard-object) pane) (inspect-structure-or-object-briefly object pane)) @@ -319,24 +328,24 @@ (inspector-table (format pane "Generic Function: ~s" (clim-mop:generic-function-name object)) - (loop for method in (clim-mop:generic-function-methods object) - do (with-output-as-presentation - (pane method (presentation-type-of method)) - (formatting-row (pane) - (formatting-cell (pane) - (print (method-qualifiers method))) - (loop for specializer in (clim-mop:method-specializers method) - do (formatting-cell (pane) - (if (typep specializer 'clim-mop:eql-specializer) - (progn - (princ "(EQL " pane) - (inspect-object - (clim-mop:eql-specializer-object - specializer) - pane) - (princ ")" pane)) - (inspect-object (class-name specializer) - pane))))))))) + (dolist (method (clim-mop:generic-function-methods object)) + (with-output-as-presentation + (pane method (presentation-type-of method)) + (formatting-row (pane) + (formatting-cell (pane) + (print (method-qualifiers method))) + (loop for specializer in (clim-mop:method-specializers method) + do (formatting-cell (pane) + (if (typep specializer 'clim-mop:eql-specializer) + (progn + (princ "(EQL " pane) + (inspect-object + (clim-mop:eql-specializer-object + specializer) + pane) + (princ ")" pane)) + (inspect-object (class-name specializer) + pane))))))))) (defun pretty-print-function (fun) "Print a function in a readable way, returning a string. On most @@ -362,12 +371,15 @@ (defmethod inspect-object ((object function) pane) (with-output-as-presentation (pane object (presentation-type-of object)) - (format pane "Function: ~A" - (pretty-print-function object)) + (with-heading-style (pane) + (princ "Function: " pane)) + (princ (pretty-print-function object) pane) #+sbcl (unless (typep object 'generic-function) - (format pane "~&Type: ~A" - (sb-kernel:%simple-fun-type (sb-kernel:%closure-fun object)))) + (with-heading-style (pane) + (format pane "~&Type: ")) + (princ (sb-kernel:%simple-fun-type (sb-kernel:%closure-fun object)) + pane)) (print-documentation object pane))) (defmethod inspect-object-briefly ((object package) pane) @@ -386,8 +398,13 @@ (inspect-object nick pane))) (inspector-table-row (princ "Used by:") + ;; FIXME: This should use some sort of list formatting, so that + ;; it can obey conventions about *print-length* and reuse code + ;; for modifying it. To support this, list printing should + ;; support delimiterless, one-item-per-line display. (dolist (used-by (package-used-by-list object)) - (inspect-object used-by pane))) + (fresh-line pane) + (inspect-object used-by pane))) (inspector-table-row (princ "Uses:") (dolist (uses (package-use-list object)) @@ -580,19 +597,24 @@ (find slot-name (clim-mop:class-slots class) :key #'clim-mop:slot-definition-name)))) (when documentation - (format stream "~&Documentation: ~A~%" documentation)) - (format stream "~&Type: ~S~%" - (clim-mop:slot-definition-type slot-object)) - (format stream "~&Allocation: ~S~%" - (clim-mop:slot-definition-allocation slot-object)) + (with-heading-style (stream) + (format stream "~&Documentation: ")) + (format stream "~A~%" documentation)) + (with-heading-style (stream) + (format stream "~&Type: ")) + (format stream "~S~%" (clim-mop:slot-definition-type slot-object)) + (with-heading-style (stream) + (format stream "~&Allocation: ")) + (format stream "~S~%" (clim-mop:slot-definition-allocation slot-object)) ;; slot-definition-{readers,writers} only works for direct slot ;; definitions (let ((readers (clim-mop:slot-definition-readers slot-object))) (when readers - (format stream "~&Readers: ") + (with-heading-style (stream) + (format stream "~&Readers: ")) (present readers (presentation-type-of readers) :stream stream))) (let ((writers (clim-mop:slot-definition-writers slot-object))) (when writers - (format stream "~&Writers: ") + (with-heading-style (stream) + (format stream "~&Writers: ")) (present writers (presentation-type-of writers) :stream stream)))))) - From afuchs at common-lisp.net Wed Feb 16 20:43:28 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Wed, 16 Feb 2005 21:43:28 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/mcclim.asd Message-ID: <20050216204328.27453884E2@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv19230 Added Files: mcclim.asd Log Message: Adding the ASDF-only dependency-aware mcclim.asd file. This file buys McCLIM ASDF-INSTALLability, among other things. Date: Wed Feb 16 21:43:26 2005 Author: afuchs From tmoore at common-lisp.net Thu Feb 17 21:23:30 2005 From: tmoore at common-lisp.net (Timothy Moore) Date: Thu, 17 Feb 2005 22:23:30 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Backends/CLX/medium.lisp Message-ID: <20050217212330.403A6884FA@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv491 Modified Files: medium.lisp Log Message: Alastair Bridgewater's fix to medium-clear-area. Fixes Paolo bug clx-medium-clear-area-transform Date: Thu Feb 17 22:23:29 2005 Author: tmoore Index: mcclim/Backends/CLX/medium.lisp diff -u mcclim/Backends/CLX/medium.lisp:1.65 mcclim/Backends/CLX/medium.lisp:1.66 --- mcclim/Backends/CLX/medium.lisp:1.65 Tue Jan 18 14:35:26 2005 +++ mcclim/Backends/CLX/medium.lisp Thu Feb 17 22:23:29 2005 @@ -965,13 +965,19 @@ (xlib:display-force-output (clx-port-display (port medium)))) (defmethod medium-clear-area ((medium clx-medium) left top right bottom) - (let ((min-x (round-coordinate (min left right))) - (min-y (round-coordinate (min top bottom))) - (max-x (round-coordinate (max left right))) - (max-y (round-coordinate (max top bottom)))) - (xlib:clear-area (port-lookup-mirror (port medium) (medium-sheet medium)) - :x min-x :y min-y - :width (- max-x min-x) :height (- max-y min-y)))) + (let ((tr (sheet-native-transformation (medium-sheet medium)))) + (with-transformed-position (tr left top) + (with-transformed-position (tr right bottom) + (let ((min-x (round-coordinate (min left right))) + (min-y (round-coordinate (min top bottom))) + (max-x (round-coordinate (max left right))) + (max-y (round-coordinate (max top bottom)))) + (xlib:clear-area (port-lookup-mirror (port medium) + (medium-sheet medium)) + :x (max #x-8000 (min #x7fff min-x)) + :y (max #x-8000 (min #x7fff min-y)) + :width (max 0 (min #xffff (- max-x min-x))) + :height (max 0 (min #xffff (- max-y min-y))))))))) (defmethod medium-beep ((medium clx-medium)) (xlib:bell (clx-port-display (port medium)))) From crhodes at common-lisp.net Mon Feb 21 13:32:52 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Mon, 21 Feb 2005 14:32:52 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Backends/CLX/image.lisp Message-ID: <20050221133252.0DA45884E2@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv32404/Backends/CLX Modified Files: image.lisp Log Message: Patch for image:write-pnm (from me, as corrected by Milan Zamazal) Since the patch applied cleanly to Backends/beagle/image.lisp, apply it there too, but if anyone out there is interested in the beagle backend, fixing this ridiculous duplication of code might be a plan. Date: Mon Feb 21 14:32:51 2005 Author: crhodes Index: mcclim/Backends/CLX/image.lisp diff -u mcclim/Backends/CLX/image.lisp:1.19 mcclim/Backends/CLX/image.lisp:1.20 --- mcclim/Backends/CLX/image.lisp:1.19 Sun Sep 14 19:55:56 2003 +++ mcclim/Backends/CLX/image.lisp Mon Feb 21 14:32:49 2005 @@ -108,12 +108,13 @@ `(the (unsigned-byte 8) (logand ,pixel 255))) (defmethod write-pnm ((image truecolor-image) filename output-format) - (with-open-file (stream filename :direction :output :if-exists :supersede) - (if (eq output-format :ascii) - (write-ppm-p3 stream (image-pixels image)) + (with-open-file (stream filename + :direction :output :if-exists :supersede + :element-type '(unsigned-byte 8)) + (if (eq output-format :ascii) + (write-ppm-p3 stream (image-pixels image)) (write-ppm-p6 stream (image-pixels image))))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; colormap image @@ -149,9 +150,11 @@ 0) (defmethod write-pnm ((image 256-gray-level-image) filename output-format) - (with-open-file (stream filename :direction :output :if-exists :supersede) - (if (eq output-format :ascii) - (write-pgm-p2 stream (image-pixels image)) + (with-open-file (stream filename + :direction :output :if-exists :supersede + :element-type '(unsigned-byte 8)) + (if (eq output-format :ascii) + (write-pgm-p2 stream (image-pixels image)) (write-pgm-p5 stream (image-pixels image))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -167,9 +170,11 @@ (make-instance 'binary-image :pixels pixels)) (defmethod write-pnm ((image binary-image) filename output-format) - (with-open-file (stream filename :direction :output :if-exists :supersede) - (if (eq output-format :ascii) - (write-pbm-p1 stream (image-pixels image)) + (with-open-file (stream filename + :direction :output :if-exists :supersede + :element-type '(unsigned-byte 8)) + (if (eq output-format :ascii) + (write-pbm-p1 stream (image-pixels image)) (write-pbm-p4 stream (image-pixels image))))) @@ -179,46 +184,48 @@ (defmacro with-write-pnm-loop ((magic-number max-value) &body body) `(let ((height (car (array-dimensions picture))) - (width (cadr (array-dimensions picture)))) - (format stream "P~A~%" ,magic-number) - (format stream "~A ~A~%" width height) - (when ,max-value - (format stream "~A~%" ,max-value)) + (width (cadr (array-dimensions picture)))) + (map nil (lambda (x) (write-byte (char-code x) stream)) + (format nil "P~A~%~A~%~A~%~@[~A~%~]" + ,magic-number width height ,max-value)) (loop for r from 0 below height do - (loop for c from 0 below width do - , at body)) + (loop for c from 0 below width do + , at body)) nil)) (defun write-pbm-p1 (stream picture) (with-write-pnm-loop (1 nil) - (format stream "~A~%" (aref picture r c)))) + (map nil (lambda (x) (write-byte (char-code x) stream)) + (format nil "~A~%" (aref picture r c))))) (defun write-pbm-p4 (stream picture) ; bad! (with-write-pnm-loop (4 nil) - (write-char (code-char (aref picture r c)) stream))) + (write-byte (aref picture r c) stream))) (defun write-pgm-p2 (stream picture) (with-write-pnm-loop (2 255) - (format stream "~A~%" (aref picture r c)))) + (map nil (lambda (x) (write-byte (char-code x) stream)) + (format nil "~A~%" (aref picture r c))))) (defun write-pgm-p5 (stream picture) (with-write-pnm-loop (5 255) - (write-char (code-char (aref picture r c)) stream))) + (write-byte (aref picture r c) stream))) (defun write-ppm-p3 (stream picture) (with-write-pnm-loop (3 255) (let ((rgb (aref picture r c))) - (format stream "~A ~A ~A~%" - (red-component rgb) - (green-component rgb) - (blue-component rgb))))) + (map nil (lambda (x) (write-byte (char-code x) stream)) + (format nil "~A ~A ~A~%" + (red-component rgb) + (green-component rgb) + (blue-component rgb)))))) (defun write-ppm-p6 (stream picture) (with-write-pnm-loop (6 255) (let ((rgb (aref picture r c))) - (write-char (code-char (red-component rgb)) stream) - (write-char (code-char (green-component rgb)) stream) - (write-char (code-char (blue-component rgb)) stream)))) + (write-byte (red-component rgb) stream) + (write-byte (green-component rgb) stream) + (write-byte (blue-component rgb) stream)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From crhodes at common-lisp.net Mon Feb 21 13:32:56 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Mon, 21 Feb 2005 14:32:56 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Backends/beagle/image.lisp Message-ID: <20050221133256.760E3884FA@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/beagle In directory common-lisp.net:/tmp/cvs-serv32404/Backends/beagle Modified Files: image.lisp Log Message: Patch for image:write-pnm (from me, as corrected by Milan Zamazal) Since the patch applied cleanly to Backends/beagle/image.lisp, apply it there too, but if anyone out there is interested in the beagle backend, fixing this ridiculous duplication of code might be a plan. Date: Mon Feb 21 14:32:52 2005 Author: crhodes Index: mcclim/Backends/beagle/image.lisp diff -u mcclim/Backends/beagle/image.lisp:1.1 mcclim/Backends/beagle/image.lisp:1.2 --- mcclim/Backends/beagle/image.lisp:1.1 Sun Jul 11 21:48:16 2004 +++ mcclim/Backends/beagle/image.lisp Mon Feb 21 14:32:52 2005 @@ -108,12 +108,13 @@ `(the (unsigned-byte 8) (logand ,pixel 255))) (defmethod write-pnm ((image truecolor-image) filename output-format) - (with-open-file (stream filename :direction :output :if-exists :supersede) - (if (eq output-format :ascii) - (write-ppm-p3 stream (image-pixels image)) + (with-open-file (stream filename + :direction :output :if-exists :supersede + :element-type '(unsigned-byte 8)) + (if (eq output-format :ascii) + (write-ppm-p3 stream (image-pixels image)) (write-ppm-p6 stream (image-pixels image))))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; colormap image @@ -149,9 +150,11 @@ 0) (defmethod write-pnm ((image 256-gray-level-image) filename output-format) - (with-open-file (stream filename :direction :output :if-exists :supersede) - (if (eq output-format :ascii) - (write-pgm-p2 stream (image-pixels image)) + (with-open-file (stream filename + :direction :output :if-exists :supersede + :element-type '(unsigned-byte 8)) + (if (eq output-format :ascii) + (write-pgm-p2 stream (image-pixels image)) (write-pgm-p5 stream (image-pixels image))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -167,9 +170,11 @@ (make-instance 'binary-image :pixels pixels)) (defmethod write-pnm ((image binary-image) filename output-format) - (with-open-file (stream filename :direction :output :if-exists :supersede) - (if (eq output-format :ascii) - (write-pbm-p1 stream (image-pixels image)) + (with-open-file (stream filename + :direction :output :if-exists :supersede + :element-type '(unsigned-byte 8)) + (if (eq output-format :ascii) + (write-pbm-p1 stream (image-pixels image)) (write-pbm-p4 stream (image-pixels image))))) @@ -179,46 +184,48 @@ (defmacro with-write-pnm-loop ((magic-number max-value) &body body) `(let ((height (car (array-dimensions picture))) - (width (cadr (array-dimensions picture)))) - (format stream "P~A~%" ,magic-number) - (format stream "~A ~A~%" width height) - (when ,max-value - (format stream "~A~%" ,max-value)) + (width (cadr (array-dimensions picture)))) + (map nil (lambda (x) (write-byte (char-code x) stream)) + (format nil "P~A~%~A~%~A~%~@[~A~%~]" + ,magic-number width height ,max-value)) (loop for r from 0 below height do - (loop for c from 0 below width do - , at body)) + (loop for c from 0 below width do + , at body)) nil)) (defun write-pbm-p1 (stream picture) (with-write-pnm-loop (1 nil) - (format stream "~A~%" (aref picture r c)))) + (map nil (lambda (x) (write-byte (char-code x) stream)) + (format nil "~A~%" (aref picture r c))))) (defun write-pbm-p4 (stream picture) ; bad! (with-write-pnm-loop (4 nil) - (write-char (code-char (aref picture r c)) stream))) + (write-byte (aref picture r c) stream))) (defun write-pgm-p2 (stream picture) (with-write-pnm-loop (2 255) - (format stream "~A~%" (aref picture r c)))) + (map nil (lambda (x) (write-byte (char-code x) stream)) + (format nil "~A~%" (aref picture r c))))) (defun write-pgm-p5 (stream picture) (with-write-pnm-loop (5 255) - (write-char (code-char (aref picture r c)) stream))) + (write-byte (aref picture r c) stream))) (defun write-ppm-p3 (stream picture) (with-write-pnm-loop (3 255) (let ((rgb (aref picture r c))) - (format stream "~A ~A ~A~%" - (red-component rgb) - (green-component rgb) - (blue-component rgb))))) + (map nil (lambda (x) (write-byte (char-code x) stream)) + (format nil "~A ~A ~A~%" + (red-component rgb) + (green-component rgb) + (blue-component rgb)))))) (defun write-ppm-p6 (stream picture) (with-write-pnm-loop (6 255) (let ((rgb (aref picture r c))) - (write-char (code-char (red-component rgb)) stream) - (write-char (code-char (green-component rgb)) stream) - (write-char (code-char (blue-component rgb)) stream)))) + (write-byte (red-component rgb) stream) + (write-byte (green-component rgb) stream) + (write-byte (blue-component rgb) stream)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From afuchs at common-lisp.net Mon Feb 21 16:36:49 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Mon, 21 Feb 2005 17:36:49 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/mcclim.asd Message-ID: <20050221163649.498CD8846F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv9838 Modified Files: mcclim.asd Log Message: Backends/CLX/image.lisp depends on .../package.lisp. Spotted by Christophe Rhodes. Date: Mon Feb 21 17:36:35 2005 Author: afuchs Index: mcclim/mcclim.asd diff -u mcclim/mcclim.asd:1.1 mcclim/mcclim.asd:1.2 --- mcclim/mcclim.asd:1.1 Wed Feb 16 21:43:25 2005 +++ mcclim/mcclim.asd Mon Feb 21 17:36:30 2005 @@ -4,7 +4,7 @@ ;;; (c) copyright 2000 by ;;; Robert Strandh (strandh at labri.u-bordeaux.fr) ;;; (c) copyright 2005 by -;;; Andreas Fuchs (asf at boinkor.net +;;; Andreas Fuchs (asf at boinkor.net) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -221,7 +221,7 @@ :pathname #.(make-pathname :directory '(:relative "Backends" "CLX")) :components ((:file "package") - (:file "image") + (:file "image" :depends-on ("package")) (:file "keysyms-common" :depends-on ("package")) (:file "keysyms" :depends-on ("keysyms-common" "package")) (:file "keysymdef" :depends-on ("keysyms-common" "package")) @@ -375,4 +375,4 @@ ;;; The actual McCLIM system that people should to use in their ASDF ;;; package dependency lists. (defsystem :mcclim - :depends-on (:clim-looks)) \ No newline at end of file + :depends-on (:clim-looks)) From ahefner at common-lisp.net Tue Feb 22 03:09:21 2005 From: ahefner at common-lisp.net (Andy Hefner) Date: Tue, 22 Feb 2005 04:09:21 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/panes.lisp Message-ID: <20050222030921.9DA0888677@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv12992 Modified Files: panes.lisp Log Message: Dummy implementation of restraining-pane. It doesn't really work, but it should if the layout protocol worked as specified. This is still an improvement over the previous version, which didn't display its children at all. Date: Tue Feb 22 04:09:18 2005 Author: ahefner Index: mcclim/panes.lisp diff -u mcclim/panes.lisp:1.149 mcclim/panes.lisp:1.150 --- mcclim/panes.lisp:1.149 Tue Feb 1 04:08:27 2005 +++ mcclim/panes.lisp Tue Feb 22 04:09:18 2005 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.149 2005/02/01 03:08:27 ahefner Exp $ +;;; $Id: panes.lisp,v 1.150 2005/02/22 03:09:18 ahefner Exp $ (in-package :clim-internals) @@ -1679,13 +1679,16 @@ ;;; RESTRAINING PANE -(defclass restraining-pane (composite-pane) ()) +(defclass restraining-pane (single-child-composite-pane) ()) (defun restraining-pane-p (pane) (typep pane 'restraining-pane)) (defmacro restraining ((&rest options) &body contents) `(make-pane 'restraining-pane , at options :contents (list , at contents))) + +(defmethod note-space-requirements-changed ((pane restraining-pane) child) + (declare (ignore pane child))) ;;; BBOARD PANE From ahefner at common-lisp.net Tue Feb 22 03:10:28 2005 From: ahefner at common-lisp.net (Andy Hefner) Date: Tue, 22 Feb 2005 04:10:28 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Listener/util.lisp Message-ID: <20050222031028.9AA1588677@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory common-lisp.net:/tmp/cvs-serv13017/Apps/Listener Modified Files: util.lisp Log Message: Applied patch to directoryp for ACL from rpgoldman. Date: Tue Feb 22 04:10:28 2005 Author: ahefner Index: mcclim/Apps/Listener/util.lisp diff -u mcclim/Apps/Listener/util.lisp:1.16 mcclim/Apps/Listener/util.lisp:1.17 --- mcclim/Apps/Listener/util.lisp:1.16 Sun Jan 2 06:14:28 2005 +++ mcclim/Apps/Listener/util.lisp Tue Feb 22 04:10:27 2005 @@ -54,6 +54,8 @@ ; There has to be a better way.. (defun directoryp (pathname) "Returns pathname when supplied with a directory, otherwise nil" + #+allegro (excl:file-directory-p pathname) + #-allegro (if (or (pathname-name pathname) (pathname-type pathname)) nil pathname)) From ahefner at common-lisp.net Tue Feb 22 03:14:28 2005 From: ahefner at common-lisp.net (Andy Hefner) Date: Tue, 22 Feb 2005 04:14:28 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/frames.lisp mcclim/package.lisp mcclim/ports.lisp Message-ID: <20050222031428.B5C1F88677@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv13053 Modified Files: frames.lisp package.lisp ports.lisp Log Message: Fix mixed up arguments to set-port-keyboard-focus. Renamed set-port-keyboard-focus to %set-port-keyboard-focus to avoid confusion with the CLIM 2.0 function port-keyboard-input-focus. Added a timestamp keyword to %set-port-keyboard-focus (not used by any callers yet). Added some comments about how the keyboard focus functions are connected. Date: Tue Feb 22 04:14:26 2005 Author: ahefner Index: mcclim/frames.lisp diff -u mcclim/frames.lisp:1.105 mcclim/frames.lisp:1.106 --- mcclim/frames.lisp:1.105 Wed Feb 2 12:33:58 2005 +++ mcclim/frames.lisp Tue Feb 22 04:14:17 2005 @@ -1280,7 +1280,7 @@ (declare (ignore pane state))) (defmethod (setf keyboard-input-focus) :after (focus frame) - (set-port-keyboard-focus focus (port frame))) + (%set-port-keyboard-focus (port frame) focus)) (defmethod (setf client-setting) (value frame setting) (setf (getf (client-settings frame) setting) value)) Index: mcclim/package.lisp diff -u mcclim/package.lisp:1.47 mcclim/package.lisp:1.48 --- mcclim/package.lisp:1.47 Tue Jan 11 14:35:18 2005 +++ mcclim/package.lisp Tue Feb 22 04:14:26 2005 @@ -1942,7 +1942,7 @@ #:port-set-sheet-region #:port-set-sheet-transformation #:port-ungrab-pointer - #:set-port-keyboard-focus + #:%set-port-keyboard-focus #:set-sheet-pointer-cursor #:synthesize-pointer-motion-event #:text-style-character-width Index: mcclim/ports.lisp diff -u mcclim/ports.lisp:1.47 mcclim/ports.lisp:1.48 --- mcclim/ports.lisp:1.47 Sun Jul 11 21:48:16 2004 +++ mcclim/ports.lisp Tue Feb 22 04:14:26 2005 @@ -72,9 +72,26 @@ )) ;; Keyboard focus is now managed per-frame rather than per-port, -;; which makes a lot of sense. The CLIM spec suggests this in a -;; "Minor Issue". So, redirect PORT-KEYBOARD-INPUT-FOCUS to the -;; current application frame for compatibility. +;; which makes a lot of sense (less sense in the presense of +;; multiple top-level windows, but no one does that yet). The CLIM +;; spec suggests this in a "Minor Issue". So, redirect +;; PORT-KEYBOARD-INPUT-FOCUS to the current application frame +;; for compatibility. + +;; Note: This would prevent you from using the function the +;; function to query who currently has the focus. I don't +;; know if this is an intended use or not. + +;; The big picture: +;; PORT-KEYBOARD-INPUT-FOCUS is defined by CLIM 2.0 +;; Our default method on this delegates to KEYBOARD-INPUT-FOCUS +;; on the current application frame. +;; %SET-PORT-KEYBOARD-FOCUS is the function which +;; should be implemented in a McCLIM backend and +;; does the work of changing the focus. +;; A method on (SETF KEYBOARD-INPUT-FOCUS) brings them together, +;; calling %SET-PORT-KEYBOARD-FOCUS. + (defmethod port-keyboard-input-focus (port) (declare (ignore port)) (when *application-frame* @@ -84,14 +101,14 @@ (when focus (if (pane-frame focus) (setf (keyboard-input-focus (pane-frame focus)) focus) - (set-port-keyboard-focus focus port)))) + (%set-port-keyboard-focus port focus)))) ;; This is not in the CLIM spec, but since (setf port-keyboard-input-focus) ;; now calls (setf keyboard-input-focus), we need something concrete the ;; backend can implement to set the focus. -(defmethod set-port-keyboard-focus (focus port) - (declare (ignore focus)) - (warn "SET-PORT-KEYBOARD-FOCUS is not implemented on ~W" port)) +(defmethod %set-port-keyboard-focus (port focus &key timestamp) + (declare (ignore focus)) + (warn "%SET-PORT-KEYBOARD-FOCUS is not implemented on ~W" port)) (defun find-port (&key (server-path *default-server-path*)) From ahefner at common-lisp.net Tue Feb 22 03:14:29 2005 From: ahefner at common-lisp.net (Andy Hefner) Date: Tue, 22 Feb 2005 04:14:29 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Backends/CLX/port.lisp Message-ID: <20050222031429.C9E6C88678@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv13053/Backends/CLX Modified Files: port.lisp Log Message: Fix mixed up arguments to set-port-keyboard-focus. Renamed set-port-keyboard-focus to %set-port-keyboard-focus to avoid confusion with the CLIM 2.0 function port-keyboard-input-focus. Added a timestamp keyword to %set-port-keyboard-focus (not used by any callers yet). Added some comments about how the keyboard focus functions are connected. Date: Tue Feb 22 04:14:28 2005 Author: ahefner Index: mcclim/Backends/CLX/port.lisp diff -u mcclim/Backends/CLX/port.lisp:1.106 mcclim/Backends/CLX/port.lisp:1.107 --- mcclim/Backends/CLX/port.lisp:1.106 Thu Feb 10 10:54:27 2005 +++ mcclim/Backends/CLX/port.lisp Tue Feb 22 04:14:28 2005 @@ -1230,16 +1230,13 @@ ;; reasonable timestamp. :timestamp 0)))))))) - - ;;; Set the keyboard input focus for the port. -;;; (oops, we lose the timestamp here.) -(defmethod set-port-keyboard-focus (focus (port clx-port)) +(defmethod %set-port-keyboard-focus ((port clx-port) focus &key timestamp) (let ((mirror (sheet-mirror focus))) (when mirror - (xlib:set-input-focus (clx-port-display port) mirror :parent nil)))) + (xlib:set-input-focus (clx-port-display port) mirror :parent timestamp)))) (defmethod port-force-output ((port clx-port)) (xlib:display-force-output (clx-port-display port))) From ahefner at common-lisp.net Tue Feb 22 07:02:55 2005 From: ahefner at common-lisp.net (Andy Hefner) Date: Tue, 22 Feb 2005 08:02:55 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/panes.lisp Message-ID: <20050222070255.D60C78867F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv25434 Modified Files: panes.lisp Log Message: Fix to window-clear (close current text output before clearing output history, else hilarity ensues), provided by Alastair Bridgewater. Date: Tue Feb 22 08:02:27 2005 Author: ahefner Index: mcclim/panes.lisp diff -u mcclim/panes.lisp:1.150 mcclim/panes.lisp:1.151 --- mcclim/panes.lisp:1.150 Tue Feb 22 04:09:18 2005 +++ mcclim/panes.lisp Tue Feb 22 08:02:18 2005 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.150 2005/02/22 03:09:18 ahefner Exp $ +;;; $Id: panes.lisp,v 1.151 2005/02/22 07:02:18 ahefner Exp $ (in-package :clim-internals) @@ -2290,6 +2290,7 @@ :height h :min-height h :max-height +fill+))) (defmethod window-clear ((pane clim-stream-pane)) + (stream-close-text-output-record pane) (let ((output-history (stream-output-history pane))) (with-bounding-rectangle* (left top right bottom) output-history (medium-clear-area (sheet-medium pane) left top right bottom)) From tmoore at common-lisp.net Tue Feb 22 14:00:18 2005 From: tmoore at common-lisp.net (Timothy Moore) Date: Tue, 22 Feb 2005 15:00:18 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/dialog.lisp mcclim/incremental-redisplay.lisp mcclim/input-editing.lisp mcclim/presentation-defs.lisp mcclim/stream-input.lisp Message-ID: <20050222140018.1BF9F884E2@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv16423 Modified Files: dialog.lisp incremental-redisplay.lisp input-editing.lisp presentation-defs.lisp stream-input.lisp Log Message: Fixed presentation highlighting to do the right thing in the :SINGLE-BOX NIL case. Fixed Goatee to not draw anything when drawing is not enabled for the stream. Changed input editing streams to never put activation gestures in the input buffer. There is only one place to receive an activation gesture: the end of the buffer. If the user types an activation gesture, the insertion pointer is moved to the end of the buffer. Fixed various problems with accepting-values. In particular, the insertion pointer does not need to be left at the end of a field when the user exits the dialog. Also, the behavior in the presence of errors new: if an error occurs while the user is typing in an accepting-values field, the bell is beeped and the insertion pointer is positioned before the stream position where the error occured. Date: Tue Feb 22 15:00:11 2005 Author: tmoore Index: mcclim/dialog.lisp diff -u mcclim/dialog.lisp:1.17 mcclim/dialog.lisp:1.18 --- mcclim/dialog.lisp:1.17 Tue Jan 18 11:58:08 2005 +++ mcclim/dialog.lisp Tue Feb 22 15:00:10 2005 @@ -102,7 +102,11 @@ ((queries :accessor queries :initform nil) (selected-query :accessor selected-query :initform nil) (align-prompts :accessor align-prompts :initarg :align-prompts - :initform nil))) + :initform nil) + (last-pass :accessor last-pass :initform nil + :documentation "Flag that indicates the last pass through the + body of ACCEPTING-VALUES, after the user has chosen to exit. This controls + when conditions will be signalled from calls to ACCEPT."))) (defmethod stream-default-view ((stream accepting-values-stream)) +textual-dialog-view+) @@ -206,6 +210,7 @@ (redisplay arecord stream)) (av-exit () (finalize-query-records *accepting-values-stream*) + (setf (last-pass *accepting-values-stream*) t) (redisplay arecord stream))) (erase-output-record arecord stream) (setf (stream-cursor-position stream) @@ -283,7 +288,7 @@ (do-prompt) (setq query-record (do-accept-present-default)))) (setf (record query) query-record) - (when (accept-condition query) + (when (and (last-pass stream) (accept-condition query)) (signal (accept-condition query))) (multiple-value-prog1 (values (value query) (ptype query) (changedp query)) @@ -344,8 +349,7 @@ :key #'query-identifier :test #'equal)) (query (car query-list))) (when selected-query - (unless (equal query-identifier - (query-identifier selected-query)) + (unless (equal query-identifier (query-identifier selected-query)) (deselect-query *accepting-values-stream* selected-query (record selected-query)))) @@ -409,7 +413,8 @@ *no-default-cache-value*) :record-type 'av-text-record) (with-output-as-presentation - (stream query-identifier 'selectable-query) + (stream query-identifier 'selectable-query + :single-box t) (surrounding-output-with-border (stream :shape :inset :move-cursor t) (setq editing-stream @@ -429,23 +434,62 @@ (setf (editing-stream record) editing-stream)) record)) -(defun av-do-accept (query record) - (let ((estream (editing-stream record)) - (ptype (ptype query)) - (view (view query)) - (default (default query)) - (default-supplied-p (default-supplied-p query))) - (setf (values (value query) (ptype query)) ; Hmm, should ptype be set here? - (input-editing-rescan-loop - estream - (if default-supplied-p - ;; Allow empty input to return a default value - #'(lambda (s) - (accept ptype :stream s :view view :prompt nil - :default default)) - #'(lambda (s) - (accept ptype :stream s :view view :prompt nil))))) - (setf (changedp query) t))) +(defun av-do-accept (query record interactive) + (let* ((estream (editing-stream record)) + (ptype (ptype query)) + (view (view query)) + (default (default query)) + (default-supplied-p (default-supplied-p query)) + (accept-args (accept-arguments query)) + (*activation-gestures* (apply #'make-activation-gestures + :existing-activation-gestures + (activation-gestures query) + accept-args)) + (*delimiter-gestures* (apply #'make-delimiter-gestures + :existing-delimiter-args + (delimiter-gestures query) + accept-args))) + ;; If there was an error on a previous pass, set the insertion pointer to + ;; 0 so the user has a chance to edit the field without causing another + ;; error. Otherwise the insertion pointer should already be at the end of + ;; the input (because it was activated); perhaps we should set it anyway. + (when (accept-condition query) + (setf (stream-insertion-pointer estream) 0)) + (reset-scan-pointer estream) + (setf (accept-condition query) nil) + ;; If a condition is thrown, then accept should return the old value and + ;; ptype. + (block accept-condition-handler + (setf (changedp query) nil) + (setf (values (value query) (ptype query)) + (input-editing-rescan-loop + estream + #'(lambda (s) + (handler-bind + ((error + #'(lambda (c) + (format *trace-output* + "accepting-values accept condition: ~A~%" + c) + (if interactive + (progn + (beep) + (goatee::set-editing-stream-insertion-pointer + estream + (1- (stream-scan-pointer estream))) + (immediate-rescan estream) + (format *trace-output* "Ack!~%")) + (progn + (setf (accept-condition query) c) + (return-from accept-condition-handler + c)))))) + (goatee::update-input-editing-stream s) + (if default-supplied-p + (accept ptype :stream s + :view view :prompt nil :default default) + (accept ptype :stream s :view view :prompt nil)))))) + (setf (changedp query) t)))) + @@ -454,48 +498,23 @@ (declare (ignore stream)) (let ((estream (editing-stream record)) (ptype (ptype query)) - (view (view query)) - (accept-args (accept-arguments query))) + (view (view query))) (declare (ignore ptype view)) ;for now - (let* ((*activation-gestures* (apply #'make-activation-gestures - :existing-activation-gestures - (activation-gestures query) - accept-args)) - - (*delimiter-gestures* (apply #'make-delimiter-gestures - :existing-delimiter-args - (delimiter-gestures query) - accept-args))) - (with-accessors ((stream-activated stream-activated) - (stream-input-buffer stream-input-buffer)) + (with-accessors ((stream-input-buffer stream-input-buffer)) estream - ;; "deactivate" editing stream if user has previously activated it. - (when stream-activated - (setf stream-activated nil) - (when (activation-gesture-p (aref stream-input-buffer - (1- (fill-pointer - stream-input-buffer)))) - (replace-input estream "" - :buffer-start (1- (fill-pointer - stream-input-buffer)) - :rescan t))) - (setf (cursor-visibility estream) t) - (setf (snapshot record) (copy-seq stream-input-buffer)) - (block accept-condition-handler - (handler-bind ((condition #'(lambda (c) - (format *trace-output* - "accepting-values accept condition: ~A~%" - c) - (setf (accept-condition query) c) - (return-from accept-condition-handler - c)))) - (av-do-accept query record))))))) - + (setf (cursor-visibility estream) t) + (setf (snapshot record) (copy-seq stream-input-buffer)) + (av-do-accept query record t)))) +;;; If the query has not been changed (i.e., ACCEPT didn't return) and there is +;;; no error, act as if the user activated the query. (defmethod deselect-query (stream query (record av-text-record)) (let ((estream (editing-stream record))) - (setf (cursor-visibility estream) nil))) + (setf (cursor-visibility estream) nil) + (when (not (or (changedp query) (accept-condition query))) + (finalize-query-record query record)))) + (defgeneric finalize-query-record (query record) (:documentation "Do any cleanup on a query before the accepting-values body @@ -513,8 +532,7 @@ (defmethod finalize-query-record (query (record av-text-record)) (let ((estream (editing-stream record))) - (when (and (not (stream-activated estream)) - (snapshot record) + (when (and (snapshot record) (not (equal (snapshot record) (stream-input-buffer estream)))) (let* ((activation-gestures (apply #'make-activation-gestures @@ -524,13 +542,9 @@ (gesture (car activation-gestures))) (when gesture (let ((c (character-gesture-name gesture))) - (replace-input estream (string c) - :buffer-start (fill-pointer (stream-input-buffer - estream)) - :rescan nil) - (setf (stream-activated estream) t) + (activate-stream estream c) (reset-scan-pointer estream) - (av-do-accept query record))))))) + (av-do-accept query record nil))))))) (defun finalize-query-records (av-stream) (loop for query in (queries av-stream) Index: mcclim/incremental-redisplay.lisp diff -u mcclim/incremental-redisplay.lisp:1.44 mcclim/incremental-redisplay.lisp:1.45 --- mcclim/incremental-redisplay.lisp:1.44 Fri Feb 11 13:55:49 2005 +++ mcclim/incremental-redisplay.lisp Tue Feb 22 15:00:10 2005 @@ -728,6 +728,33 @@ ;;; work in progress (defvar *existing-output-records* nil) +;;; Helper functions for managing a hash table of records + +(defun get-record-hash (record hash) + (let ((bucket (gethash (slot-value record 'coordinates) hash))) + (if (null bucket) + (values nil nil) + (let ((rec (find record bucket :test #'output-record-equal))) + (if rec + (values rec t) + (values nil nil)))))) + +(defun add-record-hash (record hash) + (push record (gethash (slot-value record 'coordinates) hash nil))) + +(defun delete-record-hash (record hash) + (let ((bucket (gethash (slot-value record 'coordinates) hash))) + (if bucket + (multiple-value-bind (new-bucket deleted) + (delete-1 record bucket :test #'output-record-equal) + (if deleted + (progn + (setf (gethash (slot-value record 'coordinates) hash) + new-bucket) + t) + nil)) + nil))) + (defmethod compute-difference-set ((record standard-updating-output-record) &optional (check-overlapping t) offset-x offset-y @@ -735,8 +762,7 @@ (declare (ignore offset-x offset-y old-offset-x old-offset-y)) (when (eq (output-record-dirty record) :clean) (return-from compute-difference-set (values nil nil nil nil nil))) - (let* ((existing-output-records nil) - (draws nil) + (let* ((draws nil) (moves (explicit-moves record)) (erases nil) (erase-overlapping nil) @@ -751,33 +777,34 @@ (and old-children (region-intersects-region-p visible-region old-children))) (return-from compute-difference-set (values nil nil nil nil nil))) - ;; I don't feel like adding another let and indenting this huge function - ;; some more.... - (setq existing-output-records (make-hash-table :test #'eq)) ;; XXX This means that compute-difference-set can't be called repeatedly on ;; the same tree; ugh. On the other hand, if we don't clear explicit-moves, ;; they can hang around in the tree for later passes and cause trouble. (setf (explicit-moves record) nil) - ;; Find output records in the new tree that match a record in the old tree - ;; i.e., already have a valid display on the screen. - (map-over-child-display - (if old-children + (let ((existing-output-records (make-hash-table :test 'equalp))) + ;; Find output records in the new tree that match a record in the old + ;; tree i.e., already have a valid display on the screen. + (map-over-child-display + (if old-children + #'(lambda (r) + (add-record-hash r existing-output-records)) + #'(lambda (r) (push (list r r) draws))) + (sub-record record) + visible-region) + (when old-children + (map-over-child-display #'(lambda (r) - (let ((old (find-existing-record r old-children visible-region))) - (if old - (setf (gethash old existing-output-records) r) - (push (list r r) draws)))) - #'(lambda (r) (push (list r r) draws))) - (sub-record record) - visible-region) - ;; Find old records that should be erased - (when old-children - (map-over-child-display #'(lambda (r) - (unless (gethash r existing-output-records) - (push (list r (copy-bounding-rectange r)) - erases))) - old-children - visible-region)) + (unless (delete-record-hash r existing-output-records) + (push (list r (copy-bounding-rectange r)) erases))) + old-children + visible-region) + ;; Any records left in the hash table do not have a counterpart + ;; visible on the screen and need to be drawn. + (loop + for bucket being the hash-values of existing-output-records + do (loop + for r in bucket + do (push (list r r) draws))))) (when check-overlapping (setf erase-overlapping (nconc erases draws)) (setf move-overlapping moves) Index: mcclim/input-editing.lisp diff -u mcclim/input-editing.lisp:1.43 mcclim/input-editing.lisp:1.44 --- mcclim/input-editing.lisp:1.43 Sat Feb 5 00:23:49 2005 +++ mcclim/input-editing.lisp Tue Feb 22 15:00:11 2005 @@ -45,7 +45,7 @@ (scan-pointer :accessor stream-scan-pointer :initform 0) (rescan-queued :accessor rescan-queued :initform nil) (rescanning-p :reader stream-rescanning-p :initform nil) - (activated :accessor stream-activated :initform nil))) + (activation-gesture :accessor activation-gesture :initform nil))) ;;; Markers for noise strings in the input buffer. @@ -72,6 +72,7 @@ ;;; read in while it is not an activation gesture, unread, and then read again ;;; as an activation gesture. This kind of game seems to be needed for reading ;;; forms properly. -- moore +#-(and) (defmethod stream-read-gesture ((stream standard-input-editing-stream) &rest rest-args &key peek-p &allow-other-keys) @@ -84,7 +85,9 @@ (let ((gesture (aref buffer scan-pointer))) (cond ((typep gesture 'noise-string-property) (incf scan-pointer)) - ; XXX What about if peek-p is true? + ;; XXX What about if peek-p is true? + ;; I'm thinking that accept should look for accept + ;; results explicitly. -- moore ((and (not peek-p) (typep gesture 'goatee::accept-result-extent)) (incf scan-pointer) @@ -95,7 +98,9 @@ (setf (stream-activated stream) t)) (incf scan-pointer)) (return-from stream-read-gesture gesture))))) - ;; If activated, insertion pointer is at fill pointer + ;; If activated, insertion pointer is at fill pointer XXX get rid + ;; of this + #+(or) ((stream-activated stream) (return-from stream-read-gesture (values nil :eof))) (t (when (eql scan-pointer (fill-pointer buffer)) @@ -113,7 +118,64 @@ type)) until result))))))) +(defmethod stream-read-gesture ((stream standard-input-editing-stream) + &rest rest-args &key peek-p + &allow-other-keys) + (with-keywords-removed (rest-args (:peek-p)) + (rescan-if-necessary stream) + (with-slots (buffer insertion-pointer scan-pointer activation-gesture) + stream + (loop + (loop + while (< scan-pointer insertion-pointer) + do (let ((gesture (aref buffer scan-pointer))) + ;; Skip noise strings. + ;; XXX We should skip accept results too; I think that they + ;; should be consumed by ACCEPT-1. That's not happening yet. + (cond ((characterp gesture) + (unless peek-p + (incf scan-pointer)) + (return-from stream-read-gesture gesture)) + ((and (not peek-p) + (typep gesture 'goatee::accept-result-extent)) + (incf scan-pointer) + (throw-object-ptype (goatee::object gesture) + (goatee::result-type gesture))) + (t (incf scan-pointer))) + (if (characterp gesture) + (progn + (unless peek-p + (incf scan-pointer)) + (return-from stream-read-gesture gesture)) + (incf scan-pointer)))) + ;; The scan pointer should not be greater than the insertion pointer + ;; because the code that set the insertion pointer should have queued + ;; a rescan. + (when (> scan-pointer insertion-pointer) + (warn "scan-pointer ~S > insertion-pointer ~S; shouldn't happen" + scan-pointer insertion-pointer) + (immediate-rescan stream)) + (when activation-gesture + (return-from stream-read-gesture + (prog1 + activation-gesture + (unless peek-p + (setf activation-gesture nil))))) + (setf (slot-value stream 'rescanning-p) nil) + ;; In McCLIM stream-process-gesture is responsible for inserting + ;; characters into the buffer, changing the insertion pointer and + ;; possibly setting up the activation-gesture slot. + (loop + with gesture and type + do (setf (values gesture type) + (apply #'stream-read-gesture + (encapsulating-stream-stream stream) rest-args)) + when (null gesture) + do (return-from stream-read-gesture (values gesture type)) + when (stream-process-gesture stream gesture type) + do (loop-finish)))))) +#-(and) (defmethod stream-unread-gesture ((stream standard-input-editing-stream) gesture) (declare (ignore gesture)) @@ -121,7 +183,33 @@ (setf (stream-activated stream) nil) (decf (stream-scan-pointer stream)))) -(defgeneric stream-process-gesture (stream gesture type)) +(defmethod stream-unread-gesture ((stream standard-input-editing-stream) + gesture) + (with-slots (buffer scan-pointer activation-gesture) + stream + (when (> scan-pointer 0) + (if (and (eql scan-pointer (fill-pointer buffer)) + (activation-gesture-p gesture)) + (setf activation-gesture gesture) + (decf scan-pointer))))) + +(defgeneric activate-stream (stream gesture) + (:documentation "Cause the input editing stream STREAM to be activated with + GESTURE")) + +(defmethod activate-stream ((stream standard-input-editing-stream) gesture) + (setf (activation-gesture stream) gesture) + (setf (stream-insertion-pointer stream) + (fill-pointer (stream-input-buffer stream))) + (goatee::set-editing-stream-insertion-pointer + stream + (stream-insertion-pointer stream))) + +(defgeneric stream-process-gesture (stream gesture type) + (:documentation "McCLIM relys on a text editor class (by default + GOATEE-INPUT-EDITING-MIXIN) to perform the user interaction and display for + input editing. Also, that class must update the stream buffer and the + insertion pointer, cause rescans to happen, and handle activation gestures.")) ;;; The editing functions of stream-process-gesture are performed by the ;;; primary method on goatee-input-editing-mixin @@ -768,7 +856,11 @@ "Invoke the continuation of the empty `accept' before the first non-empty accept `gesture' must be a member of that `accept''s activation or continuation gestures." - (let ((scan-pointer (1- (stream-scan-pointer stream)))) + (let* ((activationp (activation-gesture-p gesture)) + (scan-pointer (if activationp ;activation gestures don't appear in + ;the bufffer + (stream-scan-pointer stream) + (1- (stream-scan-pointer stream))))) (loop with active-continuation-function = nil for continuation in *empty-input-continuations* @@ -776,7 +868,8 @@ = continuation while (and (eq stream cont-stream) (eql scan-pointer cont-scan-pointer)) - when (or (gesture-match gesture activations) + when (if activationp + (gesture-match gesture activations) (gesture-match gesture delimeters)) do (setq active-continuation-function func) end Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.41 mcclim/presentation-defs.lisp:1.42 --- mcclim/presentation-defs.lisp:1.41 Sat Jan 22 23:31:08 2005 +++ mcclim/presentation-defs.lisp Tue Feb 22 15:00:11 2005 @@ -981,18 +981,27 @@ (defun highlight-presentation-1 (presentation stream state) (with-output-recording-options (stream :record nil) - (if (or (eq (presentation-single-box presentation) t) - (eq (presentation-single-box presentation) :highlighting)) - (highlight-output-record-rectangle presentation stream state) - (funcall-presentation-generic-function highlight-presentation - (presentation-type presentation) - presentation - stream - state)))) + (funcall-presentation-generic-function highlight-presentation + (presentation-type presentation) + presentation + stream + state))) (define-default-presentation-method highlight-presentation (type record stream state) - (highlight-output-record record stream state)) + (declare (ignore type)) + (if (or (eq (presentation-single-box record) t) + (eq (presentation-single-box record) :highlighting)) + (highlight-output-record-rectangle record stream state) + (labels ((highlighter (record) + (typecase record + (displayed-output-record + (highlight-output-record record stream state)) + (compound-output-record + (map-over-output-records #'highlighter record)) + (t nil)))) + (highlighter record)))) + (define-default-presentation-method present (object type stream (view textual-view) &key acceptably for-context-type) Index: mcclim/stream-input.lisp diff -u mcclim/stream-input.lisp:1.41 mcclim/stream-input.lisp:1.42 --- mcclim/stream-input.lisp:1.41 Tue Jan 11 16:33:32 2005 +++ mcclim/stream-input.lisp Tue Feb 22 15:00:11 2005 @@ -330,33 +330,30 @@ ;;; Standard stream methods on standard-extended-input-stream. Ignore any ;;; pointer gestures in the input buffer. - - -(defun read-gesture-or-reason (stream &rest args) - (multiple-value-bind (result reason) - (apply #'stream-read-gesture stream args) - (or result reason))) - -(defun read-result-p (gesture) - (or (characterp gesture) - (member gesture '(:eof :timeout) :test #'eq))) +;;; +;;; Is stream-read-gesture allowed to return :eof? (defmethod stream-read-char ((stream standard-extended-input-stream)) (with-encapsulating-stream (estream stream) - (loop for char = (read-gesture-or-reason estream) - until (read-result-p char) - finally (return (char-for-read char))))) + (loop + with char and reason + do (setf (values char reason) (stream-read-gesture estream)) + until (or (characterp char) (eq reason :eof)) + finally (return (if (eq reason :eof) + reason + (char-for-read char)))))) (defmethod stream-read-char-no-hang ((stream standard-extended-input-stream)) (with-encapsulating-stream (estream stream) - (loop for char = (read-gesture-or-reason estream :timeout 0) - do (when (read-result-p char) - (loop-finish)) - finally (return (cond ((eq char :eof) - :eof) - ((eq char :timeout) - nil) - (t (char-for-read char))))))) + (loop + with char and reason + do (setf (values char reason) (stream-read-gesture estream :timeout 0)) + until (or (characterp char) (eq reason :timeout) (eq reason :eof) ) + finally (return (cond ((eq reason :timeout) + nil) + ((eq reason :eof) + :eof) + (t (char-for-read char))))))) (defmethod stream-unread-char ((stream standard-extended-input-stream) char) @@ -365,20 +362,25 @@ (defmethod stream-peek-char ((stream standard-extended-input-stream)) (with-encapsulating-stream (estream stream) - (loop for char = (read-gesture-or-reason estream :peek-p t) - do (if (read-result-p char) - (loop-finish) - (stream-read-gesture estream)) ; consume pointer gesture - finally (return (char-for-read char))))) + (loop + with char and reason + do (setf (values char reason) (stream-read-gesture estream :peek-p t)) + until (or (characterp char) (eq reason :eof)) + do (stream-read-gesture estream) ; consume pointer gesture + finally (return (if (eq reason :eof) + reason + (char-for-read char)))))) (defmethod stream-listen ((stream standard-extended-input-stream)) (with-encapsulating-stream (estream stream) - (loop for char = (read-gesture-or-reason estream :timeout 0 :peek-p t) - do (if (read-result-p char) - (loop-finish) - (stream-read-gesture estream)) ; consume pointer gesture - finally (return (characterp char))))) - + (loop + with char and reason + do (setf (values char reason) (stream-read-gesture estream + :timeout 0 + :peek-p t)) + until (or (characterp char) (eq reason :eof) (eq reason :timeout)) + do (stream-read-gesture estream) ; consume pointer gesture + finally (return (characterp char))))) ;;; stream-read-line returns a second value of t if terminated by eof. (defmethod stream-read-line ((stream standard-extended-input-stream)) From tmoore at common-lisp.net Tue Feb 22 14:00:21 2005 From: tmoore at common-lisp.net (Timothy Moore) Date: Tue, 22 Feb 2005 15:00:21 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Goatee/clim-area.lisp mcclim/Goatee/editing-stream.lisp Message-ID: <20050222140021.6BA0E884E2@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Goatee In directory common-lisp.net:/tmp/cvs-serv16423/Goatee Modified Files: clim-area.lisp editing-stream.lisp Log Message: Fixed presentation highlighting to do the right thing in the :SINGLE-BOX NIL case. Fixed Goatee to not draw anything when drawing is not enabled for the stream. Changed input editing streams to never put activation gestures in the input buffer. There is only one place to receive an activation gesture: the end of the buffer. If the user types an activation gesture, the insertion pointer is moved to the end of the buffer. Fixed various problems with accepting-values. In particular, the insertion pointer does not need to be left at the end of a field when the user exits the dialog. Also, the behavior in the presence of errors new: if an error occurs while the user is typing in an accepting-values field, the bell is beeped and the insertion pointer is positioned before the stream position where the error occured. Date: Tue Feb 22 15:00:18 2005 Author: tmoore Index: mcclim/Goatee/clim-area.lisp diff -u mcclim/Goatee/clim-area.lisp:1.30 mcclim/Goatee/clim-area.lisp:1.31 --- mcclim/Goatee/clim-area.lisp:1.30 Fri Feb 11 11:03:07 2005 +++ mcclim/Goatee/clim-area.lisp Tue Feb 22 15:00:18 2005 @@ -556,30 +556,31 @@ (line-text-width area line :end line-unchanged-from-end) new-line-end))) - (multiple-value-bind (x y) - (output-record-position line) - ;; Move unchanged text at the end of line, if needed - (when (and (not (eql line-unchanged-from-end new-line-size)) - (not (eql current-unchanged-left - new-unchanged-left))) - (copy-area medium - (+ current-unchanged-left x) - y - (- line-end current-unchanged-left) - (+ ascent descent) - (+ new-unchanged-left x) - y)) - ;; If the line is now shorter, erase the old end of line. - (erase-line line medium new-line-end line-end) - ;; Erase the changed middle - (erase-line line medium start-width new-unchanged-left) - ;; Draw the middle - (when (< line-unchanged-from-start line-unchanged-from-end) - (draw-text* medium current-contents - (+ x start-width) baseline - :start line-unchanged-from-start - :end line-unchanged-from-end - :ink (foreground-ink line)))) + (when (stream-drawing-p stream) + (multiple-value-bind (x y) + (output-record-position line) + ;; Move unchanged text at the end of line, if needed + (when (and (not (eql line-unchanged-from-end new-line-size)) + (not (eql current-unchanged-left + new-unchanged-left))) + (copy-area medium + (+ current-unchanged-left x) + y + (- line-end current-unchanged-left) + (+ ascent descent) + (+ new-unchanged-left x) + y)) + ;; If the line is now shorter, erase the old end of line. + (erase-line line medium new-line-end line-end) + ;; Erase the changed middle + (erase-line line medium start-width new-unchanged-left) + ;; Draw the middle + (when (< line-unchanged-from-start line-unchanged-from-end) + (draw-text* medium current-contents + (+ x start-width) baseline + :start line-unchanged-from-start + :end line-unchanged-from-end + :ink (foreground-ink line))))) ;; Old, wrong, bounding rectangle (with-bounding-rectangle* (old-min-x old-min-y old-max-x old-max-y) line Index: mcclim/Goatee/editing-stream.lisp diff -u mcclim/Goatee/editing-stream.lisp:1.20 mcclim/Goatee/editing-stream.lisp:1.21 --- mcclim/Goatee/editing-stream.lisp:1.20 Sun Oct 24 17:47:02 2004 +++ mcclim/Goatee/editing-stream.lisp Tue Feb 22 15:00:18 2005 @@ -150,44 +150,54 @@ gesture type) (declare (ignore type)) + (when (activation-gesture-p gesture) + (setf (stream-insertion-pointer stream) + (fill-pointer (stream-input-buffer stream))) + (set-editing-stream-insertion-pointer stream + (stream-insertion-pointer stream)) + (setf (climi::activation-gesture stream) gesture) + (rescan-if-necessary stream) + (return-from stream-process-gesture gesture)) (let ((area (area stream)) (snapshot (snapshot stream))) (execute-gesture-command gesture area *simple-area-gesture-table*) - (make-input-editing-stream-snapshot snapshot area) - (let ((first-mismatch (mismatch (stream-input-buffer snapshot) - (stream-input-buffer stream)))) - (unwind-protect - (cond ((null first-mismatch) - ;; No change actually took place, event though IP may have - ;; moved. - nil) - ((< first-mismatch (stream-scan-pointer stream)) - (immediate-rescan stream)) - ((and (eql first-mismatch - (1- (stream-insertion-pointer snapshot))) - (eql (aref (stream-input-buffer snapshot) first-mismatch) - gesture)) - ;; As best we can tell an insertion happened: one gesture was - ;; entered it was inserted in the buffer. There may be other - ;; changes above IP, but we don't care. - gesture) - (t - ;; Other random changes, but we want to allow more editing - ;; before scanning them. - nil)) - (let ((snapshot-buffer (stream-input-buffer snapshot)) - (stream-buffer (stream-input-buffer stream))) - (setf (stream-insertion-pointer stream) - (stream-insertion-pointer snapshot)) - (when (< (car (array-dimensions stream-buffer)) - (fill-pointer snapshot-buffer)) - (adjust-array stream-buffer (fill-pointer snapshot-buffer))) - (setf (fill-pointer stream-buffer) (fill-pointer snapshot-buffer)) - (when (and first-mismatch - (>= (fill-pointer snapshot-buffer) first-mismatch)) - (replace stream-buffer snapshot-buffer - :start1 first-mismatch - :start2 first-mismatch))))))) + (make-input-editing-stream-snapshot snapshot area) + (let ((first-mismatch (mismatch (stream-input-buffer snapshot) + (stream-input-buffer stream)))) + (unwind-protect + (cond ((null first-mismatch) + ;; No change actually took place, event though IP may have + ;; moved. + nil) + ((< first-mismatch (stream-scan-pointer stream)) + ;; Throw out. Buffer is still updated by protect forms + (immediate-rescan stream)) + ((and (eql first-mismatch + (1- (stream-insertion-pointer snapshot))) + (eql (aref (stream-input-buffer snapshot) first-mismatch) + gesture)) + ;; As best we can tell an insertion happened: one gesture was + ;; entered it was inserted in the buffer. There may be other + ;; changes above IP, but we don't care. + gesture) + (t + ;; Other random changes, but we want to allow more editing + ;; before scanning them. + (queue-rescan stream) + nil)) + (let ((snapshot-buffer (stream-input-buffer snapshot)) + (stream-buffer (stream-input-buffer stream))) + (setf (stream-insertion-pointer stream) + (stream-insertion-pointer snapshot)) + (when (< (car (array-dimensions stream-buffer)) + (fill-pointer snapshot-buffer)) + (adjust-array stream-buffer (fill-pointer snapshot-buffer))) + (setf (fill-pointer stream-buffer) (fill-pointer snapshot-buffer)) + (when (and first-mismatch + (>= (fill-pointer snapshot-buffer) first-mismatch)) + (replace stream-buffer snapshot-buffer + :start1 first-mismatch + :start2 first-mismatch))))))) (defun reposition-stream-cursor (stream) "Moves the cursor somewhere clear of Goatee's editing area." @@ -243,6 +253,16 @@ :format "Location line ~S pos ~S isn't in buffer ~S" :format-arguments (list line pos buffer))) (return (+ total-offset pos))))) + +(defgeneric set-editing-stream-insertion-pointer (stream pointer)) + +(defmethod set-editing-stream-insertion-pointer + ((stream goatee-input-editing-mixin) pointer) + (let* ((area (area stream)) + (buffer (buffer area))) + (setf (point* buffer) (location*-offset buffer pointer)) + (redisplay-area area))) + (defun %replace-input (stream new-input start end buffer-start rescan rescan-supplied-p From ahefner at common-lisp.net Fri Feb 25 06:03:04 2005 From: ahefner at common-lisp.net (Andy Hefner) Date: Fri, 25 Feb 2005 07:03:04 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/gadgets.lisp Message-ID: <20050225060304.4B3BC8866B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv4833 Modified Files: gadgets.lisp Log Message: Fix gadget output records after recent coordinate changes, with help from Anthony Juckel and Mikemac. Date: Fri Feb 25 07:03:03 2005 Author: ahefner Index: mcclim/gadgets.lisp diff -u mcclim/gadgets.lisp:1.87 mcclim/gadgets.lisp:1.88 --- mcclim/gadgets.lisp:1.87 Mon Jan 31 07:09:55 2005 +++ mcclim/gadgets.lisp Fri Feb 25 07:03:02 2005 @@ -2699,12 +2699,8 @@ (width (space-requirement-width sr)) (height (space-requirement-height sr))) (allocate-space child width height) - (setf (gadget record) child) - (with-slots (x1 x2 y1 y2) record - (setf x1 x - y1 y - x2 (+ x width) - y2 (+ y height))))) + (setf (gadget record) child + (rectangle-edges* record) (values x y (+ x width) (+ y height))))) (defmethod note-output-record-got-sheet ((record gadget-output-record) sheet) (multiple-value-bind (x y) (output-record-position record) From tmoore at common-lisp.net Fri Feb 25 14:15:19 2005 From: tmoore at common-lisp.net (Timothy Moore) Date: Fri, 25 Feb 2005 15:15:19 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/dialog.lisp mcclim/input-editing.lisp mcclim/presentation-defs.lisp Message-ID: <20050225141519.7761D884E2@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv31004 Modified Files: dialog.lisp input-editing.lisp presentation-defs.lisp Log Message: Changed the handling of "empty input" for the purposes of returning a default value from ACCEPT. I eliminated the around method on STREAM-READ-CHAR that looked for activation/delimiter gestures and replaced it with an error handler on SIMPLE-PARSE-ERROR. The major effect of this is that (accept 'string) now return the empty string if the call to ACCEPT is not passed a default; other accept methods can return something useful for empty input too. This fixes some problems in the address book demo and with dialogs in general. Date: Fri Feb 25 15:15:17 2005 Author: tmoore Index: mcclim/dialog.lisp diff -u mcclim/dialog.lisp:1.18 mcclim/dialog.lisp:1.19 --- mcclim/dialog.lisp:1.18 Tue Feb 22 15:00:10 2005 +++ mcclim/dialog.lisp Fri Feb 25 15:15:17 2005 @@ -256,6 +256,13 @@ :key #'query-identifier :test #'equal)) (align (align-prompts stream))) (unless query + ;; If there's no default but empty input could return a sensible value, + ;; use that as a default. + (unless default-supplied-p + (setq default + (ignore-errors (accept-from-string type + "" + :view +textual-view+ )))) (setq query (make-instance 'query :query-identifier query-identifier :ptype type Index: mcclim/input-editing.lisp diff -u mcclim/input-editing.lisp:1.44 mcclim/input-editing.lisp:1.45 --- mcclim/input-editing.lisp:1.44 Tue Feb 22 15:00:11 2005 +++ mcclim/input-editing.lisp Fri Feb 25 15:15:17 2005 @@ -848,76 +848,76 @@ ;;; Infrasructure for detecting empty input, thus allowing accept-1 ;;; to supply a default. -;;; continuation = (stream scan-pointer -;;; activation-gestures delimiter gestures) -(defvar *empty-input-continuations* nil) - -(defun invoke-empty-input (stream gesture) - "Invoke the continuation of the empty `accept' before the first non-empty - accept `gesture' must be a member of that `accept''s activation or continuation - gestures." - (let* ((activationp (activation-gesture-p gesture)) - (scan-pointer (if activationp ;activation gestures don't appear in - ;the bufffer - (stream-scan-pointer stream) - (1- (stream-scan-pointer stream))))) - (loop - with active-continuation-function = nil - for continuation in *empty-input-continuations* - for (cont-stream cont-scan-pointer func activations delimeters) - = continuation - while (and (eq stream cont-stream) - (eql scan-pointer cont-scan-pointer)) - when (if activationp - (gesture-match gesture activations) - (gesture-match gesture delimeters)) - do (setq active-continuation-function func) - end - finally (when active-continuation-function - (unread-char gesture stream) - (funcall active-continuation-function))) - t)) - -(defmethod stream-read-gesture :around ((stream empty-input-mixin) - &key timeout peek-p - input-wait-test - input-wait-handler - pointer-button-press-handler) - (declare (ignore timeout input-wait-test input-wait-handler - pointer-button-press-handler)) - (if peek-p - (call-next-method) - (multiple-value-bind (gesture reason) - (call-next-method) - (when (and gesture - (or (activation-gesture-p gesture) - (delimiter-gesture-p gesture))) - (invoke-empty-input stream gesture)) - ;; invoke-empty-input won't return if it can invoke a continuation - (values gesture reason)))) - (defmacro handle-empty-input ((stream) input-form &body handler-forms) "Establishes a context on `stream' (a `standard-input-editing-stream') in - which empty input entered in `input-form' i.e., an activation gesture or - delimiter gesture typed with no other characters, may transfer control to - `handler-forms'. The gesture that caused the transfer remains to be read in - `stream'. Control is transferred to the outermost `handle-empty-input' form - that is empty. + which empty input entered in `input-form' may transfer control to + `handler-forms'. Empty input is assumed when a simple-parse-error is + signalled and there is a delimeter gesture or activation gesture in the + stream at the position where `input-form' began its input. The gesture that + caused the transfer remains to be read in `stream'. Control is transferred to + the outermost `handle-empty-input' form that is empty. Note: noise strings in the buffer, such as the prompts of recursive calls to `accept', cause input to not be empty. However, the prompt generated by `accept' is generally not part of its own empty input context." - (with-gensyms (return-block context-block) - `(block ,return-block - (block ,context-block - (let ((*empty-input-continuations* - (cons (list ,stream - (stream-scan-pointer ,stream) - #'(lambda () - (return-from ,context-block)) - *activation-gestures* - *delimiter-gestures*) - *empty-input-continuations*))) - (return-from ,return-block ,input-form))) - , at handler-forms))) + (with-gensyms (input-cont handler-cont) + `(flet ((,input-cont () + ,input-form) + (,handler-cont () + , at handler-forms)) + (declare (dynamic-extent #',input-cont #',handler-cont)) + (invoke-handle-empty-input ,stream #',input-cont #',handler-cont)))) + +(define-condition empty-input-condition (simple-condition) + ((stream :reader empty-input-condition-stream :initarg :stream))) + +;;; The code that signalled the error might have consumed the gesture, or +;;; not. +;;; XXX Actually, it would be a violation of the `accept' protocol to consume +;;; the gesture, but who knows what random accept methods are doing. +(defun empty-input-p (stream begin-scan-pointer completion-gestures) + (let ((scan-pointer (stream-scan-pointer stream)) + (fill-pointer (fill-pointer (stream-input-buffer stream)))) + ;; activated? + (cond ((and (eql begin-scan-pointer scan-pointer) + (eql scan-pointer fill-pointer)) + t) + ((or (eql begin-scan-pointer scan-pointer) + (eql begin-scan-pointer (1- scan-pointer))) + (let ((gesture (aref (stream-input-buffer stream) + begin-scan-pointer))) + (and (characterp gesture) + (gesture-match gesture completion-gestures)))) + (t nil)))) + +;;; The control flow in here might be a bit confusing. The handler catches +;;; parse errors from accept forms and checks if the input stream is empty. If +;;; so, it resignals an empty-input-condition to see if an outer call to +;;; accept is empty and wishes to handle this situation. We don't resignal the +;;; parse error itself because it might get handled by a handler on ERROR in an +;;; accept method or in user code, which would screw up the default mechanism. +;;; +;;; If the situation is not handled in the innermost empty input handler, +;;; either directly or as a result of resignalling, then it won't be handled +;;; by any of the outer handlers as the stack unwinds, because EMPTY-INPUT-P +;;; will return nil. +(defun invoke-handle-empty-input + (stream input-continuation handler-continuation) + (unless (input-editing-stream-p stream) + (return-from invoke-handle-empty-input (funcall input-continuation))) + (let ((begin-scan-pointer (stream-scan-pointer stream)) + (completion-gestures *completion-gestures*)) + (block empty-input + (handler-bind (((or simple-parse-error empty-input-condition) + #'(lambda (c) + (when (empty-input-p stream + begin-scan-pointer + completion-gestures) + (if (typep c 'empty-input-condition) + (signal c) + (signal 'empty-input-condition :stream stream)) + ;; No one else wants to handle it, so we will + (return-from empty-input nil))))) + (return-from invoke-handle-empty-input (funcall input-continuation)))) + (funcall handler-continuation))) Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.42 mcclim/presentation-defs.lisp:1.43 --- mcclim/presentation-defs.lisp:1.42 Tue Feb 22 15:00:11 2005 +++ mcclim/presentation-defs.lisp Fri Feb 25 15:15:17 2005 @@ -1082,6 +1082,12 @@ (declare (ignore object acceptably for-context-type)) (write-string "None" stream)) +(define-presentation-method accept ((type null) stream (view textual-view) + &key) + (values (completing-from-suggestions (stream) + (suggest "None" nil) + (suggest "" nil)))) + (define-presentation-type boolean () :inherit-from t) @@ -1388,12 +1394,15 @@ (princ object stream)) (define-presentation-method accept ((type string) stream (view textual-view) - &key) + &key (default nil defaultp) + (default-type type)) (let ((result (read-token stream))) (cond ((numberp length) (if (eql length (length result)) (values result type) (input-not-of-required-type result type))) + ((and (zerop (length result)) defaultp) + (values default default-type)) (t (values result type))))) (define-presentation-type pathname () From tmoore at common-lisp.net Sun Feb 27 00:06:29 2005 From: tmoore at common-lisp.net (Timothy Moore) Date: Sun, 27 Feb 2005 01:06:29 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/input-editing.lisp Message-ID: <20050227000629.67B578866C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv13917 Modified Files: input-editing.lisp Log Message: Fixed input editing problem reported by Luke Gorrie. Some old code in stream-read-gesture was causing the scan pointer to be incremented twice in some cases. Date: Sun Feb 27 01:06:28 2005 Author: tmoore Index: mcclim/input-editing.lisp diff -u mcclim/input-editing.lisp:1.45 mcclim/input-editing.lisp:1.46 --- mcclim/input-editing.lisp:1.45 Fri Feb 25 15:15:17 2005 +++ mcclim/input-editing.lisp Sun Feb 27 01:06:27 2005 @@ -141,13 +141,7 @@ (incf scan-pointer) (throw-object-ptype (goatee::object gesture) (goatee::result-type gesture))) - (t (incf scan-pointer))) - (if (characterp gesture) - (progn - (unless peek-p - (incf scan-pointer)) - (return-from stream-read-gesture gesture)) - (incf scan-pointer)))) + (t (incf scan-pointer))))) ;; The scan pointer should not be greater than the insertion pointer ;; because the code that set the insertion pointer should have queued ;; a rescan. From ahefner at common-lisp.net Sun Feb 27 23:07:41 2005 From: ahefner at common-lisp.net (Andy Hefner) Date: Mon, 28 Feb 2005 00:07:41 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/text-selection.lisp Message-ID: <20050227230741.892258866E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv23633 Modified Files: text-selection.lisp Log Message: Attempt to fix some issues with text selection. Send Latin 1 in response to :STRING and :COMPOUND_TEXT requests, request selections as :STRING by default, fall back to cut buffer contents when a selection-notify event does not supply a property. Date: Mon Feb 28 00:07:39 2005 Author: ahefner Index: mcclim/text-selection.lisp diff -u mcclim/text-selection.lisp:1.4 mcclim/text-selection.lisp:1.5 --- mcclim/text-selection.lisp:1.4 Mon Feb 14 17:31:41 2005 +++ mcclim/text-selection.lisp Mon Feb 28 00:07:36 2005 @@ -72,10 +72,10 @@ (defgeneric bind-selection (port window &optional time) (:documentation "Take ownership of the selection.")) -(defgeneric send-selection (request-event string) +(defgeneric send-selection (port request-event string) (:documentation "Send 'string' to a client in response to a selection-request-event.")) -(defgeneric get-selection-from-event (event) +(defgeneric get-selection-from-event (port event) (:documentation "Given a selection-notify event, return a string containing the incoming selection.")) @@ -244,9 +244,7 @@ :sheet owner :selection :primary)))) (when (bind-selection (port pane) pane (event-timestamp event)) - (setf (selection-owner (port pane)) pane)) - ;; - ))) + (setf (selection-owner (port pane)) pane))))) (defun repaint-markings (pane old-markings new-markings) (let ((old-region (reduce #'region-union (mapcar #'(lambda (x) (marking-region pane x)) old-markings) @@ -377,18 +375,18 @@ ;;;; Selections Events (defmethod dispatch-event :around ((pane cut-and-paste-mixin #|extended-output-stream|#) - (event selection-clear-event)) + (event selection-clear-event)) (pane-clear-markings pane (event-timestamp event))) (defmethod dispatch-event :around ((pane cut-and-paste-mixin #|extended-output-stream|#) - (event selection-request-event)) - (send-selection event (fetch-selection pane))) + (event selection-request-event)) + (send-selection (port pane) event (fetch-selection pane))) (defmethod dispatch-event :around ((pane cut-and-paste-mixin #|extended-output-stream|#) (event selection-notify-event)) - (let ((matter (get-selection-from-event event))) + (let ((matter (get-selection-from-event (port pane) event))) #+NIL (format *trace-output* "Got ~S.~%" matter) (loop for c across matter do From ahefner at common-lisp.net Sun Feb 27 23:07:52 2005 From: ahefner at common-lisp.net (Andy Hefner) Date: Mon, 28 Feb 2005 00:07:52 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Backends/CLX/port.lisp Message-ID: <20050227230752.B42C488673@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv23633/Backends/CLX Modified Files: port.lisp Log Message: Attempt to fix some issues with text selection. Send Latin 1 in response to :STRING and :COMPOUND_TEXT requests, request selections as :STRING by default, fall back to cut buffer contents when a selection-notify event does not supply a property. Date: Mon Feb 28 00:07:43 2005 Author: ahefner Index: mcclim/Backends/CLX/port.lisp diff -u mcclim/Backends/CLX/port.lisp:1.107 mcclim/Backends/CLX/port.lisp:1.108 --- mcclim/Backends/CLX/port.lisp:1.107 Tue Feb 22 04:14:28 2005 +++ mcclim/Backends/CLX/port.lisp Mon Feb 28 00:07:41 2005 @@ -1377,67 +1377,72 @@ (defmethod release-selection ((port clx-port) &optional time) (xlib:set-selection-owner - (clim-clx::clx-port-display port) + (clx-port-display port) :primary nil time) (setf (selection-owner port) nil)) (defmethod request-selection ((port clx-port) requestor time) - (xlib:convert-selection :primary :UTF8_STRING requestor :bounce time)) + (xlib:convert-selection :primary :STRING requestor :bounce time)) -(defmethod get-selection-from-event ((event clx-selection-notify-event)) - (when (null (selection-event-property event)) - (format *trace-output* "~&;; Notify property is null! Why did this happen?~%")) - (map 'string #'code-char - (xlib:get-property (sheet-direct-mirror (event-sheet event)) - (selection-event-property event) - ;; :type :text - :delete-p t - :result-type 'vector))) +(defmethod get-selection-from-event ((port clx-port) (event clx-selection-notify-event)) + ; (describe event *trace-output*) + (if (null (selection-event-property event)) + (progn + (format *trace-output* "~&;; Oops, selection-notify property is null. Trying the cut buffer instead..~%") + (xlib:cut-buffer (clx-port-display port))) + (map 'string #'code-char + (xlib:get-property (sheet-direct-mirror (event-sheet event)) + (selection-event-property event) + ;; :type :text + :delete-p t + :result-type 'vector)))) -(defmethod send-selection ((event clx-selection-request-event) string) +;; Incredibly crappy broken unportable Latin 1 encoder which should be +;; replaced by various implementation-specific versions. +(defun latin1-encode (string) + (delete-if (lambda (x) (or (< x 0) + (> x 255))) + (map 'vector #'char-code string))) + +;; TODO: INCR property? +(defmethod send-selection ((port clx-port) (event clx-selection-request-event) string) (let ((requestor (selection-event-requestor event)) (property (selection-event-property event)) (target (selection-event-target event)) (time (event-timestamp event))) (when (null property) - (format *trace-output* "~&* Requestor property is null! *~%")) + (format *trace-output* "~&* Requestor property is null! *~%")) (describe event *trace-output*) (finish-output *trace-output*) - (cond ((member target '(:UTF8_STRING :STRING :TEXT)) - (xlib:change-property requestor property - (utf-8-encode - (concatenate 'vector (map 'vector #'char-code string))) - ;;:UTF8_STRING ;### - target - 8) - (xlib:send-event requestor - :selection-notify nil - :window requestor - :selection :primary - :target target ;; :UTF8_STRING - :property property - :time time)) - ((member target '(:COMPOUND_TEXT)) - (xlib:change-property requestor property - (vector 65 65 67 - #x1B #x24 #x29 #x41 - #xA1 #xD4 - 67 65 67) - :COMPOUND_TEXT - 8) - (xlib:send-event requestor + (flet ((send-event (&key target (property property)) + (format *trace-output* + "~&;; clim-clx::send-selection - Requested target ~A, sent ~A to property ~A.~%" + (selection-event-target event) + target + property) + (xlib:send-event requestor :selection-notify nil :window requestor :selection :primary - :target :COMPOUND_TEXT + :target target :property property - :time time)) - (t - (xlib:send-event requestor - :selection-notify nil - :window requestor - :selection :primary - :target :UTF8_STRING ;;target - :property nil ;;property :time time))) + (cond ((member target '(:UTF8_STRING :TEXT)) + (xlib:change-property requestor property + (utf-8-encode + (concatenate 'vector (map 'vector #'char-code string))) + :UTF8_STRING + 8) + (send-event :target :UTF8_STRING)) + ((member target '(:STRING :COMPOUND_TEXT)) + (xlib:change-property requestor property + (latin1-encode string) + :COMPOUND_TEXT + 8) + (send-event :target :COMPOUND_TEXT)) + (t + (format *trace-output* + "~&;; Warning, unhandled type \"~A\". Trying to send as UTF8_STRING.~%" + target) + (send-event :target :UTF8_STRING :property nil)))) ;; ... (xlib:display-force-output (xlib:window-display requestor)))) From afuchs at common-lisp.net Mon Feb 28 16:23:22 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Mon, 28 Feb 2005 17:23:22 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/mcclim.asd Message-ID: <20050228162322.559B3884E2@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv15499 Modified Files: mcclim.asd Log Message: Add two dependencies spotted by Tim Daly Jr. Date: Mon Feb 28 17:23:21 2005 Author: afuchs Index: mcclim/mcclim.asd diff -u mcclim/mcclim.asd:1.2 mcclim/mcclim.asd:1.3 --- mcclim/mcclim.asd:1.2 Mon Feb 21 17:36:30 2005 +++ mcclim/mcclim.asd Mon Feb 28 17:23:20 2005 @@ -95,11 +95,11 @@ #| fall back |# "mp-nil")))) (:file "utils" :depends-on ("decls" "Lisp-Dep")) (:file "design" :depends-on ("decls" "Lisp-Dep" "utils")) - (:file "X11-colors" :depends-on ("decls" "Lisp-Dep")) + (:file "X11-colors" :depends-on ("decls" "Lisp-Dep" "design")) (:file "coordinates" :depends-on ("decls" "Lisp-Dep")) (:file "setf-star" :depends-on ("decls" "Lisp-Dep")) (:file "transforms" :depends-on ("decls" "Lisp-Dep" "coordinates" "utils")) - (:file "regions" :depends-on ("decls" "Lisp-Dep" "coordinates" "utils" "transforms" "setf-star")) + (:file "regions" :depends-on ("decls" "Lisp-Dep" "coordinates" "utils" "transforms" "setf-star" "design")) (:file "sheets" :depends-on ("decls" "Lisp-Dep" "utils" "transforms" "regions")) (:file "pixmap" :depends-on ("decls" "Lisp-Dep" "sheets" "transforms" "regions")) (:file "events" :depends-on ("decls" "Lisp-Dep" "transforms" "sheets" "utils")) @@ -179,6 +179,7 @@ ((:file "text-formatting") (:file "input-editing") (:file "presentations") + (:file "defresource") (:file "presentation-defs" :depends-on ("input-editing" "presentations")) (:file "pointer-tracking" :depends-on ("input-editing")) (:file "commands" :depends-on ("input-editing" "presentations" "presentation-defs"))