August 2005 - mcclim-cvs@common-lisp.net - mailman3.common-lisp.net

[mcclim-cvs] CVS update: mcclim/Apps/Listener/icons/wild.xpm
by mretzlaff＠common-lisp.net 31 Aug '05

31 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener/icons In directory common-lisp.net:/tmp/cvs-serv17279/Apps/Listener/icons Added Files: wild.xpm Log Message: This patch affects the CLIM-Listener. It adds : - sort-by for filenames to COM-SHOW-DIRECTORY, - an icon and a cond-clause in ICON-OF for wild pathnames, - a wrapper for LIST-DIRECTORY (that NCONCs the direct subdirectories of the directory to the output of LIST-DIRECTORY if it is called with a wild pathname), - and does some minor changes to COM-SHOW-DIRECTORY. Also it removes the SB-POSIX LIST-DIRECTORY for SBCL as that one completely ignores the pathname-name and -type, which renders it quite useless for :wild searches (pune or play on words intended). There was a short discussion about this patch in #lisp some hourse ago. As a result the wrapper for LIST-DIRECTORY is now called LIST-DIRECTORY-WITH-ALL-DIRECT-SUBDIRECTORIES. And it will only used by COM-SHOW-DIRECTORY if its new keyword parameter :list-all-direct-subdirectories is specified as t (the default being nil). The discussion (included because of the removed posix code in the former SBCL version of LIST-DIRECTORY): 01:18 < mgr> hefner: Did you have a look at my listener patch? 01:19 < hefner> I did, it looked good 01:19 < mgr> hefner: You are not angry because it removes the posix stuff? :) 01:20 < hefner> mgr: did it? :) The posix stuff was horrible, terrible. 01:20 < mgr> hefner: So, you don't object if I commit it to the mcclim repository? 01:20 < hefner> mgr: no, go ahead 01:22 < mgr> hefner: Perhaps there should be a option to COM-SHOW-DIRECTORY to switch between using LIST-DIRECTORY and LIST-DIRECTORY-WITH-ALL-SUBDIRECTORIES? Perhaps the latter is not always desired.. 01:22 < hefner> mgr: :recursive t ? 01:23 < mgr> hefner: No, it's different. if you list "/tmp/*.list" all direct subdirectories of "/tmp/" will be listed as well, altough they do not match "*.lisp". 01:24 < hefner> ah.. 01:27 < hefner> mgr: hold on, you're just calling cl:directory? Isn't that going to explode on broken symlinks? 01:33 < mgr> hefner: Uhm, explode? not really, no. Why? Symlinks are just "resolved" on sbcl. That is if you select "/foo/bar" that is a symlink to "/baz/quux", you'll always get the latter even if you select the former one. 01:34 < gilberth> mgr: not so fast. I have major hassle with CMUCL and XEmacs silly lock symlinks. 01:34 < hefner> mgr: what if /baz/quux doesn't exist? I didn't write the aweful posix code for my health. 01:35 < gilberth> They point to silly stuff like "gilbert(a)morganit.local.6092" 01:36 < mgr> gilberth: Well, the listener did always do only #'directory for cmucl.. So, don't worry this does not affect you. :) 01:36 < gilberth> great. 01:37 < hefner> not only #'directory, but (directory pathname :truenamep nil) 01:39 < gilberth> mgr: It must use the right keyword options to #'directory in CMUCL or something, since it works with borken symlinks. 01:39 < gilberth> it even shows a particular icon for the broken symlink. 01:39 < hefner> does it? that's a nice touch. 01:40 < gilberth> hefner: I thought you would know? 01:40 < hefner> I guess I forgot. 01:45 < mgr> hefner: there ist no problem with them. they will not be resolved, that is #p"/foo/bar" will be returned. it will be displayed as an invalid pathname because probe-file returns nil. 01:46 < hefner> mgr: I guess the behaviour changed. SBCL of 1.5 years ago didn't do that. Carry on. :) 01:47 < mgr> hefner: Also the posix version completely ignores the pathname-name and -type, and that's really not nice. 01:47 < hefner> well, pathname-name and pathname-type aren't nice either 01:47 < hefner> pathnames aren't nice 01:47 < mgr> hefner: Well, that's a different problem. 01:48 < mgr> hefner: I'll include this short discussion into the commit message, okay? :) 01:48 < hefner> okay Date: Wed Aug 31 07:50:41 2005 Author: mretzlaff

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Listener/dev-commands.lisp mcclim/Apps/Listener/file-types.lisp mcclim/Apps/Listener/util.lisp
by mretzlaff＠common-lisp.net 31 Aug '05

31 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory common-lisp.net:/tmp/cvs-serv17279/Apps/Listener Modified Files: dev-commands.lisp file-types.lisp util.lisp Log Message: This patch affects the CLIM-Listener. It adds : - sort-by for filenames to COM-SHOW-DIRECTORY, - an icon and a cond-clause in ICON-OF for wild pathnames, - a wrapper for LIST-DIRECTORY (that NCONCs the direct subdirectories of the directory to the output of LIST-DIRECTORY if it is called with a wild pathname), - and does some minor changes to COM-SHOW-DIRECTORY. Also it removes the SB-POSIX LIST-DIRECTORY for SBCL as that one completely ignores the pathname-name and -type, which renders it quite useless for :wild searches (pune or play on words intended). There was a short discussion about this patch in #lisp some hourse ago. As a result the wrapper for LIST-DIRECTORY is now called LIST-DIRECTORY-WITH-ALL-DIRECT-SUBDIRECTORIES. And it will only used by COM-SHOW-DIRECTORY if its new keyword parameter :list-all-direct-subdirectories is specified as t (the default being nil). The discussion (included because of the removed posix code in the former SBCL version of LIST-DIRECTORY): 01:18 < mgr> hefner: Did you have a look at my listener patch? 01:19 < hefner> I did, it looked good 01:19 < mgr> hefner: You are not angry because it removes the posix stuff? :) 01:20 < hefner> mgr: did it? :) The posix stuff was horrible, terrible. 01:20 < mgr> hefner: So, you don't object if I commit it to the mcclim repository? 01:20 < hefner> mgr: no, go ahead 01:22 < mgr> hefner: Perhaps there should be a option to COM-SHOW-DIRECTORY to switch between using LIST-DIRECTORY and LIST-DIRECTORY-WITH-ALL-SUBDIRECTORIES? Perhaps the latter is not always desired.. 01:22 < hefner> mgr: :recursive t ? 01:23 < mgr> hefner: No, it's different. if you list "/tmp/*.list" all direct subdirectories of "/tmp/" will be listed as well, altough they do not match "*.lisp". 01:24 < hefner> ah.. 01:27 < hefner> mgr: hold on, you're just calling cl:directory? Isn't that going to explode on broken symlinks? 01:33 < mgr> hefner: Uhm, explode? not really, no. Why? Symlinks are just "resolved" on sbcl. That is if you select "/foo/bar" that is a symlink to "/baz/quux", you'll always get the latter even if you select the former one. 01:34 < gilberth> mgr: not so fast. I have major hassle with CMUCL and XEmacs silly lock symlinks. 01:34 < hefner> mgr: what if /baz/quux doesn't exist? I didn't write the aweful posix code for my health. 01:35 < gilberth> They point to silly stuff like "gilbert(a)morganit.local.6092" 01:36 < mgr> gilberth: Well, the listener did always do only #'directory for cmucl.. So, don't worry this does not affect you. :) 01:36 < gilberth> great. 01:37 < hefner> not only #'directory, but (directory pathname :truenamep nil) 01:39 < gilberth> mgr: It must use the right keyword options to #'directory in CMUCL or something, since it works with borken symlinks. 01:39 < gilberth> it even shows a particular icon for the broken symlink. 01:39 < hefner> does it? that's a nice touch. 01:40 < gilberth> hefner: I thought you would know? 01:40 < hefner> I guess I forgot. 01:45 < mgr> hefner: there ist no problem with them. they will not be resolved, that is #p"/foo/bar" will be returned. it will be displayed as an invalid pathname because probe-file returns nil. 01:46 < hefner> mgr: I guess the behaviour changed. SBCL of 1.5 years ago didn't do that. Carry on. :) 01:47 < mgr> hefner: Also the posix version completely ignores the pathname-name and -type, and that's really not nice. 01:47 < hefner> well, pathname-name and pathname-type aren't nice either 01:47 < hefner> pathnames aren't nice 01:47 < mgr> hefner: Well, that's a different problem. 01:48 < mgr> hefner: I'll include this short discussion into the commit message, okay? :) 01:48 < hefner> okay Date: Wed Aug 31 07:50:38 2005 Author: mretzlaff Index: mcclim/Apps/Listener/dev-commands.lisp diff -u mcclim/Apps/Listener/dev-commands.lisp:1.29 mcclim/Apps/Listener/dev-commands.lisp:1.30 --- mcclim/Apps/Listener/dev-commands.lisp:1.29 Thu Apr 21 05:41:24 2005 +++ mcclim/Apps/Listener/dev-commands.lisp Wed Aug 31 07:50:37 2005 @@ -1028,7 +1028,9 @@ (terpri stream)) (defun sort-pathnames (list sort-by) - list) ; <--- FIXME + (case sort-by ; <--- FIXME + ('name (sort list #'string-lessp :key #'file-namestring)) + (t list))) (defun split-sort-pathnames (list group-dirs sort-by) (mapcar (lambda (x) (sort-pathnames x sort-by)) @@ -1064,31 +1066,37 @@ :provide-output-destination-keyword t) ((pathname 'pathname #+nil(or 'string 'pathname) :prompt "pathname") &key - #+NIL (sort-by '(member name size modify none) :default 'name) + (sort-by '(member name size modify none) :default 'name) (show-hidden 'boolean :default nil :prompt "show hidden") (hide-garbage 'boolean :default T :prompt "hide garbage") (show-all 'boolean :default nil :prompt "show all") (style '(member items list) :default 'items :prompt "listing style") (group-directories 'boolean :default T :prompt "group directories?") - (full-names 'boolean :default nil :prompt "show full name?")) + (full-names 'boolean :default nil :prompt "show full name?") + (list-all-direct-subdirectories 'boolean :default nil :prompt "list all direct subdirectories?")) (let* ((pathname (if (wild-pathname-p pathname) ; Forgot why I did this.. (merge-pathnames pathname) pathname)) - (dir (list-directory (gen-wild-pathname pathname)))) + (wild-pathname (gen-wild-pathname pathname)) + (dir (if list-all-direct-subdirectories + (list-directory-with-all-direct-subdirectories wild-pathname) + (list-directory wild-pathname)))) (with-text-family (T :sans-serif) (invoke-as-heading (lambda () (format T "Directory contents of ") - (present pathname))) + (present (directory-namestring pathname) 'pathname) + (when (pathname-type pathname) + (format T " (only files of type ~a)" (pathname-type pathname))))) (when (parent-directory pathname) - (with-output-as-presentation (T (parent-directory pathname) 'clim:pathname) + (with-output-as-presentation (T (strip-filespec (parent-directory pathname)) 'clim:pathname) (draw-icon T (standard-icon "up-folder.xpm") :extra-spacing 3) (format T "Parent Directory~%"))) - (dolist (group (split-sort-pathnames dir group-directories :none #+NIL sort-by)) + (dolist (group (split-sort-pathnames dir group-directories sort-by)) (unless show-all (setf group (filter-garbage-pathnames group show-hidden hide-garbage))) (ecase style @@ -1105,7 +1113,8 @@ (goatee::reposition-stream-cursor *standard-output*) (vertical-gap T)) (list (dolist (ent group) - (let ((ent (merge-pathnames ent pathname))) ; This is for CMUCL, see above. (fixme!) + (let ((ent (merge-pathnames ent pathname))) ;; This is for CMUCL, see above. (fixme!) + ;; And breaks some things for SBCL.. (mgr) (pretty-pretty-pathname ent *standard-output* :long-name full-names))))))))) #+nil ; OBSOLETE Index: mcclim/Apps/Listener/file-types.lisp diff -u mcclim/Apps/Listener/file-types.lisp:1.7 mcclim/Apps/Listener/file-types.lisp:1.8 --- mcclim/Apps/Listener/file-types.lisp:1.7 Sun Nov 9 22:12:05 2003 +++ mcclim/Apps/Listener/file-types.lisp Wed Aug 31 07:50:37 2005 @@ -133,7 +133,8 @@ ;; ICON-OF is measurably slow here in CMUCL. Interesting.. (defmethod icon-of ((pathname pathname)) - (cond ((not (probe-file pathname)) (standard-icon "invalid.xpm")) + (cond ((wild-pathname-p pathname) (standard-icon "wild.xpm")) + ((not (probe-file pathname)) (standard-icon "invalid.xpm")) ((directoryp pathname) *folder-icon*) ;; FIXME: use inode mime types (T (let ((mime-class (find-class (pathname-mime-type pathname) nil))) (if mime-class Index: mcclim/Apps/Listener/util.lisp diff -u mcclim/Apps/Listener/util.lisp:1.17 mcclim/Apps/Listener/util.lisp:1.18 --- mcclim/Apps/Listener/util.lisp:1.17 Tue Feb 22 04:10:27 2005 +++ mcclim/Apps/Listener/util.lisp Wed Aug 31 07:50:37 2005 @@ -118,6 +118,8 @@ #+SBCL (defun list-directory (pathname) + (directory pathname) + #+nil ;; ugh. is too ughy. (mgr) (let* ((pathname (strip-filespec pathname)) ;; ugh. (dir (sb-posix:opendir pathname)) (list nil)) @@ -141,6 +143,19 @@ (defun list-directory (pathname) (directory pathname)) +;;; Calls LIST-DIRECTORY and appends the subdirectories of the directory +;;; PATHNAME to the output of LIST-DIRECTORY if PATHNAME is a wild pathname. + +(defun list-directory-with-all-direct-subdirectories (pathname) + (let ((file-list (list-directory pathname))) + (if (wild-pathname-p pathname) + (nconc file-list + (delete-if (lambda (directory) + (member directory file-list :test #'equal)) + (delete-if-not #'directoryp + (list-directory (gen-wild-pathname + (strip-filespec pathname)))))) + file-list))) ;;; A farce of a "portable" run-program, which grows as I need options from ;;; the CMUCL run-program.

1 0

[mcclim-cvs] CVS update: mcclim/panes.lisp
by mretzlaff＠common-lisp.net 30 Aug '05

30 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv15426 Modified Files: panes.lisp Log Message: Added a method PANE-BORDER that works just like PANE-VIEWPORT and PANE-SCROLLER, only for BORDER-PANEs. It is not in the spec, but so is the BORDER-PANE as a whole. (And, yes, I needed it.) In addition to this it changes the IFs in PANE-VIEWPORT and PANE-SCROLLER to WHENs (both had no else-forms). (Minor change: Five changes in the comments: The section titles of the different panes are made consistent. (Most of them were of the pattern "FOO PANE", only five of them "FOO-PANE"; as I liked the former pattern more, they are now all of that pattern.)) Date: Tue Aug 30 00:39:31 2005 Author: mretzlaff Index: mcclim/panes.lisp diff -u mcclim/panes.lisp:1.154 mcclim/panes.lisp:1.155 --- mcclim/panes.lisp:1.154 Fri Aug 19 04:20:35 2005 +++ mcclim/panes.lisp Tue Aug 30 00:39:31 2005 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.154 2005/08/19 02:20:35 rstrandh Exp $ +;;; $Id: panes.lisp,v 1.155 2005/08/29 22:39:31 mretzlaff Exp $ (in-package :clim-internals) @@ -795,7 +795,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; BASIC-PANE +;;; BASIC PANE (defclass basic-pane (;; layout-protocol-mixin standard-space-requirement-options-mixin @@ -957,7 +957,7 @@ (event window-manager-delete-event)) (frame-exit (pane-frame (event-sheet event)))) -;;;; UNMANAGED-TOP-LEVEL-SHEET-PANE +;;;; UNMANAGED-TOP-LEVEL-SHEET PANE (defclass unmanaged-top-level-sheet-pane (top-level-sheet-pane) () @@ -1643,7 +1643,7 @@ (- width border-width border-width) (- height border-width border-width))))) -;;; OUTLINED-PANE +;;; OUTLINED PANE ;; same as SPACING-PANE but a different default background. @@ -1654,7 +1654,7 @@ (defmacro outlining ((&rest options) &body contents) `(make-pane 'outlined-pane ,@options :contents (list ,@contents))) -;;; BORDER-PANE +;;; BORDER PANE ;; same as outlined-pane, but thickness is now called border-width. @@ -1667,6 +1667,11 @@ (defmacro bordering ((&rest options) &body contents) `(make-pane 'border-pane ,@options :contents (list ,@contents))) +(defmethod pane-border ((pane basic-pane)) + (let ((parent (sheet-parent pane))) + (when (and parent (typep parent 'border-pane)) + parent))) + ;;; RAISED PANE (defclass raised-pane (border-pane permanent-medium-sheet-output-mixin) @@ -1751,7 +1756,7 @@ (note-input-focus-changed (sheet-child pane) state)) ;;;; -;;;; SCROLLER-PANE +;;;; SCROLLER PANE ;;;; ;;; How scrolling is done @@ -2033,9 +2038,8 @@ (defmethod pane-viewport ((pane basic-pane)) (let ((parent (sheet-parent pane))) - (if (and parent (typep parent 'viewport-pane)) - parent - nil))) + (when (and parent (typep parent 'viewport-pane)) + parent))) ;;; Default for streams that aren't even panes. @@ -2051,7 +2055,7 @@ (defmethod pane-scroller ((pane basic-pane)) (let ((viewport (pane-viewport pane))) - (if viewport + (when viewport (sheet-parent viewport)))) (defmethod scroll-extent ((pane basic-pane) x y)

1 0

[mcclim-cvs] CVS update: mcclim/Tests/regions.lisp
by rstrandh＠common-lisp.net 26 Aug '05

26 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Tests In directory common-lisp.net:/tmp/cvs-serv30153/Tests Added Files: regions.lisp Log Message: Hopefully the beginning of a testing framework for McCLIM. Date: Fri Aug 26 21:58:38 2005 Author: rstrandh

1 0

[mcclim-cvs] CVS update: Directory change: mcclim/Tests
by rstrandh＠common-lisp.net 26 Aug '05

26 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Tests In directory common-lisp.net:/tmp/cvs-serv30107/Tests Log Message: Directory /project/mcclim/cvsroot/mcclim/Tests added to the repository Date: Fri Aug 26 21:56:59 2005 Author: rstrandh New directory mcclim/Tests added

1 0

[mcclim-cvs] CVS update: mcclim/dialog.lisp
by mretzlaff＠common-lisp.net 26 Aug '05

26 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv12901 Modified Files: dialog.lisp Log Message: (climi::frame-event-queue *application-frame*) as argument :INPUT-BUFFER to the call of OPEN-WINDOW-STREAM in WITH-STREAM-IN-OWN-WINDOW (was not specified previously). The ugly delay could be dropped, because no new process is created anymore. See http://common-lisp.net/pipermail/mcclim-devel/2005-August/004239.html for more information. (Thanks go to Christophe.) The parameter :LABEL to ACCEPTING-VALUES will now actually be used to label the newly created window if :OWN-WINDOW is true. Date: Fri Aug 26 02:32:56 2005 Author: mretzlaff Index: mcclim/dialog.lisp diff -u mcclim/dialog.lisp:1.21 mcclim/dialog.lisp:1.22 --- mcclim/dialog.lisp:1.21 Thu Aug 25 22:48:40 2005 +++ mcclim/dialog.lisp Fri Aug 26 02:32:56 2005 @@ -138,12 +138,13 @@ (defmacro with-stream-in-own-window ((&optional (stream '*query-io*) &rest further-streams) + (&optional label) &rest body) - `(let* ((,stream (open-window-stream)) + `(let* ((,stream (open-window-stream :label ,label + :input-buffer (climi::frame-event-queue *application-frame*))) ,@(mapcar (lambda (a-stream) (list a-stream stream)) further-streams)) - (sleep 0.1) ;; hackhack.. some delay to "ensure" that the window-stream ist opened (unwind-protect (progn ,@body) @@ -159,7 +160,7 @@ &body body) (declare (ignorable exit-boxes initially-select-query-identifier modify-initial-query resynchronize-every-pass resize-frame - align-prompts label scroll-bars + align-prompts scroll-bars x-position y-position width height command-table frame-class)) (setq stream (stream-designator-symbol stream '*standard-input*)) (with-gensyms (accepting-values-continuation) @@ -171,7 +172,9 @@ ,@args)) )) `(if ,own-window - (with-stream-in-own-window (,stream *standard-input* *standard-output*) ,return-form) + (with-stream-in-own-window (,stream *standard-input* *standard-output*) + (,label) + ,return-form) ,return-form)))) (defun invoke-accepting-values

2 2

[mcclim-cvs] CVS update: mcclim/dialog.lisp
by mretzlaff＠common-lisp.net 25 Aug '05

25 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv26547 Modified Files: dialog.lisp Log Message: A patch against the first bug a patch by me introduced to mcclim. Sorry, that shouldn't have happened.. At least it was only a bug in a feature that the patch introduced (displaying an ACCEPTING-VALUES dialog in its :OWN-WINDOW), and it affected only code that thoughtlessly relied of this new and still broken feature. (Broken because OPEN-WINDOW-STREAM doesn't really work yet. I think there has to be a (redisplay-frame-panes frame) or something like that in its event-loop (that is the function STANDALONE-EVENT-LOOP).) Date: Thu Aug 25 22:48:41 2005 Author: mretzlaff Index: mcclim/dialog.lisp diff -u mcclim/dialog.lisp:1.20 mcclim/dialog.lisp:1.21 --- mcclim/dialog.lisp:1.20 Fri Aug 19 02:48:25 2005 +++ mcclim/dialog.lisp Thu Aug 25 22:48:40 2005 @@ -170,9 +170,9 @@ #',accepting-values-continuation ,@args)) )) - (if own-window - `(with-stream-in-own-window (,stream *standard-input* *standard-output*) ,return-form) - return-form)))) + `(if ,own-window + (with-stream-in-own-window (,stream *standard-input* *standard-output*) ,return-form) + ,return-form)))) (defun invoke-accepting-values (stream body

1 0

[mcclim-cvs] CVS update: mcclim/presentation-defs.lisp
by mretzlaff＠common-lisp.net 25 Aug '05

25 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv23472 Modified Files: presentation-defs.lisp Log Message: This patch HANDLER-BINDs the ABORT-GESTURE condition to #'abort for the function ACCEPT in presentation-defs.lisp. ABORT-GESTURE is the condition that is signaled when any of the gestures in *ABORT-GESTURES* is read (in STREAM-READ-GESTURE). Right now *ABORT-GESTURES* contains only :abort on mcclim, which is a the keyboard gesture (#\c :control) (on Genera it contains #\Abort, the ABORT-key). I do not find explicitly in the clim specification that an ACCEPT should be aborted on an ABORT-GESTURE, but it seems to be the right thing (and I have to admit that I haven't been looking very hard). I did short tests with ACCEPTING-VALUES and it seems to behave correctly with this patch, i.e. the whole dialog will be aborted. But perhaps it would be nicer if, as long as a gadget of the dialog is selected, only the edit of that gadget were aborted. Date: Thu Aug 25 22:24:12 2005 Author: mretzlaff Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.45 mcclim/presentation-defs.lisp:1.46 --- mcclim/presentation-defs.lisp:1.45 Mon Aug 8 19:15:07 2005 +++ mcclim/presentation-defs.lisp Thu Aug 25 22:24:10 2005 @@ -664,71 +664,72 @@ display-default query-identifier activation-gestures additional-activation-gestures delimiter-gestures additional-delimiter-gestures)) - (let* ((real-type (expand-presentation-type-abbreviation type)) - (real-default-type (cond (default-type-p - (expand-presentation-type-abbreviation - default-type)) - ((or defaultp provide-default) - real-type) - (t nil))) - (real-history-type (cond ((null historyp) real-type) - ((null history) nil) - (t (expand-presentation-type-abbreviation - history)))) - (*recursive-accept-p* *recursive-accept-1-p*) - (*recursive-accept-1-p* t)) - (with-keywords-removed (rest-args (:stream)) - (when (or default-type-p defaultp) - (setf rest-args - (list* :default-type real-default-type rest-args))) - (when historyp - (setf rest-args (list* :history real-history-type rest-args))) - (cond ((and viewp (symbolp view)) - (setf rest-args - (list* :view (funcall #'make-instance view) rest-args))) - ((consp view) - (setf rest-args - (list* :view (apply #'make-instance view) rest-args)))) - ;; Presentation type history interaction. According to the spec, - ;; if provide-default is true, we take the default from the - ;; presentation history. In addition, we'll implement the Genera - ;; behavior of temporarily putting the default on the history - ;; stack so the user can conveniently suck it in. - (flet ((do-accept (args) - (apply #'stream-accept stream real-type args)) - (get-history () - (when real-history-type - (funcall-presentation-generic-function - presentation-type-history-for-stream - real-history-type stream)))) - (let* ((default-from-history (and (not defaultp) provide-default)) - (history (get-history)) - (results - (multiple-value-list - (if history - (let ((*active-history-type* real-history-type)) - (cond (defaultp - (with-object-on-history - (history default real-default-type) - (do-accept rest-args))) - (default-from-history - (multiple-value-bind - (history-default history-type) - (presentation-history-head history - real-default-type) - (do-accept (if history-type - (list* :default history-default - :default-type history-type - rest-args) - rest-args)))) - (t (do-accept rest-args)))) - (do-accept rest-args)))) - (results-history (get-history))) - (when results-history - (presentation-history-add results-history - (car results) - (cadr results))) - (values-list results)))))) + (handler-bind ((abort-gesture #'abort)) + (let* ((real-type (expand-presentation-type-abbreviation type)) + (real-default-type (cond (default-type-p + (expand-presentation-type-abbreviation + default-type)) + ((or defaultp provide-default) + real-type) + (t nil))) + (real-history-type (cond ((null historyp) real-type) + ((null history) nil) + (t (expand-presentation-type-abbreviation + history)))) + (*recursive-accept-p* *recursive-accept-1-p*) + (*recursive-accept-1-p* t)) + (with-keywords-removed (rest-args (:stream)) + (when (or default-type-p defaultp) + (setf rest-args + (list* :default-type real-default-type rest-args))) + (when historyp + (setf rest-args (list* :history real-history-type rest-args))) + (cond ((and viewp (symbolp view)) + (setf rest-args + (list* :view (funcall #'make-instance view) rest-args))) + ((consp view) + (setf rest-args + (list* :view (apply #'make-instance view) rest-args)))) + ;; Presentation type history interaction. According to the spec, + ;; if provide-default is true, we take the default from the + ;; presentation history. In addition, we'll implement the Genera + ;; behavior of temporarily putting the default on the history + ;; stack so the user can conveniently suck it in. + (flet ((do-accept (args) + (apply #'stream-accept stream real-type args)) + (get-history () + (when real-history-type + (funcall-presentation-generic-function + presentation-type-history-for-stream + real-history-type stream)))) + (let* ((default-from-history (and (not defaultp) provide-default)) + (history (get-history)) + (results + (multiple-value-list + (if history + (let ((*active-history-type* real-history-type)) + (cond (defaultp + (with-object-on-history + (history default real-default-type) + (do-accept rest-args))) + (default-from-history + (multiple-value-bind + (history-default history-type) + (presentation-history-head history + real-default-type) + (do-accept (if history-type + (list* :default history-default + :default-type history-type + rest-args) + rest-args)))) + (t (do-accept rest-args)))) + (do-accept rest-args)))) + (results-history (get-history))) + (when results-history + (presentation-history-add results-history + (car results) + (cadr results))) + (values-list results))))))) (defgeneric stream-accept (stream type &key

1 0

[mcclim-cvs] CVS update: mcclim/Experimental/freetype/freetype-ffi.lisp
by crhodes＠common-lisp.net 22 Aug '05

22 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory common-lisp.net:/tmp/cvs-serv12313 Modified Files: freetype-ffi.lisp Log Message: Make the Freetype FFI 32/64 agnostic. Untested on CMUCL, but I don't think the previous version worked on CMUCL either. Date: Mon Aug 22 11:28:35 2005 Author: crhodes Index: mcclim/Experimental/freetype/freetype-ffi.lisp diff -u mcclim/Experimental/freetype/freetype-ffi.lisp:1.2 mcclim/Experimental/freetype/freetype-ffi.lisp:1.3 --- mcclim/Experimental/freetype/freetype-ffi.lisp:1.2 Sun Jun 5 22:50:29 2005 +++ mcclim/Experimental/freetype/freetype-ffi.lisp Mon Aug 22 11:28:34 2005 @@ -1,6 +1,9 @@ ;;; automatically generated, hand tweaked, do not regenerate. -(DEFPACKAGE :FREETYPE (:USE :cl #+sbcl :sb-alien #+cmucl :alien) +(DEFPACKAGE :FREETYPE + (:USE :cl + #+sbcl :sb-alien + #+cmucl :alien #+cmucl :c-call) (:EXPORT "MEMORY-BASE" "DESCENDER" "LINEAR-VERT-ADVANCE" "YX" "XX" "FREE" "AVAILABLE-SIZES" "COVERAGE" "METRICS" "RASTER-FLAG" "GLYPH" "GET-CHAR-INDEX" "LIMIT" "STRING" "SHIFT" "LEN" "UNDERLINE-POSITION" "RASTER-NEW-FUNC" "POINTS" "TAG" "SIZE-INTERNAL" "NUM-SUBGLYPHS" "UNITS-PER-EM" "LIBRARY" "ALLOC" "OPEN-FACE" "ATTACH-FILE" @@ -37,8 +40,6 @@ "BITMAP-" "FILE_BASE" "KERN_MODE" "CHAR_CODE" "RENDERER-REC-" "RASTER-REC-" "VECTOR-" "SIZE-METRICS-" "CHAR_WIDTH" "GENERIC-" "ENCODING-" "FACE_INDEX" "SLOT" "GLYPH-FORMAT-" "OPEN-ARGS-" "BBOX-" "SIZE_S")) -;;(declaim (sb-ext:muffle-conditions sb-int:deprecation-warning)) - (in-package :freetype) #+cmucl @@ -75,6 +76,52 @@ (define-alien-type freetype:ufast (unsigned 32)) +(define-alien-type freetype:ptrdiff-t (signed 32)) + +(define-alien-type freetype:size-t (unsigned 32)) + +(define-alien-type freetype:wchar-t (signed 32)) + +(define-alien-type freetype:wint-t (unsigned 32)) + +(define-alien-type freetype:bool (unsigned 8)) + +(define-alien-type freetype:fword (signed 16)) + +(define-alien-type freetype:ufword (unsigned 16)) + +(define-alien-type freetype:char (signed 8)) + +(define-alien-type freetype:byte (unsigned 8)) + +(define-alien-type freetype:string (signed 8)) + +(define-alien-type freetype:short (signed 16)) + +(define-alien-type freetype:ushort (unsigned 16)) + +(define-alien-type freetype:int (signed 32)) + +(define-alien-type freetype:uint (unsigned 32)) + +(define-alien-type freetype:long long) + +(define-alien-type freetype:ulong unsigned-long) + +(define-alien-type freetype:f2dot14 (signed 16)) + +(define-alien-type freetype:f26dot6 long) + +(define-alien-type freetype:fixed long) + +(define-alien-type freetype:error (signed 32)) + +(define-alien-type freetype:pointer (* t)) + +(define-alien-type freetype:offset freetype:size-t) + +(define-alien-type freetype:ptr-dist freetype:size-t) + (define-alien-type nil (enum nil (:mod-err-base #.#x000) (:mod-err-autohint #.#x100) (:mod-err-cache #.#x200) (:mod-err-cff #.#x300) (:mod-err-cid #.#x400) (:mod-err-pcf #.#x500) (:mod-err-psaux #.#x600) (:mod-err-psnames #.#x700) (:mod-err-raster #.#x800) @@ -118,7 +165,10 @@ (struct freetype::memory-rec- (freetype:user (* t)) (freetype:alloc freetype:alloc-func) (freetype:free freetype:free-func) (freetype:realloc freetype:realloc-func))) -(define-alien-type freetype:stream-desc (union freetype::stream-desc- (freetype:value (signed 32)) (freetype:pointer (* t)))) +(define-alien-type freetype:stream-desc + (union freetype::stream-desc- + (freetype:value long) + (freetype:pointer (* t)))) (define-alien-type freetype:stream-io (* t)) @@ -127,8 +177,8 @@ (define-alien-type nil (struct freetype::stream-rec- (freetype:base (* (unsigned 8))) - (freetype:size (unsigned 32)) - (freetype:pos (unsigned 32)) + (freetype:size freetype:ulong) + (freetype:pos freetype:ulong) (freetype:descriptor freetype:stream-desc) (freetype:pathname freetype:stream-desc) (freetype:read freetype:stream-io) @@ -137,7 +187,7 @@ (freetype:cursor (* (unsigned 8))) (freetype:limit (* (unsigned 8))))) -(define-alien-type freetype:pos (signed 32)) +(define-alien-type freetype:pos long) (define-alien-type freetype:vector (struct freetype::vector- (freetype:x freetype:pos) (freetype:y freetype:pos))) @@ -229,52 +279,6 @@ (freetype:raster-reset freetype:raster-reset-func) (freetype:raster-set-mode freetype:raster-set-mode-func) (freetype:raster-render freetype:raster-render-func) (freetype:raster-done freetype:raster-done-func))) -(define-alien-type freetype:ptrdiff-t (signed 32)) - -(define-alien-type freetype:size-t (unsigned 32)) - -(define-alien-type freetype:wchar-t (signed 32)) - -(define-alien-type freetype:wint-t (unsigned 32)) - -(define-alien-type freetype:bool (unsigned 8)) - -(define-alien-type freetype:fword (signed 16)) - -(define-alien-type freetype:ufword (unsigned 16)) - -(define-alien-type freetype:char (signed 8)) - -(define-alien-type freetype:byte (unsigned 8)) - -(define-alien-type freetype:string (signed 8)) - -(define-alien-type freetype:short (signed 16)) - -(define-alien-type freetype:ushort (unsigned 16)) - -(define-alien-type freetype:int (signed 32)) - -(define-alien-type freetype:uint (unsigned 32)) - -(define-alien-type freetype:long (signed 32)) - -(define-alien-type freetype:ulong (unsigned 32)) - -(define-alien-type freetype:f2dot14 (signed 16)) - -(define-alien-type freetype:f26dot6 (signed 32)) - -(define-alien-type freetype:fixed (signed 32)) - -(define-alien-type freetype:error (signed 32)) - -(define-alien-type freetype:pointer (* t)) - -(define-alien-type freetype:offset freetype:size-t) - -(define-alien-type freetype:ptr-dist freetype:size-t) - (define-alien-type freetype:unit-vector (struct freetype::unit-vector- (freetype:x freetype:f2dot14) (freetype:y freetype:f2dot14))) @@ -310,7 +314,7 @@ (freetype:linear-vert-advance freetype:fixed) (freetype:advance freetype:vector) (freetype:format freetype:glyph-format) (freetype:bitmap freetype:bitmap) (freetype:bitmap-left freetype:int) (freetype:bitmap-top freetype:int) (freetype:outline freetype:outline) (freetype:num-subglyphs freetype:uint) (freetype:subglyphs (* freetype:sub-glyph)) - (freetype:control-data (* t)) (freetype:control-len (signed 32)) (freetype:other (* t)) + (freetype:control-data (* t)) (freetype:control-len long) (freetype:other (* t)) (freetype:internal freetype:slot-internal))) (define-alien-type freetype:size-metrics @@ -347,7 +351,7 @@ (freetype:linear-vert-advance freetype:fixed) (freetype:advance freetype:vector) (freetype:format freetype:glyph-format) (freetype:bitmap freetype:bitmap) (freetype:bitmap-left freetype:int) (freetype:bitmap-top freetype:int) (freetype:outline freetype:outline) (freetype:num-subglyphs freetype:uint) (freetype:subglyphs (* freetype:sub-glyph)) - (freetype:control-data (* t)) (freetype:control-len (signed 32)) (freetype:other (* t)) + (freetype:control-data (* t)) (freetype:control-len long) (freetype:other (* t)) (freetype:internal freetype:slot-internal))) (define-alien-type freetype:glyph-slot (* freetype:glyph-slot-rec))

1 0

[mcclim-cvs] CVS update: mcclim/Doc/manual.tex
by rstrandh＠common-lisp.net 22 Aug '05

22 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Doc In directory common-lisp.net:/tmp/cvs-serv18523 Modified Files: manual.tex Log Message: Fixed the figure of the example application according to a mail from Dan Barlow in July of 2003. Date: Mon Aug 22 04:49:06 2005 Author: rstrandh Index: mcclim/Doc/manual.tex diff -u mcclim/Doc/manual.tex:1.30 mcclim/Doc/manual.tex:1.31 --- mcclim/Doc/manual.tex:1.30 Sun Aug 14 08:20:12 2005 +++ mcclim/Doc/manual.tex Mon Aug 22 04:49:05 2005 @@ -394,7 +394,8 @@ \begin{figure} \begin{center} -\includegraphics{ex2} +\epsfxsize=5in +\epsffile{ex2.eps} \end{center} \caption{\label{figex2} View of the improved example} \end{figure}

1 0

[mcclim-cvs] CVS update: mcclim/Lisp-Dep/fix-sbcl.lisp
by crhodes＠common-lisp.net 19 Aug '05

19 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Lisp-Dep In directory common-lisp.net:/tmp/cvs-serv32041/Lisp-Dep Modified Files: fix-sbcl.lisp Log Message: SBCL / OpenMCL(?) build fixes Fix the perennially annoying duplicate component error in the Scigraph defsystem (name the components by the full namestring, which should be unique) While I'm at it, fix the annoyance over static / dynamic packages: for sbcl, clim-lisp-patch and clim-mop are dynamic packages, so they shouldn't be created by DEFPACKAGE (because reevaluating the defpackage subsequently, say by recompiling stuff, then invokes undefined behaviour) Date: Fri Aug 19 23:34:43 2005 Author: crhodes Index: mcclim/Lisp-Dep/fix-sbcl.lisp diff -u mcclim/Lisp-Dep/fix-sbcl.lisp:1.8 mcclim/Lisp-Dep/fix-sbcl.lisp:1.9 --- mcclim/Lisp-Dep/fix-sbcl.lisp:1.8 Mon Feb 23 11:48:28 2004 +++ mcclim/Lisp-Dep/fix-sbcl.lisp Fri Aug 19 23:34:43 2005 @@ -2,10 +2,11 @@ (when (find-package "SB-MOP") (pushnew :sb-mop *features*))) -(defpackage #:clim-mop - (:use #+sb-mop #:sb-mop #-sb-mop #:sb-pcl) - #-sb-mop - (:shadowing-import-from #:sb-pcl #:eql-specializer-object)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find-package '#:clim-mop) + (make-package '#:clim-mop :use '(#+sb-mop #:sb-mop + #-sb-mop #:sb-pcl)) + (shadowing-import 'sb-pcl::eql-specializer-object '#:clim-mop))) (eval-when (:compile-toplevel :load-toplevel :execute) (loop for sym being the symbols of :clim-mop

1 0

[mcclim-cvs] CVS update: mcclim/mcclim.asd mcclim/patch.lisp
by crhodes＠common-lisp.net 19 Aug '05

19 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv32041 Modified Files: mcclim.asd patch.lisp Log Message: SBCL / OpenMCL(?) build fixes Fix the perennially annoying duplicate component error in the Scigraph defsystem (name the components by the full namestring, which should be unique) While I'm at it, fix the annoyance over static / dynamic packages: for sbcl, clim-lisp-patch and clim-mop are dynamic packages, so they shouldn't be created by DEFPACKAGE (because reevaluating the defpackage subsequently, say by recompiling stuff, then invokes undefined behaviour) Date: Fri Aug 19 23:34:42 2005 Author: crhodes Index: mcclim/mcclim.asd diff -u mcclim/mcclim.asd:1.5 mcclim/mcclim.asd:1.6 --- mcclim/mcclim.asd:1.5 Wed Apr 20 00:35:42 2005 +++ mcclim/mcclim.asd Fri Aug 19 23:34:41 2005 @@ -78,7 +78,7 @@ (parse-namestring c) (make-pathname :type "lisp" :defaults *clim-directory*)) - collect `(:file ,(pathname-name p) :pathname ,p)))))) + collect `(:file ,(namestring p) :pathname ,p)))))) (defsystem :clim-lisp :components Index: mcclim/patch.lisp diff -u mcclim/patch.lisp:1.4 mcclim/patch.lisp:1.5 --- mcclim/patch.lisp:1.4 Mon Nov 15 05:47:41 2004 +++ mcclim/patch.lisp Fri Aug 19 23:34:41 2005 @@ -1,6 +1,10 @@ (in-package :cl-user) -(defpackage :clim-lisp-patch - (:use) - (:export #:describe #:describe-object #:interactive-stream-p)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find-package :clim-lisp-patch) + (make-package :clim-lisp-patch :use nil))) +(export '(clim-lisp-patch::describe + clim-lisp-patch::describe-object + clim-lisp-patch::interactive-stream-p) + :clim-lisp-patch)

1 0

[mcclim-cvs] CVS update: mcclim/panes.lisp
by rstrandh＠common-lisp.net 19 Aug '05

19 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv19958 Modified Files: panes.lisp Log Message: Patch to panes.lisp from Max-Gerd Retzlaff. Date: Fri Aug 19 04:20:35 2005 Author: rstrandh Index: mcclim/panes.lisp diff -u mcclim/panes.lisp:1.153 mcclim/panes.lisp:1.154 --- mcclim/panes.lisp:1.153 Wed Jun 22 11:49:15 2005 +++ mcclim/panes.lisp Fri Aug 19 04:20:35 2005 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.153 2005/06/22 09:49:15 tmoore Exp $ +;;; $Id: panes.lisp,v 1.154 2005/08/19 02:20:35 rstrandh Exp $ (in-package :clim-internals) @@ -2591,6 +2591,7 @@ #+clim-mp (unless input-buffer (clim-sys:make-process (lambda () (let ((*application-frame* frame)) + (redisplay-frame-panes frame :force-p t) (standalone-event-loop))))) (slot-value frame 'stream)))

1 0

[mcclim-cvs] CVS update: mcclim/dialog.lisp
by rstrandh＠common-lisp.net 19 Aug '05

19 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv14088 Modified Files: dialog.lisp Log Message: Patches to dialog.lisp from Max-Gerd Retzlaff. Date: Fri Aug 19 02:48:26 2005 Author: rstrandh Index: mcclim/dialog.lisp diff -u mcclim/dialog.lisp:1.19 mcclim/dialog.lisp:1.20 --- mcclim/dialog.lisp:1.19 Fri Feb 25 15:15:17 2005 +++ mcclim/dialog.lisp Fri Aug 19 02:48:25 2005 @@ -136,6 +136,19 @@ (defvar *accepting-values-stream* nil) +(defmacro with-stream-in-own-window ((&optional (stream '*query-io*) + &rest further-streams) + &rest body) + `(let* ((,stream (open-window-stream)) + ,@(mapcar (lambda (a-stream) + (list a-stream stream)) + further-streams)) + (sleep 0.1) ;; hackhack.. some delay to "ensure" that the window-stream ist opened + (unwind-protect + (progn + ,@body) + (close ,stream)))) + (defmacro accepting-values ((&optional (stream t) &rest args @@ -144,17 +157,22 @@ align-prompts label scroll-bars x-position y-position width height command-table frame-class) &body body) - (declare (ignorable own-window exit-boxes initially-select-query-identifier + (declare (ignorable exit-boxes initially-select-query-identifier modify-initial-query resynchronize-every-pass resize-frame align-prompts label scroll-bars x-position y-position width height command-table frame-class)) (setq stream (stream-designator-symbol stream '*standard-input*)) (with-gensyms (accepting-values-continuation) - `(flet ((,accepting-values-continuation (,stream) - ,@body)) - (invoke-accepting-values ,stream - #',accepting-values-continuation - ,@args)))) + (let ((return-form + `(flet ((,accepting-values-continuation (,stream) + ,@body)) + (invoke-accepting-values ,stream + #',accepting-values-continuation + ,@args)) + )) + (if own-window + `(with-stream-in-own-window (,stream *standard-input* *standard-output*) ,return-form) + return-form)))) (defun invoke-accepting-values (stream body @@ -167,7 +185,10 @@ (frame-class 'accept-values)) (declare (ignore own-window exit-boxes modify-initial-query resize-frame label scroll-bars x-position y-position - width height frame-class)) + width height frame-class)) + (when (and align-prompts ;; t means the same as :right + (not (eq align-prompts :left))) + (setf align-prompts :right)) (multiple-value-bind (cx cy) (stream-cursor-position stream) (let* ((*accepting-values-stream* (make-instance 'accepting-values-stream @@ -224,11 +245,11 @@ (fresh-line stream) (with-output-as-presentation (stream nil 'exit-button) - (format stream "Exit")) + (format stream "OK")) (write-char #\space stream) (with-output-as-presentation (stream nil 'abort-button) - (format stream "Abort")) + (format stream "Cancel")) (terpri stream))) (defmethod stream-accept ((stream accepting-values-stream) type

1 0

[mcclim-cvs] CVS update: mcclim/design.lisp mcclim/ports.lisp
by rstrandh＠common-lisp.net 18 Aug '05

18 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv26220 Modified Files: design.lisp ports.lisp Log Message: Removed a few compiler warnings. Date: Thu Aug 18 21:58:18 2005 Author: rstrandh Index: mcclim/design.lisp diff -u mcclim/design.lisp:1.23 mcclim/design.lisp:1.24 --- mcclim/design.lisp:1.23 Wed Oct 6 07:12:12 2004 +++ mcclim/design.lisp Thu Aug 18 21:58:18 2005 @@ -89,6 +89,8 @@ (define-protocol-class color (design uniform-design)) +(defgeneric color-rgb (color)) + (defmethod print-object ((color color) stream) (print-unreadable-object (color stream :identity nil :type t) (multiple-value-call #'format stream "~,4F ~,4F ~,4F" (color-rgb color)))) @@ -239,6 +241,8 @@ (saturation (atan f2 f1))) (values intensity hue saturation))))) +(defgeneric color-ihs (color)) + (defmethod color-ihs ((color color)) (multiple-value-call #'rgb-to-ihs (color-rgb color))) @@ -354,6 +358,8 @@ (print-unreadable-object (flipper stream :identity nil :type t) (format stream "~S ~S" design1 design2)))) +(defgeneric make-flipping-ink (design1 design2)) + (defmethod make-flipping-ink ((design1 design) (design2 design)) (make-instance 'standard-flipping-ink :design1 design1 :design2 design2)) @@ -396,9 +402,13 @@ (defun make-pattern (array designs) (make-instance 'indexed-pattern :array array :designs designs)) +(defgeneric pattern-width (pattern)) + (defmethod pattern-width ((pattern indexed-pattern)) (with-slots (array) pattern (array-dimension array 1))) + +(defgeneric pattern-height (pattern)) (defmethod pattern-height ((pattern indexed-pattern)) (with-slots (array) pattern Index: mcclim/ports.lisp diff -u mcclim/ports.lisp:1.48 mcclim/ports.lisp:1.49 --- mcclim/ports.lisp:1.48 Tue Feb 22 04:14:26 2005 +++ mcclim/ports.lisp Thu Aug 18 21:58:18 2005 @@ -92,6 +92,9 @@ ;; A method on (SETF KEYBOARD-INPUT-FOCUS) brings them together, ;; calling %SET-PORT-KEYBOARD-FOCUS. +(defgeneric port-keyboard-input-focus (port)) +(defgeneric (setf port-keyboard-input-focus) (focus port)) + (defmethod port-keyboard-input-focus (port) (declare (ignore port)) (when *application-frame* @@ -107,7 +110,7 @@ ;; now calls (setf keyboard-input-focus), we need something concrete the ;; backend can implement to set the focus. (defmethod %set-port-keyboard-focus (port focus &key timestamp) - (declare (ignore focus)) + (declare (ignore focus timestamp)) (warn "%SET-PORT-KEYBOARD-FOCUS is not implemented on ~W" port))

1 0

[mcclim-cvs] CVS update: mcclim/commands.lisp
by rstrandh＠common-lisp.net 18 Aug '05

18 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv28655 Modified Files: commands.lisp Log Message: Patch from Max-Gerd Retzlaff Date: Thu Aug 18 06:30:11 2005 Author: rstrandh Index: mcclim/commands.lisp diff -u mcclim/commands.lisp:1.53 mcclim/commands.lisp:1.54 --- mcclim/commands.lisp:1.53 Wed Jun 22 13:41:35 2005 +++ mcclim/commands.lisp Thu Aug 18 06:30:09 2005 @@ -746,30 +746,36 @@ ;; We don't need fresh gensyms of these variables for each accept form. (with-gensyms (value ptype changedp) `(defun ,name (,command-table ,stream ,partial-command) - (destructuring-bind (,command-name ,@original-args) - ,partial-command - (let ((,command-line-name (command-line-name-for-command - ,command-name - ,command-table - :errorp nil)) - ,@(mapcar #'list required-arg-names original-args)) - (accepting-values (,stream) - (format ,stream - "You are being prompted for arguments to ~S~%" - ,command-line-name) - ,@(loop - for var in required-arg-names - for original-var in original-args - for parameter in required-args - append `((multiple-value-bind (,value ,ptype ,changedp) - ,(accept-form-for-argument-partial - stream parameter var original-var) - (declare (ignore ,ptype)) - (terpri ,stream) - (when ,changedp - (setq ,var ,value)))))) - (list ,command-name ,@required-arg-names)))))))) - + (do ((still-missing nil t)) + (nil) + (destructuring-bind (,command-name ,@original-args) + ,partial-command + (let ((,command-line-name (command-line-name-for-command + ,command-name + ,command-table + :errorp nil)) + ,@(mapcar #'list required-arg-names original-args)) + (accepting-values (,stream) + (format ,stream + "You are being prompted for arguments to ~S~%~%" + ,command-line-name) + ,@(loop + for var in required-arg-names + for original-var in original-args + for parameter in required-args + append `((multiple-value-bind (,value ,ptype ,changedp) + ,(accept-form-for-argument-partial + stream parameter var original-var) + (declare (ignore ,ptype)) + (terpri ,stream) + (when ,changedp + (setq ,var ,value))))) + (when still-missing + (format ,stream + "~&Please supply all arguments."))) + (setf ,partial-command (list ,command-name ,@required-arg-names)) + (unless (partial-command-p ,partial-command) + (return ,partial-command)))))))))) ;;; XXX What do to about :acceptably? Probably need to wait for Goatee "buffer ;;; streams" so we can insert an accept-result-extent in the buffer for @@ -1079,7 +1085,6 @@ stream (view textual-view) &key) - (declare (ignore acceptably for-context-type)) (let ((command-line-name (command-line-name-for-command object command-table :errorp nil))) (if command-line-name

1 0

[mcclim-cvs] CVS update: mcclim/Examples/town-example.lisp
by rstrandh＠common-lisp.net 18 Aug '05

18 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Examples In directory common-lisp.net:/tmp/cvs-serv24274 Added Files: town-example.lisp Log Message: Another example of the use of CLIM. (thanks to Max-Gerd Retzlaff) It tries to demonstrate the following topics: custom view classes, different present presentation methods for different views, completion for accept presentation methods, accepting-values dialogues, presentation to command translators, partial commands in menus, automatically generated menus, and keystroke gestures for commands. Date: Thu Aug 18 05:25:31 2005 Author: rstrandh

1 0

[mcclim-cvs] CVS update: mcclim/frames.lisp mcclim/incremental-redisplay.lisp
by rstrandh＠common-lisp.net 18 Aug '05

18 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv24177 Modified Files: frames.lisp incremental-redisplay.lisp Log Message: Initial cleanups to incremental redisplay. Date: Thu Aug 18 05:17:22 2005 Author: rstrandh Index: mcclim/frames.lisp diff -u mcclim/frames.lisp:1.107 mcclim/frames.lisp:1.108 --- mcclim/frames.lisp:1.107 Sun Apr 17 20:46:26 2005 +++ mcclim/frames.lisp Thu Aug 18 05:17:21 2005 @@ -484,25 +484,6 @@ (:disowned (disown-frame fm frame))))))) -;;; Defined in incremental-redisplay.lisp -(defvar *enable-updating-output*) - -#+nil -(defun redisplay-changed-panes (frame) - (map-over-sheets #'(lambda (pane) - (multiple-value-bind (redisplayp clearp) - (pane-needs-redisplay pane) - (when redisplayp - (when (and clearp - (or (not (pane-incremental-redisplay - pane)) - (not *enable-updating-output*))) - (window-clear pane)) - (redisplay-frame-pane frame pane) - (unless (eq redisplayp :command-loop) - (setf (pane-needs-redisplay pane) nil))))) - (frame-top-level-sheet frame))) - (defparameter +default-prompt-style+ (make-text-style :fix :italic :normal)) (defmethod default-frame-top-level Index: mcclim/incremental-redisplay.lisp diff -u mcclim/incremental-redisplay.lisp:1.51 mcclim/incremental-redisplay.lisp:1.52 --- mcclim/incremental-redisplay.lisp:1.51 Tue Aug 16 06:30:37 2005 +++ mcclim/incremental-redisplay.lisp Thu Aug 18 05:17:21 2005 @@ -245,8 +245,7 @@ (defmethod pane-needs-redisplay :around ((pane updating-output-stream-mixin)) (let ((redisplayp (call-next-method))) (values redisplayp (and (not (eq redisplayp :no-clear)) - (or (not (pane-incremental-redisplay pane)) - (not *enable-updating-output*)))))) + (not (pane-incremental-redisplay pane)))))) (defmethod window-clear :after ((pane updating-output-stream-mixin)) "Get rid of any updating output records stored in the stream; they're gone @@ -850,9 +849,6 @@ ;; move overlapping nil))))) -(defparameter *enable-updating-output* t - "Switch to turn on incremental redisplay") - (defvar *trace-updating-output* nil) (defvar *no-unique-id* (cons nil nil)) @@ -874,8 +870,6 @@ unique-id id-test cache-value cache-test &key (fixed-position nil) (all-new nil) (parent-cache nil)) - (unless *enable-updating-output* - (return-from invoke-updating-output (funcall continuation stream))) (finish-output stream) (let ((parent-cache (or parent-cache *current-updating-output* stream))) (when (eq unique-id *no-unique-id*) @@ -991,16 +985,6 @@ (defvar *dump-updating-output* nil) -;;; Protocol for notifying that records have been added or deleted, -;;; for real, during redisplay. - -(defgeneric redisplay-add-output-record (record stream) - (:documentation "Process an output record that has been added (i.e., - was not in the output history of the stream) during redisplay. The - record has not been displayed yet.")) - -(defgeneric redisplay-delete-output-record (record bounding-rectangle stream)) - (defgeneric redisplay-output-record (record stream &optional check-overlapping)) @@ -1032,30 +1016,6 @@ (delete-stale-updating-output record)) (set-medium-graphics-state current-graphics-state stream))))) -(defmethod redisplay-add-output-record (record - (stream updating-output-stream-mixin)) - (with-bounding-rectangle* (x1 y1 x2 y2) - record - (draw-rectangle* stream x1 y1 x2 y2 - :ink +background-ink+))) - -(defmethod redisplay-add-output-record :after - (record (stream updating-output-stream-mixin)) - (note-output-record-got-sheet record stream)) - -(defmethod redisplay-delete-output-record - (record bounding-rectangle (stream updating-output-stream-mixin)) - (declare (ignore record)) - (with-bounding-rectangle* (x1 y1 x2 y2) - bounding-rectangle - (draw-rectangle* stream x1 y1 x2 y2 - :ink +background-ink+))) - -(defmethod redisplay-delete-output-record :after - (record bounding-rectangle (stream updating-output-stream-mixin)) - (declare (ignore bounding-rectangle)) - (note-output-record-lost-sheet record stream)) - (defun erase-rectangle (stream bounding) (with-bounding-rectangle* (x1 y1 x2 y2) bounding @@ -1244,7 +1204,7 @@ ((frame application-frame) (pane updating-output-stream-mixin) &key force-p) (setf (id-counter pane) 0) (let ((incremental-redisplay (pane-incremental-redisplay pane))) - (cond ((or (not incremental-redisplay) (not *enable-updating-output*)) + (cond ((not incremental-redisplay) (call-next-method)) ((or (null (updating-record pane)) force-p)

1 0

[mcclim-cvs] CVS update: mcclim/incremental-redisplay.lisp
by rstrandh＠common-lisp.net 16 Aug '05

16 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv26736 Modified Files: incremental-redisplay.lisp Log Message: Fixed a bug in function-matches-p. It should use symbol-function and not symbol-value. Date: Tue Aug 16 06:30:37 2005 Author: rstrandh Index: mcclim/incremental-redisplay.lisp diff -u mcclim/incremental-redisplay.lisp:1.50 mcclim/incremental-redisplay.lisp:1.51 --- mcclim/incremental-redisplay.lisp:1.50 Mon Aug 15 02:41:38 2005 +++ mcclim/incremental-redisplay.lisp Tue Aug 16 06:30:37 2005 @@ -124,9 +124,9 @@ ((and (symbolp map-test-func) (symbolp func)) ; not eq nil) ((and (symbolp map-test-func) (fboundp map-test-func)) - (eq (symbol-value map-test-func) func)) + (eq (symbol-function map-test-func) func)) ((and (symbolp func) (fboundp func)) - (eq map-test-func (symbol-value func))) + (eq map-test-func (symbol-function func))) (t nil)))) (defun ensure-test (map test)

1 0

[mcclim-cvs] CVS update: mcclim/incremental-redisplay.lisp
by tmoore＠common-lisp.net 15 Aug '05

15 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv9635 Modified Files: incremental-redisplay.lisp Log Message: Change specialized output-record-hash method to specialize on standard-bounding-rectangle, as noted by Taylor Campbell Date: Mon Aug 15 02:41:38 2005 Author: tmoore Index: mcclim/incremental-redisplay.lisp diff -u mcclim/incremental-redisplay.lisp:1.49 mcclim/incremental-redisplay.lisp:1.50 --- mcclim/incremental-redisplay.lisp:1.49 Tue Aug 9 22:30:12 2005 +++ mcclim/incremental-redisplay.lisp Mon Aug 15 02:41:38 2005 @@ -715,7 +715,7 @@ (:documentation "Produce a value that can be used to hash the output record in an equalp hash table")) -(defmethod output-record-hash ((record basic-output-record)) +(defmethod output-record-hash ((record standard-bounding-rectangle)) (slot-value record 'coordinates)) (defconstant +fixnum-bits+ (integer-length most-positive-fixnum))

1 0

[mcclim-cvs] CVS update: mcclim/Backends/CLX/medium.lisp
by crhodes＠common-lisp.net 14 Aug '05

14 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv27374/Backends/CLX Modified Files: medium.lisp Log Message: Whoops. Forgot to commit this one. (Thanks to Peter Mechlenborg) Date: Sun Aug 14 14:47:42 2005 Author: crhodes Index: mcclim/Backends/CLX/medium.lisp diff -u mcclim/Backends/CLX/medium.lisp:1.66 mcclim/Backends/CLX/medium.lisp:1.67 --- mcclim/Backends/CLX/medium.lisp:1.66 Thu Feb 17 22:23:29 2005 +++ mcclim/Backends/CLX/medium.lisp Sun Aug 14 14:47:42 2005 @@ -827,6 +827,47 @@ direction first-not-done)) (values width (+ ascent descent) width 0 ascent)) )))))) ) +#-unicode +(defmethod climi::text-bounding-rectangle* + ((medium clx-medium) string &key text-style (start 0) end) + (when (characterp string) + (setf string (make-string 1 :initial-element string))) + (unless end (setf end (length string))) + (unless text-style (setf text-style (medium-text-style medium))) + (let ((xfont (text-style-to-X-font (port medium) text-style))) + (cond ((= start end) + (values 0 0 0 0)) + (t + (let ((position-newline (position #\newline string :start start))) + (cond ((not (null position-newline)) + (multiple-value-bind (width ascent descent left right + font-ascent font-descent direction + first-not-done) + (xlib:text-extents xfont string + :start start :end position-newline + :translate #'translate) + (declare (ignorable left right + font-ascent font-descent + direction first-not-done)) + (multiple-value-bind (minx miny maxx maxy) + (text-bounding-rectangle* + medium string :text-style text-style + :start (1+ position-newline) :end end) + (values (min minx left) (- ascent) + (max maxx right) (+ descent maxy))))) + (t + (multiple-value-bind (width ascent descent left right + font-ascent font-descent direction + first-not-done) + (xlib:text-extents xfont string + :start start :end end + :translate #'translate) + (declare (ignore width direction first-not-done)) + ;; FIXME: Potential style points: + ;; * (min 0 left), (max width right) + ;; * font-ascent / ascent + (values left (- font-ascent) right font-descent))))))))) + #+unicode (defmethod text-size ((medium clx-medium) string &key text-style (start 0) end) (when (characterp string)

1 0

[mcclim-cvs] CVS update: mcclim/Doc/ex2c.lisp mcclim/Doc/manual.tex
by rstrandh＠common-lisp.net 14 Aug '05

14 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Doc In directory common-lisp.net:/tmp/cvs-serv1335 Modified Files: manual.tex Added Files: ex2c.lisp Log Message: Added example using incremental redisplay. Date: Sun Aug 14 08:20:13 2005 Author: rstrandh Index: mcclim/Doc/manual.tex diff -u mcclim/Doc/manual.tex:1.29 mcclim/Doc/manual.tex:1.30 --- mcclim/Doc/manual.tex:1.29 Sun Aug 14 06:32:38 2005 +++ mcclim/Doc/manual.tex Sun Aug 14 08:20:12 2005 @@ -403,6 +403,25 @@ must have an option of \texttt{:name t}. The reason is that some commands will be available only from menus or by some other mechanism. +You may notice that if the output of the application is hidden (say by +the window of some other application) and then re-exposed, the output +reappears normally, without any intervention necessary on the part of +the programmer. This effect is accomplished by a CLIM mechanism +called \emph{output recording}. Essentially, every piece of output is +not only displayed in the pane, but also captured in an \emph{output + record} associated with the pane. When a pane is re-exposed, its +output records are consulted and if any of them overlap the +re-exposed region, they are redisplayed. In fact, some others may be +redisplayed as well, because CLIM guarantees that the effect will be +the same as when the initial output was created. It does that by +making sure that the order between (partially) overlapping output +records is respected. + +Not all panes support output recording, but certainly application +panes do, so it is good to use some subclass of +\texttt{application-pane} to display application-specific object, +because output recording is then automatic. + \section{An application displaying a data structure} Many applications use a central data structure that is to be on @@ -448,6 +467,73 @@ the value of a single number (or \texttt{NIL}), but you could think of this as displaying all the objects that have been drawn in some figure drawing program or displaying all the entries in an address book. + +\section{Incremental redisplay} + +While the example in the previous section is a very simple way of +structuring an application (let commands arbitrarily modify the data +structure, and simply erase the pane and redisplay the structure after +each iteration of the command loop), the visual result is not so great +when many objects are to be displayed. There is most often a +noticeable flicker between the moment when the pane is cleared and the +objects are drawn. Sometimes this is inevitable (as when nearly all +objects change), but most of the time, only an incremental +modification has been made, and most of the objects are still in the +same place as before. + +In simple toolkits, the application programmer would have to figure +out what has changed since the previous display, and only display the +differences. CLIM offers a mechanism called \emph{incremental + redisplay} that automates a large part of this task. As we +mentioned earlier, CLIM captures output in the form of \emph{output + records}. The same mechanism is used to obtain incremental +redisplay. + +To use incremental redisplay, Client code remains structured in the +simple way that was mention above: after each iteration of the command +loop, the display function output the entire data structure as usual, +except that it helps the incremental redisplay mechanism by telling +CLIM which piece of output corresponds to which piece of output during +the previous iteration of the command loop. It does this by giving +some kind of \emph{unique identity} to some piece of output, and some +means of indicating whether the contents of this output is \emph{the + same} as it was last time. With this information, the CLIM +incremental redisplay mechanism can figure out whether some output is +new, has disappeared, or has been moved, compared to the previous +iteration of the command loop. As with re-exposure, CLIM guarantees +that the result is identical to that which would have been obtained, +had all the output records been output in order to a blank pane. + +The next example illustrates this idea. It is a simple application +that displays a fixed number (here 20) of lines, each line being a +number. Here is the code: + +\verbatimtabinput{ex2c.lisp} + +We store the numbers in a slot called \texttt{numbers} of the +application frame. However, we store each number in its own list. +This is a simple way to provide a unique identity for each number. We +could not use the number itself, because two numbers could be the same +and the identities would not be unique. Instead, we use the cons cell +that store the number as the unique identity. By using +\texttt{:id-test \#'eq} we inform CLIM that it can figure out whether +an output record is the same as one that was issued previous time by +using the function \texttt{eq} to compare them. But there is a second +test that has to be verified, namely whether an output record that was +issued last time has to be redisplayed or not. That is the purpose of +the cache-value. Here we use the number itself as the cache value and +\texttt{eql} as the test to determine whether the output is going to +be the same as last time. + +For convenience, we display a \texttt{*} at the beginning of the +current line, and we provide two commands \texttt{next} and +\texttt{previous} to navigate between the lines. + +Notice that in the declaration of the pane in the application frame, +we have given the option \texttt{:incremental-redisplay t}. This +informs CLIM not to clear the pane after each command-loop iteration, +but to keep the output records around and compare them to the new ones +that are produced during the new iteration. \chapter{Using presentation types}

1 0

[mcclim-cvs] CVS update: mcclim/Doc/ex2b.lisp mcclim/Doc/manual.tex
by rstrandh＠common-lisp.net 14 Aug '05

14 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Doc In directory common-lisp.net:/tmp/cvs-serv26982 Modified Files: manual.tex Added Files: ex2b.lisp Log Message: Another simple example with explanations. Date: Sun Aug 14 06:32:39 2005 Author: rstrandh Index: mcclim/Doc/manual.tex diff -u mcclim/Doc/manual.tex:1.28 mcclim/Doc/manual.tex:1.29 --- mcclim/Doc/manual.tex:1.28 Sun Aug 14 06:01:19 2005 +++ mcclim/Doc/manual.tex Sun Aug 14 06:32:38 2005 @@ -403,6 +403,52 @@ must have an option of \texttt{:name t}. The reason is that some commands will be available only from menus or by some other mechanism. +\section{An application displaying a data structure} + +Many applications use a central data structure that is to be on +display at all times, and that is modified by the commands of the +application. CLIM allows for a very easy way to write such an +application. The main idea is to store the data structure in slots of +the application frame, and to use a \emph{display function} that after +each iteration of the command loop displays the entire data structure +to the application pane. + +Here is a variation of the previous application that shows this +possibility: + +\verbatimtabinput{ex2b.lisp} + +Here, we have added a slot that is called \texttt{current-number} to +the application frame. It is initialized to \texttt{NIL} and it has +an accessor function that allow us to query and to modify the value. + +Observe that in this example, we no longer have the option +\texttt{:display-time nil} set in the application pane. By default, +then, the \texttt{:display-time} is \texttt{:command-loop} which means +that the pane is erased after each iteration of the command loop. +Also observe the option \texttt{:display-function} which takes a +symbol that names a function to be called to display the pane after it +has been cleared. In this case, the name is \texttt{display-app}, the +name of the function defined immediately after the application frame. + +Instead of immediately displaying information about its argument, the +command \texttt{com-parity} instead modifies the new slot of the +application frame. Think of this function as being more general, for +instance a command to add a new object to a set of graphical objects +in a figure drawing program, or as a command to add a new name to an +address book. Notice how this function accesses the current +application frame by means of the special variable +\texttt{*application-frame*}. + +A display function is called with the frame and the pane as +arguments. It is good style to use the pane as the stream in calls to +functions that will result in output. This makes it possible for the +same function to be used by several different frames, should that be +called for. In our simple example, the display function only displays +the value of a single number (or \texttt{NIL}), but you could think of +this as displaying all the objects that have been drawn in some figure +drawing program or displaying all the entries in an address book. + \chapter{Using presentation types} \section{What is a presentation type}

1 0

[mcclim-cvs] CVS update: mcclim/Doc/manual.tex mcclim/Doc/ex2.lisp
by rstrandh＠common-lisp.net 14 Aug '05

14 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Doc In directory common-lisp.net:/tmp/cvs-serv23985 Modified Files: manual.tex ex2.lisp Log Message: Added :display-time nil to example 2 so that it will run correctly. Added a paragraph to the manual explaining what that means. Date: Sun Aug 14 06:01:23 2005 Author: rstrandh Index: mcclim/Doc/manual.tex diff -u mcclim/Doc/manual.tex:1.27 mcclim/Doc/manual.tex:1.28 --- mcclim/Doc/manual.tex:1.27 Thu Apr 7 09:54:59 2005 +++ mcclim/Doc/manual.tex Sun Aug 14 06:01:19 2005 @@ -1,6 +1,7 @@ % -*- coding: latin-1; -*- \documentclass{book} +\usepackage[T1]{fontenc} \usepackage[latin1]{inputenc} \usepackage{color} \usepackage{epsfig} @@ -350,6 +351,22 @@ such as \texttt{format} and \texttt{read} and to CLIM-specific functions such as \texttt{draw-line}. +In this example we have such an application pane, the name of which is +\texttt{app}. As you can see, we have defined it with an option +\texttt{:display-time nil}. The default value for this option for an +application pane is \texttt{:command-loop}, which means that the pane +is cleared after each iteration in the command loop, and then +redisplayed using a client-supplied \emph{display function}. The +default display function does nothing, and we have not supplied any, +so if we had omitted the \texttt{:display-time nil} option, the +\texttt{parity} command would have written to the pane. Then, at the +end of the command loop, the pane would have been cleared, and nothing +else would have been displayed. The net result is that we would have +seen no visible output. With the option \texttt{:display-time nil}, +the pane is never cleared, and output is accumulated every time we +execute the \texttt{parity} command. + + For this example, let us also add a few \emph{commands}. Such commands are defined by the use of a macro called \texttt{define-}\textit{name}\texttt{-command}, where \textit{name} is @@ -648,9 +665,8 @@ c. Mirrors are outlined with dotted rectangles. \begin{figure} - \begin{center} - \input native.pstex_t -%\inputfig{native.pstex_t} +\begin{center} +\inputfig{native.pstex_t} \end{center} \caption{\label{fignative} A sheet with a nontrivial transformation} \end{figure} Index: mcclim/Doc/ex2.lisp diff -u mcclim/Doc/ex2.lisp:1.2 mcclim/Doc/ex2.lisp:1.3 --- mcclim/Doc/ex2.lisp:1.2 Thu Jul 22 14:04:55 2004 +++ mcclim/Doc/ex2.lisp Sun Aug 14 06:01:21 2005 @@ -10,7 +10,7 @@ () (:pointer-documentation t) (:panes - (app :application :height 600 :width 600) + (app :application :display-time nil :height 400 :width 600) (int :interactor :height 200 :width 600)) (:layouts (default (vertically () app int))))

1 0

[mcclim-cvs] CVS update: mcclim/Experimental/freetype/freetype-fonts.lisp
by crhodes＠common-lisp.net 13 Aug '05

13 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory common-lisp.net:/tmp/cvs-serv4334/Experimental/freetype Modified Files: freetype-fonts.lisp Log Message: Commit working version of text-bounding-rectangle* stuff, as trailed on mcclim-devel 2005-08-12. Basically, this is needed because the drawn area for left-to-right text need not lie between (x,y-ascent) and (x+width,y+descent). (No doubt other text drawing directions suffer from the same problem, but they're not yet implemented in McCLIM). New per-medium function TEXT-BOUNDING-RECTANGLE* which actually returns the bounding-rectangle* of what is drawn (cf. TEXT-WIDTH, which doesn't do anything of the sort). Use it in DEF-GRECORDING DRAW-TEXT, and in add-{string,character}-to-output-record, to properly adjust the output record coordinates. While we're at it, fix the bounding box for :y-align :center DRAW-TEXT. Implement this per-medium function for the CLX backend, for the experimental freetype text handling, and for postscript (tested using Climacs, Tabcode and clim-demo::postscript-text). This patch was mostly motivated by the observation that incremental redisplay in climacs windows using the freetype backend caused graphical artifacts to appear over time, thanks to glyphs drawing outside the output record bounding rectangles. Breaks: * CLX backend with #+unicode (clisp?) * Beagle backend * OpenGL backend (please fix!) Date: Sat Aug 13 16:28:34 2005 Author: crhodes Index: mcclim/Experimental/freetype/freetype-fonts.lisp diff -u mcclim/Experimental/freetype/freetype-fonts.lisp:1.10 mcclim/Experimental/freetype/freetype-fonts.lisp:1.11 --- mcclim/Experimental/freetype/freetype-fonts.lisp:1.10 Fri Jul 29 08:50:20 2005 +++ mcclim/Experimental/freetype/freetype-fonts.lisp Sat Aug 13 16:28:33 2005 @@ -160,7 +160,8 @@ :y-origin top :x-advance dx :y-advance dy) - (list glyph-id dx dy)))) + (let ((right (+ left (array-dimension arr 1)))) + (list glyph-id dx dy left right top))))) ;;;;;;; mcclim interface @@ -182,22 +183,32 @@ (defmethod clim-clx::font-glyph-width ((font freetype-face) char) (with-slots (display font matrix) font (nth 1 (display-get-glyph display font matrix char)))) +(defmethod clim-clx::font-glyph-left ((font freetype-face) char) + (with-slots (display font matrix) font + (nth 3 (display-get-glyph display font matrix char)))) +(defmethod clim-clx::font-glyph-right ((font freetype-face) char) + (with-slots (display font matrix) font + (nth 4 (display-get-glyph display font matrix char)))) +;;; this is a hacky copy of XLIB:TEXT-EXTENTS (defmethod clim-clx::font-text-extents ((font freetype-face) string &key (start 0) (end (length string)) translate) ;; -> (width ascent descent left right ;; font-ascent font-descent direction ;; first-not-done) translate - (values - (loop for i from start below end - sum (clim-clx::font-glyph-width font (char-code (aref string i)))) - (clim-clx::font-ascent font) - (clim-clx::font-descent font) - 0 0 - (clim-clx::font-ascent font) - (clim-clx::font-descent font) - 0 end)) + (let ((width (loop for i from start below end + sum (clim-clx::font-glyph-width font (char-code (aref string i)))))) + (values + width + (clim-clx::font-ascent font) + (clim-clx::font-descent font) + (clim-clx::font-glyph-left font (char-code (char string start))) + (- width (- (clim-clx::font-glyph-width font (char-code (char string (1- end)))) + (clim-clx::font-glyph-right font (char-code (char string (1- end)))))) + (clim-clx::font-ascent font) + (clim-clx::font-descent font) + 0 end))) (defun drawable-picture (drawable) (or (getf (xlib:drawable-plist drawable) 'picture) @@ -373,6 +384,47 @@ font-ascent font-descent direction first-not-done)) (values width (+ ascent descent) width 0 ascent)) )))))) ) + +(defmethod climi::text-bounding-rectangle* + ((medium clx-medium) string &key text-style (start 0) end) + (when (characterp string) + (setf string (make-string 1 :initial-element string))) + (unless end (setf end (length string))) + (unless text-style (setf text-style (medium-text-style medium))) + (let ((xfont (text-style-to-X-font (port medium) text-style))) + (cond ((= start end) + (values 0 0 0 0)) + (t + (let ((position-newline (position #\newline string :start start))) + (cond ((not (null position-newline)) + (multiple-value-bind (width ascent descent left right + font-ascent font-descent direction + first-not-done) + (font-text-extents xfont string + :start start :end position-newline + :translate #'translate) + (declare (ignorable left right + font-ascent font-descent + direction first-not-done)) + (multiple-value-bind (minx miny maxx maxy) + (climi::text-bounding-rectangle* + medium string :text-style text-style + :start (1+ position-newline) :end end) + (values (min minx left) (- ascent) + (max maxx right) (+ descent maxy))))) + (t + (multiple-value-bind (width ascent descent left right + font-ascent font-descent direction + first-not-done) + (font-text-extents xfont string + :start start :end end + :translate #'translate) + (declare (ignore width direction first-not-done)) + ;; FIXME: Potential style points: + ;; * (min 0 left), (max width right) + ;; * font-ascent / ascent + (values left (- font-ascent) right font-descent))))))))) + (defmethod make-medium-gcontext* (medium foreground background line-style text-style (ink color) clipping-region) (let* ((drawable (sheet-mirror (medium-sheet medium)))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs August 2005