January 2007 - mcclim-cvs@common-lisp.net

[mcclim-cvs] CVS mcclim/Goatee
by thenriksen 07 Jan '07

07 Jan '07

Update of /project/mcclim/cvsroot/mcclim/Goatee In directory clnet:/tmp/cvs-serv18682/Goatee Modified Files: presentation-history.lisp Log Message: Now Goatee has Drei-like presentation history commands. --- /project/mcclim/cvsroot/mcclim/Goatee/presentation-history.lisp 2004/01/20 16:07:26 1.1 +++ /project/mcclim/cvsroot/mcclim/Goatee/presentation-history.lisp 2007/01/07 19:36:06 1.2 @@ -30,67 +30,40 @@ (defun insert-ptype-history (object type) (multiple-value-bind (line pos) (point* *buffer*) - (setf *insert-extent* (make-instance 'extent - :start-line line - :start-pos pos)) (multiple-value-bind (printed-rep accept-object) (present-acceptably-to-string object type +textual-view+ ; XXX type) - (format *trace-output* "insert-ptype-history: ~S, ~S~%" - (pos (bp-start *insert-extent*)) - (pos (bp-end *insert-extent*))) ;; XXX accept-object - (insert *buffer* printed-rep :line line :pos pos) - (format *trace-output* "insert-ptype-history:: ~S, ~S~%" - (pos (bp-start *insert-extent*)) - (pos (bp-end *insert-extent*)))))) + (insert *buffer* printed-rep :line line :pos pos)))) -(defun cmd-presentation-history-yank (&key &allow-other-keys) +(defun cmd-history-yank-next (&key &allow-other-keys) (let* ((accepting-type climi::*active-history-type*) - (history (and accepting-type - (climi::presentation-type-history accepting-type)))) - (setq *last-history-type* accepting-type - *last-history* history) + (history (and accepting-type + (presentation-type-history accepting-type)))) (when history (multiple-value-bind (object type) - (climi::presentation-history-head history accepting-type) - (if type - (insert-ptype-history object type)))))) + (climi::presentation-history-next history accepting-type) + (when type + (clear-buffer *buffer*) + (insert-ptype-history object type)))))) -(defun cmd-presentation-history-yank-next (&key &allow-other-keys) - (when (and *last-history-type* *last-history*) +(defun cmd-history-yank-previous (&key &allow-other-keys) + (let* ((accepting-type climi::*active-history-type*) + (history (and accepting-type + (presentation-type-history accepting-type)))) + (when history (multiple-value-bind (object type) - (climi::presentation-history-next *last-history* *last-history-type*) - (when type - (delete-region *buffer* - (bp-start *insert-extent*) - (bp-end *insert-extent*)) - (insert-ptype-history object type))))) - - -(defun goatee-next (&key &allow-other-keys) - (cond ((or (eq *last-command* 'cmd-presentation-history-yank) - (and (eq *last-command* 'goatee-next) - (or (eq *last-yank-command* 'cmd-presentation-history-yank-next) - (eq *last-yank-command* - 'cmd-presentation-history-yank-prev)))) - (funcall #'cmd-presentation-history-yank-next) - (setq *last-yank-command* 'cmd-presentation-history-yank-next)) - ((or (eq *last-command* 'cmd-yank) - (eq *last-command* 'cmd-yank-prev) - (and (eq *last-command* 'goatee-next) - (or (eq *last-yank-command* 'cmd-yank-next) - (eq *last-yank-command* 'cmd-yank-prev)))) - (funcall #'cmd-yank-next) - (setq *last-yank-command* 'cmd-yank-next)) - (t (beep)))) - -(add-gesture-command-to-table '(#\y :control :meta) - 'cmd-presentation-history-yank - *simple-area-gesture-table*) - -(add-gesture-command-to-table '(#\y :meta) - 'goatee-next - *simple-area-gesture-table*) + (climi::presentation-history-previous history accepting-type) + (when type + (clear-buffer *buffer*) + (insert-ptype-history object type)))))) + +(add-gesture-command-to-table '(#\p :meta) + 'cmd-history-yank-previous + *simple-area-gesture-table*) + +(add-gesture-command-to-table '(#\n :meta) + 'cmd-history-yank-next + *simple-area-gesture-table*)

1 0

[mcclim-cvs] CVS mcclim/Backends/CLX
by dlichteblau 07 Jan '07

07 Jan '07

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv18071/Backends/CLX Modified Files: medium.lisp Log Message: Add a new class RGB-IMAGE (renamed from closure's IMAGELIB:AIMAGE) and RGB-IMAGE-DESIGN (used to implement CLOSURE/CLIM-DEVICE::RO/IMG). Drawing code implemented only in CLIM-CLX, and only for true color visuals. * Examples/rgb-image.lisp: New file, from closure/src/imagelib/basic.lisp. * Backends/CLX/medium.lisp (MEDIUM-DRAW-IMAGE-DESIGN*, MEDIUM-FREE-IMAGE-DESIGN, COMPUTE-RGB-IMAGE-PIXMAP, COMPUTE-RGB-IMAGE-MASK, IMAGE-TO-XIMAGE-FOR-DRAWABLE, IMAGE-TO-XIMAGE, MASK->BYTE, PIXEL-TRANSLATOR): Methods and functions, renamed from original closure code. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2006/12/28 19:30:40 1.78 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2007/01/07 19:32:28 1.79 @@ -6,6 +6,7 @@ ;;; Julien Boninfante (boninfan(a)emi.u-bordeaux.fr) ;;; Robert Strandh (strandh(a)labri.u-bordeaux.fr) ;;; (c) copyright 2001 by Arnaud Rouanet (rouanet(a)emi.u-bordeaux.fr) +;;; (c) copyright 1998,1999 by Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -1151,3 +1152,152 @@ (setf (medium-buffer medium) nil))) (funcall continuation))) + +;;; RGB-IMAGE support, from Closure + +(defmethod climi::medium-draw-image-design* + ((medium clx-medium) (design climi::rgb-image-design) x y) + (let* ((da (sheet-direct-mirror (medium-sheet medium))) + (image (slot-value design 'climi::image)) + (width (climi::image-height image)) + (height (climi::image-height image))) + (destructuring-bind (&optional pixmap mask) + (slot-value design 'climi::medium-data) + (unless pixmap + (setf pixmap (compute-rgb-image-pixmap da image)) + (when (climi::image-alpha-p image) + (setf mask (compute-rgb-image-mask da image))) + (setf (slot-value design 'climi::medium-data) (list pixmap mask))) + (multiple-value-bind (x y) + (transform-position + (sheet-device-transformation (medium-sheet medium)) + x y) + (setf x (round x)) + (setf y (round y)) + (let ((gcontext (xlib:create-gcontext :drawable da))) + (cond + (mask + (xlib:with-gcontext (gcontext + :clip-mask mask + :clip-x x + :clip-y (- y height)) + (xlib:copy-area pixmap gcontext 0 0 width height + da x (- y height)))) + (t + (xlib:copy-area pixmap gcontext 0 0 width height + da x (- y height))))))))) + +(defmethod climi::medium-free-image-design + ((medium clx-medium) (design climi::rgb-image-design)) + (destructuring-bind (&optional pixmap mask) + (slot-value design 'climi::medium-data) + (when pixmap + (xlib:free-pixmap pixmap) + (when mask + (xlib:free-pixmap mask)) + (setf (slot-value design 'climi::medium-data) nil)))) + +(defun compute-rgb-image-pixmap (drawable image) + (let* ((width (climi::image-width image)) + (height (climi::image-height image)) + (depth (xlib:drawable-depth drawable)) + (im (image-to-ximage-for-drawable drawable image))) + (setf width (max width 1)) + (setf height (max height 1)) + (let* ((pixmap (xlib:create-pixmap :drawable drawable + :width width + :height height + :depth depth)) + (gc (xlib:create-gcontext :drawable pixmap))) + (unless (or (>= width 2048) (>= height 2048)) ;### CLX bug + (xlib:put-image pixmap gc im + :src-x 0 :src-y 0 + :x 0 :y 0 + :width width :height height)) + (xlib:free-gcontext gc) + pixmap))) + +(defun compute-rgb-image-mask (drawable image) + (let* ((width (climi::image-width image)) + (height (climi::image-height image)) + (bitmap (xlib:create-pixmap :drawable drawable + :width width + :height height + :depth 1)) + (gc (xlib:create-gcontext :drawable bitmap + :foreground 1 + :background 0)) + (idata (climi::image-data image)) + (xdata (make-array (list height width) + :element-type '(unsigned-byte 1))) + (im (xlib:create-image :width width + :height height + :depth 1 + :data xdata)) ) + (dotimes (y width) + (dotimes (x height) + (if (> (aref idata x y) #x80000000) + (setf (aref xdata x y) 0) + (setf (aref xdata x y) 1)))) + (unless (or (>= width 2048) (>= height 2048)) ;### CLX breaks here + (xlib:put-image bitmap gc im :src-x 0 :src-y 0 + :x 0 :y 0 :width width :height height + :bitmap-p nil)) + (xlib:free-gcontext gc) + bitmap)) + +(defun image-to-ximage-for-drawable (drawable image) + (image-to-ximage image + (xlib:drawable-depth drawable) + (pixel-translator (xlib:window-colormap drawable)))) + +(defun image-to-ximage (image depth translator) + (let* ((width (climi::image-width image)) + (height (climi::image-height image)) + (idata (climi::image-data image)) + ;; FIXME: this (and the :BITS-PER-PIXEL, below) is a hack on + ;; top of a hack. At some point in the past, XFree86 and/or + ;; X.org decided that they would no longer support pixmaps + ;; with 24 bpp, which seems to be what most AIMAGEs want to + ;; be. For now, force everything to a 32-bit pixmap. + (xdata (make-array (list height width) :element-type '(unsigned-byte 32))) + (ximage (xlib:create-image :width width + :height height + :depth depth + :bits-per-pixel 32 + :data xdata))) + (declare (type (simple-array (unsigned-byte 32) (* *)) idata)) + (loop for x fixnum from 0 below width do + (loop for y fixnum from 0 below height do + (setf (aref xdata y x) + (funcall translator + x y + (ldb (byte 24 0) (aref idata y x)))))) + ximage)) + +(defun mask->byte (mask) + (let ((h (integer-length mask))) + (let ((l (integer-length (logxor mask (1- (ash 1 h)))))) + (byte (- h l) l)))) + +;; fixme! This is not just incomplete, but also incorrect: The original +;; true color code knew how to deal with non-linear RGB value +;; allocation. +(defun pixel-translator (colormap) + (unless (eq (xlib:visual-info-class (xlib:colormap-visual-info colormap)) + :true-color) + (error "sorry, cannot draw rgb image for non-true-color drawable yet")) + colormap + (let* ((info (xlib:colormap-visual-info colormap)) + (rbyte (mask->byte (xlib:visual-info-red-mask info))) + (gbyte (mask->byte (xlib:visual-info-green-mask info))) + (bbyte (mask->byte (xlib:visual-info-blue-mask info)))) + (lambda (x y sample) + (declare (ignore x y)) + (dpb (the (unsigned-byte 8) (ldb (byte 8 0) sample)) + rbyte + (dpb (the (unsigned-byte 8) (ldb (byte 8 8) sample)) + gbyte + (dpb (the (unsigned-byte 8) (ldb (byte 8 16) sample)) + bbyte + 0))))))

1 0

[mcclim-cvs] CVS mcclim/Extensions
by dlichteblau 07 Jan '07

07 Jan '07

Update of /project/mcclim/cvsroot/mcclim/Extensions In directory clnet:/tmp/cvs-serv18071/Extensions Added Files: rgb-image.lisp Log Message: Add a new class RGB-IMAGE (renamed from closure's IMAGELIB:AIMAGE) and RGB-IMAGE-DESIGN (used to implement CLOSURE/CLIM-DEVICE::RO/IMG). Drawing code implemented only in CLIM-CLX, and only for true color visuals. * Examples/rgb-image.lisp: New file, from closure/src/imagelib/basic.lisp. * Backends/CLX/medium.lisp (MEDIUM-DRAW-IMAGE-DESIGN*, MEDIUM-FREE-IMAGE-DESIGN, COMPUTE-RGB-IMAGE-PIXMAP, COMPUTE-RGB-IMAGE-MASK, IMAGE-TO-XIMAGE-FOR-DRAWABLE, IMAGE-TO-XIMAGE, MASK->BYTE, PIXEL-TRANSLATOR): Methods and functions, renamed from original closure code. --- /project/mcclim/cvsroot/mcclim/Extensions/rgb-image.lisp 2007/01/07 19:32:29 NONE +++ /project/mcclim/cvsroot/mcclim/Extensions/rgb-image.lisp 2007/01/07 19:32:29 1.1 ;;; (c) copyright 1998 by Gilbert Baumann ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the ;;; "Software"), to deal in the Software without restriction, including ;;; without limitation the rights to use, copy, modify, merge, publish, ;;; distribute, sublicense, and/or sell copies of the Software, and to ;;; permit persons to whom the Software is furnished to do so, subject to ;;; the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY ;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;;; ;;; (Hacked for inclusion into McCLIM by David Lichteblau.) (in-package :climi) ;;; ARGB image data represented as an (unsigned-byte 32) array (defclass rgb-image () ((width :initarg :width :accessor image-width) (height :initarg :height :accessor image-height) (data :initarg :data :accessor image-data :type (or null (simple-array (unsigned-byte 32) (* *)))) (alphap :initarg :alphap :initform nil :accessor image-alpha-p))) ;;; Applications (closure in particular) might want to cache any ;;; backend-specific data required to draw an RGB-IMAGE. ;;; ;;; To implement this caching, designs must be created separately for each ;;; medium, so that mediums can put their own data into them. (defclass rgb-image-design (design) ((medium :initarg :medium) (image :initarg :image) (medium-data :initform nil))) (defun make-rgb-image-design (medium image) (make-instance 'rgb-image-design :medium medium :image image)) ;;; Protocol to free cached data (defgeneric medium-free-image-design (medium design)) (defun free-image-design (design) (medium-free-image-design (slot-value design 'medium) design)) ;;; Drawing protocol (defgeneric medium-draw-image-design* (medium design x y)) (defmethod medium-draw-image-design* :before (medium design x y) (assert (eq medium (slot-value design 'medium))))

1 0

[mcclim-cvs] CVS mcclim
by dlichteblau 07 Jan '07

07 Jan '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv18071 Modified Files: mcclim.asd Log Message: Add a new class RGB-IMAGE (renamed from closure's IMAGELIB:AIMAGE) and RGB-IMAGE-DESIGN (used to implement CLOSURE/CLIM-DEVICE::RO/IMG). Drawing code implemented only in CLIM-CLX, and only for true color visuals. * Examples/rgb-image.lisp: New file, from closure/src/imagelib/basic.lisp. * Backends/CLX/medium.lisp (MEDIUM-DRAW-IMAGE-DESIGN*, MEDIUM-FREE-IMAGE-DESIGN, COMPUTE-RGB-IMAGE-PIXMAP, COMPUTE-RGB-IMAGE-MASK, IMAGE-TO-XIMAGE-FOR-DRAWABLE, IMAGE-TO-XIMAGE, MASK->BYTE, PIXEL-TRANSLATOR): Methods and functions, renamed from original closure code. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/01/06 13:27:25 1.47 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/01/07 19:32:28 1.48 @@ -348,7 +348,8 @@ :pathname #.(make-pathname :directory '(:relative "Goatee") :name "presentation-history" :type "lisp")) (:file "input-editing-goatee") (:file "input-editing-drei") - (:file "text-editor-gadget"))) + (:file "text-editor-gadget") + (:file "Extensions/rgb-image"))) (defsystem :clim-clx :depends-on (:clim #+(or sbcl openmcl ecl allegro) :clx)

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 06 Jan '07

06 Jan '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv19077 Modified Files: mcclim.asd Log Message: Really Make CLISP Work. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/01/06 13:11:42 1.46 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/01/06 13:27:25 1.47 @@ -41,6 +41,11 @@ (defun find-swank () (or (find-swank-package) (find-swank-system))) + (defun dep-on-swank () + (if (and (find-swank-system) + (not (find-package :swank))) + '(and) + '(or))) (defun ifswank () (if (find-swank) '(and) @@ -257,7 +262,7 @@ (defsystem :drei-mcclim - :depends-on (:flexichain :esa-mcclim :clim-core #+#.(mcclim.system::ifswank) :swank) + :depends-on (:flexichain :esa-mcclim :clim-core #+#.(mcclim.system::dep-on-swank) :swank) :components ((:module "cl-automaton" :pathname #.(make-pathname :directory '(:relative "Drei" "cl-automaton"))

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 06 Jan '07

06 Jan '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv15615 Modified Files: mcclim.asd Log Message: Make McCLIM loadable in CLISP. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/12/26 16:44:45 1.45 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/01/06 13:11:42 1.46 @@ -40,7 +40,11 @@ (asdf:missing-component ()))) (defun find-swank () (or (find-swank-package) - (find-swank-system)))) + (find-swank-system))) + (defun ifswank () + (if (find-swank) + '(and) + '(or)))) ;;; Legacy CMUCL support stuff #+cmu @@ -253,7 +257,7 @@ (defsystem :drei-mcclim - :depends-on (:flexichain :esa-mcclim :clim-core #.(if (find-swank-system) :swank (values))) + :depends-on (:flexichain :esa-mcclim :clim-core #+#.(mcclim.system::ifswank) :swank) :components ((:module "cl-automaton" :pathname #.(make-pathname :directory '(:relative "Drei" "cl-automaton")) @@ -304,9 +308,7 @@ (:file "lisp-syntax" :depends-on ("core" "motion" "fundamental-syntax")) (:file "lisp-syntax-swine" :depends-on ("lisp-syntax")) (:file "lisp-syntax-commands" :depends-on ("lisp-syntax-swine" "misc-commands")) - #.(if (find-swank) - '(:file "lisp-syntax-swank" :depends-on ("lisp-syntax")) - (values)))))) + #+#.(mcclim.system::ifswank) (:file "lisp-syntax-swank" :depends-on ("lisp-syntax")))))) (defsystem :drei-tests :depends-on (:drei-mcclim :fiveam)

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 06 Jan '07

06 Jan '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv7516 Modified Files: commands.lisp Log Message: When doing sub-accepts for `command-or-form', inherit the history of the `command-or-form' type. --- /project/mcclim/cvsroot/mcclim/commands.lisp 2007/01/04 09:15:24 1.68 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2007/01/06 12:51:16 1.69 @@ -1401,8 +1401,8 @@ (if (member initial-char *command-dispatchers*) (progn (read-gesture :stream stream) - (accept command-ptype :stream stream :view view :prompt nil)) - (accept 'form :stream stream :view view :prompt nil))) + (accept command-ptype :stream stream :view view :prompt nil :history 'command-or-form)) + (accept 'form :stream stream :view view :prompt nil :history 'command-or-form))) (t (funcall (cdar *input-context*) object type event options)))))

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 06 Jan '07

06 Jan '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv7414 Modified Files: presentation-defs.lisp Log Message: Improve presentation history - is now explicitly a stack, and works pretty much as you would expect. Goatee's support is temporarily broken until I can make `define-input-editor-command' also define commands for Goatee. --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/12/13 21:33:43 1.65 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2007/01/06 12:50:38 1.66 @@ -451,8 +451,20 @@ (defun presentation-type-history (type) (funcall-presentation-generic-function presentation-type-history type)) -(defclass presentation-history-ring (goatee::ring) - ()) +(defclass presentation-history () + ((stack :accessor presentation-history-array + :initform (make-array 1 :fill-pointer 0 + :adjustable t) + :documentation "The history, with the newest objects at +the end of the array. Should contain conses with the car being +the object and the cdr being the type.") + (pointer :accessor presentation-history-pointer + :initform nil + :documentation "The index of the \"current\" object, +used when navigating the history. If NIL, means that no +navigation has yet been performed.")) + (:documentation "Class for objects that contain the history for +a specific type.")) (define-default-presentation-method presentation-type-history (type) (if (and *application-frame* @@ -468,7 +480,7 @@ (history-object (gethash name history-table))) (unless history-object (setf history-object - (make-instance 'presentation-history-ring) + (make-instance 'presentation-history) (gethash name history-table) history-object)) history-object)) @@ -505,53 +517,94 @@ (funcall-presentation-generic-function presentation-type-history type)) (defun presentation-history-insert (history object ptype) - (goatee::ring-obj-insert (cons object ptype) history)) - -(defun presentation-history-head (history ptype) + "Unconditionally insert `object' as an input of presentation +type `type' at the top of the presentation history `history', as +the most recently added object." + (vector-push-extend (cons object ptype) + (presentation-history-array history))) + +(defun presentation-history-top (history ptype) + "Find the topmost (most recently added object) of `history' +that is of the presentation type `ptype' or a subtype. Two values +will be returned, the object and the presentation type of the +object. If no applicable object can be found, these values will +both be NIL." (loop - for cell = (goatee::dbl-head history) then (goatee::next cell) - for (object . object-ptype) = (and cell (goatee::contents cell)) - while cell - if (presentation-subtypep object-ptype ptype) - return (values object object-ptype) - finally (return (values nil nil)))) + with array = (presentation-history-array history) + for index from (1- (fill-pointer array)) downto 0 + for (object . object-ptype) = (aref array index) + do + (when (presentation-subtypep object-ptype ptype) + (return (aref array index))) + finally (return (values nil nil)))) + +(defun presentation-history-reset-pointer (history) + "Set the pointer to point at the object most recently added +object." + (setf (presentation-history-pointer history) nil)) (defun presentation-history-next (history ptype) - (let ((first-object (goatee::backward history))) - (loop - for first-time = t then nil - for cell = first-object then (goatee::backward history) - for (object . object-ptype) = (goatee::contents cell) - while (or first-time (not (eq first-object cell))) - if (presentation-subtypep object-ptype ptype) - return (values object object-ptype) - end - finally (return (values nil nil))))) + "Go to the next input (forward in time) in `history' that is a +presentation-subtype of `ptype', respective to the pointer in +`history'. Returns two values: the found object and its +presentation type, both of which will be NIL if no applicable +object can be found." + (with-accessors ((pointer presentation-history-pointer) + (array presentation-history-array)) history + ;; If no navigation has been performed, we have no object to go + ;; forwards to. + (if (or (null pointer) (>= (1+ pointer) (length array))) + (values nil nil) + (progn + (incf pointer) + (destructuring-bind (object . object-ptype) + (aref array pointer) + (if object-ptype + (if (presentation-subtypep object-ptype ptype) + (values object object-ptype) + (presentation-history-next history ptype)) + (values nil nil))))))) (defun presentation-history-previous (history ptype) - (let ((first-object (goatee::forward history))) - (loop - for first-time = t then nil - for cell = first-object then (goatee::forward history) - for (object . object-ptype) = (goatee::contents cell) - while (or first-time (not (eq first-object cell))) - if (presentation-subtypep object-ptype ptype) - return (values object object-ptype) - end - finally (return (values nil nil))))) + "Go to the previous input (backward in time) in `history' that +is a presentation-subtype of `ptype', respective to the pointer +in `history'. Returns two values: the found object and its +presentation type, both of which will be NIL if no applicable +object can be found." + (with-accessors ((pointer presentation-history-pointer) + (array presentation-history-array)) history + (if (and (numberp pointer) (zerop pointer)) + (values nil nil) + (progn + (if pointer + (decf pointer) + (setf pointer (1- (fill-pointer array)))) + (destructuring-bind (object . object-ptype) + (when (array-in-bounds-p array pointer) + (aref array pointer)) + (if object-ptype + (if (presentation-subtypep object-ptype ptype) + (values object object-ptype) + (progn (presentation-history-previous history ptype))) + (values nil nil))))))) (defmacro with-object-on-history ((history object ptype) &body body) - `(goatee::with-object-on-ring ((cons ,object ,ptype) ,history) - ,@body)) + "Evaluate `body' with `object' as `ptype' as the head (most +recently added object) on `history', and remove it again after +`body' has run. If `body' as `ptype' is already the head, the +history will be unchanged." + (with-gensyms (added) + `(let ((,added (presentation-history-add ,history ,object ,ptype))) + (unwind-protect (progn ,@body) + (when ,added + (decf (fill-pointer (presentation-history-array ,history)))))))) (defun presentation-history-add (history object ptype) "Add OBJECT and PTYPE to the HISTORY unless they are already at the head of HISTORY" - (let* ((cell (goatee::dbl-head history)) - (contents (and cell (goatee::contents cell)))) - (unless (and cell - (eql object (car contents)) - (equal ptype (cdr contents))) + (multiple-value-bind (top-object top-ptype) + (presentation-history-top history ptype) + (unless (and top-ptype (eql object top-object) (equal ptype top-ptype)) (presentation-history-insert history object ptype)))) ;;; Context-dependent input @@ -730,34 +783,37 @@ ;; 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)))) + (labels ((get-history () + (when real-history-type + (funcall-presentation-generic-function + presentation-type-history-for-stream + real-history-type stream))) + (do-accept (args) + (apply #'stream-accept stream real-type args))) (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)))) + (unwind-protect + (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-top 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)))) + (unless *recursive-accept-p* + (presentation-history-reset-pointer (get-history)))) (do-accept rest-args)))) (results-history (get-history))) (when results-history

1 0

[mcclim-cvs] CVS mcclim/Doc
by rstrandh 06 Jan '07

06 Jan '07

Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv22828 Modified Files: mcclim.texi Log Message: Added a section on how CLIM applications produce output. --- /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi 2007/01/06 05:00:17 1.5 +++ /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi 2007/01/06 05:27:53 1.6 @@ -418,6 +418,7 @@ @cindex writing an application @menu +* How CLIM applications produce output:: * Panes and Gadgets:: * Defining Application Frames:: * A First Attempt:: @@ -427,6 +428,84 @@ * Incremental redisplay:: @end menu +@node How CLIM applications produce output +@section How CLIM applications produce output + +CLIM stream panes use output recording. This means that such a pane +maintains a display list, consisting of a sequence of output records, +ordered chronologically, from the first output record to be drawn to +the last. + +This display list is used to fill in damaged areas of the pane, for +instance as a result of the pane being partially or totally covered by +other panes, and then having some or all of its area again becoming +visible. The output records of the display list that have some parts +in common with the exposed area are partially or totally replayed (in +chronological order) to redraw the contents of the area. + +An application can have a pane establish this display list in several +fundamentally different ways. + +Very simple applications have no internal data structure to keep track +of application objects, and simply produce output to the pane from +time to time as a result of running commands, occasionally perhaps +erasing the pane and starting over. Such applications typically use +text or graphics output as a result of running commands. CLIM +maintains the display list for the pane, and adds to the end of it, +each time also producing the pixels that result from drawing the new +output record. If the pane uses scrolling (which it typically does), +then CLIM must determine the extent of the pane so as to update the +scroll bar after each new output. + +More complicated applications use a display function. Before the +display function is run, the existing display list is typically +deleted, so that the purpose of the display function becomes to +establish an entirely new display list. The display function might +for instance produce some kind of form to be filled in, and +application commands can use text or graphics operations to fill in +the form. A game of tic-tac-toe could work this way, where the +display function draws the board and commands draw shapes into the +squares. + +Even more complicated applications might have some internal data +structure that has a direct mapping to output, and commands simply +modify this internal data structure. In this case, the display +function is run after each time around the command loop, because a +command can have modified the internal data structure in some +arbitrary ways. Some such applications might simply want to delete +the existing display list and produce a new one each time (to minimize +flicker, double buffering could be used). This is a very simple way +of structuring an application, and entirely acceptable in many cases. +Consider, for instance, a board game where pieces can be moved (as +opposed to just added). A very simple way of structuring such an +application is to have an internal representation of the board, and to +make the display function traverse this data structure and produce the +complete output each time in the command loop. + +Some applications have very large internal data structures to be +displayed, and it would cause a serious performance problem if the +display list had to be computer from scratch each time around the +command loop. To solve this problem, CLIM contains a feature called +incremental redisplay. It allows many of the output records to be +kept from one iteration of the command loop to the next. This can be +done in two different ways. The simplest way is for the application +to keep the simple structure which consists of traversing the entire +data structure each time, but at various points indicate to CLIM that +the output has not changed since last time, so as to avoid actually +invoking the application code for computing it. This is accomplished +by the use of @t{updating-output}. The advantage of +@t{updating-output} is that the application logic remains +straightforward, and it is up to CLIM to do the hard work of recycling +output records. The disadvantage is that for some very demanding +applications, this method might not be fast enough. + +The other way is more complicated and requires the programmer to +structure the application differently. Essentially, the application +has to keep track of the output records in the display list, and +inform CLIM about modifications to it. The main disadvantage of this +method is that the programmer must now write the application to keep +track of the output records itself, as opposed to leaving it to CLIM. + @node Panes and Gadgets @section Panes and Gadgets

1 0

[mcclim-cvs] CVS mcclim/Doc
by rstrandh 06 Jan '07

06 Jan '07

Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv16226 Modified Files: Makefile Log Message: Added image conversion to PDF needed by the PDF version of the manual. --- /project/mcclim/cvsroot/mcclim/Doc/Makefile 2006/12/24 12:54:19 1.8 +++ /project/mcclim/cvsroot/mcclim/Doc/Makefile 2007/01/06 05:01:02 1.9 @@ -9,7 +9,7 @@ HTMLDIRS=$(basename $(MCCLIMTEXI)) IMAGES=ex2.eps inspect-as-cells.eps inspect-object-1.eps \ inspect-object-2.eps inspect-object-3.eps native.fig -IMAGETARGETTYPES=gif png eps +IMAGETARGETTYPES=gif png eps pdf TARGETIMAGES=$(shell sh ./makeimages.sh -e "$(IMAGES)" "$(IMAGETARGETTYPES)") # Place where generated documentation ends up. The value of # DOCSTRINGDIR has to end with a slash or you lose (it's passed to

1 0