From thenriksen at common-lisp.net Fri Dec 1 21:51:08 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 1 Dec 2006 16:51:08 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061201215108.2F4F64D044@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv9192 Modified Files: input-editor.lisp Log Message: Removed all non-specified use of `stream-input-buffer' because it's very slow (consing up a brand new array). --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/11/22 14:15:53 1.6 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/12/01 21:51:08 1.7 @@ -171,8 +171,9 @@ (clear-undo-history (buffer (drei-instance stream)))) (defmethod stream-input-buffer ((stream drei-input-editing-mixin)) - ;; NOTE: This is very slow, we should attempt to replace uses of - ;; this function in McCLIM with something more efficient. + ;; NOTE: This is very slow, please do not use it unless you want to + ;; be compatible with other editor substrates. Use the Drei buffer + ;; directly instead. (with-accessors ((buffer buffer)) (drei-instance stream) (let* ((array (buffer-sequence buffer 0 (size buffer)))) (make-array (length array) @@ -275,71 +276,70 @@ &allow-other-keys) (with-keywords-removed (rest-args (:peek-p)) (rescan-if-necessary stream) - (with-accessors ((buffer stream-input-buffer) - (insertion-pointer stream-insertion-pointer) + (with-accessors ((insertion-pointer stream-insertion-pointer) (scan-pointer stream-scan-pointer) (activation-gesture activation-gesture)) stream - (loop - (loop - while (< scan-pointer insertion-pointer) - while (< scan-pointer (length buffer)) - do (let ((gesture (aref buffer scan-pointer))) - ;; Skip noise strings. - (cond ((typep gesture 'noise-string) - (incf scan-pointer)) - ((and (not peek-p) - (typep gesture 'accept-result)) - (incf scan-pointer) - #+(or mcclim building-mcclim) - (climi::throw-object-ptype (object gesture) - (result-type gesture))) - ;; Note that this implies that - ;; `stream-read-gesture' may return accept - ;; results, which might as well be arbitrary - ;; objects to the code calling - ;; `stream-read-gesture', since it can't really - ;; do anything with them except for asserting - ;; that they exist. According to the spec, - ;; "accept results are treated as a single - ;; gesture", and this kind of behavior is - ;; necessary to make sure `stream-read-gesture' - ;; doesn't simply claim that there are no more - ;; gestures in the input-buffer when the - ;; remaining gesture(s) is an accept result. - ((typep gesture 'accept-result) - (return-from stream-read-gesture gesture)) - (t - (unless peek-p + (let ((buffer (buffer (drei-instance stream)))) + (loop + (loop + while (< scan-pointer insertion-pointer) + while (< scan-pointer (size buffer)) + do (let ((gesture (buffer-object buffer scan-pointer))) + ;; Skip noise strings. + (cond ((typep gesture 'noise-string) (incf scan-pointer)) - (return-from stream-read-gesture gesture)) - (t (incf scan-pointer))))) - (setf (stream-rescanning stream) nil) - (when activation-gesture - (return-from stream-read-gesture - (prog1 activation-gesture - (unless peek-p - (setf activation-gesture nil))))) - ;; In McCLIM, stream-process-gesture is responsible for - ;; inserting characters into the buffer, changing the - ;; insertion pointer and possibly setting up the - ;; activation-gesture slot. - (loop - with gesture and type - do (setf (values gesture type) - (apply #'stream-read-gesture - (encapsulating-stream-stream stream) rest-args)) - when (null gesture) - do (return-from stream-read-gesture (values gesture type)) - when (stream-process-gesture stream gesture type) - do (loop-finish)))))) + ((and (not peek-p) + (typep gesture 'accept-result)) + (incf scan-pointer) + #+(or mcclim building-mcclim) + (climi::throw-object-ptype (object gesture) + (result-type gesture))) + ;; Note that this implies that + ;; `stream-read-gesture' may return accept + ;; results, which might as well be arbitrary + ;; objects to the code calling + ;; `stream-read-gesture', since it can't really + ;; do anything with them except for asserting + ;; that they exist. According to the spec, + ;; "accept results are treated as a single + ;; gesture", and this kind of behavior is + ;; necessary to make sure `stream-read-gesture' + ;; doesn't simply claim that there are no more + ;; gestures in the input-buffer when the + ;; remaining gesture(s) is an accept result. + ((typep gesture 'accept-result) + (return-from stream-read-gesture gesture)) + (t + (unless peek-p + (incf scan-pointer)) + (return-from stream-read-gesture gesture)) + (t (incf scan-pointer))))) + (setf (stream-rescanning stream) nil) + (when activation-gesture + (return-from stream-read-gesture + (prog1 activation-gesture + (unless peek-p + (setf activation-gesture nil))))) + ;; In McCLIM, stream-process-gesture is responsible for + ;; inserting characters into the buffer, changing the + ;; insertion pointer and possibly setting up the + ;; activation-gesture slot. + (loop + with gesture and type + do (setf (values gesture type) + (apply #'stream-read-gesture + (encapsulating-stream-stream stream) rest-args)) + when (null gesture) + do (return-from stream-read-gesture (values gesture type)) + when (stream-process-gesture stream gesture type) + do (loop-finish))))))) (defmethod stream-unread-gesture ((stream drei-input-editing-mixin) gesture) - (with-accessors ((buffer stream-input-buffer) - (scan-pointer stream-scan-pointer) + (with-accessors ((scan-pointer stream-scan-pointer) (activation-gesture activation-gesture)) stream (when (> scan-pointer 0) - (if (and (eql scan-pointer (fill-pointer buffer)) + (if (and (eql scan-pointer (stream-insertion-pointer stream)) (activation-gesture-p gesture)) (setf activation-gesture gesture) (decf scan-pointer))))) @@ -355,8 +355,8 @@ `stream-read-gesture' for the stream encapsulated by `stream'. The second return value of this function will be `type' if stuff is inserted after the insertion pointer." - (let* ((before (stream-input-buffer stream)) - (drei (drei-instance stream)) + (let* ((drei (drei-instance stream)) + (buffer (buffer drei)) (*command-processor* drei) (was-directly-processing (directly-processing-p drei)) (minibuffer (or (minibuffer drei) *minibuffer*)) @@ -389,7 +389,8 @@ (display-message "Aborted"))))))) ;; Will also take care of redisplaying minibuffer. (display-drei drei) - (let ((first-mismatch (mismatch before (stream-input-buffer stream)))) + (let ((first-mismatch (offset (high-mark buffer)))) + (clear-modify buffer) (cond ((null first-mismatch) ;; No change actually took place, even though IP may ;; have moved. From thenriksen at common-lisp.net Fri Dec 1 22:39:15 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 1 Dec 2006 17:39:15 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061201223915.11B9469006@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv14362 Modified Files: input-editor.lisp Log Message: Now support for CLIM 2.2 (Franz User Guide) style input buffers. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/12/01 21:51:08 1.7 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/12/01 22:39:14 1.8 @@ -41,7 +41,12 @@ :initform nil) (%rescanning-p :reader stream-rescanning-p :writer (setf stream-rescanning) - :initform nil)) + :initform nil) + (%input-buffer-array :accessor input-buffer-array + :initform nil + :documentation "After a command has been +executed, the contents of the Drei area instance shall be +replaced by the contents of this array, if non-NIL.")) (:documentation "An mixin that helps in implementing Drei-based input-editing streams. This class should not be directly instantiated.")) @@ -170,15 +175,62 @@ ;; want to permit the user to undo input for this context. (clear-undo-history (buffer (drei-instance stream)))) +(defun update-drei-buffer (stream) + "Update the Drei buffer of the Drei instance used by `stream' +if the `input-buffer-array' of `stream' is non-NIl. This will set +the contents of the array to the contents of the array up to the +fill pointer. When this function returns, the +`input-buffer-array' of `stream' will be NIL. Also, the syntax +will be up-to-date." + (with-accessors ((array input-buffer-array)) stream + (let ((buffer (buffer (drei-instance stream)))) + (when array + ;; Attempt to minimise the changes to the buffer, so the + ;; position of marks will not be changed too much. Find the + ;; first mismatch between buffer contents and array contents. + (let ((index (loop + for index from 0 below (min (length array) + (size buffer)) + unless (eql (buffer-object buffer index) + (aref array index)) + do (return index) + finally (return nil))) + (insertion-pointer (stream-insertion-pointer stream))) + (when index ; NIL if buffer and array are identical. + ;; Delete from the first mismatch to the end of the buffer. + (delete-buffer-range buffer index + (- (size buffer) index)) + ;; Insert from the mismatch to array end into the buffer. + (insert-buffer-sequence buffer index + (subseq array index)) + ;; We also need to update the syntax. + (update-syntax buffer (syntax buffer)) + ;; Finally, see if it is possible to maintain the old + ;; position of the insertion pointer. + (setf (stream-insertion-pointer stream) + (min insertion-pointer (size buffer))))) + (setf array nil))))) + +;; While the CLIM spec says that user-commands are not allowed to do +;; much with the input buffer, the Franz User Guide provides some +;; examples that hint to the opposite. How do we make modifications of +;; the input-buffer, which must be a standard array with a fill +;; pointer, to be applied to the "real" buffer? This is how: when this +;; method is called, we store the object in the stream object. In the +;; command loop, we check the stream object and update the buffer +;; (using `update-drei-buffer') to reflect the changes done to the +;; buffer. (defmethod stream-input-buffer ((stream drei-input-editing-mixin)) - ;; NOTE: This is very slow, please do not use it unless you want to - ;; be compatible with other editor substrates. Use the Drei buffer - ;; directly instead. - (with-accessors ((buffer buffer)) (drei-instance stream) - (let* ((array (buffer-sequence buffer 0 (size buffer)))) - (make-array (length array) - :fill-pointer (length array) - :initial-contents array)))) + ;; NOTE: This is very slow (consing up a whole new array - twice!), + ;; please do not use it unless you want to be compatible with other + ;; editor substrates. Use the Drei buffer directly instead. + (or (input-buffer-array stream) + (setf (input-buffer-array stream) + (with-accessors ((buffer buffer)) (drei-instance stream) + (let* ((array (buffer-sequence buffer 0 (size buffer)))) + (make-array (length array) + :fill-pointer (length array) + :initial-contents array)))))) (defmethod replace-input ((stream drei-input-editing-mixin) (new-input array) &key @@ -372,21 +424,25 @@ *pointer-documentation-output* minibuffer) :prompt "M-x ") - ;; We narrow the buffer to the input position, so the user won't - ;; be able to erase the original command (when entering command - ;; arguments) or stuff like argument prompts. - (accepting-from-user (drei) - (drei-core:with-narrowed-buffer (drei (input-position stream) t t) - (handler-case (process-gestures-or-command drei) - (unbound-gesture-sequence (c) - (display-message "~A is unbound" (gesture-name (gestures c)))) - (abort-gesture (c) - (if (member (abort-gesture-event c) - *abort-gestures* - :test #'event-matches-gesture-name-p) - (signal 'abort-gesture :event (abort-gesture-event c)) - (when was-directly-processing - (display-message "Aborted"))))))) + ;; Commands are permitted to signal immediate rescans, but + ;; we may need to do some stuff first. + (unwind-protect + (accepting-from-user (drei) + ;; We narrow the buffer to the input position, so the user won't + ;; be able to erase the original command (when entering command + ;; arguments) or stuff like argument prompts. + (drei-core:with-narrowed-buffer (drei (input-position stream) t t) + (handler-case (process-gestures-or-command drei) + (unbound-gesture-sequence (c) + (display-message "~A is unbound" (gesture-name (gestures c)))) + (abort-gesture (c) + (if (member (abort-gesture-event c) + *abort-gestures* + :test #'event-matches-gesture-name-p) + (signal 'abort-gesture :event (abort-gesture-event c)) + (when was-directly-processing + (display-message "Aborted"))))))) + (update-drei-buffer stream)) ;; Will also take care of redisplaying minibuffer. (display-drei drei) (let ((first-mismatch (offset (high-mark buffer)))) From thenriksen at common-lisp.net Fri Dec 1 23:02:59 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 1 Dec 2006 18:02:59 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Goatee Message-ID: <20061201230259.E289B702E8@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Goatee In directory clnet:/tmp/cvs-serv18978/Goatee Modified Files: editing-stream.lisp Log Message: Implement `erase-input-buffer' (somewhat, mostly so older CLIM programs won't hit a NO-APPLICABLE-METHOD error). --- /project/mcclim/cvsroot/mcclim/Goatee/editing-stream.lisp 2006/11/22 14:23:22 1.23 +++ /project/mcclim/cvsroot/mcclim/Goatee/editing-stream.lisp 2006/12/01 23:02:59 1.24 @@ -406,3 +406,8 @@ (defmethod redraw-input-buffer ((stream goatee-input-editing-mixin) &optional (start-position 0)) (declare (ignore start-position)) (redisplay-area (area stream))) + +(defmethod erase-input-buffer ((stream goatee-input-editing-mixin) + &optional (start-position 0)) + (declare (ignore start-position)) + (clear-output-record (area stream))) From thenriksen at common-lisp.net Fri Dec 1 23:03:00 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 1 Dec 2006 18:03:00 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061201230300.2D0DE710D2@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv18978/Drei Modified Files: input-editor.lisp Log Message: Implement `erase-input-buffer' (somewhat, mostly so older CLIM programs won't hit a NO-APPLICABLE-METHOD error). --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/12/01 22:39:14 1.8 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/12/01 23:02:59 1.9 @@ -560,6 +560,13 @@ ;; figure out what to redraw than to just redraw everything. (display-drei (drei-instance stream))) +(defmethod erase-input-buffer ((stream drei-input-editing-mixin) + &optional (start-position 0)) + (declare (ignore start-position)) + ;; Again, we ignore `start-position'. What is the big idea behind + ;; this function anyway? + (clear-output-record (drei-instance stream))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; `Add-input-editor-command' From thenriksen at common-lisp.net Sat Dec 2 20:28:18 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 2 Dec 2006 15:28:18 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061202202818.5C2C230027@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv7322 Modified Files: lisp-syntax.lisp Log Message: Improved and fixed some `token-to-object' methods. Soon, Drei will be able to compile itself! --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/11/27 12:28:01 1.7 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/12/02 20:28:18 1.8 @@ -1709,6 +1709,8 @@ (define-form-predicate form-token-p (token-mixin)) (define-form-predicate form-string-p (string-form)) (define-form-predicate form-quoted-p (quote-form backquote-form)) +(define-form-predicate form-comma-p (comma-form)) +(define-form-predicate form-comma-at-p (comma-at-form)) (define-form-predicate comment-p (comment)) @@ -2563,7 +2565,13 @@ (defmethod token-to-object (syntax (token backquote-form) &rest args) (let ((backquoted-form (first-form (children token)))) (if (form-list-p backquoted-form) - `'(,@(apply #'token-to-object syntax backquoted-form args)) + `(list ,@(loop for element in (children backquoted-form) + if (form-comma-p element) + collect (apply #'token-to-object syntax element args) + else if (form-comma-at-p element) + nconc (apply #'token-to-object syntax element args) + else if (formp element) + collect (apply #'token-to-object syntax element :quote t args))) `',(apply #'token-to-object syntax backquoted-form args)))) (defmethod token-to-object (syntax (token comma-form) &rest args) @@ -2634,7 +2642,7 @@ ""))))) (defmethod token-to-object ((syntax lisp-syntax) (token complete-function-form) &rest args &key &allow-other-keys) - (fdefinition (apply #'token-to-object syntax (second (children token)) args))) + (list 'function (apply #'token-to-object syntax (second (children token)) args))) (defmethod token-to-object ((syntax lisp-syntax) (token bit-vector-form) &key &allow-other-keys) From dlichteblau at common-lisp.net Sun Dec 3 08:09:07 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 3 Dec 2006 03:09:07 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061203080907.2D3386301D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv20228 Modified Files: gadgets.lisp Log Message: Fix gsharp startup crash reported by "C Y": * gadgets.lisp (realize-native-widget :around): Don't call gadget-active-p unless it's actually a gadget. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/11/26 17:54:08 1.14 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/12/03 08:09:06 1.15 @@ -587,7 +587,8 @@ (defmethod realize-native-widget :around ((gadget native-widget-mixin)) (let ((widget (call-next-method))) - (gtk_widget_set_sensitive widget (if (gadget-active-p gadget) 1 0)) + (when (typep gadget 'gadget) + (gtk_widget_set_sensitive widget (if (gadget-active-p gadget) 1 0))) widget)) (defmethod activate-gadget :after ((gadget native-widget-mixin)) From dlichteblau at common-lisp.net Sun Dec 3 15:24:10 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 3 Dec 2006 10:24:10 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061203152410.14BB47D164@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv3918 Modified Files: medium.lisp pixmap.lisp port.lisp Log Message: Set the antialising mode on /all/ cairo crs. * medium.lisp (set-antialias): New function. (sync-sheet, sync-ink, make-cairo-surface): Call set-antialias. * port.lisp ((initialize-instance :after), mirror-drawable): Call set-antialias. Fix the beams: * pixmap.lisp (%medium-copy-area): Perform clipping. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/11/19 15:55:11 1.12 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/12/03 15:24:09 1.13 @@ -74,6 +74,12 @@ (not (region-equal (last-seen-region medium) (sheet-region (medium-sheet medium))))))) +(defun set-antialias (cr) + (cairo_set_antialias cr + (if *antialiasingp* + :CAIRO_ANTIALIAS_DEFAULT + :CAIRO_ANTIALIAS_NONE))) + (defun sync-sheet (medium) (when (medium-sheet medium) ;ignore the metrik-medium (setf (gethash medium (dirty-mediums (port medium))) t)) @@ -85,7 +91,7 @@ (setf (cr medium) (gdk_cairo_create drawable)) (dispose-flipping-pixmap medium) (pushnew medium (mirror-mediums mirror)) - (cairo_set_antialias (cr medium) (if *antialiasingp* 0 1))) + (set-antialias (cr medium))) (setf (last-seen-sheet medium) (medium-sheet medium)) (setf (last-seen-region medium) (sheet-region (medium-sheet medium)))))) @@ -250,6 +256,7 @@ (setf (flipping-pixmap medium) (gdk_pixmap_new drawable width height -1))))) (setf (cr medium) (gdk_cairo_create pixmap)) + (set-antialias (cr medium)) (setf (flipping-region medium) region) (cairo_paint (cr medium)) (sync-transformation medium) @@ -938,6 +945,7 @@ (cairo_get_target (cr compatible-medium)) format width height)) (c (cairo_create s))) + (set-antialias c) (make-instance 'gtkairo-medium :cr c :surface s))) (defmacro with-pattern ((m1 mp) &body body) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/pixmap.lisp 2006/04/17 18:40:27 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/pixmap.lisp 2006/12/03 15:24:09 1.2 @@ -44,16 +44,23 @@ (to-drawable (medium-gdkdrawable to-medium))) (cairo_surface_flush from-surface) (cairo_surface_flush to-surface) - (let ((gc (gdk_gc_new to-drawable))) - (gdk_draw_drawable to-drawable - gc - from-drawable - (truncate from-x) - (truncate from-y) - (truncate to-x) - (truncate to-y) - (truncate width) - (truncate height)) + (let ((gc (gdk_gc_new to-drawable)) + (region (medium-clipping-region to-medium))) + (unless (eq region +nowhere+) + (setf region + (region-intersection + region + (make-rectangle* to-x to-y (+ to-x width) (+ to-y height)))) + (loop for (x y w h) in (clipping-region->rect-seq region) do + (gdk_draw_drawable to-drawable + gc + from-drawable + (truncate (+ from-x x (- to-x))) + (truncate (+ from-y y (- to-y))) + (truncate x) + (truncate y) + (truncate w) + (truncate h)))) (gdk_gc_unref gc)) (cairo_surface_mark_dirty to-surface)))) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/11/19 17:31:20 1.11 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/12/03 15:24:09 1.12 @@ -83,6 +83,7 @@ (gtk_init (cffi:null-pointer) (cffi:null-pointer)) (let ((cr (gdk_cairo_create (gdk_screen_get_root_window (gdk_screen_get_default))))) + (set-antialias cr) (setf (metrik-medium port) (make-instance 'metrik-medium :port port :cr cr)))) (when clim-sys:*multiprocessing-p* @@ -150,6 +151,7 @@ (height (floor (bounding-rectangle-max-y region))) (pixmap (gdk_pixmap_new window width height -1)) (cr (gdk_cairo_create pixmap))) + (set-antialias cr) (cairo_set_source_rgba cr 1.0d0 1.0d0 From dlichteblau at common-lisp.net Sun Dec 3 19:17:26 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 3 Dec 2006 14:17:26 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061203191726.BF94A2E1B8@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv18224 Modified Files: event.lisp Log Message: * event.lisp (gdkmodifiertype->modifier-state): Uncomment the mod2 -> super-key mapping, it has been reported to be incorrect. (key-handler): Map symbol :TAB to character #\tab. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/11/25 21:14:53 1.14 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/12/03 19:17:26 1.15 @@ -169,7 +169,7 @@ (if (logtest GDK_SHIFT_MASK state) +shift-key+ 0) (if (logtest GDK_CONTROL_MASK state) +control-key+ 0) (if (logtest GDK_MOD1_MASK state) +meta-key+ 0) - (if (logtest GDK_MOD2_MASK state) +super-key+ 0) + ;; (if (logtest GDK_MOD2_MASK state) +super-key+ 0) (if (logtest GDK_MOD3_MASK state) +hyper-key+ 0) ;;; (if (logtest GDK_MOD4_MASK state) ??? 0) ;;; (if (logtest GDK_MOD5_MASK state) ??? 0) @@ -224,6 +224,8 @@ (cond ((eq sym :backspace) (setf char #\backspace)) + ((eq sym :tab) + (setf char #\tab)) ((null char)) ((eql char #\return)) ((eql char #\escape) From thenriksen at common-lisp.net Sun Dec 3 19:18:06 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 3 Dec 2006 14:18:06 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061203191806.62CA132014@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv18496 Modified Files: input-editing-drei.lisp Log Message: Stuff inserted via the presentation history should never be an accept result. --- /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2006/11/27 07:44:46 1.3 +++ /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2006/12/03 19:18:06 1.4 @@ -208,7 +208,9 @@ (multiple-value-bind (object type) (presentation-history-next history accepting-type) (when type - (presentation-replace-input stream object type (stream-default-view stream))))))) + (presentation-replace-input stream object type (stream-default-view stream) + :allow-other-keys t + :accept-result nil)))))) (defun history-yank-previous (stream input-buffer gesture numeric-argument) (declare (ignore input-buffer gesture numeric-argument)) @@ -219,7 +221,9 @@ (multiple-value-bind (object type) (presentation-history-previous history accepting-type) (when type - (presentation-replace-input stream object type (stream-default-view stream))))))) + (presentation-replace-input stream object type (stream-default-view stream) + :allow-other-keys t + :accept-result nil)))))) (add-input-editor-command '((#\n :meta)) 'history-yank-next) From thenriksen at common-lisp.net Sun Dec 3 19:59:29 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 3 Dec 2006 14:59:29 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc/Guided-Tour Message-ID: <20061203195929.7D1B55D00B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour In directory clnet:/tmp/cvs-serv26347/Doc/Guided-Tour Modified Files: guided-tour.tex Log Message: Added mention of Gtkairo. --- /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour/guided-tour.tex 2006/11/05 16:54:10 1.5 +++ /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour/guided-tour.tex 2006/12/03 19:59:29 1.6 @@ -223,9 +223,10 @@ facilities will automatically adapt to use whatever toolkit is available on and appropriate for the host environment. In addition, portable Lisp-based implementations of the abstract gadget pane -protocols are provided.\footnote{\mcclim{} does not support look and feel - adaptiveness at the moment except for the experimental beagle backend for Mac - OS X's Cocoa platform. Hence, \mcclim{} mostly uses this portable Lisp-based +protocols are provided.\footnote{\mcclim{} does not support look and + feel adaptiveness at the moment except for the experimental beagle + backend for Mac OS X's Cocoa platform, or the Gtkairo backend using + GTK. Hence, \mcclim{} mostly uses this portable Lisp-based implementation.} \paragraph*{Application Building} \CLIM{} provides a set of tools for From thenriksen at common-lisp.net Sun Dec 3 22:50:13 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 3 Dec 2006 17:50:13 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061203225013.D13416003B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv20865/Drei Modified Files: core.lisp Log Message: Oops, these arguments should be the other way around. --- /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2006/12/03 22:50:13 1.2 @@ -250,8 +250,8 @@ syntax-line-indentation-function fill-column tab-width - compress-whitespaces - syntax)))) + syntax + compress-whitespaces)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From ahefner at common-lisp.net Sun Dec 3 22:56:46 2006 From: ahefner at common-lisp.net (ahefner) Date: Sun, 3 Dec 2006 17:56:46 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20061203225646.DD9446003B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv20883 Modified Files: dev-commands.lisp listener.lisp Log Message: If we're going to present the package portion of the prompt, we might as well define a translator to do something useful with it (or am I missing the point?). While we're at it, present the package in the wholine-pane, and add a popup to choose a new package. Also, added discussion of presentation of values at the REPL, as I'm not entirely happy with the current behavior, but leave it unchanged for the moment. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/11/21 20:34:40 1.38 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/12/03 22:56:46 1.39 @@ -23,7 +23,7 @@ (define-command-table application-commands) -(define-command-table lisp-dev-commands :inherit-from nil) ;; "Abstract" command table used for defining some translators in +(define-command-table lisp-dev-commands :inherit-from nil) ;; Translators live here (define-command-table lisp-commands :inherit-from (lisp-dev-commands)) (define-command-table show-commands :inherit-from (lisp-dev-commands)) @@ -519,11 +519,11 @@ ((class-spec 'class-name :prompt "class") &key (orientation 'keyword :prompt "orientation" :default :horizontal)) - (let ((class (frob-to-class class-spec))) - (if (not (null class)) + (let ((class (frob-to-class class-spec))) + (if (not (null class)) (class-grapher *standard-output* class #'clim-mop:class-direct-subclasses :orientation orientation) - (note "~A is not a defined class." class-spec)))) + (note "~A is not a defined class." class-spec)))) ; Lookup direct slots from along the CPL given a class and a slot name. @@ -1261,7 +1261,7 @@ ;; So.. yeah. (defun automagic-translator (pathname) - "Returns values, the command translation, and a documentation string for the translation." + "Returns 2 values: the command translation, and a documentation string for the translation." (cond ((wild-pathname-p pathname) (values `(com-show-directory ,pathname) "Show Matching Files" @@ -1443,26 +1443,47 @@ ;;; Eval (defun display-evalues (values) - (with-drawing-options (t :ink +olivedrab+) - (cond ((null values) - (format t "No values.~%")) - ((= 1 (length values)) - (let ((o (first values))) - (with-output-as-presentation (t o (presentation-type-of o) - :single-box t) - (present (first values) 'expression))) - (fresh-line)) - (t (do* ((i 0 (1+ i)) - (items values (rest items)) - (o (first items) (first items))) - ((null items)) + (labels + ((present-value (value) + ;; I would really prefer this to behave as below, as presenting + ;; things as expressions causes translators applicable to expression + ;; to override those which would be otherwise applicable (such as + ;; the set-current-package translator). I retain the use of w-o-a-p, + ;; swapping the inner/outer presentation types, with the assumption + ;; that someone (the form reader?) really does want expressions, and + ;; the presentation-type-of is seldom a subtype of expression. + ;; Aside from that, the problem with my code below is that it + ;; will use the default presentation method for the type, which will + ;; not necessarily print in the fashion expected from the lisp REPL. + ;; Possibly this +listener-view+ could save the day here, but I'm + ;; unclear on why it exists. --Hefner + + ;; Okay, set-current-package translator now mysteriously works, but + ;; I stand by the notion that 'expression should not be the type of + ;; the innermost presentation. + + #+(or) + (with-output-as-presentation (t value 'expression :single-box t) + (present value (presentation-type-of value) :single-box t)) + + (with-output-as-presentation (t value (presentation-type-of value) + :single-box t) + (present (first values) 'expression)))) + (with-drawing-options (t :ink +olivedrab+) + (cond ((null values) + (format t "No values.~%")) + ((= 1 (length values)) + (present-value (first values)) + (fresh-line)) + (t (do* ((i 0 (1+ i)) + (items values (rest items)) + (object (first items) (first items))) + ((null items)) (with-drawing-options (t :ink +limegreen+) (with-text-style (t (make-text-style nil :italic :small)) (format t "~A " i))) - (with-output-as-presentation (t o (presentation-type-of o) - :single-box t) - (present o 'expression)) - (fresh-line)))))) + (present-value object) + (fresh-line))))))) (defun shuffle-specials (form values) (setf +++ ++ @@ -1476,7 +1497,7 @@ * (first values))) (define-command (com-eval :menu t :command-table lisp-commands) - ((form 'clim:form :prompt "form")) + ((form 'clim:form :prompt "form")) (let* ((- form) (values (multiple-value-list (eval form)))) (fresh-line) @@ -1563,3 +1584,14 @@ :provide-output-destination-keyword nil) ((p 'package)) (setf *package* p)) + +(define-presentation-to-command-translator set-current-package + (package com-set-package lisp-commands + :pointer-documentation ((object stream) + (format stream "Set current package to ~A" (package-name object))) + :documentation ((stream) (format stream "Set Package")) + :menu t + :tester ((object) (not (eql *package* object)))) + (object) + (list object)) + --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/11/21 22:39:32 1.30 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/12/03 22:56:46 1.31 @@ -19,6 +19,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. +(define-presentation-type listener-current-package () :inherit-from 'package) ;; Wholine Pane @@ -92,7 +93,8 @@ (cell (:left) (format t "~A@~A" username sitename)) (cell (:center) (format t "Package ") - (print-package-name t)) + (with-output-as-presentation (t *package* 'listener-current-package) + (print-package-name t))) (cell (:center) (when (probe-file *default-pathname-defaults*) (with-output-as-presentation (t (truename *default-pathname-defaults*) 'pathname) @@ -163,7 +165,7 @@ (defmethod stream-present :around ((stream listener-interactor-pane) object type &rest args &key (single-box nil sbp) &allow-other-keys) - (apply #'call-next-method stream object type :single-box t args) + (apply #'call-next-method stream object type :single-box t args) ;; we would do this, but CLIM:PRESENT calls STREAM-PRESENT with all ;; the keyword arguments explicitly. *sigh*. #+nil @@ -199,6 +201,29 @@ doc wholine)))) +;;; Package selection popup + +(define-listener-command (com-choose-package) + () + (let ((new-package (menu-choose (sort (mapcar (lambda (package) (cons (package-name package) + package)) + (list-all-packages)) + #'string< + :key #'car) + :label "Choose Package"))) + (when new-package + (setf *package* new-package)))) + +(define-presentation-to-command-translator choose-package-translator + (listener-current-package com-choose-package listener + :echo nil + :priority 100 ; These presentations appear in exactly one context, so give this a high priority. + :documentation ((object stream) + (declare (ignore object)) + (format stream "Choose package"))) + (current-package) + nil) + ;;; Lisp listener command loop (defmethod read-frame-command ((frame listener) &key (stream *standard-input*)) From thenriksen at common-lisp.net Mon Dec 4 07:48:49 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 4 Dec 2006 02:48:49 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/cl-automaton Message-ID: <20061204074849.1C1829@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/cl-automaton In directory clnet:/tmp/cvs-serv11067/Drei/cl-automaton Removed Files: state-and-transition-test.lisp eqv-hash-test.lisp automaton-test.lisp automaton-test-package.lisp Log Message: Removed old RT-based tests. From thenriksen at common-lisp.net Mon Dec 4 07:48:49 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 4 Dec 2006 02:48:49 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061204074849.619909@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv11067/Drei Removed Files: kill-ring-test.lisp drei.asd buffer-test.lisp base-test.lisp Log Message: Removed old RT-based tests. From thenriksen at common-lisp.net Mon Dec 4 07:51:27 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 4 Dec 2006 02:51:27 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests Message-ID: <20061204075127.960644046@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv11404/Drei/Tests Log Message: Directory /project/mcclim/cvsroot/mcclim/Drei/Tests added to the repository From thenriksen at common-lisp.net Mon Dec 4 07:52:18 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 4 Dec 2006 02:52:18 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests/cl-automaton Message-ID: <20061204075218.0ED914049@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton In directory clnet:/tmp/cvs-serv11497/Drei/Tests/cl-automaton Log Message: Directory /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton added to the repository From thenriksen at common-lisp.net Mon Dec 4 07:54:51 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 4 Dec 2006 02:54:51 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests/cl-automaton Message-ID: <20061204075451.5AF784048@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton In directory clnet:/tmp/cvs-serv11709/Drei/Tests/cl-automaton Added Files: state-and-transition-tests.lisp regexp-tests.lisp eqv-hash-tests.lisp automaton-tests.lisp Log Message: Replaced the old RT-based test suite with a new FiveAM-based one. Also added a fair amount of new tests. What isn't tested is: - CLIM parts - Commands - Syntax module and specific syntaxes (Unfortunately, these are arguably the most interesting things to test). --- /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton/state-and-transition-tests.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton/state-and-transition-tests.lisp 2006/12/04 07:54:51 1.1 ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic at yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas at sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) (def-suite state-and-transition-tests :description "The test suite for CL-AUTOMATON state-and-transition related tests.") (in-suite state-and-transition-tests) (test clone.transition (let* ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (t2 (automaton::clone t1))) (is (eqv t1 t2 +equalp-key-situation+)) (is (eql (hash t1 +equalp-key-situation+) (hash t2 +equalp-key-situation+))))) (test transition<.1 (let ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\c) :maxc (char-code #\d) :to (make-instance 'automaton::state))) (automaton::*to-first* nil)) (is-true (automaton::transition< t1 t2)))) (test transition<.2 (let ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\c) :maxc (char-code #\d) :to (make-instance 'automaton::state))) (automaton::*to-first* t)) (setf (automaton::num (automaton::to t1)) 1) (is-true (automaton::transition< t2 t1))) (let ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\d) :to (make-instance 'automaton::state))) (automaton::*to-first* t)) (is-true (automaton::transition< t2 t1)))) (test transition<.3 (let ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\c) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (automaton::*to-first* nil)) (is-true (automaton::transition< t1 t2)))) (test sstep.test-1 (let* ((s (make-instance 'automaton::state)) (tr (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to s))) (htadd (automaton::transitions s) tr) (is (eq (automaton::sstep s #\a) s)))) (test sstep.test-2 (let* ((s (make-instance 'automaton::state)) (tr (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to s))) (htadd (automaton::transitions s) tr) (is-false (automaton::sstep s #\c)))) (test add-epsilon (let* ((s1 (make-instance 'automaton::state)) (s2 (make-instance 'automaton::state)) (tr (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to s2))) (htadd (automaton::transitions s2) tr) (automaton::add-epsilon s1 s2) (is-true (htpresent (automaton::transitions s1) tr)))) (test sorted-transition-vector (let* ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\c) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (s (make-instance 'automaton::state))) (htadd (automaton::transitions s) t1) (htadd (automaton::transitions s) t2) (is (equalp (automaton::sorted-transition-vector s nil) (vector t1 t2))))) (test sorted-transition-list (let* ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\c) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (s (make-instance 'automaton::state))) (htadd (automaton::transitions s) t1) (htadd (automaton::transitions s) t2) (is (equal (automaton::sorted-transition-list s nil) (list t1 t2)))))--- /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton/regexp-tests.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton/regexp-tests.lisp 2006/12/04 07:54:51 1.1 ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic at yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas at sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) (def-suite regexp-tests :description "The test suite for CL-AUTOMATON regexp related tests.") (in-suite regexp-tests) (automaton-test string-regexp.1 (is-true (regexp-equal (string-regexp "#") (automaton::make-regexp :empty)))) (automaton-test string-regexp.2 (is-true (regexp-equal (string-regexp "foo") (make-instance 'automaton::regexp :kind :string :s "foo"))) (is-true (regexp-equal (string-regexp "\"foo\"") (make-instance 'automaton::regexp :kind :string :s "foo"))) (is-true (regexp-equal (string-regexp "()") (make-instance 'automaton::regexp :kind :string :s "")))) (automaton-test string-regexp.3 (is-true (regexp-equal (string-regexp "c") (make-instance 'automaton::regexp :kind :char :c #\c))) (is-true (regexp-equal (string-regexp "\c") (make-instance 'automaton::regexp :kind :char :c #\c))) (is-true (regexp-equal (string-regexp "\\c") (make-instance 'automaton::regexp :kind :char :c #\c)))) (automaton-test string-regexp.4 (is-true (regexp-equal (string-regexp ".") (automaton::make-regexp :anychar)))) (automaton-test string-regexp.5 (is-true (regexp-equal (string-regexp "@") (automaton::make-regexp :anystring)))) (automaton-test string-regexp.6 (is-true (regexp-equal (string-regexp "<11-15>") (make-instance 'automaton::regexp :kind :interval :minr 11 :maxr 15 :digits 2))) (is-true (regexp-equal (string-regexp "<11-115>") (make-instance 'automaton::regexp :kind :interval :minr 11 :maxr 115 :digits 0))) (is-true (regexp-equal (string-regexp "<115-11>") (make-instance 'automaton::regexp :kind :interval :minr 11 :maxr 115 :digits 0)))) (automaton-test string-regexp.7 (is-true (regexp-equal (string-regexp "") (make-instance 'automaton::regexp :kind :automaton :s "sub")))) (automaton-test string-regexp.8 (is-true (regexp-equal (string-regexp "[a-z]") (make-instance 'automaton::regexp :kind :char-range :from #\a :to #\z))) (is-true (regexp-equal (string-regexp "[a]") (make-instance 'automaton::regexp :kind :char :c #\a)))) (automaton-test string-regexp.9 (is-true (regexp-equal (string-regexp "[a][b][c]") (make-instance 'automaton::regexp :kind :string :s "abc")))) (automaton-test string-regexp.10 (is-true (regexp-equal (string-regexp "[ab]") (automaton::make-regexp :union (make-instance 'automaton::regexp :kind :char :c #\a) (make-instance 'automaton::regexp :kind :char :c #\b))))) (automaton-test string-regexp.11 (is-true (regexp-equal (string-regexp "[^a-c0-3]") (automaton::make-regexp :intersection (automaton::make-regexp :anychar) (automaton::make-regexp :complement (automaton::make-regexp :union (make-instance 'automaton::regexp :kind :char-range :from #\a :to #\c) (make-instance 'automaton::regexp :kind :char-range :from #\0 :to #\3)))))) (is-true (regexp-equal (string-regexp "[a^b-c]") (automaton::make-regexp :union (automaton::make-regexp :union (make-instance 'automaton::regexp :kind :char :c #\a) (make-instance 'automaton::regexp :kind :char :c #\^)) (make-instance 'automaton::regexp :kind :char-range :from #\b :to #\c))))) (automaton-test string-regexp.12 (is-true (regexp-equal (string-regexp "~[a-c]") (automaton::make-regexp :complement (make-instance 'automaton::regexp :kind :char-range :from #\a :to #\c))))) (automaton-test string-regexp.13 (is-true (regexp-equal (string-regexp "f?") (automaton::make-regexp :optional (make-instance 'automaton::regexp :kind :char :c #\f))))) (automaton-test string-regexp.14 (is-true (regexp-equal (string-regexp "(\"foo\")?") (automaton::make-regexp :optional (make-instance 'automaton::regexp :kind :string :s "foo"))))) (automaton-test string-regexp.15 (is-true (regexp-equal (string-regexp "[a-c]*") (automaton::make-regexp :repeat (make-instance 'automaton::regexp :kind :char-range :from #\a :to #\c))))) (automaton-test string-regexp.16 (is-true (regexp-equal (string-regexp "(\"foo\")+") (make-instance 'automaton::regexp :kind :repeat-min :exp1 (make-instance 'automaton::regexp :kind :string :s "foo") :minr 1)))) (automaton-test string-regexp.17 (is-true (regexp-equal (string-regexp "[a-c]{3}") (make-instance 'automaton::regexp :kind :repeat-minmax :exp1 (make-instance 'automaton::regexp :kind :char-range :from #\a :to #\c) :minr 3 :maxr 3)))) (automaton-test string-regexp.18 (is-true (regexp-equal (string-regexp "(~c){1,2}") (make-instance 'automaton::regexp :kind :repeat-minmax :exp1 (automaton::make-regexp :complement (make-instance 'automaton::regexp :kind :char :c #\c)) :minr 1 :maxr 2)))) (automaton-test string-regexp.19 (is-true (regexp-equal (string-regexp "[a-z]~[0-9]") (automaton::make-regexp :concatenation (make-instance 'automaton::regexp :kind :char-range :from #\a :to #\z) (automaton::make-regexp :complement (make-instance 'automaton::regexp :kind :char-range :from #\0 :to #\9)))))) (automaton-test string-regexp.20 (is-true (regexp-equal (string-regexp "(ab+)&(a+b)|c") (automaton::make-regexp :union (automaton::make-regexp :intersection (automaton::make-regexp :concatenation (make-instance 'automaton::regexp :kind :char :c #\a) (make-instance 'automaton::regexp :kind :repeat-min :exp1 (make-instance 'automaton::regexp :kind :char :c #\b) :minr 1)) (automaton::make-regexp :concatenation (make-instance 'automaton::regexp :kind :repeat-min :exp1 (make-instance 'automaton::regexp :kind :char :c #\a) :minr 1) (make-instance 'automaton::regexp :kind :char :c #\b))) (make-instance 'automaton::regexp :kind :char :c #\c))))) (automaton-test string-regexp.21 (is-true (regexp-equal (string-regexp "a\"b\"+c") (automaton::make-regexp :concatenation (make-instance 'automaton::regexp :kind :char :c #\a) (automaton::make-regexp :concatenation (make-instance 'automaton::regexp :kind :repeat-min :exp1 (make-instance 'automaton::regexp :kind :string :s "b") :minr 1) (make-instance 'automaton::regexp :kind :char :c #\c)))))) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton/eqv-hash-tests.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton/eqv-hash-tests.lisp 2006/12/04 07:54:51 1.1 ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic at yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas at sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) (def-suite eqv-hash-tests :description "The test suite for CL-AUTOMATON eqv-hash related tests.") (in-suite eqv-hash-tests) (defclass foo () ((slot1 :initform 0 :initarg :slot1 :type fixnum :accessor slot1) (slot2 :initform 0 :initarg :slot2 :type fixnum :accessor slot2))) (defclass foo-intention (equalp-key-situation) ()) (defparameter +foo-intention+ (make-instance 'foo-intention)) (defmethod eqv ((foo1 foo) (foo2 foo) (s (eql +foo-intention+))) (eql (slot1 foo1) (slot1 foo2))) (defmethod hash ((foo1 foo) (s (eql +foo-intention+))) (floor (slot1 foo1) 2)) (test htref.test-1 ; (eqv i1 i2), (= (hash i1) (hash i2)) (let ((ght (make-generalized-hash-table +foo-intention+)) (i1 (make-instance 'foo :slot1 1 :slot2 2)) (i2 (make-instance 'foo :slot1 1 :slot2 3))) (setf (htref ght i1) i1) (setf (htref ght i2) i2) (is (= (cnt ght) 1)) (is (eq (htref ght i1) i2)) (is (htref ght i2) i2))) [143 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton/automaton-tests.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton/automaton-tests.lisp 2006/12/04 07:54:51 1.1 [439 lines skipped] From thenriksen at common-lisp.net Mon Dec 4 07:54:51 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 4 Dec 2006 02:54:51 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests Message-ID: <20061204075451.A4ED3A0F1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv11709/Drei/Tests Added Files: undo-tests.lisp testing.lisp rectangle-tests.lisp packages.lisp motion-tests.lisp kill-ring-tests.lisp editing-tests.lisp core-tests.lisp buffer-tests.lisp base-tests.lisp Log Message: Replaced the old RT-based test suite with a new FiveAM-based one. Also added a fair amount of new tests. What isn't tested is: - CLIM parts - Commands - Syntax module and specific syntaxes (Unfortunately, these are arguably the most interesting things to test). --- /project/mcclim/cvsroot/mcclim/Drei/Tests/undo-tests.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/undo-tests.lisp 2006/12/04 07:54:51 1.1 ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas at sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) (def-suite undo-tests :description "The test suite for tests related to Drei's undo system.") (in-suite undo-tests) (defclass test-undo-record (standard-undo-record) ()) (defmethod flip-undo-record ((record test-undo-record))) (test add-undo (let ((tree (make-instance 'standard-undo-tree))) (finishes (add-undo (make-instance 'test-undo-record) tree)) (finishes (add-undo (make-instance 'test-undo-record) tree)))) (test undo (let ((tree (make-instance 'standard-undo-tree))) (add-undo (make-instance 'test-undo-record) tree) (add-undo (make-instance 'test-undo-record) tree) (finishes (undo tree 2)) (signals no-more-undo (undo tree 1)))) (test redo (let ((tree (make-instance 'standard-undo-tree))) (add-undo (make-instance 'test-undo-record) tree) (undo tree 1) (redo tree 1) (finishes (undo tree 1)))) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/testing.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/testing.lisp 2006/12/04 07:54:51 1.1 ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic at yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas at sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) ;; Define some stuff to ease the pain of writing repetitive test ;; cases. Also provide test-running entry point. (defclass delegating-standard-buffer (delegating-buffer) () (:default-initargs :implementation (make-instance 'standard-buffer))) (eval-when (:load-toplevel :compile-toplevel :execute) (defparameter *buffer-classes* '((standard-buffer) (delegating-standard-buffer) (binseq-buffer persistent-left-sticky-mark persistent-right-sticky-mark) (obinseq-buffer persistent-left-sticky-mark persistent-right-sticky-mark) (binseq2-buffer persistent-left-sticky-line-mark persistent-right-sticky-line-mark)))) (defmacro buffer-test (name &body body) "Define FiveAM tests for all the standard buffer classes. %%BUFFER in `body' will be substituted for a buffer class, %%LEFT-STICKY-MARK will be substituted for a left-sticky-mark class and %%RIGHT-STICKY-MARK will be substituted for a right sticky mark class." (let (result) (dolist (class-spec *buffer-classes*) (destructuring-bind (buffer &optional (left-sticky-mark 'standard-left-sticky-mark) (right-sticky-mark 'standard-right-sticky-mark)) class-spec (let ((alist (list (cons '%%buffer `',buffer) (cons '%%left-sticky-mark `',left-sticky-mark) (cons '%%right-sticky-mark `',right-sticky-mark)))) (push `(test ,(intern (concatenate 'string (symbol-name buffer) "-" (symbol-name name))) ,@(sublis alist body)) result)))) (list* 'progn result))) (defmacro with-buffer ((buffer &key (syntax ''drei-fundamental-syntax:fundamental-syntax) (initial-contents "")) &body body) `(let ((,buffer (make-instance 'drei-buffer :syntax ,syntax :initial-contents ,initial-contents))) (update-syntax ,buffer (syntax ,buffer)) , at body)) (defun buffer-contents (&optional (buffer *current-buffer*)) "The contents of `*current-buffer*' as a string." (buffer-substring buffer 0 (size buffer))) (defun buffer-is (string &optional (buffer *current-buffer*) (begin-offset 0) (end-offset (size buffer))) "Check (using FiveAM) whether `buffer' contains `string' in the subsequence delimited by `begin-offset' and `end-offset'." (is (string= (buffer-substring buffer begin-offset end-offset) string))) (defclass test-drei (drei) () (:documentation "An instantiable Drei variant with no display. Used for testing.")) (defmacro with-drei-environment ((&key (initial-contents "") (syntax ''drei-fundamental-syntax:fundamental-syntax)) &body body) (with-gensyms (buffer drei) `(with-buffer (,buffer :initial-contents ,initial-contents :syntax ,syntax) (let ((,drei (make-instance 'test-drei :buffer ,buffer))) (with-bound-drei-special-variables (,drei :minibuffer nil) , at body))))) (defun run-tests () (format t "Testing buffer protocol implementation(s)~%") (run! 'buffer-tests) (format t "Testing basic functions~%") (run! 'base-tests) (format t "Testing the kill ring~%") (run! 'kill-ring-tests) (format t "Testing mark motion~%") (run! 'motion-tests) (format t "Testing text editing functions~%") (run! 'editing-tests) (format t "Testing miscellaneus editor functions~%") (run! 'core-tests) (format t "Testing rectangle editing~%") (run! 'rectangle-tests) (format t "Testing undo~%") (run! 'undo-tests) (format t "Running the CL-AUTOMATON tests~%") (format t "Testing regular expressions~%") (run! 'regexp-tests) (format t "Testing eqv-hash~%") (run! 'eqv-hash-tests) (format t "Testing states and transitions~%") (run! 'state-and-transition-tests) (format t "Testing core automata functions~%") (run! 'automaton-tests)) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/rectangle-tests.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/rectangle-tests.lisp 2006/12/04 07:54:51 1.1 ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas at sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) (def-suite rectangle-tests :description "The test suite for rectangle-editing related tests.") (in-suite rectangle-tests) (test map-rectangle-lines (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (macrolet ((check (startcol endcol) `(progn (is-true (beginning-of-line-p mark)) (is (= (line-number mark) (incf line))) (is (> 4 line)) (is (= startcol ,startcol)) (is (= endcol ,endcol))))) (beginning-of-buffer *current-point*) (end-of-buffer *current-mark*) (let ((line -1)) (map-rectangle-lines *current-buffer* #'(lambda (mark startcol endcol) (check 0 16)) *current-point* *current-mark*) (is (= line 3))) (let ((line -1)) (map-rectangle-lines *current-buffer* #'(lambda (mark startcol endcol) (check 0 16)) *current-mark* *current-point*) (is (= line 3))) (setf (offset *current-point*) 2) (setf (offset *current-mark*) 63) (let ((line -1)) (map-rectangle-lines *current-buffer* #'(lambda (mark startcol endcol) (check 2 13)) *current-point* *current-mark*) (is (= line 3))) (let ((line -1)) (map-rectangle-lines *current-buffer* #'(lambda (mark startcol endcol) (check 2 13)) *current-mark* *current-point*) (is (= line 3))) (beginning-of-buffer *current-point*) (beginning-of-buffer *current-mark*) (let ((line -1)) (map-rectangle-lines *current-buffer* #'(lambda (mark startcol endcol) (check 0 0)) *current-point* *current-mark*) (is (= line 0)))))) (test extract-and-delete-rectangle-line (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer *current-point*) (end-of-buffer *current-mark*) (is (equal (map-rectangle-lines *current-buffer* #'extract-and-delete-rectangle-line *current-point* *current-mark*) '("Line number one " "Line number two " "Line number thre" "Line number four"))) (buffer-is " e ")) (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer *current-point*) (end-of-buffer *current-mark*) (beginning-of-line *current-mark*) (is (equal (map-rectangle-lines *current-buffer* #'extract-and-delete-rectangle-line *current-point* *current-mark*) '("" "" "" ""))) (buffer-is "Line number one Line number two Line number three Line number four")) (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer *current-point*) (forward-line *current-point* *current-syntax*) (forward-object *current-point* 5) (end-of-buffer *current-mark*) (backward-line *current-mark* *current-syntax*) (beginning-of-line *current-mark*) (forward-object *current-mark* 12) (is (equal (map-rectangle-lines *current-buffer* #'extract-and-delete-rectangle-line *current-point* *current-mark*) '("number " "number "))) (buffer-is "Line number one Line two Line three Line number four"))) (test open-rectangle-line (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer *current-point*) (end-of-buffer *current-mark*) (map-rectangle-lines *current-buffer* #'open-rectangle-line *current-point* *current-mark*) (buffer-is " Line number one Line number two Line number three Line number four")) (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer *current-point*) (end-of-buffer *current-mark*) (beginning-of-line *current-mark*) (map-rectangle-lines *current-buffer* #'open-rectangle-line *current-point* *current-mark*) (buffer-is "Line number one Line number two Line number three Line number four")) (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer *current-point*) (forward-line *current-point* *current-syntax*) (forward-object *current-point* 5) (end-of-buffer *current-mark*) (backward-line *current-mark* *current-syntax*) (beginning-of-line *current-mark*) (forward-object *current-mark* 12) (map-rectangle-lines *current-buffer* #'open-rectangle-line *current-point* *current-mark*) (buffer-is "Line number one Line number two Line number three Line number four"))) (test clear-rectangle-line (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer *current-point*) (end-of-buffer *current-mark*) (map-rectangle-lines *current-buffer* #'clear-rectangle-line *current-point* *current-mark*) (buffer-is " e ")) (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer *current-point*) (end-of-buffer *current-mark*) (beginning-of-line *current-mark*) (map-rectangle-lines *current-buffer* #'clear-rectangle-line *current-point* *current-mark*) (buffer-is "Line number one Line number two Line number three Line number four")) (with-drei-environment (:initial-contents "Line number one [234 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Tests/packages.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/packages.lisp 2006/12/04 07:54:51 1.1 [267 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Tests/motion-tests.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/motion-tests.lisp 2006/12/04 07:54:51 1.1 [583 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Tests/kill-ring-tests.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/kill-ring-tests.lisp 2006/12/04 07:54:51 1.1 [702 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Tests/editing-tests.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/editing-tests.lisp 2006/12/04 07:54:51 1.1 [1117 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Tests/core-tests.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/core-tests.lisp 2006/12/04 07:54:51 1.1 [1503 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Tests/buffer-tests.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/buffer-tests.lisp 2006/12/04 07:54:51 1.1 [2397 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Tests/base-tests.lisp 2006/12/04 07:54:51 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/base-tests.lisp 2006/12/04 07:54:51 1.1 [3252 lines skipped] From thenriksen at common-lisp.net Mon Dec 4 07:54:52 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 4 Dec 2006 02:54:52 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061204075452.27F32A0F2@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv11709 Modified Files: mcclim.asd Log Message: Replaced the old RT-based test suite with a new FiveAM-based one. Also added a fair amount of new tests. What isn't tested is: - CLIM parts - Commands - Syntax module and specific syntaxes (Unfortunately, these are arguably the most interesting things to test). --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/11/19 15:55:34 1.35 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/12/04 07:54:51 1.36 @@ -307,6 +307,31 @@ '(:file "lisp-syntax-swank" :depends-on ("lisp-syntax")) (values)))))) +(defsystem :drei-tests + :depends-on (:drei-mcclim :fiveam) + :components + ((:module "Tests" + :pathname #.(make-pathname :directory '(:relative "Drei" "Tests")) + :components + ((:module + "cl-automaton" + :depends-on ("testing") + :components + ((:file "eqv-hash-tests") + (:file "state-and-transition-tests") + (:file "automaton-tests") + (:file "regexp-tests"))) + (:file "packages") + (:file "testing" :depends-on ("packages")) + (:file "buffer-tests" :depends-on ("testing")) + (:file "base-tests" :depends-on ("testing")) + (:file "kill-ring-tests" :depends-on ("testing")) + (:file "motion-tests" :depends-on ("testing")) + (:file "editing-tests" :depends-on ("testing")) + (:file "core-tests" :depends-on ("testing")) + (:file "rectangle-tests" :depends-on ("testing")) + (:file "undo-tests" :depends-on ("testing")))))) + (defsystem :clim :depends-on (:clim-core :goatee-core :clim-postscript :drei-mcclim) :components From thenriksen at common-lisp.net Mon Dec 4 07:57:36 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 4 Dec 2006 02:57:36 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061204075736.B64A22E1CB@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv12103/Drei Modified Files: syntax.lisp Log Message: Syntax-querying-methods should be specialised on syntaxes. --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2006/11/18 21:01:46 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2006/12/04 07:57:36 1.4 @@ -865,9 +865,9 @@ (defgeneric word-constituentp (syntax obj) (:documentation "Return T if `obj' is a word constituent character in `syntax'.") - (:method (syntax obj) + (:method ((syntax syntax) obj) nil) - (:method (syntax (obj character)) + (:method ((syntax syntax) (obj character)) (alphanumericp obj))) (defgeneric whitespacep (syntax obj) From thenriksen at common-lisp.net Mon Dec 4 10:17:22 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 4 Dec 2006 05:17:22 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061204101722.890F2671A3@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv5240/Drei Modified Files: undo.lisp drei.lisp Log Message: Explicitly define the generic functions of some accessor methods. --- /project/mcclim/cvsroot/mcclim/Drei/undo.lisp 2006/11/19 11:39:45 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/undo.lisp 2006/12/04 10:17:21 1.3 @@ -84,6 +84,10 @@ (defclass undo-record () () (:documentation "The base class for all undo records.")) +(defgeneric undo-tree (record) + (:documentation "The undo tree to which the undo record +`record' belongs.")) + (defclass standard-undo-record (undo-record) ((parent :initform nil :accessor parent) (tree :initform nil --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/11/30 17:33:31 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/12/04 10:17:21 1.10 @@ -128,24 +128,39 @@ ;;; ;;; Undo +(defgeneric undo-tree (buffer) + (:documentation "The undo-tree object associated with the +buffer. This usually contains a record of every change that has +been made to the buffer since it was created.")) + +(defgeneric undo-accumulate (buffer) + (:documentation "A list of the changes that have been made to +`buffer' since the last time undo was added to the undo tree for +the buffer. The list returned by this function is initially +NIL (the empty list). The :before methods on +`insert-buffer-object', `insert-buffer-sequence', and +`delete-buffer-range' push undo records on to this list.")) + +(defgeneric performing-undo (buffer) + (:documentation "If true, the buffer is currently performing an +undo operation. The :before methods on `insert-buffer-object', +`insert-buffer-sequence', and `delete-buffer-range' push undo +records onto the undo accumulator only if `performing-undo' is +false, so that no undo information is added as a result of an +undo operation.")) + (defclass undo-mixin () ((tree :initform (make-instance 'standard-undo-tree) :reader undo-tree :documentation "Returns the undo-tree of the buffer.") (undo-accumulate :initform '() :accessor undo-accumulate - :documentation "The list returned by this -function is initially NIL (the empty list). The :before methods -on `insert-buffer-object', `insert-buffer-sequence', and -`delete-buffer-range' push undo records on to this list.") + :documentation "The undo records created +since the start of the undo context.") (performing-undo :initform nil :accessor performing-undo - :documentation "This is initially NIL. -The :before methods on `insert-buffer-object', -`insert-buffer-sequence', and `delete-buffer-range' push undo -records onto the undo accumulator only if this slot is NIL so -that no undo information is added as a result of an undo -operation.")) + :documentation "True if we are currently +performing undo, false otherwise.")) (:documentation "This is a mixin class that buffer classes can inherit from. It contains an undo tree, an undo accumulator and a flag specifyng whether or not it is currently performing From thenriksen at common-lisp.net Mon Dec 4 18:12:38 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 4 Dec 2006 13:12:38 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061204181238.C28E93E007@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv31244 Modified Files: lisp-syntax.lisp Log Message: Hack together a solution for the bug reported by Robert Strand on mcclim-devel. I'm not pretty sure the `token-to-object' function is insufficient for properly handling the evil of backquoting. It'll have to be revised at some point. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/12/02 20:28:18 1.8 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/12/04 18:12:38 1.9 @@ -2535,7 +2535,7 @@ (defmethod token-to-object (syntax (token list-form) &rest args) (loop for child in (children token) if (typep child 'comma-at-form) - append (apply #'token-to-object syntax child args) + nconc (listed (apply #'token-to-object syntax child args)) else if (formp child) collect (apply #'token-to-object syntax child args))) @@ -2567,11 +2567,11 @@ (if (form-list-p backquoted-form) `(list ,@(loop for element in (children backquoted-form) if (form-comma-p element) - collect (apply #'token-to-object syntax element args) + collect (apply #'token-to-object syntax element args) else if (form-comma-at-p element) - nconc (apply #'token-to-object syntax element args) + nconc (listed (apply #'token-to-object syntax element args)) else if (formp element) - collect (apply #'token-to-object syntax element :quote t args))) + collect (apply #'token-to-object syntax element :quote t args))) `',(apply #'token-to-object syntax backquoted-form args)))) (defmethod token-to-object (syntax (token comma-form) &rest args) From thenriksen at common-lisp.net Mon Dec 4 19:20:47 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 4 Dec 2006 14:20:47 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061204192047.8F4525D007@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv12188 Modified Files: lisp-syntax.lisp Log Message: Backward Up was broken, now it isn't, I hope. I admit that I have no idea what that condition I removed was supposed to do, since `formp' will be T for anything it's ever going to be called with. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/12/04 18:12:38 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/12/04 19:20:47 1.10 @@ -2142,18 +2142,17 @@ (form-around-in-children (children stack-top) offset)))) (defun find-list-parent-offset (form fn) - "Find a list parent of `token' and return `fn' + "Find a list parent of `token' and return `fn' applied to this parent token. `Fn' should be a function that returns an offset when applied to a token (eg. `start-offset' or `end-offset'). If a list parent cannot be found, return `fn' applied to `form'." - (when (not (formp form)) - (let ((parent (parent form))) - (typecase parent - (form* (funcall fn form)) - (list-form (funcall fn form)) - (null (funcall fn form)) - (t (find-list-parent-offset parent fn)))))) + (let ((parent (parent form))) + (typecase parent + (form* (funcall fn form)) + (list-form (funcall fn form)) + (null (funcall fn form)) + (t (find-list-parent-offset parent fn))))) (defun find-list-child-offset (form fn &optional (min-offset 0)) "Find a list child of `token' with a minimum start @@ -2250,11 +2249,11 @@ (form-after syntax (offset mark)) (form-around syntax (offset mark))))) (when form - (let ((parent (parent form))) - (when (not (null parent)) - (let ((new-offset (find-list-parent-offset parent fn))) - (when new-offset - (setf (offset mark) new-offset)))))))) + (let ((parent (parent form))) + (when (not (null parent)) + (let ((new-offset (find-list-parent-offset parent fn))) + (when new-offset + (setf (offset mark) new-offset)))))))) (defmethod backward-one-up (mark (syntax lisp-syntax)) (up-list-by-fn mark syntax #'start-offset)) From thenriksen at common-lisp.net Mon Dec 4 19:22:02 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 4 Dec 2006 14:22:02 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061204192202.3ECCD5D009@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv12357 Modified Files: kill-ring.lisp Log Message: Added explicit `defgeneric's. --- /project/mcclim/cvsroot/mcclim/Drei/kill-ring.lisp 2006/11/28 23:34:10 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/kill-ring.lisp 2006/12/04 19:22:02 1.4 @@ -24,6 +24,14 @@ (in-package :drei-kill-ring) +(defgeneric kill-ring-chain (ring) + (:documentation "Return the cursorchain associated with the +kill ring `ring'.")) + +(defgeneric kill-ring-cursor (ring) + (:documentation "Return the flexicursor associated with the +kill ring.")) + (defclass kill-ring () ((max-size :type (integer 5 *) ;5 element minimum from flexichain protocol :initarg :max-size From thenriksen at common-lisp.net Mon Dec 4 20:07:53 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 4 Dec 2006 15:07:53 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061204200753.66C3C671A3@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv22078 Modified Files: lisp-syntax-swine.lisp lisp-syntax-commands.lisp Log Message: Using #\Tab for completing Lisp symbols will no longer potentially cause you to be presented with a list of every symbol in the package. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2006/11/14 12:27:53 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2006/12/04 20:07:53 1.3 @@ -997,61 +997,69 @@ (best (caar set))) (values best set))) -(defun complete-symbol-at-mark-with-fn (syntax mark &optional (fn #'find-completions)) +(defun complete-symbol-at-mark-with-fn (syntax mark &key (completion-finder #'find-completions) + (complete-blank t)) "Attempt to find and complete the symbol at `mark' using the - function `fn' to get the list of completions. If the completion + function `completion-finder' to get the list of completions. If the completion is ambiguous, a list of possible completions will be - displayed. If no symbol can be found at `mark', return nil." + displayed. If no symbol can be found at `mark', return NIL. If + there is no symbol at `mark' and `complete-blank' is true (the + default), all symbols available in the current package will be + shown. If `complete-blank' is true, nothing will be shown and + the function will return NIL." (let* ((token (form-around syntax (offset mark))) (useful-token (and (not (null token)) (form-token-p token) (not (= (start-offset token) (offset mark)))))) - (multiple-value-bind (longest completions) - (funcall fn syntax - (if useful-token - (start-offset (fully-quoted-form token)) - (if (and (form-quoted-p token) - (form-incomplete-p token)) - (start-offset token) - (offset mark))) - (if useful-token - (token-string syntax token) - "")) - (if completions - (if (= (length completions) 1) - (replace-symbol-at-mark mark syntax longest) - (progn - (esa:display-message (format nil "Longest is ~a|" longest)) - (let ((selection (menu-choose (mapcar - ;; FIXME: this can - ;; get ugly. - #'(lambda (completion) - (if (listp completion) - (cons completion - (first completion)) - completion)) - completions) - :label "Possible completions" - :scroll-bars :vertical))) - (if useful-token - (replace-symbol-at-mark mark syntax (or selection longest)) - (insert-sequence mark (or selection longest)))))) - (esa:display-message "No completions found"))) - t)) + (when (or useful-token complete-blank) + (multiple-value-bind (longest completions) + (funcall completion-finder syntax + (if useful-token + (start-offset (fully-quoted-form token)) + (if (and (form-quoted-p token) + (form-incomplete-p token)) + (start-offset token) + (offset mark))) + (if useful-token + (token-string syntax token) + "")) + (if completions + (if (= (length completions) 1) + (replace-symbol-at-mark mark syntax longest) + (progn + (esa:display-message (format nil "Longest is ~a|" longest)) + (let ((selection (menu-choose (mapcar + ;; FIXME: this can + ;; get ugly. + #'(lambda (completion) + (if (listp completion) + (cons completion + (first completion)) + completion)) + completions) + :label "Possible completions" + :scroll-bars :vertical))) + (if useful-token + (replace-symbol-at-mark mark syntax (or selection longest)) + (insert-sequence mark (or selection longest))) + t))) + (esa:display-message "No completions found")))))) -(defun complete-symbol-at-mark (syntax mark) +(defun complete-symbol-at-mark (syntax mark &optional (complete-blank t)) "Attempt to find and complete the symbol at `mark'. If the completion is ambiguous, a list of possible completions will be displayed. If no symbol can be found at `mark', return nil." - (complete-symbol-at-mark-with-fn syntax mark)) + (complete-symbol-at-mark-with-fn syntax mark :complete-blank complete-blank)) -(defun fuzzily-complete-symbol-at-mark (syntax mark) +(defun fuzzily-complete-symbol-at-mark (syntax mark &optional (complete-blank t)) "Attempt to find and complete the symbol at `mark' using fuzzy completion. If the completion is ambiguous, a list of possible completions will be displayed. If no symbol can be found at `mark', return nil." - (complete-symbol-at-mark-with-fn syntax mark #'find-fuzzy-completions)) + (complete-symbol-at-mark-with-fn syntax mark + :completion-finder #'find-fuzzy-completions + :complete-blank complete-blank)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2006/11/14 12:27:53 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2006/12/04 20:07:53 1.3 @@ -125,29 +125,26 @@ (forward-object mark) (clear-completions))) -(define-command (com-complete-symbol :name t :command-table lisp-table) () +(define-command (com-complete-symbol :name t :command-table lisp-table) + () "Attempt to complete the symbol at mark. If successful, move point to end of symbol. -If more than one completion is available, a list of -possible completions will be displayed." - (let* ((pane *current-window*) - (buffer (buffer pane)) - (syntax (syntax buffer)) - (mark (point pane))) - (complete-symbol-at-mark syntax mark))) +If more than one completion is available, a list of possible +completions will be displayed. If there is no symbol at mark, all +relevant symbols accessible in the current package will be +displayed." + (complete-symbol-at-mark *current-syntax* *current-mark*)) -(define-command (com-fuzzily-complete-symbol :name t :command-table lisp-table) () +(define-command (com-fuzzily-complete-symbol :name t :command-table lisp-table) + () "Attempt to fuzzily complete the abbreviation at mark. Fuzzy completion tries to guess which symbol is abbreviated. If the abbreviation is ambiguous, a list of possible completions -will be displayed." - (let* ((pane *current-window*) - (buffer (buffer pane)) - (syntax (syntax buffer)) - (mark (point pane))) - (fuzzily-complete-symbol-at-mark syntax mark))) +will be displayed. If there is no symbol at mark, all relevant +symbols accessible in the current package will be displayed." + (fuzzily-complete-symbol-at-mark *current-syntax* *current-mark*)) (define-command (com-indent-line-and-complete-symbol :name t :command-table lisp-table) () "Indents the current line and performs symbol completion. @@ -162,7 +159,7 @@ (offset point)) (let* ((buffer (buffer pane)) (syntax (syntax buffer))) - (or (complete-symbol-at-mark syntax point) + (or (complete-symbol-at-mark syntax point nil) (show-arglist-for-form-at-mark point syntax)))))) (define-presentation-to-command-translator lookup-symbol-arglist From thenriksen at common-lisp.net Mon Dec 4 22:31:19 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 4 Dec 2006 17:31:19 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061204223119.0C8193301D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv11335/Drei Modified Files: drei-clim.lisp Log Message: Patch from rpg: now handle both CLIM 2.2 and CLIM 2.0-style scroller options. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/24 22:43:03 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/12/04 22:31:18 1.13 @@ -403,7 +403,7 @@ (drei-class 'drei-gadget-pane)) (check-type initial-contents array) (check-type border-width integer) - (check-type scroll-bars (member :vertical :horizontal t nil)) + (check-type scroll-bars (member t :both :vertical :horizontal nil)) (with-keywords-removed (args (:minibuffer :scroll-bars :border-width :syntax)) (let* ((borderp (and border-width (plusp border-width))) (minibuffer-pane (cond ((eq minibuffer t) From thenriksen at common-lisp.net Mon Dec 4 22:31:19 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 4 Dec 2006 17:31:19 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061204223119.46A223301D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv11335 Modified Files: decls.lisp Log Message: Patch from rpg: now handle both CLIM 2.2 and CLIM 2.0-style scroller options. --- /project/mcclim/cvsroot/mcclim/decls.lisp 2006/11/22 14:15:53 1.41 +++ /project/mcclim/cvsroot/mcclim/decls.lisp 2006/12/04 22:31:19 1.42 @@ -696,6 +696,8 @@ (defgeneric pane-scroller (pane)) (defgeneric scroll-extent (pane x y)) +(deftype scroll-bar-spec () '(member t :both :vertical :horizontal nil)) + ;;;; 29.3.4 The Layout Protocol ;; (define-protocol-class space-requirement ()) From rgoldman at common-lisp.net Tue Dec 5 02:08:44 2006 From: rgoldman at common-lisp.net (rgoldman) Date: Mon, 4 Dec 2006 21:08:44 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061205020844.7DF0F63012@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv11209 Modified Files: panes.lisp Log Message: Handle :both (clim 2.2) as synonym for t in :scroll-bars. --- /project/mcclim/cvsroot/mcclim/panes.lisp 2006/11/08 01:18:22 1.173 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2006/12/05 02:08:44 1.174 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.173 2006/11/08 01:18:22 thenriksen Exp $ +;;; $Id: panes.lisp,v 1.174 2006/12/05 02:08:44 rgoldman Exp $ (in-package :clim-internals) @@ -1900,7 +1900,7 @@ (defparameter *scrollbar-thickness* 17) (defclass scroller-pane (composite-pane) - ((scroll-bar :type (member t :vertical :horizontal nil) + ((scroll-bar :type scroll-bar-spec ; (member t :vertical :horizontal nil) ;; ### Note: I added NIL here, so that the application ;; programmer can switch off scroll bars alltogether. ;; The spec though has it neither in the description of @@ -2091,8 +2091,9 @@ (when (first (sheet-children viewport)) (setf (slot-value pane 'background) ;### hmm ... (pane-background (first (sheet-children viewport))))) - ;; - (when (member scroll-bar '(:vertical t)) + ;; make sure that we have ok options for the scroll-bar argument... + (check-type scroll-bar scroll-bar-spec) ; (member :vertical :horizontal :both t nil)) + (when (member scroll-bar '(:vertical :both t)) (setq vscrollbar (make-pane 'scroll-bar-pane :orientation :vertical @@ -2118,7 +2119,7 @@ :min-value 0 :max-value 1)) (sheet-adopt-child pane vscrollbar)) - (when (member scroll-bar '(:horizontal t)) + (when (member scroll-bar '(:horizontal :both t)) (setq hscrollbar (make-pane 'scroll-bar-pane :orientation :horizontal @@ -2430,7 +2431,7 @@ mouse-wheel-scroll-mixin cut-and-paste-mixin) ((redisplay-needed :initarg :display-time) - (scroll-bars :type (member t :vertical :horizontal nil) + (scroll-bars :type scroll-bar-spec ; (member t :vertical :horizontal nil) :initform nil :initarg :scroll-bars :accessor pane-scroll-bars) From thenriksen at common-lisp.net Wed Dec 6 11:31:12 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 6 Dec 2006 06:31:12 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061206113112.CAA4519007@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv26314 Modified Files: lisp-syntax.lisp Log Message: Somewhat-fixed `token-to-object's handling of backquote forms. Has been tested by repeatedly using `token-to-object' to convert lisp-syntax.lisp into lists and feeding them to `eval' (this calls out for a test case that recompiles Drei using code extracted with this method!) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/12/04 19:20:47 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/12/06 11:31:12 1.11 @@ -1050,9 +1050,9 @@ ;;;;;;;;;;;;;;;; Comma ;;; parse trees -(defclass comma-form (form) ()) -(defclass comma-at-form (form) ()) -(defclass comma-dot-form (form) ()) +(defclass comma-form (form complete-form-mixin) ()) +(defclass comma-at-form (form complete-form-mixin) ()) +(defclass comma-dot-form (form complete-form-mixin) ()) (define-parser-state |, | (form-may-follow) ()) (define-parser-state |, form | (lexer-toplevel-state parser-state) ()) @@ -2477,25 +2477,21 @@ :case case :no-error t)) -(defgeneric token-to-object (syntax token &key no-error package quote read &allow-other-keys) +(defgeneric token-to-object (syntax token &key no-error package read backquoted &allow-other-keys) (:documentation "Return the Lisp object `token' would evaluate to if read. An attempt will be made to construct objects from incomplete tokens. This function may signal an error if `no-error' is nil and `token' cannot be converted to a Lisp object. Otherwise, nil will be returned.") - (:method :around (syntax (token t) &rest args &key - package quote no-error &allow-other-keys) + (:method :around (syntax (token t) &key package no-error &allow-other-keys) ;; Ensure that every symbol that is READ will be looked up ;; in the correct package. Also handle quoting. (flet ((act () (let ((*package* (or package (package-at-mark - syntax (start-offset token))))) - (cond (quote - (setf (getf args :quote) nil) - `',(call-next-method)) - (t - (call-next-method)))))) + syntax (start-offset token))))) + + (call-next-method)))) (if no-error (ignore-errors (act)) (act)))) @@ -2510,6 +2506,57 @@ (error "Cannot convert incomplete form to Lisp object: ~A" token)))) +;;; The complicated primary structure forms. + +;; The problem is that we can't portably create in-memory backquote +;; forms, so we have to rewrite them to calls to `nconc'. I think this +;; is valid, because the CLHS doesn't specify the in-memory +;; representation of backquoted forms, and thus the user can't assume +;; that it isn't just a whole bunch of calls to `nconc' anyway. +(defmethod token-to-object (syntax (token list-form) &rest args &key backquoted) + (if backquoted + `(nconc ,@(loop for child in (children token) + if (typep child 'comma-at-form) + collect (apply #'token-to-object syntax child :backquoted nil args) + else if (typep child 'comma-form) + collect `(list ,(apply #'token-to-object syntax child :backquoted nil args)) + else if (form-token-p child) + collect `(list ,`',(apply #'token-to-object syntax child args)) + else if (formp child) + collect `(list ,(apply #'token-to-object syntax child args)))) + (mapcar #'(lambda (child) + (apply #'token-to-object syntax child args)) + (remove-if-not #'formp (children token))))) + +(defmethod token-to-object (syntax (token complete-quote-form) &rest args &key backquoted) + (if backquoted + (let ((quoted-form (first-form (children token)))) + (if (form-token-p quoted-form) + `(list 'quote (quote ,(apply #'token-to-object syntax (second (children token)) args))) + `(list 'quote ,(apply #'token-to-object syntax (second (children token)) args)))) + `',(apply #'token-to-object syntax (second (children token)) args))) + +(defmethod token-to-object (syntax (token incomplete-quote-form) &rest args) + (declare (ignore args)) + ;; Utterly arbitrary, but reasonable in my opinion. + '(quote)) + +;; I'm not sure backquotes are handled correctly, but they should be, +;; at least when :read t is specified. +(defmethod token-to-object (syntax (token backquote-form) &rest args) + (let ((backquoted-form (first-form (children token)))) + (if (form-token-p backquoted-form) + `',(apply #'token-to-object syntax backquoted-form args) + (apply #'token-to-object syntax backquoted-form :backquoted t args)))) + +(defmethod token-to-object (syntax (token comma-form) &rest args) + (apply #'token-to-object syntax (first-form (children token)) :backquoted nil args)) + +(defmethod token-to-object (syntax (token comma-at-form) &rest args) + (apply #'token-to-object syntax (first-form (children token)) :backquoted nil args)) + +;;; The atom(-ish) forms. + (defmethod token-to-object (syntax (token complete-token-lexeme) &key no-error read (case (readtable-case *readtable*)) &allow-other-keys) @@ -2531,13 +2578,6 @@ (let ((*read-base* (base syntax))) (read-from-string (token-string syntax token)))) -(defmethod token-to-object (syntax (token list-form) &rest args) - (loop for child in (children token) - if (typep child 'comma-at-form) - nconc (listed (apply #'token-to-object syntax child args)) - else if (formp child) - collect (apply #'token-to-object syntax child args))) - (defmethod token-to-object (syntax (token simple-vector-form) &key &allow-other-keys) (apply #'vector (call-next-method))) @@ -2551,34 +2591,6 @@ (declare (ignore no-error)) (read-from-string (token-string syntax token))) -(defmethod token-to-object (syntax (token complete-quote-form) &rest args) - (apply #'token-to-object syntax (second (children token)) :quote t args)) - -(defmethod token-to-object (syntax (token incomplete-quote-form) &rest args) - (declare (ignore args)) - ;; Utterly arbitrary, but reasonable in my opinion. - '(quote)) - -;; I'm not sure backquotes are handled correctly, but they should be, -;; at least when :read t is specified. -(defmethod token-to-object (syntax (token backquote-form) &rest args) - (let ((backquoted-form (first-form (children token)))) - (if (form-list-p backquoted-form) - `(list ,@(loop for element in (children backquoted-form) - if (form-comma-p element) - collect (apply #'token-to-object syntax element args) - else if (form-comma-at-p element) - nconc (listed (apply #'token-to-object syntax element args)) - else if (formp element) - collect (apply #'token-to-object syntax element :quote t args))) - `',(apply #'token-to-object syntax backquoted-form args)))) - -(defmethod token-to-object (syntax (token comma-form) &rest args) - (apply #'token-to-object syntax (first-form (children token)) args)) - -(defmethod token-to-object (syntax (token comma-at-form) &rest args) - (apply #'token-to-object syntax (first-form (children token)) args)) - (defmethod token-to-object (syntax (token function-form) &rest args) (list 'cl:function (apply #'token-to-object syntax (second (children token)) args))) From thenriksen at common-lisp.net Wed Dec 6 13:00:00 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 6 Dec 2006 08:00:00 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061206130000.C71553C005@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv9653 Modified Files: input-editor.lisp Log Message: Try to handle "partially readable" objects. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/12/01 23:02:59 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/12/06 13:00:00 1.10 @@ -304,6 +304,56 @@ printed-rep) args)))) +;; The purpose of this method is to ensure that things such as lists +;; should are not completely inserted as literal objects if they have +;; unreadable elements. +(defmethod presentation-replace-input + ((stream drei-input-editing-mixin) object (type (eql 'expression)) view + &rest args &key + (buffer-start (input-position stream)) rescan + query-identifier (for-context-type type)) + (declare (ignore query-identifier rescan for-context-type buffer-start)) + ;; Build up an array, `insertion', and use `replace-input' to insert + ;; it. + (let ((insertion (make-array 10 :adjustable t :fill-pointer 0))) + (labels ((insert-object (object) + (vector-push-extend object insertion + (* (length insertion)))) + (insert-objects (objects) + (setf insertion (adjust-array insertion + (+ (length insertion) + (length objects)) + :fill-pointer (+ (fill-pointer insertion) + (length objects)))) + (setf (subseq insertion (- (fill-pointer insertion) + (length objects))) objects)) + (present-object (object) + (multiple-value-bind (printed-rep accept-object) + (present-acceptably-to-string object 'expression + +textual-view+ 'expression) + (if (null accept-object) + (insert-objects printed-rep) + (typecase object + (list (insert-list-in-stream object)) + (array (insert-object #\#) + (insert-list-in-stream object)) + (function (let ((name (nth-value 2 (function-lambda-expression object)))) + (insert-objects (or (format nil "#'~A" name) + (vector object))))) + ;; Okay, we give up, just insert it. + (t (insert-object object))))))) + (present-object object)) + (with-keywords-removed (args (:type :view :query-identifier :for-context-type)) + (apply #'replace-input stream insertion args)))) + +(defmethod presentation-replace-input + ((stream drei-input-editing-mixin) object (type (eql 'form)) view + &rest args &key + (buffer-start (input-position stream)) rescan + query-identifier (for-context-type type)) + (declare (ignore query-identifier rescan for-context-type buffer-start)) + (apply #'presentation-replace-input stream object 'expression view args)) + (defvar *drei-input-editing-stream* nil "Used to provide CLIM-specified input-editing-commands with the input-editing-stream. Bound when executing a command.") From thenriksen at common-lisp.net Thu Dec 7 14:03:00 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 7 Dec 2006 09:03:00 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061207140300.024D434000@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv29673 Modified Files: input-editor.lisp Log Message: Improved the support for the CLIM 2.2-specified input-editor interface, in particular, integration of the input-buffer with the Drei buffer. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/12/06 13:00:00 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/12/07 14:03:00 1.11 @@ -175,41 +175,116 @@ ;; want to permit the user to undo input for this context. (clear-undo-history (buffer (drei-instance stream)))) -(defun update-drei-buffer (stream) - "Update the Drei buffer of the Drei instance used by `stream' -if the `input-buffer-array' of `stream' is non-NIl. This will set -the contents of the array to the contents of the array up to the -fill pointer. When this function returns, the -`input-buffer-array' of `stream' will be NIL. Also, the syntax -will be up-to-date." +(defun buffer-array-mismatch (sequence1 sequence2 + &key (from-end nil) + (start1 0) + (start2 0)) + "Like `cl:mismatch', but supporting fewer keyword arguments, +and the two sequences can be Drei buffers instead." + (flet ((seq-elt (seq i) + (typecase seq + (drei-buffer (buffer-object seq i)) + (array (aref seq i)))) + (seq-length (seq) + (typecase seq + (drei-buffer (size seq)) + (array (length seq))))) + (if from-end + (loop + for index1 downfrom (1- (seq-length sequence1)) to 0 + for index2 downfrom (1- (seq-length sequence2)) to 0 + unless (= index1 index2 0) + if (or (= index1 0) + (= index2 0)) + return index1 + unless (eql (seq-elt sequence1 index1) + (seq-elt sequence2 index2)) + return (1+ index1)) + + (do* ((i1 start1 (1+ i1)) + (i2 start2 (1+ i2)) + x1 x2) + ((and (>= i1 (seq-length sequence1)) + (>= i2 (seq-length sequence2))) nil) + (if (>= i1 (seq-length sequence1)) (return i1)) + (if (>= i2 (seq-length sequence2)) (return i1)) + (setq x1 (seq-elt sequence1 i1)) + (setq x2 (seq-elt sequence2 i2)) + (unless (eql x1 x2) + (return i1)))))) + +(defun synchronize-drei-buffer (stream) + "If the `input-buffer-array' of `stream' is non-NIL, copy the +contents of the array to the Drei buffer. This will set the +contents of the buffer to the contents of the array up to the +fill pointer." (with-accessors ((array input-buffer-array)) stream (let ((buffer (buffer (drei-instance stream)))) (when array ;; Attempt to minimise the changes to the buffer, so the ;; position of marks will not be changed too much. Find the ;; first mismatch between buffer contents and array contents. - (let ((index (loop - for index from 0 below (min (length array) - (size buffer)) - unless (eql (buffer-object buffer index) - (aref array index)) - do (return index) - finally (return nil))) - (insertion-pointer (stream-insertion-pointer stream))) - (when index ; NIL if buffer and array are identical. - ;; Delete from the first mismatch to the end of the buffer. - (delete-buffer-range buffer index - (- (size buffer) index)) - ;; Insert from the mismatch to array end into the buffer. - (insert-buffer-sequence buffer index - (subseq array index)) - ;; We also need to update the syntax. - (update-syntax buffer (syntax buffer)) - ;; Finally, see if it is possible to maintain the old - ;; position of the insertion pointer. - (setf (stream-insertion-pointer stream) - (min insertion-pointer (size buffer))))) - (setf array nil))))) + (multiple-value-bind (index buffer-end array-end) + (let* ((buffer-array-mismatch-begin (or (buffer-array-mismatch + buffer array) + 0)) + (buffer-buffer-array-mismatch-end (or (buffer-array-mismatch + buffer array :from-end t + :start2 buffer-array-mismatch-begin) + buffer-array-mismatch-begin)) + (array-buffer-array-mismatch-end (or (buffer-array-mismatch + array buffer :from-end t + :start2 buffer-array-mismatch-begin) + buffer-array-mismatch-begin))) + (values buffer-array-mismatch-begin + (max buffer-buffer-array-mismatch-end buffer-array-mismatch-begin) + (max array-buffer-array-mismatch-end buffer-array-mismatch-begin))) + (let ((insertion-pointer (stream-insertion-pointer stream))) + (when index ; NIL if buffer and array are identical. + ;; Delete from the first mismatch to the end of the + ;; mismatch. + (delete-buffer-range buffer index (- buffer-end index)) + ;; Also delete from the end of the buffer if the array + ;; is smaller than the buffer. + (when (> (size buffer) (length array)) + (delete-buffer-range buffer (length array) + (- (size buffer) + (length array)))) + ;; Insert from the mismatch to end mismatch from the + ;; array into the buffer. + (insert-buffer-sequence buffer index (subseq array index array-end)) + ;; We also need to update the syntax. + (update-syntax buffer (syntax buffer)) + ;; Finally, see if it is possible to maintain the old + ;; position of the insertion pointer. + (setf (stream-insertion-pointer stream) + (min insertion-pointer (size buffer)))))))))) + +(defun synchronize-input-buffer-array (stream) + "If the `input-buffer-array' of `stream' is non-NIL, copy the +contents of the Drei buffer to the array. The fill pointer of the +array will point to after the last element." + (with-accessors ((array input-buffer-array)) stream + (let ((buffer (buffer (drei-instance stream)))) + (when array + (let ((new-array (buffer-sequence buffer 0 (size buffer)))) + (setf array + ;; We probably lose if `adjust-array' doesn't + ;; destructively modify `array. + (adjust-array array (length new-array) + :initial-contents new-array + :fill-pointer (length new-array)))))))) + +(defun update-drei-buffer (stream) + "Update the Drei buffer of the Drei instance used by `stream' +if the `input-buffer-array' of `stream' is non-NIl. This will set +the contents of the buffer to the contents of the array up to the +fill pointer. Changes to the buffer will be recordes as +undoable. When this function returns, the `input-buffer-array' of +`stream' will be NIL. Also, the syntax will be up-to-date." + (with-undo ((list (buffer (drei-instance stream)))) + (synchronize-drei-buffer stream)) + (setf (input-buffer-array stream) nil)) ;; While the CLIM spec says that user-commands are not allowed to do ;; much with the input buffer, the Franz User Guide provides some @@ -224,13 +299,11 @@ ;; NOTE: This is very slow (consing up a whole new array - twice!), ;; please do not use it unless you want to be compatible with other ;; editor substrates. Use the Drei buffer directly instead. - (or (input-buffer-array stream) - (setf (input-buffer-array stream) - (with-accessors ((buffer buffer)) (drei-instance stream) - (let* ((array (buffer-sequence buffer 0 (size buffer)))) - (make-array (length array) - :fill-pointer (length array) - :initial-contents array)))))) + (unless (input-buffer-array stream) + ;; Create dummy array and synchronize it to the buffer contents. + (setf (input-buffer-array stream) (make-array 0 :fill-pointer 0)) + (synchronize-input-buffer-array stream)) + (input-buffer-array stream)) (defmethod replace-input ((stream drei-input-editing-mixin) (new-input array) &key @@ -241,6 +314,13 @@ (check-type start integer) (check-type end integer) (check-type buffer-start integer) + ;; Since this is a CLIM-specified function, we have to make sure the + ;; input-buffer-array is taken into consideration, because some + ;; input-editor-command might call this function and expect the + ;; changes to be reflected in the array it holds. Also, if changes + ;; have been made to the array, they need to be propagated to the + ;; buffer before we do anything. + (synchronize-drei-buffer stream) (let* ((drei (drei-instance stream)) (new-contents (subseq new-input start end)) (old-contents (buffer-sequence (buffer drei) @@ -253,11 +333,16 @@ (unless equal (setf (offset begin-mark) buffer-start) (delete-region begin-mark (stream-scan-pointer stream)) - (insert-sequence begin-mark new-contents)) - (update-syntax (buffer drei) (syntax (buffer drei))) + (insert-sequence begin-mark new-contents) + (update-syntax (buffer drei) (syntax (buffer drei))) + ;; Make the buffer reflect the changes in the array. + (synchronize-input-buffer-array stream)) (display-drei drei) (when (or rescan (not equal)) - (queue-rescan stream))))) + (queue-rescan stream)) + ;; We have to return "the position in the input buffer". We + ;; return the insertion position. + buffer-start))) (defun present-acceptably-to-string (object type view for-context-type) "Return two values - a string containing the printed @@ -608,14 +693,17 @@ (declare (ignore start-position)) ;; We ignore `start-position', because it would be more work to ;; figure out what to redraw than to just redraw everything. + ;; We assume that this function is mostly called from non-Drei-aware + ;; code, and thus synchronise the input-editor-array with the Drei + ;; buffer before redisplaying. + (update-drei-buffer stream) (display-drei (drei-instance stream))) (defmethod erase-input-buffer ((stream drei-input-editing-mixin) &optional (start-position 0)) (declare (ignore start-position)) - ;; Again, we ignore `start-position'. What is the big idea behind - ;; this function anyway? - (clear-output-record (drei-instance stream))) + ;; No-op, just to save older CLIM programs from dying. + nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From thenriksen at common-lisp.net Thu Dec 7 14:34:14 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 7 Dec 2006 09:34:14 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061207143414.A58097C03F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv422 Modified Files: input-editor.lisp Log Message: Add missing definition of `insert-list-in-stream'. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/12/07 14:03:00 1.11 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/12/07 14:34:14 1.12 @@ -412,6 +412,14 @@ (length objects)))) (setf (subseq insertion (- (fill-pointer insertion) (length objects))) objects)) + (insert-list-in-stream (list) + (insert-object #\() + (mapl #'(lambda (cons) + (present-object (first cons)) + (when (rest cons) + (insert-object #\Space))) + list) + (insert-object #\))) (present-object (object) (multiple-value-bind (printed-rep accept-object) (present-acceptably-to-string object 'expression From thenriksen at common-lisp.net Thu Dec 7 15:02:46 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 7 Dec 2006 10:02:46 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061207150246.45BCB5001B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv5095 Modified Files: drei.lisp Log Message: I think that Drei variant-specific commands should take priority over standard editor commands. I just hope I didn't have a good reason for having the old order. --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/12/04 10:17:21 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/12/07 15:02:45 1.11 @@ -550,10 +550,10 @@ (defmethod command-table-inherit-from ((table drei-command-table)) (let ((syntax-table (command-table *current-syntax*))) - (list* syntax-table - (when (use-editor-commands-p syntax-table) - 'editor-table) - (additional-command-tables *current-window* table)))) + (append `(,syntax-table) + (additional-command-tables *current-window* table) + (when (use-editor-commands-p syntax-table) + '(editor-table))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From thenriksen at common-lisp.net Sat Dec 9 21:28:05 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 9 Dec 2006 16:28:05 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20061209212805.926961900F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv20849/ESA Modified Files: utils.lisp packages.lisp Log Message: Added `maptree' utility function. --- /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2006/11/08 01:10:15 1.1 +++ /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2006/12/09 21:28:05 1.2 @@ -192,4 +192,16 @@ "binds NEW-VAR (defaults to VAR) to VAR with the keyword arguments specified in KEYWORDS removed." `(let ((,new-var (remove-keywords ,var ',keywords))) - , at body)) \ No newline at end of file + , at body)) + +(defun maptree (fn x) + "This auxiliary function is like MAPCAR but has two extra +purposes: (1) it handles dotted lists; (2) it tries to make the +result share with the argument x as much as possible." + (if (atom x) + (funcall fn x) + (let ((a (funcall fn (car x))) + (d (maptree fn (cdr x)))) + (if (and (eql a (car x)) (eql d (cdr x))) + x + (cons a d))))) --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2006/11/08 01:10:15 1.1 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2006/12/09 21:28:05 1.2 @@ -39,7 +39,8 @@ #:case-relevant-test #:with-keywords-removed #:invoke-with-dynamic-bindings-1 - #:invoke-with-dynamic-bindings)) + #:invoke-with-dynamic-bindings + #:maptree)) (defpackage :esa (:use :clim-lisp :clim :esa-utils) From thenriksen at common-lisp.net Sat Dec 9 23:55:40 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 9 Dec 2006 18:55:40 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061209235540.1EF489@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv15428/Drei Modified Files: packages.lisp drei.lisp Log Message: Added ever-so-slightly more flexible system for handling conditions. --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/11/24 22:43:03 1.8 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/12/09 23:55:37 1.9 @@ -219,7 +219,7 @@ ;; DREI interface stuff. #:drei #:drei-pane #:drei-gadget-pane #:drei-area - #:handling-drei-conditions + #:handling-drei-conditions #:handle-drei-condition #:execute-drei-command #:display-drei-contents #:display-drei-cursor #:with-drei-options #:performing-drei-operations #:invoke-performing-drei-operations --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/12/07 15:02:45 1.11 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/12/09 23:55:39 1.12 @@ -690,35 +690,65 @@ ;;; ;;; Some standard building block machinery. +(defgeneric handle-drei-condition (drei condition) + (:documentation "When an unhandled condition that is a subtype +of `user-condition-mixin' (and some other hardcoded condition +types) is signalled during execution of a Drei command, this +generic function will be called with the Drei instance as the +first argument, and the condition as the second argument.")) + +(defmethod handle-drei-condition (drei (condition offset-before-beginning)) + (beep) (display-message "Beginning of buffer")) + +(defmethod handle-drei-condition (drei (condition offset-after-end)) + (beep) (display-message "End of buffer")) + +(defmethod handle-drei-condition (drei (condition motion-before-beginning)) + (beep) (display-message "Beginning of buffer")) + +(defmethod handle-drei-condition (drei (condition motion-after-end)) + (beep) (display-message "End of buffer")) + +(defmethod handle-drei-condition (drei (condition no-expression)) + (beep) (display-message "No expression around point")) + +(defmethod handle-drei-condition (drei (condition no-such-operation)) + (beep) (display-message "Operation unavailable for syntax")) + +(defmethod handle-drei-condition (drei (condition buffer-read-only)) + (beep) (display-message "Buffer is read only")) + +(defmethod handle-drei-condition (drei (condition user-condition-mixin)) + (beep) (with-minibuffer-stream (minibuffer) + (let ((*print-escape* nil)) + (princ condition minibuffer)))) + (defmacro handling-drei-conditions (&body body) "Evaluate `body' while handling Drei user notification signals. The handling consists of displaying their meaning to the user in the minibuffer. This is the macro that ensures conditions such as `motion-before-end' does not land the user in the debugger." + ;; Perhaps a DREI-CONDITION class should be added so we could more + ;; easily catch all these. `User-condition-mixin' isn't available + ;; at, for example, the buffer level, after all. `(handler-case (progn , at body) - (offset-before-beginning () - (beep) (display-message "Beginning of buffer")) - (offset-after-end () - (beep) (display-message "End of buffer")) - (motion-before-beginning () - (beep) (display-message "Beginning of buffer")) - (motion-after-end () - (beep) (display-message "End of buffer")) - (no-expression () - (beep) (display-message "No expression around point")) - (no-such-operation () - (beep) (display-message "Operation unavailable for syntax")) - (buffer-read-only () - (beep) (display-message "Buffer is read only")) - ;; I'd like a situation where all conditions that should result - ;; in the user being informed of something just inherit from - ;; `user-condition-mixin'. Enumerating all possible conditions - ;; where is not scaleable. (user-condition-mixin (c) - (beep) (with-minibuffer-stream (minibuffer) - (let ((*print-escape* nil)) - (princ c minibuffer)))))) + (handle-drei-condition *current-window* c)) + (offset-before-beginning (c) + (handle-drei-condition *current-window* c)) + (offset-after-end (c) + (handle-drei-condition *current-window* c)) + (motion-before-beginning (c) + (handle-drei-condition *current-window* c)) + (motion-after-end (c) + (handle-drei-condition *current-window* c)) + (no-expression (c) + (handle-drei-condition *current-window* c)) + (no-such-operation (c) + (handle-drei-condition *current-window* c)) + (buffer-read-only (c) + (handle-drei-condition *current-window* c)))) (defmacro with-bound-drei-special-variables ((drei-instance &key (current-buffer nil current-buffer-p) @@ -879,5 +909,5 @@ :update-syntax t :with-undo t) (handling-drei-conditions - (apply (command-name command) (command-arguments command)) - (setf (previous-command drei) command)))))) + (apply (command-name command) (command-arguments command))) + (setf (previous-command drei) command))))) From thenriksen at common-lisp.net Sun Dec 10 00:08:30 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 9 Dec 2006 19:08:30 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20061210000830.61D9725002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv19625/ESA Modified Files: esa.lisp Log Message: Removed commented-out code. --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2006/11/27 11:54:49 1.3 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2006/12/10 00:08:30 1.4 @@ -744,12 +744,7 @@ (loop (setf *current-gesture* (esa-read-gesture :command-processor command-processor)) (unless (process-gesture command-processor *current-gesture*) - (return))) - #+nil(loop - for gestures = '() then (nconc gestures (list *current-gesture*)) - for *current-gesture* = (esa-read-gesture :command-processor command-processor) - unless (process-gestures command-processor) - do (return))) + (return)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From dlichteblau at common-lisp.net Sun Dec 10 16:34:33 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 10 Dec 2006 11:34:33 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061210163433.2B30A2F04B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv29303 Modified Files: BUGS event.lisp ffi.lisp gtk-ffi.lisp Added Files: keygen.lisp keys.lisp Removed Files: keysymdef.lisp Log Message: Reimplemented key event handling. * event.lisp (*KEYSYMS*, DEFINE-KEYSYM): Removed. (*KEYS*, DEFINE-KEY): New. (GDKMODIFIERTYPE->MODIFIER-STATE): Ignore hyper, too. (STATE-WITHOUT-BUTTONS): New. (+CLIM-MODIFIERS+, MODIFY-MODIFIERS): Copy&Paste from CLIM-CLX. (KEY-HANDLER): Reimplemented using *keys* and modify-modifiers. * ffi.lisp: Regenerated. * keys.lisp: New file. * keygen.lisp: New file. * keysymdef.lisp: Removed. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/11/25 21:11:33 1.13 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/12/10 16:34:32 1.14 @@ -104,7 +104,7 @@ visible part of a (scrolled) sheet. Right now we're copying the entire window around, which seems excessive. -19. +(FIXED) 19. Key press events for modifier keys don't have the corresponding modifier bit set; key release events do. This is opposite to what CLIM-CLX does. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/12/03 19:17:26 1.15 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/12/10 16:34:32 1.16 @@ -22,10 +22,10 @@ ;;; Locking rule for this file: The entire event loop grabs the GTK ;;; lock, individual callees don't. -(defvar *keysyms* (make-hash-table)) +(defvar *keys* (make-hash-table)) -(defmacro define-keysym (name id) - `(setf (gethash ,id *keysyms*) ',name)) +(defmacro define-key (name &rest clauses) + `(setf (gethash ,name *keys*) ',clauses)) (defun connect-signal (widget name sym) (g-signal-connect widget name (cffi:get-callback sym))) @@ -170,7 +170,7 @@ (if (logtest GDK_CONTROL_MASK state) +control-key+ 0) (if (logtest GDK_MOD1_MASK state) +meta-key+ 0) ;; (if (logtest GDK_MOD2_MASK state) +super-key+ 0) - (if (logtest GDK_MOD3_MASK state) +hyper-key+ 0) + ;; (if (logtest GDK_MOD3_MASK state) +hyper-key+ 0) ;;; (if (logtest GDK_MOD4_MASK state) ??? 0) ;;; (if (logtest GDK_MOD5_MASK state) ??? 0) ;;; (if (logtest GDK_LOCK_MASK state) ??? 0) @@ -209,44 +209,62 @@ :sheet (widget->sheet widget *port*) :modifier-state (gdkmodifiertype->modifier-state state))))) +(defun state-without-buttons (state) + (logand state (1- GDK_BUTTON1_MASK))) + +;; aus CLIM-CLX geklaut: +(defconstant +clim-modifiers+ '(((:meta-left :meta-right) #.+meta-key+) + ((:hyper-left :hyper-right) #.+hyper-key+) + ((:super-left :super-right) #.+super-key+) + ((:shift-left :shift-right) #.+shift-key+) + ((:control-left :control-right) + #.+control-key+))) +(defun modify-modifiers (type keysym-keyword modifiers) + (let ((keysym-modifier (loop for (keysyms modifier) in +clim-modifiers+ + if (member keysym-keyword keysyms) + return modifier))) + (cond ((and keysym-modifier (eql type GDK_KEY_PRESS)) + (logior modifiers keysym-modifier)) + ((and keysym-modifier (eql type GDK_KEY_RELEASE)) + (logandc2 modifiers keysym-modifier)) + (t modifiers)))) + (define-signal key-handler (widget event) (let ((sheet (widget->sheet widget *port*))) - (multiple-value-bind (root-x root-y state) + (multiple-value-bind (root-x root-y) (%gdk-display-get-pointer) (multiple-value-bind (x y) (mirror-pointer-position (sheet-direct-mirror sheet)) (cffi:with-foreign-slots ((type time state keyval string length) event gdkeventkey) - (let ((char (when (plusp length) - ;; fixme: what about the other characters in `string'? - (char string 0))) - (sym (gethash keyval *keysyms*))) - (cond - ((eq sym :backspace) - (setf char #\backspace)) - ((eq sym :tab) - (setf char #\tab)) - ((null char)) - ((eql char #\return)) - ((eql char #\escape) - (setf char nil)) - ((< 0 (char-code char) 32) - (setf char (code-char (+ (char-code char) 96))))) - (enqueue - (make-instance (if (eql type GDK_KEY_PRESS) - 'key-press-event - 'key-release-event) - :key-name sym - ;; fixme: was ist mit dem rest des strings? - ;; fixme: laut dokumentation hier nicht utf-8 - :key-character char - :x x - :y y - :graft-x root-x - :graft-y root-y - :sheet sheet - :modifier-state (gdkmodifiertype->modifier-state state) - :timestamp time)))))))) + (let ((state (state-without-buttons state)) + (modifier-state (gdkmodifiertype->modifier-state state))) + (let ((clauses (gethash keyval *keys*)) + sym char) + (loop + for (st sy ch) in clauses + when (or (eql st t) (find state st)) + do + (setf sym sy) + (setf char ch) + (return)) + (unless char + (setf modifier-state + (modify-modifiers type sym modifier-state))) + (unless (eq sym 'throw-away) + (enqueue + (make-instance (if (eql type GDK_KEY_PRESS) + 'key-press-event + 'key-release-event) + :key-name sym + :key-character char + :x x + :y y + :graft-x root-x + :graft-y root-y + :sheet sheet + :modifier-state modifier-state + :timestamp time)))))))))) (defvar *last-seen-button* 3) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/11/26 17:54:08 1.7 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/12/10 16:34:32 1.8 @@ -906,6 +906,11 @@ (invalidate_children :int) ;gboolean ) +(defcfun "gdk_x11_drawable_get_xid" + :unsigned-long + (drawable :pointer) ;GdkDrawable * + ) + (defcfun "gtk_adjustment_new" :pointer (value :double) ;gdouble --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/25 21:14:53 1.17 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/12/10 16:34:32 1.18 @@ -357,6 +357,8 @@ GdkGrabStatus GdkWindowHints GtkStateType GdkDragAction GConnectFlags GdkDragProtocol + gdk_x11_drawable_get_xid + cairo_format_t cairo_operator_t cairo_fill_rule_t cairo_line_cap_t cairo_line_join_t cairo_font_slant_t cairo_font_weight_t cairo_status_t cairo_filter_t cairo_extend_t)) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/keygen.lisp 2006/12/10 16:34:33 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/keygen.lisp 2006/12/10 16:34:33 1.1 ;;; -*- Mode: Lisp; -*- ;;; (c) 2006 David Lichteblau (david at lichteblau.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-gtkairo) #+(or) (defparameter *key-table* (clim-gtkairo::collect-key-table)) #+(or) (print-key-table) (define-application-frame keygen () () (:panes (target :application)) (:layouts (default target)) (:top-level ())) (defmacro with-backend (name &body body) `(let* ((clim:*default-server-path* (list ,name)) (clim::*default-frame-manager* (car (climi::frame-managers (find-port))))) , at body)) (defun collect-key-table () (with-backend :clx (run-frame-top-level (make-application-frame 'keygen :top-level-lambda (lambda (clx) (with-backend :gtkairo (run-frame-top-level (make-application-frame 'keygen :top-level-lambda (lambda (gtk) (collect-key-table-1 clx gtk)))))))))) (defun collect-key-table-1 (clx gtk) (let ((real-handler (fdefinition 'key-handler-impl)) (table (make-hash-table))) (unwind-protect (progn (setf (fdefinition 'key-handler-impl) (lambda (widget event) (cffi:with-foreign-slots ((type time state keyval) event gdkeventkey) (setf (gethash time table) (list (state-without-buttons state) keyval))) (funcall real-handler widget event))) (collect-key-table-2 clx gtk table)) (setf (fdefinition 'key-handler-impl) real-handler)))) (defun collect-key-table-2 (clx gtk native-events) (let* ((clx-target (find-pane-named clx 'target)) (clx-win (clim:sheet-mirror clx-target)) (dpy (xlib:window-display clx-win)) (screen (xlib:display-default-screen dpy)) (min (xlib:display-min-keycode dpy)) (max (xlib:display-max-keycode dpy)) (gtk-target (find-pane-named gtk 'target)) (gtk-win (xlib::lookup-window dpy (gdk_x11_drawable_get_xid (cffi:foreign-slot-value (mirror-widget (clim:sheet-mirror gtk-target)) 'gtkwidget 'gdkwindow)))) (time 0) (clx-events (make-hash-table)) (gtk-events (make-hash-table))) (format t "Waiting for windows to come up...~%") (sleep 5) (dotimes (state 64) (format t "Sending events for state ~D...~%" state) (loop for code from min to max do (dolist (type '(:key-press :key-release)) (send-key-event screen clx-win state type code :time time) (send-key-event screen gtk-win state type code :time time) (slurp-events clx-target clx-events t) (slurp-events gtk-target gtk-events) (incf time)))) (format t "Waiting for events to come in...~%") (sleep 5) (slurp-events clx-target clx-events) (slurp-events gtk-target gtk-events) (format t "Done.~%") (let ((result (make-array time)) (real-failures 0) (mod-failures 0) (misses 0)) (dotimes (x time) (let* ((e (gethash x clx-events)) (f (gethash x gtk-events)) (a (de e)) (b (de f))) (cond ((null f) (incf misses)) ((equal a b) ;; (format t "PASS ~A~%" a) ) ((equal (cdr a) (cdr b)) (format t "FAIL ~A/~A~%" a b) (incf mod-failures)) (t (format t "FAIL ~A/~A~%" a b) (incf real-failures))) (setf (elt result x) (cons e (gethash x native-events))))) (format t "~D failures, ~D modifier failures, ~D misses~%" real-failures mod-failures misses) result))) (defun slurp-events (target table &optional block) (loop for e = (slurp-key-event target block) while e do (setf (gethash (event-timestamp e) table) e) (setf block nil))) (defun de (ev) (if ev (list (event-modifier-state ev) (keyboard-event-key-name ev) (keyboard-event-character ev)) nil)) (defun send-key-event (screen win state type code &key time) (xlib:send-event win type (list type) :code code :state state :window win :root (xlib:screen-root screen) :time (or time 0) :x 1 :y 2 :root-x 10 :root-y 20 :same-screen-p t)) (defun slurp-key-event (pane &optional block) (loop for event = (if block (event-read pane) (event-read-no-hang pane)) until (typep event '(or null key-press-event key-release-event)) finally (return event))) (defun cwd () (slot-value (asdf:find-system :clim-gtkairo) 'asdf::relative-pathname)) (defun print-key-table () (let ((table (make-hash-table))) (loop for (ok state value) across *key-table* do (when value (let* ((name (if ok (keyboard-event-key-name ok) 'throw-away)) (char (if ok (keyboard-event-character ok) 'throw-away)) (def (gethash value table))) (dolist (clause def (push (list (list state) name char) (gethash value table))) (when (and (eql (second clause) name) (eql (third clause) char)) (pushnew state (car clause)) (return)))))) (with-open-file (s (merge-pathnames "Backends/gtkairo/keys.lisp" (cwd)) :direction :output :if-exists :rename-and-delete) (write-line ";; autogenerated by keygen.lisp" s) (print '(in-package :clim-gtkairo) s) (loop for value being each hash-key in table using (hash-value spec) do (print `(define-key ,value ,@(simplify-spec spec)) s))))) (defun simplify-spec (clauses) (flet ((count-keys (x) (length (car x)))) (let* ((max (reduce #'max clauses :key #'count-keys)) (clause (find max clauses :key #'count-keys))) (append (remove clause clauses) `((t ,@(cdr clause))))))) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/keys.lisp 2006/12/10 16:34:33 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/keys.lisp 2006/12/10 16:34:33 1.1 ;; autogenerated by keygen.lisp (IN-PACKAGE :CLIM-GTKAIRO) (DEFINE-KEY 0 ((0) THROW-AWAY THROW-AWAY) (T NIL NIL)) (DEFINE-KEY 65307 (T :ESCAPE NIL)) (DEFINE-KEY 49 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|1| #\1) (T :! #\!)) (DEFINE-KEY 50 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|2| #\2) (T :@ #\@)) (DEFINE-KEY 51 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|3| #\3) (T :|#| #\#)) (DEFINE-KEY 52 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|4| #\4) (T :$ #\$)) (DEFINE-KEY 53 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|5| #\5) (T :% #\%)) (DEFINE-KEY 54 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|6| #\6) (T :DEAD-CIRCUMFLEX NIL)) (DEFINE-KEY 55 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|7| #\7) (T :& #\&)) (DEFINE-KEY 56 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|8| #\8) (T :* #\*)) (DEFINE-KEY 57 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|9| #\9) (T :|(| #\()) (DEFINE-KEY 48 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|0| #\0) (T :|)| #\))) (DEFINE-KEY 91 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :[ #\[) (T :{ #\{)) (DEFINE-KEY 93 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :] #\]) (T :} #\})) (DEFINE-KEY 65288 (T :BACKSPACE #\Backspace)) (DEFINE-KEY 65289 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :TAB #\Tab) (T :ISO-LEFT-TAB NIL)) (DEFINE-KEY 39 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|'| #\') (T :|"| #\")) (DEFINE-KEY 44 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|,| #\,) (T :< #\<)) (DEFINE-KEY 46 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|.| #\.) (T :> #\>)) (DEFINE-KEY 112 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|p| #\p) (T :P #\P)) (DEFINE-KEY 121 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|y| #\y) (T :Y #\Y)) (DEFINE-KEY 102 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|f| #\f) (T :F #\F)) (DEFINE-KEY 103 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|g| #\g) (T :G #\G)) (DEFINE-KEY 99 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|c| #\c) (T :C #\C)) (DEFINE-KEY 114 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|r| #\r) (T :R #\R)) (DEFINE-KEY 108 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|l| #\l) (T :L #\L)) (DEFINE-KEY 47 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :/ #\/) (T :? #\?)) (DEFINE-KEY 61 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) := #\=) (T :+ #\+)) (DEFINE-KEY 65293 (T :RETURN #\Return)) (DEFINE-KEY 65509 (T :CAPS-LOCK NIL)) (DEFINE-KEY 97 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|a| #\a) (T :A #\A)) (DEFINE-KEY 111 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|o| #\o) (T :O #\O)) (DEFINE-KEY 101 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|e| #\e) (T :E #\E)) (DEFINE-KEY 117 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|u| #\u) (T :U #\U)) (DEFINE-KEY 105 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|i| #\i) (T :I #\I)) (DEFINE-KEY 100 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|d| #\d) (T :D #\D)) (DEFINE-KEY 104 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|h| #\h) (T :H #\H)) (DEFINE-KEY 116 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|t| #\t) (T :T #\T)) (DEFINE-KEY 110 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|n| #\n) (T :N #\N)) (DEFINE-KEY 115 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|s| #\s) (T :S #\S)) (DEFINE-KEY 45 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :- #\-) (T :_ #\_)) (DEFINE-KEY 96 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|`| #\`) (T :DEAD-TILDE NIL)) (DEFINE-KEY 65505 (T :SHIFT-LEFT NIL)) (DEFINE-KEY 65508 (T :CONTROL-RIGHT NIL)) (DEFINE-KEY 58 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|:| #\:) (T :|;| #\;)) (DEFINE-KEY 113 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|q| #\q) (T :Q #\Q)) (DEFINE-KEY 106 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|j| #\j) (T :J #\J)) (DEFINE-KEY 107 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|k| #\k) (T :K #\K)) (DEFINE-KEY 120 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|x| #\x) (T :X #\X)) (DEFINE-KEY 98 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|b| #\b) (T :B #\B)) (DEFINE-KEY 109 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|m| #\m) (T :M #\M)) (DEFINE-KEY 119 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|w| #\w) (T :W #\W)) (DEFINE-KEY 118 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|v| #\v) (T :V #\V)) (DEFINE-KEY 122 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|z| #\z) (T :Z #\Z)) (DEFINE-KEY 65506 (T :SHIFT-RIGHT NIL)) (DEFINE-KEY 65450 (T :KP-MULTIPLY NIL)) (DEFINE-KEY 65511 (T :META-LEFT NIL)) (DEFINE-KEY 32 (T :| | #\ )) (DEFINE-KEY 65507 (T :CONTROL-LEFT NIL)) (DEFINE-KEY 65470 (T :F1 NIL)) (DEFINE-KEY 65471 (T :F2 NIL)) (DEFINE-KEY 65472 (T :F3 NIL)) (DEFINE-KEY 65473 (T :F4 NIL)) (DEFINE-KEY 65474 (T :F5 NIL)) (DEFINE-KEY 65475 (T :F6 NIL)) (DEFINE-KEY 65476 (T :F7 NIL)) (DEFINE-KEY 65477 (T :F8 NIL)) (DEFINE-KEY 65478 (T :F9 NIL)) (DEFINE-KEY 65479 (T :F10 NIL)) (DEFINE-KEY 65407 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :NUM-LOCK NIL) (T :POINTER-ENABLE-KEYS NIL)) (DEFINE-KEY 65300 (T :SCROLL-LOCK NIL)) (DEFINE-KEY 65429 ((44 40 36 32 12 8 4 0) :KP-HOME NIL) (T :KP-7 NIL)) (DEFINE-KEY 65431 ((44 40 36 32 12 8 4 0) :KP-UP NIL) (T :KP-8 NIL)) (DEFINE-KEY 65434 ((44 40 36 32 12 8 4 0) :KP-PRIOR NIL) (T :KP-9 NIL)) (DEFINE-KEY 65453 (T :KP-SUBTRACT NIL)) (DEFINE-KEY 65430 ((44 40 36 32 12 8 4 0) :KP-LEFT NIL) (T :KP-4 NIL)) (DEFINE-KEY 65437 ((44 40 36 32 12 8 4 0) :KP-BEGIN NIL) (T :KP-5 NIL)) (DEFINE-KEY 65432 ((44 40 36 32 12 8 4 0) :KP-RIGHT NIL) (T :KP-6 NIL)) (DEFINE-KEY 65451 (T :KP-ADD NIL)) (DEFINE-KEY 65436 ((44 40 36 32 12 8 4 0) :KP-END NIL) (T :KP-1 NIL)) (DEFINE-KEY 65433 ((44 40 36 32 12 8 4 0) :KP-DOWN NIL) (T :KP-2 NIL)) (DEFINE-KEY 65435 ((44 40 36 32 12 8 4 0) :KP-NEXT NIL) (T :KP-3 NIL)) (DEFINE-KEY 65438 ((44 40 36 32 12 8 4 0) :KP-INSERT NIL) (T :KP-0 NIL)) (DEFINE-KEY 65439 ((44 40 36 32 12 8 4 0) :KP-DELETE NIL) (T :KP-DECIMAL NIL)) (DEFINE-KEY 65377 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :PRINT NIL) (T :SYS-REQ NIL)) (DEFINE-KEY 60 ((62 58 54 50 46 42 38 34 30 26 22 18 14 10 6 2) :> #\>) (T :< #\<)) (DEFINE-KEY 65480 (T :F11 NIL)) (DEFINE-KEY 65312 (T :MULTI-KEY NIL)) (DEFINE-KEY 65360 (T :HOME NIL)) (DEFINE-KEY 65362 (T :UP NIL)) (DEFINE-KEY 65365 (T :PRIOR NIL)) (DEFINE-KEY 65361 (T :LEFT NIL)) (DEFINE-KEY 65363 (T :RIGHT NIL)) (DEFINE-KEY 65367 (T :END NIL)) (DEFINE-KEY 65364 (T :DOWN NIL)) (DEFINE-KEY 65366 (T :NEXT NIL)) (DEFINE-KEY 65379 (T :INSERT NIL)) (DEFINE-KEY 65535 (T :DELETE #\Rubout)) (DEFINE-KEY 65421 (T :KP-ENTER NIL)) (DEFINE-KEY 92 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|\\| #\\) (T :|\|| #\|)) (DEFINE-KEY 65299 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :PAUSE NIL) (T :BREAK NIL)) (DEFINE-KEY 65455 (T :KP-DIVIDE NIL)) (DEFINE-KEY 65512 (T :META-RIGHT NIL)) (DEFINE-KEY 65383 (T :MENU NIL)) (DEFINE-KEY 268828536 (T :SUN-AUDIO-MUTE NIL)) (DEFINE-KEY 268828535 (T :SUN-AUDIO-LOWER-VOLUME NIL)) (DEFINE-KEY 268828537 (T :SUN-AUDIO-RAISE-VOLUME NIL)) (DEFINE-KEY 33 (T :! #\!)) (DEFINE-KEY 64 (T :@ #\@)) (DEFINE-KEY 35 (T :|#| #\#)) (DEFINE-KEY 36 (T :$ #\$)) (DEFINE-KEY 37 (T :% #\%)) (DEFINE-KEY 65106 (T :DEAD-CIRCUMFLEX NIL)) (DEFINE-KEY 38 (T :& #\&)) (DEFINE-KEY 42 (T :* #\*)) (DEFINE-KEY 40 (T :|(| #\()) (DEFINE-KEY 41 (T :|)| #\))) (DEFINE-KEY 123 (T :{ #\{)) (DEFINE-KEY 125 (T :} #\})) (DEFINE-KEY 65056 (T :ISO-LEFT-TAB NIL)) (DEFINE-KEY 34 (T :|"| #\")) (DEFINE-KEY 62 (T :> #\>)) (DEFINE-KEY 80 (T :P #\P)) (DEFINE-KEY 89 (T :Y #\Y)) (DEFINE-KEY 70 (T :F #\F)) (DEFINE-KEY 71 (T :G #\G)) (DEFINE-KEY 67 (T :C #\C)) (DEFINE-KEY 82 (T :R #\R)) (DEFINE-KEY 76 (T :L #\L)) (DEFINE-KEY 63 (T :? #\?)) (DEFINE-KEY 43 (T :+ #\+)) (DEFINE-KEY 65 (T :A #\A)) (DEFINE-KEY 79 (T :O #\O)) (DEFINE-KEY 69 (T :E #\E)) (DEFINE-KEY 85 (T :U #\U)) (DEFINE-KEY 73 (T :I #\I)) (DEFINE-KEY 68 (T :D #\D)) (DEFINE-KEY 72 (T :H #\H)) (DEFINE-KEY 84 (T :T #\T)) (DEFINE-KEY 78 (T :N #\N)) (DEFINE-KEY 83 (T :S #\S)) [28 lines skipped] From dlichteblau at common-lisp.net Sun Dec 10 16:34:57 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 10 Dec 2006 11:34:57 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061210163457.C34B12F052@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv29411 Modified Files: mcclim.asd Log Message: Reimplemented key event handling. * event.lisp (*KEYSYMS*, DEFINE-KEYSYM): Removed. (*KEYS*, DEFINE-KEY): New. (GDKMODIFIERTYPE->MODIFIER-STATE): Ignore hyper, too. (STATE-WITHOUT-BUTTONS): New. (+CLIM-MODIFIERS+, MODIFY-MODIFIERS): Copy&Paste from CLIM-CLX. (KEY-HANDLER): Reimplemented using *keys* and modify-modifiers. * ffi.lisp: Regenerated. * keys.lisp: New file. * keygen.lisp: New file. * keysymdef.lisp: Removed. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/12/04 07:54:51 1.36 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/12/10 16:34:57 1.37 @@ -384,7 +384,7 @@ (:file "graft") (:file "port") (:file "event") - (:file "keysymdef") + (:file "keys") (:file "medium") (:file "pixmap") (:file "frame-manager") From thenriksen at common-lisp.net Sun Dec 10 19:28:49 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 10 Dec 2006 14:28:49 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests Message-ID: <20061210192849.2A454301F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv24081/Drei/Tests Modified Files: testing.lisp packages.lisp Added Files: lisp-syntax-tests.lisp Log Message: Improved the Lisp syntax module, in particular, the `form-to-object' function (previously `token-to-object') should now be as capable as a proper Lisp reader. This has been used to implement some (in my opinion) neat behavior for the expression accept method. Also added some test cases for the function. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/testing.lisp 2006/12/04 07:54:51 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/testing.lisp 2006/12/10 19:28:48 1.2 @@ -111,6 +111,8 @@ (run! 'rectangle-tests) (format t "Testing undo~%") (run! 'undo-tests) + (format t "Testing the Lisp syntax module~%") + (run! 'lisp-syntax-tests) (format t "Running the CL-AUTOMATON tests~%") (format t "Testing regular expressions~%") --- /project/mcclim/cvsroot/mcclim/Drei/Tests/packages.lisp 2006/12/04 07:54:51 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/packages.lisp 2006/12/10 19:28:48 1.2 @@ -30,4 +30,6 @@ :drei-editing :automaton :eqv-hash :drei-core :drei-kill-ring :drei-syntax :drei :esa :esa-utils :clim :drei-lisp-syntax :drei-undo) (:shadowing-import-from :automaton #:run) - (:export #:run-tests)) + (:shadowing-import-from :drei-lisp-syntax #:form) + (:export #:run-tests + #:*run-self-compilation-test*)) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2006/12/10 19:28:49 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2006/12/10 19:28:49 1.1 ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas at sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) (def-suite lisp-syntax-tests :description "The test suite for tests related to the Lisp syntax module.") (in-suite lisp-syntax-tests) (defvar *run-self-compilation-test* nil "If true, running the Lisp syntax module test suite will involve an extreme stress test wherein the Lisp parser will be used to read in the Drei source code, recompile Drei based on the parser result and re-run the test suite (except for this self-compilation test, of course).") (defmacro testing-lisp-syntax ((buffer-contents) &body body) `(with-buffer (buffer :initial-contents ,buffer-contents :syntax 'lisp-syntax) (flet ((get-object (&rest args) (apply #'form-to-object (syntax buffer) (first (drei-lisp-syntax::children (slot-value (syntax buffer) 'drei-lisp-syntax::stack-top))) args))) , at body))) (defmacro testing-symbol ((sym-sym &rest args) &body body) `(let ((,sym-sym (get-object , at args))) , at body (unless (or (null (symbol-package sym)) (eq (symbol-package sym) (find-package :clim)) (eq (symbol-package sym) (find-package :common-lisp))) (unintern ,sym-sym (symbol-package sym))))) (defmacro testing-lisp-syntax-symbol ((buffer-contents sym-sym &rest args) &body body) `(with-buffer (buffer :initial-contents ,buffer-contents :syntax 'lisp-syntax) (flet ((get-object (&rest args) (apply #'form-to-object (syntax buffer) (first (drei-lisp-syntax::children (slot-value (syntax buffer) 'drei-lisp-syntax::stack-top))) args))) (testing-symbol (,sym-sym , at args) , at body)))) (test form-to-object-1 (testing-lisp-syntax ("T") (is (eq (get-object) t))) (testing-lisp-syntax ("t") (is (eq (get-object) t)))) (test form-to-object-2 (testing-lisp-syntax ("nil") (is (eq (get-object) nil))) (testing-lisp-syntax ("NIL") (is (eq (get-object) nil))) (testing-lisp-syntax ("NIl") (is (eq (get-object) nil))) (testing-lisp-syntax ("NIl") (is-false (eq (get-object :case :preserve) nil)))) (test form-to-object-3 (testing-lisp-syntax ("iDoNotExist") (testing-symbol (sym :case :upcase) (is-false (symbol-package sym)) (is (string= (symbol-name sym) "IDONOTEXIST"))) (testing-symbol (sym :case :preserve) (is-false (symbol-package sym)) (is (string= (symbol-name sym) "iDoNotExist"))) (testing-symbol (sym :case :downcase) (is-false (symbol-package sym)) (is (string= (symbol-name sym) "idonotexist"))) (testing-symbol (sym :read t :case :upcase) (is-true (symbol-package sym)) (is (string= (symbol-name sym) "IDONOTEXIST"))) (testing-symbol (sym :read t :case :preserve) (is-true (symbol-package sym)) (is (string= (symbol-name sym) "iDoNotExist"))) (testing-symbol (sym :read t :case :downcase) (is-true (symbol-package sym)) (is (string= (symbol-name sym) "idonotexist"))) (testing-symbol (sym :case :invert) (is-false (symbol-package sym)) (is (string= (symbol-name sym) "iDoNotExist")))) (testing-lisp-syntax-symbol ("IDONOTEXIST" sym :case :invert) (is-false (symbol-package sym)) (is (string= (symbol-name sym) "idonotexist"))) (testing-lisp-syntax-symbol ("idonotexist" sym :case :invert) (is-false (symbol-package sym)) (is (string= (symbol-name sym) "IDONOTEXIST")))) (test form-to-object-4 (testing-lisp-syntax ("#:iDoNotExist") (testing-symbol (sym :case :upcase) (is-false (symbol-package sym)) (is (string= (symbol-name sym) "IDONOTEXIST"))) (testing-symbol (sym :case :preserve) (is-false (symbol-package sym)) (is (string= (symbol-name sym) "iDoNotExist"))) (testing-symbol (sym :case :downcase) (is-false (symbol-package sym)) (is (string= (symbol-name sym) "idonotexist"))) (testing-symbol (sym :case :invert) (is-false (symbol-package sym)) (is (string= (symbol-name sym) "iDoNotExist")))) (testing-lisp-syntax ("#:IDONOTEXIST") (let ((sym (get-object :case :invert))) (is-false (symbol-package sym)) (is (string= (symbol-name sym) "idonotexist")))) (testing-lisp-syntax ("#:idonotexist") (let ((sym (get-object :case :invert))) (is-false (symbol-package sym)) (is (string= (symbol-name sym) "IDONOTEXIST"))))) (test form-to-object-5 (testing-lisp-syntax-symbol ("|123|" sym :read t) (is (string= (symbol-name sym) "123"))) (testing-lisp-syntax-symbol ("|LIST|" sym :read t :case :downcase) (is (string= (symbol-name sym) "LIST"))) (testing-lisp-syntax-symbol ("| |" sym :read t) (is (string= (symbol-name sym) " "))) (testing-lisp-syntax-symbol ("|foo|bar|abbabz|" sym :read t) (is (string= (symbol-name sym) "fooBARabbabz"))) (testing-lisp-syntax-symbol ("||" sym :read t) (is (string= (symbol-name sym) ""))) (testing-lisp-syntax-symbol ("||||" sym :read t) (is (string= (symbol-name sym) "")))) (test form-to-object-6 (testing-lisp-syntax-symbol (":foo" sym :read t) (is (string= (symbol-name sym) "FOO")) (is (eq (symbol-package sym) (find-package :keyword))))) (test form-to-object-7 (testing-lisp-syntax ("123") (is (= (get-object) 123))) (testing-lisp-syntax ("-123") (is (= (get-object) -123))) (testing-lisp-syntax (".123") (is (= (get-object) .123))) (testing-lisp-syntax ("-.123") (is (= (get-object) -.123))) (testing-lisp-syntax ("1.234") (is (= (get-object) 1.234))) (testing-lisp-syntax ("-1.234") (is (= (get-object) -1.234))) (testing-lisp-syntax ("1e7") (is (= (get-object) 1e7))) (testing-lisp-syntax ("1E7") (is (= (get-object) 1e7))) (testing-lisp-syntax ("1.123E7") (is (= (get-object) 1.123e7))) (testing-lisp-syntax ("-1.123E7") (is (= (get-object) -1.123e7))) (testing-lisp-syntax (".123E7") (is (= (get-object) .123e7))) (testing-lisp-syntax ("-.123E7") (is (= (get-object) -.123e7))) (testing-lisp-syntax ("1.34e-7") (is (= (get-object) 1.34e-7)))) (test form-to-object-8 (testing-lisp-syntax ("#b0000") (is (= (get-object) 0))) (testing-lisp-syntax ("#b10") (is (= (get-object) 2))) (testing-lisp-syntax ("#b-10") (is (= (get-object) -2))) (testing-lisp-syntax ("#x00") (is (= (get-object) 0))) (testing-lisp-syntax ("#xFE") (is (= (get-object) 254))) (testing-lisp-syntax ("#x-FE") (is (= (get-object) -254))) (testing-lisp-syntax ("#o00") (is (= (get-object) 0))) (testing-lisp-syntax ("#o71") (is (= (get-object) 57))) (testing-lisp-syntax ("#o-71") (is (= (get-object) -57)))) (test form-to-object-9 (testing-lisp-syntax ("#\\a") (is (char= (get-object) #\a))) (testing-lisp-syntax ("#\\Null") (is (char= (get-object) #\Null))) (testing-lisp-syntax ("#\\NULL") (is (char= (get-object) #\Null))) (testing-lisp-syntax ("#\\ ") (is (char= (get-object) #\Space)))) (test form-to-object-10 (testing-lisp-syntax ("(t t t)") (is (equal (get-object) '(t t t)))) (testing-lisp-syntax ("()") (is (eq (get-object) nil))) (testing-lisp-syntax ("(#\\ t)") (is (equal (get-object) '(#\Space t)))) (testing-lisp-syntax ("(NIL nil Nil)") (destructuring-bind (a b c) (get-object :case :preserve) (is (string= (symbol-name a) "NIL")) (is (string= (symbol-name b) "nil")) (is (string= (symbol-name c) "Nil"))))) (test form-to-object-11 (testing-lisp-syntax ("#(t t t)") (is (equalp (get-object) #(t t t)))) (testing-lisp-syntax ("#()") (is (equalp (get-object) #()))) (testing-lisp-syntax ("#(#\\ t)") (is (equalp (get-object) #(#\Space t)))) (testing-lisp-syntax ("#(NIL nil Nil)") (destructuring-bind (a b c) (loop for x across (get-object :case :preserve) collecting x) (is (string= (symbol-name a) "NIL")) (is (string= (symbol-name b) "nil")) (is (string= (symbol-name c) "Nil"))))) (test form-to-object-12 (testing-lisp-syntax ("(t . t)") (is (equal (get-object) '(t . t)))) (testing-lisp-syntax ("(t.t)") (is (string= (first (get-object)) "T.T"))) (testing-lisp-syntax ("(t . nil)") (is (equal (get-object) '(t)))) (testing-lisp-syntax ("(t t . t)") (is (equal (get-object) '(t t . t)))) (testing-lisp-syntax ("(#\\ . t)") (is (equal (get-object) '(#\Space . t)))) (testing-lisp-syntax ("(t t . 't)") (is (equal (get-object) '(t t quote t)))) (testing-lisp-syntax ("(NIL nil . Nil)") (destructuring-bind (a b . c) (get-object :case :preserve) (is (string= (symbol-name a) "NIL")) (is (string= (symbol-name b) "nil")) (is (string= (symbol-name c) "Nil"))))) (test form-to-object-13 (testing-lisp-syntax ("(t ") (finishes (get-object)) (signals form-conversion-error (get-object :read t)) (finishes (get-object :read t :no-error t)))) (test form-to-object-14 (testing-lisp-syntax ("`(list ,(+ 2 2))") (is (equal (eval (get-object)) '(list 4)))) (testing-lisp-syntax ("``(list ,,(+ 2 2))") (is (equal (eval (eval (get-object))) '(list 4)))) (testing-lisp-syntax ("(let ((a '(1 2 3))) `(list , at a))") (is (equal (eval (get-object :read t)) '(list 1 2 3)))) (testing-lisp-syntax ("(let ((a '(1 2 3))) `(let ((b 42)) `(list (,, at a) ,b))))") (is (equal (eval (eval (get-object :read t))) '(list (1 2 3) 42)))) (testing-lisp-syntax ("(let ((a '(1 2 3))) `(list ,a `',(+ 2 2)))") (is (equal (second (eval (get-object :read t))) '(1 2 3)))) (testing-lisp-syntax ("(let ((a 'list)) `',a)") (is (equal (eval (eval (get-object :read t))) 'list))) (testing-lisp-syntax ("(let ((a '(1 2 3))) `',`',a)") (is (equal (eval (get-object :read t)) '''(1 2 3)))) (testing-lisp-syntax ("(let ((a '(1 2 3))) ``(list ,@',a))") (is (equal (eval (eval (eval (get-object :read t)))) '(1 2 3)))) (testing-lisp-syntax ("(let ((a '(4 5 6))) `(list 1 2 3 ,.a))") (is (equal (eval (eval (get-object :read t))) '(1 2 3 4 5 6)))) (testing-lisp-syntax ("(let ((a '('(4 5 6) '(7 8 9)))) ```(list 1 2 3 ,.,@',a))") (is (equal (eval (eval (eval (eval (get-object :read t))))) '(1 2 3 4 5 6 7 8 9)))) (testing-lisp-syntax ("`(car . cdr)") (is (equal (eval (get-object :read t)) '(car . cdr))))) (test form-to-object-15 (testing-lisp-syntax ("`#(1 ,(+ 2 2) 6)") (is (equalp (eval (get-object :read t)) #(1 4 6)))) (testing-lisp-syntax ("(let ((a '(2 3 4 5))) `#(1 , at a 6))") (is (equalp (eval (get-object :read t)) #(1 2 3 4 5 6)))) (testing-lisp-syntax ("`#(list ,(+ 2 2))") (is (equalp (eval (get-object)) #(list 4)))) (testing-lisp-syntax ("``(list #(,,(+ 2 2)))") (is (equalp (eval (eval (get-object))) '(list #(4))))) (testing-lisp-syntax ("(let ((a '(1 2 3))) `(let ((b 42)) `#(list #(,, at a) ,b))))") (is (equalp (eval (eval (get-object :read t))) #(list #(1 2 3) 42)))) (testing-lisp-syntax ("(let ((a #(1 2 3))) `(list #(,a) `#',(+ 2 2)))") (is (equalp (second (eval (get-object :read t))) #(#(1 2 3))))) (testing-lisp-syntax ("(let ((a 'list)) `#(,a))") (is (equalp (eval (eval (get-object :read t))) #(list)))) (testing-lisp-syntax ("(let ((a '(1 2 3))) `#(,`#(,a)))") (is (equalp (eval (get-object :read t)) #(#((1 2 3)))))) (testing-lisp-syntax ("(let ((a '(1 2 3))) ``#(,@',a))") (is (equalp (eval (eval (eval (get-object :read t)))) #(1 2 3)))) (testing-lisp-syntax ("(let ((a '(4 5 6))) `#(1 2 3 ,.a))") (is (equalp (eval (eval (get-object :read t))) #(1 2 3 4 5 6)))) (testing-lisp-syntax ("(let ((a '('(4 5 6) '(7 8 9)))) ```#(1 2 3 ,.,@',a))") (is (equalp (eval (eval (eval (eval (get-object :read t))))) #(1 2 3 4 5 6 7 8 9))))) (test form-to-object-16 (testing-lisp-syntax ("#+mcclim t") (is (eq (get-object) t))) (testing-lisp-syntax ("#-mcclim t") (is (eq (get-object) nil))) (testing-lisp-syntax ("(#+mcclim t)") (is (equal (get-object) '(t)))) (testing-lisp-syntax ("(#-mcclim t)") (is (equal (get-object) '())))) (defgeneric find-pathnames (module) (:documentation "Get a list of the pathnames of the files making up an ASDF module/system/component.") (:method-combination nconc)) (defmethod find-pathnames nconc ((module asdf:module)) (mapcan #'find-pathnames (asdf:module-components module))) (defmethod find-pathnames nconc ((module asdf:source-file)) (list (asdf:component-pathname module))) ;; Thank you Mr. Insane 3000! (defun slurp-file (pathname) (with-open-file (strm pathname) (let ((string (make-string (file-length strm)))) (read-sequence string strm) [24 lines skipped] From thenriksen at common-lisp.net Sun Dec 10 19:28:50 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 10 Dec 2006 14:28:50 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061210192850.A70FA111CA@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv24081/Drei Modified Files: packages.lisp lisp-syntax.lisp lisp-syntax-swine.lisp lisp-syntax-commands.lisp input-editor.lisp Log Message: Improved the Lisp syntax module, in particular, the `form-to-object' function (previously `token-to-object') should now be as capable as a proper Lisp reader. This has been used to implement some (in my opinion) neat behavior for the expression accept method. Also added some test cases for the function. --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/12/09 23:55:37 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/12/10 19:28:49 1.10 @@ -432,8 +432,12 @@ (:use :clim-lisp :clim :clim-extensions :drei-buffer :drei-base :drei-syntax :drei-fundamental-syntax :flexichain :drei :drei-motion :drei-editing :esa-utils :esa :drei-core :esa-io) - (:export #:lisp-string - #:edit-definition) + (:export #:lisp-syntax + #:lisp-string + #:edit-definition + #:form + #:form-to-object + #:form-conversion-error) (:shadow clim:form)) (defpackage :drei-commands --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/12/06 11:31:12 1.11 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/12/10 19:28:49 1.12 @@ -243,7 +243,7 @@ (defclass lexer-state () () - (:documentation "These states are used to determine how the lexer + (:documentation "These states are used to determine how the lexer should behave.")) (defmacro define-lexer-state (name superclasses &body body) @@ -257,23 +257,23 @@ (define-lexer-state lexer-toplevel-state () () - (:documentation "In this state, the lexer assumes it can skip + (:documentation "In this state, the lexer assumes it can skip whitespace and should recognize ordinary lexemes of the language except for the right parenthesis")) (define-lexer-state lexer-list-state (lexer-toplevel-state) () - (:documentation "In this state, the lexer assumes it can skip + (:documentation "In this state, the lexer assumes it can skip whitespace and should recognize ordinary lexemes of the language")) (define-lexer-state lexer-string-state () () - (:documentation "In this state, the lexer is working inside a string + (:documentation "In this state, the lexer is working inside a string delimited by double quote characters.")) (define-lexer-state lexer-line-comment-state () () - (:documentation "In this state, the lexer is working inside a line + (:documentation "In this state, the lexer is working inside a line comment (starting with a semicolon.")) (define-lexer-state lexer-long-comment-state () @@ -314,7 +314,7 @@ (defclass parser-state () ()) (defmacro define-parser-state (name superclasses &body body) - `(progn + `(progn (defclass ,name ,superclasses , at body) (defvar ,name (make-instance ',name)))) @@ -336,12 +336,12 @@ (end (find-if-not #'null children :key #'end-offset :from-end t))) (when start (setf start-mark (slot-value start 'start-mark) - size (- (end-offset end) (start-offset start))))))) + size (- (end-offset end) (start-offset start))))))) ;;; until here ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defclass lisp-nonterminal (nonterminal) ()) +(defclass lisp-nonterminal (nonterminal) ()) (defclass form (lisp-nonterminal) ()) (defclass complete-form-mixin () ()) (defclass incomplete-form-mixin () ()) @@ -411,7 +411,7 @@ (setf (offset scan) start-offset) (setf start-mark scan size new-size)) - lexeme))) + lexeme))) (defmethod lex ((syntax lisp-syntax) (state lexer-toplevel-state) scan) (macrolet ((fo () `(forward-object scan))) @@ -439,7 +439,7 @@ (#\# (fo) (cond ((end-of-buffer-p scan) (make-instance 'incomplete-lexeme)) - (t + (t (let ((prefix 0)) (loop until (end-of-buffer-p scan) while (digit-char-p (object-after scan)) @@ -450,7 +450,7 @@ (if (end-of-buffer-p scan) (make-instance 'incomplete-lexeme) (case (object-after scan) - ((#\Backspace #\Tab #\Newline #\Linefeed + ((#\Backspace #\Tab #\Newline #\Linefeed #\Page #\Return #\Space #\)) (fo) (make-instance 'error-lexeme)) @@ -487,6 +487,9 @@ ((#\O #\o) 8) ((#\X #\x) 16)))) (fo) + (when (char= (object-after scan) + #\-) + (fo)) (loop until (end-of-buffer-p scan) while (digit-char-p (object-after scan) radix) do (fo))) @@ -666,31 +669,33 @@ (defmethod lex ((syntax lisp-syntax) (state lexer-escaped-token-state) scan) (let ((bars-seen 0)) (macrolet ((fo () `(forward-object scan))) - (tagbody - start - (when (end-of-buffer-p scan) - (return-from lex (make-instance 'text-lexeme))) - (when (eql (object-after scan) #\\) - (fo) - (when (end-of-buffer-p scan) - (return-from lex (make-instance 'incomplete-lexeme))) - (fo) - (go start)) - (when (eql (object-after scan) #\|) - (incf bars-seen) - (fo) - (go start)) - (if (evenp bars-seen) - (unless (whitespacep syntax (object-after scan)) - (fo) - (go start)) - (when (constituentp (object-after scan)) - (fo) - (go start))) - (return-from lex - (if (oddp bars-seen) - (make-instance 'multiple-escape-end-lexeme) - (make-instance 'text-lexeme))))))) + (flet ((end () + (return-from lex + (if (oddp bars-seen) + (make-instance 'multiple-escape-end-lexeme) + (make-instance 'text-lexeme))))) + (tagbody + start + (when (end-of-buffer-p scan) + (end)) + (when (eql (object-after scan) #\\) + (fo) + (when (end-of-buffer-p scan) + (return-from lex (make-instance 'incomplete-lexeme))) + (fo) + (go start)) + (when (eql (object-after scan) #\|) + (incf bars-seen) + (fo) + (go start)) + (if (evenp bars-seen) + (unless (whitespacep syntax (object-after scan)) + (fo) + (go start)) + (when (constituentp (object-after scan)) + (fo) + (go start))) + (end)))))) (defmethod lex ((syntax lisp-syntax) (state lexer-error-state) scan) (macrolet ((fo () `(forward-object scan))) @@ -703,7 +708,7 @@ ;;; nonterminals (defclass line-comment (lisp-nonterminal) ()) -(defclass long-comment (lisp-nonterminal) ()) +(defclass long-comment (lisp-nonterminal) ()) (defclass error-symbol (lisp-nonterminal) ()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -772,13 +777,13 @@ (with-slots (start-mark size) result (setf start-mark (clone-mark scan :right) size 0)))) - result)) + result)) (define-parser-state error-state (lexer-error-state parser-state) ()) (define-parser-state error-reduce-state (lexer-toplevel-state parser-state) ()) (define-lisp-action (error-reduce-state (eql nil)) - (throw 'done nil)) + (throw 'done nil)) ;;; the default action for any lexeme is shift (define-lisp-action (t lisp-lexeme) @@ -791,14 +796,14 @@ ;;; the default new state is the error state (define-new-lisp-state (t parser-symbol) error-state) -;;; the new state when an error-state +;;; the new state when an error-state (define-new-lisp-state (t error-symbol) error-reduce-state) -;;;;;;;;;;;;;;;; Top-level +;;;;;;;;;;;;;;;; Top-level #| rules - form* -> + form* -> form* -> form* form |# @@ -818,7 +823,7 @@ (reduce-all form*)) (define-new-lisp-state (|initial-state | form*) |form* | ) - + (define-lisp-action (|form* | (eql nil)) (throw 'done nil)) @@ -927,7 +932,7 @@ (define-lisp-action (|" word* " | t) (reduce-until-type complete-string-form string-start-lexeme)) -;;; reduce at the end of the buffer +;;; reduce at the end of the buffer (define-lisp-action (|" word* | (eql nil)) (reduce-until-type incomplete-string-form string-start-lexeme)) @@ -1125,7 +1130,7 @@ (define-new-lisp-state (|#- form | form) |#- form form |) (define-new-lisp-state (|#- | comment) |#- |) (define-new-lisp-state (|#- form | comment) |#- form |) - + (define-lisp-action (|#+ form form | t) (reduce-until-type reader-conditional-positive-form reader-conditional-positive-lexeme)) @@ -1292,7 +1297,7 @@ (t (loop with new-tree = (cadr (member tree siblings :test #'eq)) until (null (children new-tree)) do (setf new-tree (car (children new-tree))) - finally (return new-tree))))))) + finally (return new-tree))))))) (defun find-last-valid-lexeme (parse-tree offset) (cond ((or (null parse-tree) (null (start-offset parse-tree))) nil) @@ -1302,7 +1307,7 @@ (find-last-valid-lexeme (car (last (children parse-tree))) offset)) ((>= (end-offset parse-tree) offset) (find-last-valid-lexeme (preceding-parse-tree parse-tree) offset)) - (t parse-tree))) + (t parse-tree))) (defun find-first-potentially-valid-lexeme (parse-trees offset) (cond ((null parse-trees) nil) @@ -1322,7 +1327,7 @@ (and (eq (class-of tree1) (class-of tree2)) (eq (parser-state tree1) (parser-state tree2)) (= (end-offset tree1) (end-offset tree2)))) - + (defmethod print-object ((mark mark) stream) (print-unreadable-object (mark stream :type t :identity t) (format stream "~s" (offset mark)))) @@ -1350,7 +1355,7 @@ (>= (start-offset potentially-valid-trees) (end-offset stack-top))) do (setf potentially-valid-trees - (next-tree potentially-valid-trees))))))) + (next-tree potentially-valid-trees))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -1435,7 +1440,7 @@ (typep x 'complete-list-form)) (let ((candidate (first-form (children x)))) (and (form-token-p candidate) - (eq (token-to-object syntax candidate + (eq (form-to-object syntax candidate :no-error t) 'cl:in-package))))))) (with-slots (stack-top) syntax @@ -1457,12 +1462,12 @@ (when (form-list-p x) (let ((candidate (first-form (children x)))) (and (form-token-p candidate) - (eq (token-to-object syntax candidate + (eq (form-to-object syntax candidate :no-error t) 'cl:in-package))))) (extract (x) (let ((designator (second-form (children x)))) - (token-to-object syntax designator + (form-to-object syntax designator :no-error t)))) (with-slots (stack-top) syntax (loop for child in (children stack-top) @@ -1672,18 +1677,18 @@ "Return the text of the definition at mark." (let ((definition (definition-at-mark mark syntax))) (buffer-substring (buffer mark) - (start-offset definition) + (start-offset definition) (end-offset definition)))) - + (defun text-of-expression-at-mark (mark-or-offset syntax) "Return the text of the expression at `mark-or-offset'." (let ((expression (expression-at-mark mark-or-offset syntax))) - (token-string syntax expression))) + (form-string syntax expression))) (defun symbol-name-at-mark (mark-or-offset syntax) "Return the text of the symbol at `mark-or-offset'." (let ((token (symbol-at-mark mark-or-offset syntax))) - (when token (token-string syntax token)))) + (when token (form-string syntax token)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -1711,6 +1716,7 @@ (define-form-predicate form-quoted-p (quote-form backquote-form)) (define-form-predicate form-comma-p (comma-form)) (define-form-predicate form-comma-at-p (comma-at-form)) +(define-form-predicate form-comma-dot-p (comma-dot-form)) (define-form-predicate comment-p (comment)) @@ -1805,16 +1811,16 @@ (defmethod display-parse-tree :around (parse-symbol stream (drei drei) (syntax lisp-syntax)) (with-slots (top bot) drei - (when (and (start-offset parse-symbol) + (when (and (start-offset parse-symbol) (mark< (start-offset parse-symbol) bot) (mark> (end-offset parse-symbol) top)) - (call-next-method)))) + (call-next-method)))) (defmethod display-parse-tree (parse-symbol stream (drei drei) (syntax lisp-syntax)) (with-slots (top bot) drei (loop for child in (children parse-symbol) - when (and (start-offset child) + when (and (start-offset child) (mark> (end-offset child) top)) do (if (mark< (start-offset child) bot) (display-parse-tree child stream drei syntax) @@ -1850,9 +1856,9 @@ (defmethod display-parse-tree ((parse-symbol token-mixin) stream (drei drei) (syntax lisp-syntax)) (if (> (the fixnum (end-offset parse-symbol)) (the fixnum (start-offset parse-symbol))) - (let ((string (token-string syntax parse-symbol))) + (let ((string (form-string syntax parse-symbol))) (multiple-value-bind (symbol status) - (token-to-object syntax parse-symbol :no-error t) + (form-to-object syntax parse-symbol :no-error t) (with-output-as-presentation (stream (if status symbol string) (if status 'symbol 'unknown-symbol) @@ -1881,7 +1887,7 @@ :id-test #'equal :cache-value parser-symbol :cache-test #'eql) - (let ((object (token-to-object syntax parser-symbol))) + (let ((object (form-to-object syntax parser-symbol))) (present object (presentation-type-of object) :stream stream)))) (defmethod display-parse-tree ((parser-symbol lisp-lexeme) stream (drei drei) @@ -1900,15 +1906,15 @@ (with-slots (ink face) parser-symbol (setf ink (medium-ink (sheet-medium stream)) face (text-style-face (medium-text-style (sheet-medium stream)))) - (let ((string (token-string syntax parser-symbol))) + (let ((string (form-string syntax parser-symbol))) (present string 'string :stream stream)))))) - + (defmethod display-parse-tree :before ((parse-symbol lisp-lexeme) stream (drei drei) (syntax lisp-syntax)) (handle-whitespace stream (buffer drei) *white-space-start* (start-offset parse-symbol)) (setf *white-space-start* (end-offset parse-symbol))) -(define-presentation-type lisp-string () +(define-presentation-type lisp-string () :description "lisp string") (defmethod display-parse-tree ((parse-symbol complete-string-form) stream (drei drei) (syntax lisp-syntax)) @@ -1980,7 +1986,7 @@ "The KEYWORD package.") (defmethod eval-feature-conditional ((conditional token-mixin) (syntax lisp-syntax)) - (let* ((string (token-string syntax conditional)) + (let* ((string (form-string syntax conditional)) (symbol (parse-symbol string :package +keyword-package+))) (member symbol *features*))) @@ -1996,7 +2002,7 @@ (remove-if #'comment-p children)))) - (type-string (token-string syntax type)) + (type-string (form-string syntax type)) (type-symbol (parse-symbol type-string :package +keyword-package+))) (case type-symbol (:and (funcall #'every #'eval-fc conditionals)) @@ -2004,7 +2010,7 @@ (:not (when conditionals [820 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2006/12/04 20:07:53 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2006/12/10 19:28:49 1.4 @@ -417,7 +417,7 @@ indexing-start-arg operator-form)) (preceding-arg-obj (when preceding-arg-token - (token-to-object syntax preceding-arg-token + (form-to-object syntax preceding-arg-token :no-error t)))) (values preceding-arg-obj argument-indices)))) @@ -461,7 +461,7 @@ argument\" is defined as an argument that would be directly bound to a symbol when evaluating the operators body, or as an argument that would be a direct component of a &body or &rest argument." - (let ((operator (token-to-object syntax operator-form))) + (let ((operator (form-to-object syntax operator-form))) (and ;; An operator is not an argument to itself. (not (eq arg-form @@ -790,11 +790,11 @@ ;; If we cannot find a form, there's no point in looking ;; up any of this stuff. (,operator-sym (when (and ,form-sym (form-list-p ,form-sym)) - (token-to-object ,syntax (form-operator ,syntax ,form-sym)))) + (form-to-object ,syntax (form-operator ,syntax ,form-sym)))) (,operands-sym (when (and ,form-sym (form-list-p ,form-sym)) (mapcar #'(lambda (operand) (when operand - (token-to-object ,syntax operand))) + (form-to-object ,syntax operand))) (form-operands ,syntax ,form-sym))))) (declare (ignorable ,form-sym ,operator-sym ,operands-sym)) (multiple-value-bind (,preceding-operand-sym ,operand-indices-sym) @@ -1022,7 +1022,7 @@ (start-offset token) (offset mark))) (if useful-token - (token-string syntax token) + (form-string syntax token) "")) (if completions (if (= (length completions) 1) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2006/12/04 20:07:53 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2006/12/10 19:28:49 1.4 @@ -98,7 +98,7 @@ (mark (point pane)) (token (this-form mark syntax))) (if (and token (form-token-p token)) - (com-lookup-arglist (token-to-object syntax token)) + (com-lookup-arglist (form-to-object syntax token)) (display-message "Could not find symbol at point.")))) (define-command (com-lookup-arglist :name t :command-table lisp-table) @@ -189,7 +189,7 @@ (with-syntax-package (*current-syntax* *current-point*) (let ((*read-base* (base *current-syntax*))) (drei-commands::com-eval-expression - (token-to-object *current-syntax* token :read t) + (form-to-object *current-syntax* token :read t) insertp))) (display-message "Nothing to evaluate.")))) --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/12/07 14:34:14 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/12/10 19:28:49 1.13 @@ -841,11 +841,19 @@ do (with-activation-gestures (nil :override t) (stream-process-gesture stream gesture nil)) finally (unread-gesture gesture :stream stream) - (let* ((object (drei-lisp-syntax::token-to-object syntax form - :read t - :package *package*)) - (ptype (presentation-type-of object))) - (return-from control-loop - (values object - (if (presentation-subtypep ptype 'expression) - ptype 'expression)))))))) + (let* ((object (handler-case + (drei-lisp-syntax:form-to-object syntax form + :read t + :package *package*) + (drei-lisp-syntax:form-conversion-error (e) + ;; Move point to the problematic form + ;; and signal a rescan. + (setf (activation-gesture stream) nil) + (handle-drei-condition drei e) + (display-drei drei) + (immediate-rescan stream)))) + (ptype (presentation-type-of object))) + (return-from control-loop + (values object + (if (presentation-subtypep ptype 'expression) + ptype 'expression)))))))) From thenriksen at common-lisp.net Sun Dec 10 19:29:31 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 10 Dec 2006 14:29:31 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061210192931.2EA3519008@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv24187 Modified Files: mcclim.asd Log Message: Added lisp-syntax-tests.lisp file to the DREI-TESTS system. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/12/10 16:34:57 1.37 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/12/10 19:29:31 1.38 @@ -330,7 +330,8 @@ (:file "editing-tests" :depends-on ("testing")) (:file "core-tests" :depends-on ("testing")) (:file "rectangle-tests" :depends-on ("testing")) - (:file "undo-tests" :depends-on ("testing")))))) + (:file "undo-tests" :depends-on ("testing")) + (:file "lisp-syntax-tests" :depends-on ("testing")))))) (defsystem :clim :depends-on (:clim-core :goatee-core :clim-postscript :drei-mcclim) From dlichteblau at common-lisp.net Sun Dec 10 19:33:05 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 10 Dec 2006 14:33:05 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061210193305.DFE4D1A09C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv24530 Modified Files: event.lisp frame-manager.lisp gtk-ffi.lisp Log Message: Fix CMUCL support. * event.lisp (get-next-event): Yield. * frame-manager.lisp ((defgeneric make-pane-2)): New. * gtk-ffi.lisp (invoke-with-gtk): Inhibit scheduling. * mcclim.asd: Don't (require :clx) when :gtkairo is set. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/12/10 16:34:32 1.16 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/12/10 19:33:05 1.17 @@ -115,6 +115,7 @@ (t #+clim-gtkairo::do-not-block-in-ffi (sb-sys:wait-until-fd-usable (gdk-xlib-fd) :input 0.1) + #+cmu (mp:process-yield) (gtk-main-iteration port #-clim-gtkairo::do-not-block-in-ffi t) (dequeue port)))) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/11/19 18:08:16 1.9 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/12/10 19:33:05 1.10 @@ -44,6 +44,9 @@ :port (port frame) initargs)) +;; make CMUCL happy +(defgeneric make-pane-2 (type &rest args &key &allow-other-keys)) + (defmethod make-pane-2 (type &rest initargs) (apply #'make-instance type initargs)) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/12/10 16:34:32 1.18 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/12/10 19:33:05 1.19 @@ -131,17 +131,18 @@ ;; functions to lock and unlock a recursive lock for that, which the ;; portability files currently don't provide. (defun invoke-with-gtk (fn) - (with-cairo-floats () - (unless *have-lock* - (gdk_threads_enter)) - (unwind-protect - (let ((*have-lock* t)) - (funcall fn)) + (#-cmu progn #+cmu mp:without-scheduling + (with-cairo-floats () (unless *have-lock* - ;; fixme: gdk documentation recommends flushing before releasing - ;; the lock. But doing so makes everything s.l.o.w. + (gdk_threads_enter)) + (unwind-protect + (let ((*have-lock* t)) + (funcall fn)) + (unless *have-lock* + ;; fixme: gdk documentation recommends flushing before releasing + ;; the lock. But doing so makes everything s.l.o.w. ;;; (gdk_flush) - (gdk_threads_leave))))) + (gdk_threads_leave)))))) ;;; GROVELME From dlichteblau at common-lisp.net Sun Dec 10 19:33:28 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 10 Dec 2006 14:33:28 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061210193328.7FEBB1A09E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv24626 Modified Files: NEWS mcclim.asd Log Message: Fix CMUCL support. * event.lisp (get-next-event): Yield. * frame-manager.lisp ((defgeneric make-pane-2)): New. * gtk-ffi.lisp (invoke-with-gtk): Inhibit scheduling. * mcclim.asd: Don't (require :clx) when :gtkairo is set. --- /project/mcclim/cvsroot/mcclim/NEWS 2006/11/23 17:21:38 1.9 +++ /project/mcclim/cvsroot/mcclim/NEWS 2006/12/10 19:33:28 1.10 @@ -3,6 +3,7 @@ ** backend improvements: Gtkairo *** Double buffering is now supported (fixes disappearing widgets on Windows). *** X errors no longer terminate the lisp process. +*** Some bugfixes, including CMUCL support and better key event handling. *** Native implementation of context menus, list panes, label panes, and option panes. ** Improvement: Added new editor substrate ("Drei"). --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/12/10 19:29:31 1.38 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/12/10 19:33:28 1.39 @@ -53,7 +53,7 @@ (extensions:without-package-locks (load "gray-streams:gray-streams-library")) (load "gray-streams:gray-streams-library"))) - #-clx + #-(or clx gtkairo) (require :clx) #+mp (when (eq mp::*initial-process* mp::*current-process*) (format t "~%~%You need to run (mp::startup-idle-and-top-level-loops) to start up the multiprocessing support.~%~%"))) From thenriksen at common-lisp.net Sun Dec 10 23:26:39 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 10 Dec 2006 18:26:39 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061210232639.F33C355397@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv32537 Modified Files: stream-input.lisp NEWS Log Message: Added implementation of `delete-gesture-name'. --- /project/mcclim/cvsroot/mcclim/stream-input.lisp 2006/10/27 22:50:40 1.49 +++ /project/mcclim/cvsroot/mcclim/stream-input.lisp 2006/12/10 23:26:39 1.50 @@ -431,6 +431,11 @@ `(add-gesture-name ',name ',type ',gesture-spec ,@(and unique `(:unique ',unique)))) +(defun delete-gesture-name (name) + "Delete the gesture named by the symbol `name' from the list of +known gestures." + (remhash name *gesture-names*)) + ;;; XXX perhaps this should be in the backend somewhere? (defconstant +name-to-char+ '((:newline . #\newline) (:linefeed . #\linefeed) --- /project/mcclim/cvsroot/mcclim/NEWS 2006/12/10 19:33:28 1.10 +++ /project/mcclim/cvsroot/mcclim/NEWS 2006/12/10 23:26:39 1.11 @@ -8,6 +8,7 @@ option panes. ** Improvement: Added new editor substrate ("Drei"). ** Improvement: Improved the pathname presentation methods considerably. +** specification compliance: DELETE-GESTURE-NAME function now implemented. * Changes in mcclim-0.9.3 "All Souls' Day" relative to 0.9.2: ** backend improvement: The Null backend now registers itself in the From thenriksen at common-lisp.net Sun Dec 10 23:35:12 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 10 Dec 2006 18:35:12 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061210233512.5B8185B005@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv663 Modified Files: stream-output.lisp package.lisp decls.lisp Log Message: Made `stream-set-cursor-position' a generic function and exported it, as seen in CLIM 2.2. --- /project/mcclim/cvsroot/mcclim/stream-output.lisp 2006/05/05 10:24:02 1.60 +++ /project/mcclim/cvsroot/mcclim/stream-output.lisp 2006/12/10 23:35:12 1.61 @@ -223,7 +223,7 @@ (defmethod* (setf stream-cursor-position) (x y (stream standard-extended-output-stream)) (setf (cursor-position (stream-text-cursor stream)) (values x y))) -(defun stream-set-cursor-position (stream x y) +(defmethod stream-set-cursor-position ((stream standard-extended-output-stream) x y) (setf (stream-cursor-position stream) (values x y))) (defmethod stream-increment-cursor-position ((stream standard-extended-output-stream) dx dy) --- /project/mcclim/cvsroot/mcclim/package.lisp 2006/06/29 08:16:02 1.55 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2006/12/10 23:35:12 1.56 @@ -353,6 +353,8 @@ ;; this list of exported symbols was automatically generated from the ;; specification as of version 1.17 of this very file, please think twice ;; before fiddling with it. thanks! --gb 2002-11-10 + ;; A good reason for fiddling with with it is to add symbols from + ;; CLIM 2.2. --thenriksen 2006-12-11 #:*abort-gestures* ;variable #:*accelerator-gestures* ;variable @@ -1417,6 +1419,7 @@ #:stream-replay ;generic function #:stream-rescanning-p ;generic function #:stream-scan-pointer ;generic function + #:stream-set-cursor-position ;generic function #:stream-set-input-focus ;generic function #:stream-start-line-p ;generic function #:stream-start-line-p ;generic function --- /project/mcclim/cvsroot/mcclim/decls.lisp 2006/12/04 22:31:19 1.42 +++ /project/mcclim/cvsroot/mcclim/decls.lisp 2006/12/10 23:35:12 1.43 @@ -429,6 +429,7 @@ (defgeneric (setf stream-text-cursor) (cursor stream)) (defgeneric stream-cursor-position (stream)) ;; (defgeneric (setf* stream-cursor-position) (x y stream)) unsure how to declare this, can somebody help? --GB +(defgeneric stream-set-cusor-position (stream x y)) ; This is actually in 19.3.1 in CLIM 2.2 (defgeneric stream-increment-cursor-position (stream dx dy)) ;;; 15.4 Text Protocol [complete] From thenriksen at common-lisp.net Mon Dec 11 22:04:55 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 11 Dec 2006 17:04:55 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061211220455.F22CF3903A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv12745/Drei Modified Files: lisp-syntax.lisp Log Message: New default package for Lisp syntax: *package*. Mostly to fix symbol completion in the Listener. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/12/10 19:28:49 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/12/11 22:04:55 1.13 @@ -1370,7 +1370,7 @@ the (in-package) preceding `mark-or-offset'. If none can be found, return the package specified in the attribute list. If no package can be found at all, or the otherwise found packages are -invalid, return the CLIM-USER package." +invalid, return the value of `*package*'." (as-offsets ((offset mark-or-offset)) (let* ((designator (rest (find offset (package-list syntax) :key #'first @@ -1383,7 +1383,7 @@ (package osp) (string (find-package osp)))) (find-package (option-specified-package syntax)) - (find-package :clim-user))))) + *package*)))) (defun provided-package-name-at-mark (syntax mark-or-offset) "Get the name of the specified Lisp package for the From thenriksen at common-lisp.net Mon Dec 11 22:55:28 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 11 Dec 2006 17:55:28 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061211225528.A85CE3A01E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv23363/Drei Modified Files: input-editor.lisp Log Message: Fixed so non-movement of the scan pointer won't cause an error. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/12/10 19:28:49 1.13 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/12/11 22:55:28 1.14 @@ -821,10 +821,11 @@ nil)) ;; True if `gesture' was freshly read from the user, and not ;; just retrieved from the buffer during a rescan. - for freshly-inserted = (not (equal (buffer-object - (buffer drei) - (1- (stream-scan-pointer stream))) - gesture)) + for freshly-inserted = (and (plusp (stream-scan-pointer stream)) + (not (equal (buffer-object + (buffer drei) + (1- (stream-scan-pointer stream))) + gesture))) for form = (drei-lisp-syntax::form-after syntax (input-position stream)) ;; We do not stop until the input is complete and an activation ;; gesture has just been provided. The freshness check is so From thenriksen at common-lisp.net Tue Dec 12 18:54:59 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 12 Dec 2006 13:54:59 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061212185459.AD1CA4044@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv4739 Modified Files: presentation-defs.lisp NEWS Log Message: Added support for `presentation-type-specifier-p'. --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/11/27 07:44:46 1.61 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/12/12 18:54:57 1.62 @@ -194,6 +194,21 @@ (values t t) (values nil nil))))) +(define-presentation-generic-function + %presentation-type-specifier-p + presentation-type-specifier-p + (type-class type)) + +(define-default-presentation-method presentation-type-specifier-p (type) + t) + +(defun presentation-type-specifier-p (type) + "Return true if `type' is a valid presentation type specifier, +otherwise return false." + (funcall-presentation-generic-function + presentation-type-specifier-p + type)) + (defun default-describe-presentation-type (description stream plural-count) (if (symbolp description) (setq description (make-default-description (symbol-name description)))) --- /project/mcclim/cvsroot/mcclim/NEWS 2006/12/10 23:26:39 1.11 +++ /project/mcclim/cvsroot/mcclim/NEWS 2006/12/12 18:54:57 1.12 @@ -9,6 +9,8 @@ ** Improvement: Added new editor substrate ("Drei"). ** Improvement: Improved the pathname presentation methods considerably. ** specification compliance: DELETE-GESTURE-NAME function now implemented. +** specification compliance: PRESENTATION-TYPE-SPECIFIER-P presentaion + function now implemented. * Changes in mcclim-0.9.3 "All Souls' Day" relative to 0.9.2: ** backend improvement: The Null backend now registers itself in the From thenriksen at common-lisp.net Tue Dec 12 22:17:42 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 12 Dec 2006 17:17:42 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061212221742.B2FED47143@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv3063 Modified Files: presentation-defs.lisp Log Message: Fixed presentation-type-specifier-p to do as certain older CLIM programs expect. --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/12/12 18:54:57 1.62 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/12/12 22:17:42 1.63 @@ -202,12 +202,16 @@ (define-default-presentation-method presentation-type-specifier-p (type) t) -(defun presentation-type-specifier-p (type) - "Return true if `type' is a valid presentation type specifier, +(defun presentation-type-specifier-p (object) + "Return true if `object' is a valid presentation type specifier, otherwise return false." - (funcall-presentation-generic-function - presentation-type-specifier-p - type)) + ;; Apparently, this funtion has to handle arbitrary objects. + (let ((name (presentation-type-name object))) + (when (and (or (symbolp name) + (and (typep name 'class) + (not (typep name 'built-in-class)))) + (get-ptype-metaclass name)) + (%presentation-type-specifier-p t object)))) (defun default-describe-presentation-type (description stream plural-count) (if (symbolp description) From afuchs at common-lisp.net Tue Dec 12 22:32:40 2006 From: afuchs at common-lisp.net (afuchs) Date: Tue, 12 Dec 2006 17:32:40 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061212223240.B39F25D009@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv6318 Modified Files: input-editing.lisp Log Message: Flip the *use-goatee* default to NIL, as prompted by this discussion: YuleAthas: do you think it's responsible to flip the *use-goatee* switch now? antifuchs: yes. --- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2006/11/08 01:18:22 1.53 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2006/12/12 22:32:40 1.54 @@ -27,7 +27,7 @@ (in-package :clim-internals) -(defvar *use-goatee* t +(defvar *use-goatee* nil "I true, use the Goatee editing component instead of Drei. The Goatee component is faster and more mature than Drei.") From thenriksen at common-lisp.net Tue Dec 12 22:36:32 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 12 Dec 2006 17:36:32 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061212223632.60F2E60038@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv6690 Modified Files: input-editing.lisp Log Message: Added support for CLIM 2.2-style `with-activation-gestures' and `with-delimiter-gestures'. --- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2006/12/12 22:32:40 1.54 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2006/12/12 22:36:32 1.55 @@ -63,12 +63,14 @@ (t existing-delimiter-gestures))) (defmacro with-activation-gestures ((gestures &key override) &body body) - ;; XXX Guess this implies that gestures need to be defined at compile time. - ;; Sigh. - (let ((gesture-form (if (and (symbolp gestures) - (gethash gestures *gesture-names*)) - `(list ',gestures) - gestures)) + ;; XXX Guess this implies that gestures need to be defined at + ;; compile time. Sigh. We permit both CLIM 2.0-style gesture names + ;; and CLIM 2.2 style characters. + (let ((gesture-form (cond ((or (and (symbolp gestures) + (gethash gestures *gesture-names*)) + (characterp gestures)) + `(list ',gestures)) + (t gestures))) (gestures (gensym)) (override-var (gensym))) `(let* ((,gestures ,gesture-form) ;Preserve evaluation order of arguments @@ -81,15 +83,17 @@ , at body))) (defmacro with-delimiter-gestures ((gestures &key override) &body body) - ;; XXX Guess this implies that gestures need to be defined at compile time. - ;; Sigh. - (let ((gesture-form (if (and (symbolp gestures) - (gethash gestures *gesture-names*)) - `(list ',gestures) - gestures)) + ;; XXX Guess this implies that gestures need to be defined at + ;; compile time. Sigh. We permit both CLIM 2.0-style gesture names + ;; and CLIM 2.2 style characters. + (let ((gesture-form (cond ((or (and (symbolp gestures) + (gethash gestures *gesture-names*)) + (characterp gestures)) + `(list ',gestures)) + (t gestures))) (gestures (gensym)) (override-var (gensym))) - `(let* ((,gestures ,gesture-form) ;Preserve evaluation order of arguments + `(let* ((,gestures ,gesture-form) ;Preserve evaluation order of arguments (,override-var ,override) (*delimiter-gestures* (make-delimiter-gestures (if ,override-var From thenriksen at common-lisp.net Wed Dec 13 15:31:08 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 13 Dec 2006 10:31:08 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061213153108.172AC39053@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv9667 Modified Files: dialog.lisp Log Message: Now `*use-goatee*' also affects calls to `accept' within `accepting-values'. --- /project/mcclim/cvsroot/mcclim/dialog.lisp 2006/11/08 01:18:22 1.23 +++ /project/mcclim/cvsroot/mcclim/dialog.lisp 2006/12/13 15:31:07 1.24 @@ -449,7 +449,9 @@ (surrounding-output-with-border (stream :shape :inset :move-cursor t) (setq editing-stream - (make-instance 'standard-input-editing-stream + (make-instance (if *use-goatee* + 'goatee-input-editing-stream + 'standard-input-editing-stream) :stream stream :cursor-visibility nil :background-ink +grey90+ From thenriksen at common-lisp.net Wed Dec 13 19:35:01 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 13 Dec 2006 14:35:01 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061213193501.29AE4341E8@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv17106 Modified Files: presentations.lisp Log Message: Added method on `get-ptype-metaclass' that specifies that a CLOS class is its own ptype metaclass (for handling of anynomous classes as per the CLIM spec). --- /project/mcclim/cvsroot/mcclim/presentations.lisp 2006/08/05 19:54:31 1.77 +++ /project/mcclim/cvsroot/mcclim/presentations.lisp 2006/12/13 19:35:01 1.78 @@ -466,6 +466,12 @@ (defmethod get-ptype-metaclass ((type (eql *builtin-t-class*))) type) +(defmethod get-ptype-metaclass ((type class)) + type) + +(defmethod get-ptype-metaclass (type) + (error "~A is not the name of a presentation type" type)) + ;;; external functions (defun find-presentation-type-class (name &optional (errorp t) environment) (declare (ignore environment)) From thenriksen at common-lisp.net Wed Dec 13 19:36:00 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 13 Dec 2006 14:36:00 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061213193600.0061F3C00A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv17296 Modified Files: presentation-defs.lisp Log Message: Hopefully fixed `presentation-type-specifier-p'. Of course, I also thought this the last two times. --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/12/12 22:17:42 1.63 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/12/13 19:36:00 1.64 @@ -207,11 +207,9 @@ otherwise return false." ;; Apparently, this funtion has to handle arbitrary objects. (let ((name (presentation-type-name object))) - (when (and (or (symbolp name) - (and (typep name 'class) - (not (typep name 'built-in-class)))) + (when (and (typep name '(or symbol class)) (get-ptype-metaclass name)) - (%presentation-type-specifier-p t object)))) + (funcall-presentation-generic-function presentation-type-specifier-p object)))) (defun default-describe-presentation-type (description stream plural-count) (if (symbolp description) @@ -1634,6 +1632,11 @@ :options #.+completion-options+ :inherit-from t) +(define-presentation-method presentation-type-specifier-p ((type sequence)) + (and (listp type) + (consp (rest type)) + (presentation-type-specifier-p (second type)))) + (define-presentation-method presentation-typep (object (type completion)) (map nil #'(lambda (obj) (when (funcall test object (funcall value-key obj)) From thenriksen at common-lisp.net Wed Dec 13 20:41:56 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 13 Dec 2006 15:41:56 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061213204156.31DF77C03F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv25558/Drei Modified Files: lisp-syntax.lisp Log Message: No longer presenting every lexeme as a string. That was probably a bad idea to begin with. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/12/11 22:04:55 1.13 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/12/13 20:41:56 1.14 @@ -1906,8 +1906,7 @@ (with-slots (ink face) parser-symbol (setf ink (medium-ink (sheet-medium stream)) face (text-style-face (medium-text-style (sheet-medium stream)))) - (let ((string (form-string syntax parser-symbol))) - (present string 'string :stream stream)))))) + (write-string (form-string syntax parser-symbol) stream))))) (defmethod display-parse-tree :before ((parse-symbol lisp-lexeme) stream (drei drei) (syntax lisp-syntax)) From thenriksen at common-lisp.net Wed Dec 13 21:05:11 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 13 Dec 2006 16:05:11 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20061213210511.997EF553AB@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv28359/Apps/Listener Modified Files: dev-commands.lisp Log Message: Fixed minor typo that prevented multiple value returns from being printed properly. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/12/03 22:56:46 1.39 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/12/13 21:05:11 1.40 @@ -1468,7 +1468,7 @@ (with-output-as-presentation (t value (presentation-type-of value) :single-box t) - (present (first values) 'expression)))) + (present value 'expression)))) (with-drawing-options (t :ink +olivedrab+) (cond ((null values) (format t "No values.~%")) From thenriksen at common-lisp.net Wed Dec 13 21:33:43 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 13 Dec 2006 16:33:43 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061213213343.D96DE2202F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv32310 Modified Files: presentation-defs.lisp Log Message: Moved presentation method to after the definition of the relevant type. --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/12/13 19:36:00 1.64 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/12/13 21:33:43 1.65 @@ -1632,11 +1632,6 @@ :options #.+completion-options+ :inherit-from t) -(define-presentation-method presentation-type-specifier-p ((type sequence)) - (and (listp type) - (consp (rest type)) - (presentation-type-specifier-p (second type)))) - (define-presentation-method presentation-typep (object (type completion)) (map nil #'(lambda (obj) (when (funcall test object (funcall value-key obj)) @@ -1840,6 +1835,11 @@ :inherit-from 't :parameters-are-types t) +(define-presentation-method presentation-type-specifier-p ((type sequence)) + (and (listp type) + (consp (rest type)) + (presentation-type-specifier-p (second type)))) + (define-presentation-method presentation-typep (object (type sequence)) ;; XXX TYPE here is the sequence element type, not the whole type specifier (unless (or (listp object) (vectorp object)) From thenriksen at common-lisp.net Wed Dec 13 22:30:31 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 13 Dec 2006 17:30:31 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061213223031.B786E49082@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv8176 Modified Files: commands.lisp Log Message: Added portable implementation of `display-command-table-menu'. --- /project/mcclim/cvsroot/mcclim/commands.lisp 2006/11/08 01:18:22 1.65 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2006/12/13 22:30:31 1.66 @@ -541,6 +541,35 @@ gesture)) gesture))) +(defmethod display-command-table-menu ((command-table standard-command-table) + (stream fundamental-output-stream) + &rest args + &key max-width max-height n-rows n-columns + x-spacing y-spacing initial-spacing + row-wise (cell-align-x :left) + (cell-align-y :top) (move-cursor t)) + (formatting-item-list (stream :max-width max-width :max-height max-height :n-rows n-rows + :n-columns n-columns :x-spacing x-spacing :y-spacing y-spacing + :initial-spacing initial-spacing :row-wise row-wise + :move-cursor move-cursor) + (map-over-command-table-menu-items + #'(lambda (item-name accelerator item) + (declare (ignore accelerator)) + (formatting-cell (stream :align-x cell-align-x :align-y cell-align-y) + (cond ((eq (command-menu-item-type item) :menu) + (with-text-style (stream (make-text-style :serif '(:bold :italic) nil)) + (write-string item-name stream) + (terpri stream)) + (surrounding-output-with-border (stream) + (apply #'display-command-table-menu + (find-command-table (command-menu-item-value item)) + stream args))) + ((eq (command-menu-item-type item) :command) + (let ((name (command-name (command-menu-item-value item)))) + (when (command-line-name-for-command name command-table :errorp nil) + (present name 'command-name :stream stream))))))) + command-table))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Commands From thenriksen at common-lisp.net Wed Dec 13 22:31:58 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 13 Dec 2006 17:31:58 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061213223158.0D31E49082@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv8248 Modified Files: decls.lisp Log Message: Added portable implementation of `display-command-table-menu'. --- /project/mcclim/cvsroot/mcclim/decls.lisp 2006/12/10 23:35:12 1.43 +++ /project/mcclim/cvsroot/mcclim/decls.lisp 2006/12/13 22:31:57 1.44 @@ -583,6 +583,20 @@ (stream object type view &key buffer-start rescan query-identifier for-context-type)) +;;; 27.3 Command Menus + +(defgeneric display-command-table-menu (command-table stream &key max-width + max-height n-rows n-columns x-spacing + y-spacing initial-spacing row-wise + cell-align-x cell-align-y move-cursor) + (:documentation "Display a menu of the commands accessible in +`command-table' to `stream'. + +`max-width', `max-height', `n-rows', `n-columns', `x-spacing', +`y-spacing', `row-wise', `initial-spacing', `cell-align-x', +`cell-align-y', and `move-cursor' are as for +`formatting-item-list'.")) + ;;; 28.2 Specifying the Panes of a Frame (defgeneric destroy-frame (frame)) From thenriksen at common-lisp.net Thu Dec 14 19:43:52 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 14 Dec 2006 14:43:52 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061214194352.A010368001@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv20066 Modified Files: menu.lisp decls.lisp commands.lisp Log Message: Moved `display-command-table-menu' to menu.lisp and implemented `display-command-menu'. --- /project/mcclim/cvsroot/mcclim/menu.lisp 2006/05/13 00:19:36 1.36 +++ /project/mcclim/cvsroot/mcclim/menu.lisp 2006/12/14 19:43:51 1.37 @@ -415,3 +415,43 @@ (- real-height 4))) (incf x width) (incf x x-spacing))))) + +(defmethod display-command-table-menu ((command-table standard-command-table) + (stream fundamental-output-stream) + &rest args + &key max-width max-height n-rows n-columns + x-spacing y-spacing initial-spacing + row-wise (cell-align-x :left) + (cell-align-y :top) (move-cursor t)) + (formatting-item-list (stream :max-width max-width :max-height max-height :n-rows n-rows + :n-columns n-columns :x-spacing x-spacing :y-spacing y-spacing + :initial-spacing initial-spacing :row-wise row-wise + :move-cursor move-cursor) + (map-over-command-table-menu-items + #'(lambda (item-name accelerator item) + (declare (ignore accelerator)) + (formatting-cell (stream :align-x cell-align-x :align-y cell-align-y) + (cond ((eq (command-menu-item-type item) :menu) + (with-text-style (stream (make-text-style :serif '(:bold :italic) nil)) + (write-string item-name stream) + (terpri stream)) + (surrounding-output-with-border (stream) + (apply #'display-command-table-menu + (find-command-table (command-menu-item-value item)) + stream args))) + ((eq (command-menu-item-type item) :command) + (let ((name (command-name (command-menu-item-value item)))) + (when (command-line-name-for-command name command-table :errorp nil) + (present name 'command-name :stream stream))))))) + command-table))) + +(defmethod display-command-menu (frame (stream fundamental-output-stream) + &rest args &key + (command-table (frame-command-table frame)) + initial-spacing row-wise max-width + max-height n-rows n-columns + (cell-align-x :left) (cell-align-y :top)) + (declare (ignore initial-spacing row-wise max-width max-height + n-rows n-columns cell-align-x cell-align-y)) + (with-keywords-removed (args (:command-table)) + (apply #'display-command-table-menu command-table stream args))) --- /project/mcclim/cvsroot/mcclim/decls.lisp 2006/12/13 22:31:57 1.44 +++ /project/mcclim/cvsroot/mcclim/decls.lisp 2006/12/14 19:43:51 1.45 @@ -659,6 +659,18 @@ (defgeneric run-frame-top-level (frame &key &allow-other-keys)) (defgeneric command-enabled (command-name frame)) (defgeneric (setf command-name) (enabled command-name frame)) +(defgeneric display-command-menu (frame stream &key command-table + initial-spacing row-wise max-width + max-height n-rows n-columns + cell-align-x cell-align-y) + (:documentation "Display the command table associated with +`command-table' on `stream' by calling +`display-command-table-menu'. If no command table is +provided, (frame-command-table frame) will be used. + +The arguments `initial-spacing', `row-wise', +`max-width', `max-height', `n-rows', `n-columns', `cell-align-x', +and `cell-align-y' are as for `formatting-item-list'.")) ;;;; 28.5.2 Frame Manager Operations --- /project/mcclim/cvsroot/mcclim/commands.lisp 2006/12/13 22:30:31 1.66 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2006/12/14 19:43:51 1.67 @@ -541,35 +541,6 @@ gesture)) gesture))) -(defmethod display-command-table-menu ((command-table standard-command-table) - (stream fundamental-output-stream) - &rest args - &key max-width max-height n-rows n-columns - x-spacing y-spacing initial-spacing - row-wise (cell-align-x :left) - (cell-align-y :top) (move-cursor t)) - (formatting-item-list (stream :max-width max-width :max-height max-height :n-rows n-rows - :n-columns n-columns :x-spacing x-spacing :y-spacing y-spacing - :initial-spacing initial-spacing :row-wise row-wise - :move-cursor move-cursor) - (map-over-command-table-menu-items - #'(lambda (item-name accelerator item) - (declare (ignore accelerator)) - (formatting-cell (stream :align-x cell-align-x :align-y cell-align-y) - (cond ((eq (command-menu-item-type item) :menu) - (with-text-style (stream (make-text-style :serif '(:bold :italic) nil)) - (write-string item-name stream) - (terpri stream)) - (surrounding-output-with-border (stream) - (apply #'display-command-table-menu - (find-command-table (command-menu-item-value item)) - stream args))) - ((eq (command-menu-item-type item) :command) - (let ((name (command-name (command-menu-item-value item)))) - (when (command-line-name-for-command name command-table :errorp nil) - (present name 'command-name :stream stream))))))) - command-table))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Commands From thenriksen at common-lisp.net Thu Dec 14 22:02:16 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 14 Dec 2006 17:02:16 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061214220216.9A81D3F003@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv9245 Modified Files: NEWS Log Message: Added some more notes about new stuff. --- /project/mcclim/cvsroot/mcclim/NEWS 2006/12/12 18:54:57 1.12 +++ /project/mcclim/cvsroot/mcclim/NEWS 2006/12/14 22:02:16 1.13 @@ -11,6 +11,10 @@ ** specification compliance: DELETE-GESTURE-NAME function now implemented. ** specification compliance: PRESENTATION-TYPE-SPECIFIER-P presentaion function now implemented. +** specification compliance: DISPLAY-COMMAND-TABLE-MENU function now + implemented. +** specification compliance: DISPLAY-COMMAND-MENU function now + implemented. * Changes in mcclim-0.9.3 "All Souls' Day" relative to 0.9.2: ** backend improvement: The Null backend now registers itself in the From thenriksen at common-lisp.net Sun Dec 17 00:29:14 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 16 Dec 2006 19:29:14 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061217002914.6DBDB12033@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv21353 Modified Files: frames.lisp Log Message: Support pane-names in `redisplay-frame-pane', patch from Raymond Toy. --- /project/mcclim/cvsroot/mcclim/frames.lisp 2006/07/01 21:00:31 1.120 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2006/12/17 00:29:14 1.121 @@ -368,22 +368,25 @@ (defmethod redisplay-frame-pane :around ((frame application-frame) pane &key force-p) - (multiple-value-bind (redisplayp clearp) - (pane-needs-redisplay pane) - (when force-p - (setq redisplayp (or redisplayp t) - clearp t)) - (when redisplayp - (let ((hilited (frame-hilited-presentation frame))) - (when hilited - (highlight-presentation-1 (car hilited) (cdr hilited) :unhighlight) - (setf (frame-hilited-presentation frame) nil))) - (with-possible-double-buffering (frame pane) - (when clearp - (window-clear pane)) - (call-next-method)) - (unless (or (eq redisplayp :command-loop) (eq redisplayp :no-clear)) - (setf (pane-needs-redisplay pane) nil))))) + (let ((pane-object (if (typep pane 'pane) + pane + (find-pane-named frame pane)))) + (multiple-value-bind (redisplayp clearp) + (pane-needs-redisplay pane-object) + (when force-p + (setq redisplayp (or redisplayp t) + clearp t)) + (when redisplayp + (let ((hilited (frame-hilited-presentation frame))) + (when hilited + (highlight-presentation-1 (car hilited) (cdr hilited) :unhighlight) + (setf (frame-hilited-presentation frame) nil))) + (with-possible-double-buffering (frame pane-object) + (when clearp + (window-clear pane-object)) + (call-next-method)) + (unless (or (eq redisplayp :command-loop) (eq redisplayp :no-clear)) + (setf (pane-needs-redisplay pane-object) nil)))))) (defmethod run-frame-top-level ((frame application-frame) &key &allow-other-keys) @@ -561,7 +564,6 @@ command-name) nil)))) - (defmethod make-pane-1 :around (fm (frame standard-application-frame) type &rest args &key (input-buffer nil input-buffer-p) From crhodes at common-lisp.net Sun Dec 17 19:42:51 2006 From: crhodes at common-lisp.net (crhodes) Date: Sun, 17 Dec 2006 14:42:51 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20061217194251.76531471EC@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv2959/Backends/CLX Modified Files: image.lisp Log Message: card8 in the CLX image code is an undefined type. For want of anything better or inspiration, use xlib:card8 instead. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/image.lisp 2006/03/23 08:45:26 1.21 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/image.lisp 2006/12/17 19:42:51 1.22 @@ -84,7 +84,7 @@ ((pixels :initarg :pixels :type (simple-array (unsigned-byte 24) (* *)) :reader image-pixels) - (max-level :initarg :max-level :type card-8 :reader image-max-level))) + (max-level :initarg :max-level :type xlib:card8 :reader image-max-level))) (defun make-truecolor-image (pixels max-value) (make-instance 'truecolor-image :pixels pixels :max-level max-value)) From ahefner at common-lisp.net Sun Dec 17 19:53:52 2006 From: ahefner at common-lisp.net (ahefner) Date: Sun, 17 Dec 2006 14:53:52 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20061217195352.87CD552014@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv3781 Modified Files: medium.lisp Log Message: Upload indexed patterns via xlib:put-image. Attempt to handle various pixel formats. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2006/04/17 18:12:16 1.74 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2006/12/17 19:53:52 1.75 @@ -220,30 +220,268 @@ (setf (gethash ink design-cache) (call-next-method)))))) +(defun st3 (x y z) + (values (logand (truncate (* x 255)) 255) + (logand (truncate (* y 255)) 255) + (logand (truncate (* z 255)) 255))) + +(declaim (ftype (function (sequence) + (values (simple-array (unsigned-byte 8) 1) + (simple-array (unsigned-byte 8) 1) + (simple-array (unsigned-byte 8) 1) + (simple-array (unsigned-byte 8) 1))) + inks-to-rgb)) + +(defun inks-to-rgb (inks) + "Returns four values: byte arrays for the red, green, blue, and opacity components [0,255] of a sequence of inks" + (let ((red-map (make-array (length inks) :element-type '(unsigned-byte 8) + :initial-element 255)) + (green-map (make-array (length inks) :element-type '(unsigned-byte 8) + :initial-element 0)) + (blue-map (make-array (length inks) :element-type '(unsigned-byte 8) + :initial-element 255)) + (opacity-map (make-array (length inks) :element-type '(unsigned-byte 8) + :initial-element 255)) + (length (length inks))) + (loop for index from 0 below length + as ink = (elt inks index) + do (flet ((transform (parameter) (logand (truncate (* parameter 255)) 255))) + (cond + ((colorp ink) + (multiple-value-bind (r g b) (color-rgb ink) + (setf (elt red-map index) (transform r) + (elt green-map index) (transform g) + (elt blue-map index) (transform b) + (elt opacity-map index) 255))) + ((eq ink +transparent-ink+) + (setf (elt opacity-map index) 0))))) + (values red-map green-map blue-map opacity-map))) + +(defun integer-count-bits (integer) + (loop for i from 0 below (integer-length integer) + sum (ldb (byte 1 i) integer))) + +(defun compute-channel-fields (mask num-bytes) + (loop with counted-bits = 0 + with output-width = (integer-count-bits mask) + for index from (1- num-bytes) downto 0 + as submask = (ldb (byte 8 (* 8 index)) mask) + as submask-bits = (integer-count-bits submask) + as output-shift-left = (- (integer-length submask) submask-bits) + as input-position = (+ (- 8 counted-bits submask-bits)) + collect (if (zerop submask) + nil + (prog1 + (list output-shift-left submask-bits input-position) + (assert (<= output-width 8)) + (incf counted-bits submask-bits))))) + +(defun compute-channel-expressions (channel-mask-specs num-bytes) + (labels ((single-channel-expressions (mask channel-name) + (mapcar (lambda (fieldspec) + (and fieldspec + (destructuring-bind (output-shift-left submask-bits input-position) + fieldspec + `(ash (ldb (byte ,submask-bits ,input-position) ,channel-name) ,output-shift-left)))) + (compute-channel-fields mask num-bytes) ))) + (reduce (lambda (left-exprs right-exprs) + (mapcar (lambda (left-expr right-expr) + (if right-expr + (cons right-expr left-expr) + left-expr)) + left-exprs + right-exprs)) + channel-mask-specs + :key (lambda (channel-mask-spec) + (destructuring-bind (var-name mask) channel-mask-spec + (single-channel-expressions mask var-name))) + :initial-value (map 'list #'identity (make-array num-bytes :initial-element nil))))) + +(defun generate-pixel-assignments (array-var index-var channel-mask-specs num-bytes byte-order) + `(setf ,@(mapcan (lambda (byte-exprs byte-index) + (and byte-exprs + (list `(elt ,array-var (+ ,index-var ,byte-index)) + (if (= 1 (length byte-exprs)) + (first byte-exprs) + `(logior , at byte-exprs))))) + (compute-channel-expressions channel-mask-specs num-bytes) + (funcall (ecase byte-order + (:lsbfirst #'reverse) + (:msbfirst #'identity)) + (loop for i from 0 below num-bytes collect i))))) + +(defun generate-indexed-converter-expr (rgb-masks num-bytes byte-order) + `(lambda (image-array converted-data mask-data width height inks) + (declare (optimize (speed 3) + (safety 0) + (space 0) + (debug 0)) + (type xlib:card16 width height) + (type (simple-array xlib:card8 1) converted-data mask-data)) + (macrolet ((conversion-body () + `(let ((index 0) + (mask-index 0) + (mask-bitcursor 1)) + (declare (type (unsigned-byte 9) mask-bitcursor) + (type xlib:array-index mask-index index)) + + (multiple-value-bind (red-map green-map blue-map opacity-map) (inks-to-rgb inks) + (dotimes (y height) + (unless (= 1 mask-bitcursor) + (setf mask-bitcursor 1 + mask-index (1+ mask-index))) + (dotimes (x width) + (let ((ink-index (aref image-array y x))) + (when (< (elt opacity-map ink-index) #x40) ; FIXME? Arbitrary threshold. + (setf (elt mask-data mask-index) (logxor (elt mask-data mask-index) mask-bitcursor))) + #+NIL + (setf (elt converted-data (+ index 0)) (elt blue-map ink-index) + (elt converted-data (+ index 1)) (elt green-map ink-index) + (elt converted-data (+ index 2)) (elt red-map ink-index)) + (let ((red (elt red-map ink-index)) + (green (elt green-map ink-index)) + (blue (elt blue-map ink-index))) + ,',(generate-pixel-assignments 'converted-data 'index + (mapcar #'list '(red green blue) rgb-masks) + num-bytes byte-order)) + (setf index (+ ,',num-bytes index) + mask-bitcursor (ash mask-bitcursor 1) + mask-index (+ mask-index (ash mask-bitcursor -8)) + mask-bitcursor (logand (logior mask-bitcursor + (ash mask-bitcursor -8)) + #xff))))))))) + ;; We win big if we produce several specialized versions of this according + ;; to the type of array holding the color indexes. + (typecase image-array + ((simple-array xlib:card8 2) ; 256-color images + (locally (declare (type (simple-array xlib:card8 2) image-array)) (conversion-body))) + ((simple-array fixnum 2) ; High-color index images (XPM reader produces these..) + (locally (declare (type (simple-array fixnum 2) image-array)) (conversion-body))) + (t (conversion-body)))))) + +(defun convert-indexed->mask (image-array mask-data width height inks) + (declare (optimize (speed 3) + (safety 0) + (space 0) + (debug 0)) + (type xlib:card16 width height) + (type (simple-array xlib:card8 1) mask-data)) + (macrolet ((conversion-body () + '(let ((mask-index 0) + (mask-bitcursor 1)) + (declare (type (unsigned-byte 9) mask-bitcursor) + (type xlib:array-index mask-index)) + + (multiple-value-bind (red-map green-map blue-map opacity-map) (inks-to-rgb inks) + (declare (ignore red-map green-map blue-map)) + + (dotimes (y height) + (unless (= 1 mask-bitcursor) + (setf mask-bitcursor 1 + mask-index (1+ mask-index))) + (dotimes (x width) + (let ((ink-index (aref image-array y x))) + (when (< (elt opacity-map ink-index) #x40) ; FIXME? Arbitrary threshold. + (setf (elt mask-data mask-index) (logxor (elt mask-data mask-index) mask-bitcursor))) + (setf mask-bitcursor (ash mask-bitcursor 1) + mask-index (+ mask-index (ash mask-bitcursor -8)) + mask-bitcursor (logand (logior mask-bitcursor + (ash mask-bitcursor -8)) + #xff))))))))) + ;; Again, we win big if we produce several specialized versions of this. + (typecase image-array + ((simple-array xlib:card8 2) ; 256-color images + (locally (declare (type (simple-array xlib:card8 2) image-array)) (conversion-body))) + ((simple-array fixnum 2) ; High-color index images (XPM reader produces these..) + (locally (declare (type (simple-array fixnum 2) image-array)) (conversion-body))) + (t (conversion-body))))) + +(defparameter *pixel-converter-cache* (make-hash-table :test 'equal)) + +(defun get-indexed-converter (visual-info byte-order bytes-per-pixel) + (let* ((rgb-masks (list (xlib:visual-info-red-mask visual-info) + (xlib:visual-info-green-mask visual-info) + (xlib:visual-info-blue-mask visual-info))) + (key (list rgb-masks byte-order bytes-per-pixel))) + (symbol-macrolet ((fn (gethash key *pixel-converter-cache*))) + (or fn (setf fn (compile nil (generate-indexed-converter-expr rgb-masks bytes-per-pixel byte-order))))))) + +(defun fill-pixmap-indexed (visual-info depth byte-order array pm pm-gc mask mask-gc w h inks) + (assert (= (array-total-size array) (* w h))) + (let* ((ceil-w-8 (ceiling w 8)) + (bytes-per-pixel + (case depth + ((24 32) 4) + ((15 16) 2) + (otherwise nil))) + (mask-data (make-array (* ceil-w-8 h) + :element-type '(unsigned-byte 8) + :initial-element #xff)) + (pixel-converter nil)) + + (if (and bytes-per-pixel + (member byte-order '(:lsbfirst :msbfirst)) + (setf pixel-converter (get-indexed-converter visual-info byte-order bytes-per-pixel))) + ;; Fast path - Image upload + (let ((converted-data (make-array (* bytes-per-pixel (array-total-size array)) :element-type 'xlib:card8))) + ;; Fill the pixel arrays + (funcall pixel-converter array converted-data mask-data w h inks) + + ;; Create an xlib "image" and copy it to our pixmap. + ;; I do this because I'm not smart enough to operate xlib:put-raw-image. + (let ((image (xlib:create-image :bits-per-pixel (* 8 bytes-per-pixel) :depth depth + :width w :height h + :format :z-pixmap + :data converted-data))) + (xlib:put-image (pixmap-mirror pm) pm-gc image + :x 0 :y 0 + :width w :height h))) + + ;; Fallback for unsupported visual, plotting pixels + (progn + (dotimes (y h) + (dotimes (x w) + (let ((ink (elt inks (aref array y x)))) + (unless (eq ink +transparent-ink+) + (draw-point* pm x y :ink ink))))) + (convert-indexed->mask array mask-data w h inks))) + + ;; We can use image upload for the mask in either case. + (let ((mask-image (xlib:create-image :bits-per-pixel 1 :depth 1 + :width w :height h + :data mask-data))) + (xlib:put-image mask mask-gc mask-image + :x 0 :y 0 + :width w :height h)))) + (defmethod design-gcontext ((medium clx-medium) (ink climi::indexed-pattern)) (let* ((array (slot-value ink 'climi::array)) (inks (slot-value ink 'climi::designs)) (w (array-dimension array 1)) (h (array-dimension array 0))) - (let* ((pm (allocate-pixmap (first (port-grafts (port medium))) w h)) - (mask (xlib:create-pixmap :drawable (port-lookup-mirror + (assert (not (zerop w))) + (assert (not (zerop h))) + + ;; Establish color and mask pixmaps + (let* ((display (clx-port-display (port medium))) + (screen (clx-port-screen (port medium))) + (drawable (port-lookup-mirror (port medium) (medium-sheet medium))) + (pm (allocate-pixmap (first (port-grafts (port medium))) w h)) + (mask (xlib:create-pixmap :drawable drawable + #+NIL + (port-lookup-mirror (port medium) (first (port-grafts (port medium)))) :depth 1 :width w :height h)) + (pm-gc (xlib:create-gcontext :drawable (pixmap-mirror pm))) (mask-gc (xlib:create-gcontext :drawable mask :foreground 1))) + (xlib:draw-rectangle mask mask-gc 0 0 w h t) (setf (xlib:gcontext-foreground mask-gc) 0) - (dotimes (y h) - (dotimes (x w) - (let ((ink (elt inks (aref array y x)))) - (cond ((eq ink +transparent-ink+) - (xlib:draw-point mask mask-gc x y)) - (t - (draw-point* pm x y :ink ink)))))) - (xlib:free-gcontext mask-gc) - (let ((gc (xlib:create-gcontext :drawable (port-lookup-mirror (port medium) (medium-sheet medium))))) + + (let ((gc (xlib:create-gcontext :drawable drawable))) (setf (xlib:gcontext-fill-style gc) :tiled (xlib:gcontext-tile gc) (port-lookup-mirror (port pm) pm) (xlib:gcontext-clip-x gc) 0 @@ -251,6 +489,19 @@ (xlib:gcontext-ts-x gc) 0 (xlib:gcontext-ts-y gc) 0 (xlib:gcontext-clip-mask gc) mask) + + (let ((byte-order (xlib:display-byte-order display)) + ;; Hmm. Pixmaps are not windows, so you can't query their visual. + ;; We'd like to draw to pixmaps as well as windows, so use the + ;; depth and visual of the screen root, and hope this works. + ;(visual-info (xlib:window-visual-info drawable)) + (visual-info (xlib:visual-info display (xlib:screen-root-visual screen))) + (depth (xlib:screen-root-depth screen)) + (*print-base* 16)) + (fill-pixmap-indexed visual-info depth byte-order array pm pm-gc mask mask-gc w h inks)) + + (xlib:free-gcontext mask-gc) + (xlib:free-gcontext pm-gc) gc)))) (defmethod design-gcontext ((medium clx-medium) (ink climi::rectangular-tile)) From ahefner at common-lisp.net Sun Dec 17 20:00:13 2006 From: ahefner at common-lisp.net (ahefner) Date: Sun, 17 Dec 2006 15:00:13 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Experimental Message-ID: <20061217200013.E4D0758334@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental In directory clnet:/tmp/cvs-serv4400 Modified Files: xpm.lisp Log Message: Rewrote XPM parser to parse directly from one large byte array, rather than using read-line and strings. --- /project/mcclim/cvsroot/mcclim/Experimental/xpm.lisp 2003/07/12 19:36:56 1.2 +++ /project/mcclim/cvsroot/mcclim/Experimental/xpm.lisp 2006/12/17 20:00:13 1.3 @@ -2,10 +2,12 @@ ;;; --------------------------------------------------------------------------- ;;; Title: XPM Parser ;;; Created: 2003-05-25 -;;; Author: Gilbert Baumann +;;; Authors: Gilbert Baumann +;;; Andy Hefner ;;; License: LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2003 by Gilbert Baumann +;;; (c) copyright 2006 by Andy Hefner ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -26,6 +28,26 @@ ;;;; Notes +;;; This is essentially a rewrite/transliteration of Gilbert's original code, +;;; modified to improve performance. This is achieved primarily by using +;;; read-sequence into an (unsigned-byte 8) array and parsing directly +;;; from this array (the original code read a list of strings using read-line +;;; and further divided these into substrings in various places. It is +;;; substantially faster than the original code, but there are opportunities +;;; to further improve performance by perhaps several times, including: +;;; - Use an array rather than hash table to resolve color tokens +;;; (I avoided doing this for now due to a pathological case of a file +;;; with a small palette but high CPP and sparse color tokens) +;;; - Stricter type declarations (some but not all of the code assumes cpp<3) +;;; - In the worst case (photographs), we spent most of our time parsing +;;; the palette (it may have thousands or millions of entries). +;;; - For the above case, we should be generating an RGB or RGBA image +;;; rather than an indexed-pattern (and consing a ton of color objects). +;;; - People who save photographs in XPM format are morons, so it isn't +;;; worth optimizing. + +;;; Gilbert's Notes: + ;; - We lose when the XPM image only specifies colors for say the mono ;; visual. ;; @@ -47,14 +69,9 @@ ;; - This needs to be incorporated into READ-BITMAP-FILE or what ever ;; that is called. ;; -;; - Also: Don't read from text streams but also be able to read from -;; binary streams, as a general image reader will want a binary -;; stream and first parse off a magic to figure out the format and -;; then pass the stream further down here. -;; ;; - We might be interested in the hot spot also. ;; -;; --GB 2003-05-25 +;; --GB 2003-05-25 ;;;; Summary of the File Format @@ -140,174 +157,293 @@ ;; | prefixed by the name of the company. This would ensure uniqueness. ;; | -(defun xpm-white-space-p (char) - (member char '(#\space #\tab #\newline))) - -(defun xpm-pop-token (string start end) - ;; -> token-start, token-end - (let* ((p1 (position-if-not #'xpm-white-space-p string :start start :end end)) - (p2 (and p1 (or (position-if #'xpm-white-space-p string :start p1 :end end) end)))) - (values p1 p2))) - -(defun xpm-parse-color (string cpp &key (start 0) (end (length string))) - (let ((code (subseq string start (+ start cpp))) - (color (xpm-parse-color-spec string :start (+ start cpp) :end end))) +(deftype xpm-data-array () `(simple-array (unsigned-byte 8) 1)) +(deftype array-index () + #-sbcl '#.(integer 0 #.array-dimension-limit) + #+sbcl 'sb-int:index) +(deftype xpm-pixcode () `(unsigned-byte 24)) ; Bogus upper limit for speed.. =/ + +(defmacro xpm-over-array ((arrayform elt0 idx0 elt1 idx1 start) &body body) + (let ((arraysym (gensym)) + (lengthsym (gensym))) + `(let* ((,arraysym ,arrayform) + (,lengthsym (length ,arraysym))) + (declare (type xpm-data-array ,arraysym) + (optimize (speed 3))) + (loop for ,idx0 of-type array-index from ,start below (1- ,lengthsym) + as ,idx1 of-type array-index = (1+ ,idx0) + as ,elt0 = (aref ,arraysym ,idx0) + as ,elt1 = (aref ,arraysym ,idx1) + do (progn , at body))))) + +(declaim (inline xpm-whitespace-p) + (ftype (function ((unsigned-byte 8)) t) xpm-whitespace-p)) +(defun xpm-white-space-p (code) + (declare (type (unsigned-byte 8) code) + (optimize (speed 3))) + (or (= code 32) ; #\Space + (= code 9) ; #\Tab + (= code 10))) ; #\Newline + +(defun xpm-token-terminator-p (code) + (declare (type (unsigned-byte 8) code)) + (or (xpm-white-space-p code) + (= code 34))) ; #\" + +(defun xpm-token-bounds (data start) + (xpm-over-array (data b0 start b1 i1 start) + (when (not (xpm-white-space-p b0)) + (xpm-over-array (data b0 end b1 i1 start) + (when (xpm-token-terminator-p b0) (return-from xpm-token-bounds (values start end)))) + (error "Unbounded token"))) + (error "Missing token")) + +(defun xpm-extract-color-token (data start end) + (declare (type xpm-data-array data) + (type array-index start end) + (optimize (speed 3))) + (let ((x 0)) + (declare (type xpm-pixcode x)) ; Bah, this didn't help. + (loop for i from start below end do (setf x (+ (ash x 8) (elt data i)))) + x)) + +(defun xpm-parse-color (data cpp index) + (declare (type xpm-data-array data) + (type (integer 1 4) cpp) ; ??? =p + (type array-index index) + (optimize (speed 3) (safety 0))) + (let* ((color-token-end (the array-index (+ index cpp))) + (code (xpm-extract-color-token data index color-token-end)) + (string-end (1- (xpm-exit-string data color-token-end))) + (color (xpm-parse-color-spec data color-token-end string-end))) + (declare (type array-index color-token-end string-end) + (type xpm-pixcode code)) (unless color - (error "Color ~S does not parse." (subseq string (+ start cpp) end))) - (values code color))) - -(defparameter *xpm-color-keys* - '("m" "s" "g4" "g" "c")) + (error "Color ~S does not parse." (map 'string #'code-char (subseq data color-token-end string-end)))) + (values code color (1+ string-end)))) -(defun xpm-parse-color-spec (string &key (start 0) (end (length string))) - ;; Lossage! - ;; There exist files which say e.g. "c light yellow". - ;; How am I supposed to parse that? - ;; - ;; It seems that the C code just parse everything until one of keys. - ;; That is we do the same although it is quite stupid. - ;; - (let ((start0 start) - (key nil) - (color nil) - (last-was-key nil)) - (labels ((quux (k c) - (let ((ink (xpm-parse-single-color k c))) +(declaim (inline xpm-key-p)) +(defun xpm-key-p (x) + (or (= x 109) + (= x 115) + (= x 103) + (= x 99))) + +(defun xpm-parse-color-spec (data start end) + ;; Gilbert says: + ;; > Lossage! + ;; > There exist files which say e.g. "c light yellow". + ;; > How am I supposed to parse that? + ;; > + ;; > It seems that the C code just parse everything until one of keys. + ;; > That is we do the same although it is quite stupid. + ;(declare (optimize (debug 3) (safety 3))) + (declare (optimize (speed 3) (space 0) (safety 0)) + (type xpm-data-array data) + (type array-index start end)) + (let ((original-start start) + key last-was-key + color-token-start + color-token-end) + (declare (type (or null array-index) color-token-start color-token-end) + (type (or null (unsigned-byte 8)) key)) + (flet ((find-token (start end) + (let* ((p1 (position-if-not #'xpm-white-space-p data :start start :end end)) + (p2 (and p1 (or (position-if #'xpm-white-space-p data :start p1 :end end) end)))) + (values p1 p2))) + (quux (key color-token-start color-token-end) + (let ((ink (xpm-parse-single-color key data color-token-start color-token-end))) (when ink - (return-from xpm-parse-color-spec ink))))) - (loop - (multiple-value-bind (p1 p2) (xpm-pop-token string start end) - (unless p1 - (cond (last-was-key - (error "Premature end of color line (no color present after key): ~S." - (subseq string start0 end)))) - (if color - (quux key color)) - (error "We failed to parse a color out of ~S." - (subseq string start0 end))) - (let ((thing (subseq string p1 p2))) - (cond (last-was-key - (setf last-was-key nil) - (setf color thing)) - ((find thing *xpm-color-keys* :test #'string=) - (when color - (quux key color)) - (setf last-was-key t - color nil - key thing)) - (t - (when (null color) - (error "Color not prefixed by a key: ~S." - (subseq string start0 end))) - (setf last-was-key nil) - (setf color (concatenate 'string color " " thing))))) - (setf start p2) ))))) - -(defun xpm-parse-single-color (key color) - (cond ((and (string= key "s") (string-equal color "None")) + (return-from xpm-parse-color-spec ink)))) + (stringize () (map 'string #'code-char (subseq data original-start end)))) + (loop + (multiple-value-bind (p1 p2) (find-token start end) + (unless p1 + (when last-was-key + (error "Premature end of color line (no color present after key): ~S." (stringize))) + (when color-token-start (quux key color-token-start color-token-end)) + (error "We failed to parse a color out of ~S." (stringize))) + (cond (last-was-key + (setf last-was-key nil + color-token-start p1 + color-token-end p2)) + ((xpm-key-p (elt data p1)) + (when color-token-start (quux key color-token-start color-token-end)) + (setf last-was-key t + color-token-start nil + color-token-end nil + key (elt data p1))) + (t (when (null color-token-start) + (error "Color not prefixed by a key: ~S." (stringize))) + (setf last-was-key nil) + (setf color-token-end p2))) + (setf start p2)))))) + +(defun xpm-subvector-eql-p (data start end vector) ; FIXME: Guarantee type of input 'vector' and strengthen declaration + (declare (type xpm-data-array data) + (type array-index start end) + (type simple-array vector) + (optimize (speed 3))) + (and (= (length vector) (- end start)) + (loop for i from start below end + do (unless (= (elt data i) (elt vector (- i start))) (return nil)) + return t))) + +(defun xpm-parse-single-color (key data start end) + (declare (type xpm-data-array data) + (type array-index start end) + (type (unsigned-byte 8) key) + (optimize (speed 3))) + (cond ((and (= key 115) + (or + (xpm-subvector-eql-p data start end #|"None"|# #(78 111 110 101)) + (xpm-subvector-eql-p data start end #|"background"|# #(98 97 99 107 103 114 111 117 110 100)))) clim:+transparent-ink+) - ((and (string= key "c") - (xpm-parse-single-color-2 color))))) - -(defun xpm-parse-single-color-2 (color &aux ink) - (cond ((and (char= (char color 0) #\#) - (= 0 (mod (- (length color) 1) 3)) - (every #'(lambda (x) (digit-char-p x 16)) (subseq color 1))) - (let* ((n (1- (length color))) - (w (* 4 (/ n 3))) - (m (1- (expt 2 w))) - (x (parse-integer color :start 1 :radix 16))) - (clim:make-rgb-color (/ (ldb (byte w (* 2 w)) x) m) - (/ (ldb (byte w (* 1 w)) x) m) - (/ (ldb (byte w (* 0 w)) x) m)))) - ((setq ink (xpm-find-named-color color)) - ink))) + ((= key 99) (xpm-parse-single-color-2 data start end)) + (t (error "Unimplemented key type ~A" key)))) -(defun xpm-parse-header (string &key (start 0) (end (length string))) +(declaim (ftype (function ((unsigned-byte 8)) t) xpm-hex-digit-p)) +(defun xpm-hex-digit-p (byte) + (declare (type (unsigned-byte 8) byte) + (optimize (speed 3))) + (or (<= 48 byte 57) + (<= 65 byte 70) + (<= 97 byte 102))) + +(defun xpm-parse-integer-hex (data start end) + (declare (type xpm-data-array data) + (type array-index start end) + (optimize (speed 3))) + (let ((accumulator 0)) ; stupid optimizer.. + (loop for index from start below end + as byte = (elt data index) + do (setf accumulator (+ (ash accumulator 4) + (cond ((<= 48 byte 57) (- byte 48)) + ((<= 65 byte 70) (- byte 65 -10)) + ((<= 97 byte 102) (- byte 97 -10)) + (t (error "Unknown hex digit ~A, this should be impossible." byte))))) + finally (return accumulator)))) + +(defun xpm-parse-single-color-2 (data start end) + (declare (type xpm-data-array data) + (type array-index start end) + (optimize (speed 3))) + (or (and (= (elt data start) 35) ; 35 = #\# + (= 0 (mod (- end start 1) 3)) + (loop for i from (1+ start) below end do (unless (xpm-hex-digit-p (elt data i)) (return nil)) finally (return t)) + (let* ((n (- end start 1)) + (w (* 4 (/ n 3))) + (m (1- (expt 2 w))) + (x (xpm-parse-integer-hex data (1+ start) end))) + (clim:make-rgb-color (/ (ldb (byte w (* 2 w)) x) m) + (/ (ldb (byte w (* 1 w)) x) m) + (/ (ldb (byte w (* 0 w)) x) m)))) + (xpm-find-named-color (map 'string #'code-char (subseq data start end))))) + +(defun xpm-parse-header (data &optional (index 0)) + (setf index (xpm-find-next-c-string data index)) + (flet ((token (name) + (multiple-value-bind (p1 p2) (xpm-token-bounds data index) + (unless p1 (error "~A field missing in header." name)) + (setf index p2) + (parse-integer (map 'string #'code-char (subseq data p1 p2)) :radix 10 :junk-allowed nil)))) (values - (multiple-value-bind (p1 p2) (xpm-pop-token string start end) - (unless p1 (error "width field missing in header.")) - (setf start p2) - (parse-integer string :start p1 :end p2 :radix 10 :junk-allowed nil)) - (multiple-value-bind (p1 p2) (xpm-pop-token string start end) - (unless p1 (error "height field missing in header.")) - (setf start p2) - (parse-integer string :start p1 :end p2 :radix 10 :junk-allowed nil)) - (multiple-value-bind (p1 p2) (xpm-pop-token string start end) - (unless p1 (error "ncolors field missing in header.")) - (setf start p2) - (parse-integer string :start p1 :end p2 :radix 10 :junk-allowed nil)) - (multiple-value-bind (p1 p2) (xpm-pop-token string start end) - (unless p1 (error "cpp field missing in header.")) - (setf start p2) - (parse-integer string :start p1 :end p2 :radix 10 :junk-allowed nil)))) - -(defun xpm-parse* (strings) - (multiple-value-bind (width height ncolors cpp) (xpm-parse-header (pop strings)) - (let ((color-hash (make-hash-table :test #'equal)) + (token "width") + (token "height") + (token "ncolors") + (token "cpp") + (xpm-exit-string data index)))) + +(defun xpm-parse* (data) + (declare (type xpm-data-array data)) + (multiple-value-bind (width height ncolors cpp index) (xpm-parse-header data) + (let ((color-hash (make-hash-table :test #'eql)) (designs (make-array ncolors)) (j 0)) + (dotimes (i ncolors) - (multiple-value-bind (code ink) (xpm-parse-color (pop strings) cpp) - (setf (aref designs j) ink) - (setf (gethash code color-hash) j) + (multiple-value-bind (code ink post-index) (xpm-parse-color data cpp (xpm-find-next-c-string data index)) + (setf (aref designs j) ink + (gethash code color-hash) j + index post-index) (incf j))) - (let ((res (make-array (list height width)))) + + ;; It is considerably faster still to make the array below of element type '(unsigned-byte 8), + ;; but this would be wrong by failing to load many legal XPM files. To support both, most + ;; of this file would have to be compiled twice for the different types, which is more + ;; trouble than its worth. =( + (let ((res (make-array (list height width) #|:element-type '(unsigned-byte 8)|#))) + ;(line-start (xpm-find-next-c-string data index)) + (setf index (xpm-find-next-c-string data index)) (dotimes (y height) (dotimes (x width) + (when (= 34 (elt data index)) ; Reached closing quote for this line of pixels? + (setf index (xpm-find-next-c-string data (1+ index)))) (setf (aref res y x) - (or (gethash (subseq (first strings) (* x cpp) (+ cpp (* x cpp))) color-hash) + (or (gethash (xpm-extract-color-token data index (+ index cpp)) color-hash) (error "Color code ~S not defined." - (subseq (first strings) (* x cpp) (+ cpp (* x cpp))))))) - (pop strings)) + (subseq data index (+ index cpp))))) + (incf index cpp))) (clim:make-pattern res designs))))) - -(defun xpm-parse-next-c-string (input) - (do ((c (read-char input nil nil) (read-char input nil nil))) [101 lines skipped] From ahefner at common-lisp.net Tue Dec 19 01:53:15 2006 From: ahefner at common-lisp.net (ahefner) Date: Mon, 18 Dec 2006 20:53:15 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Experimental Message-ID: <20061219015315.BE539671CD@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental In directory clnet:/tmp/cvs-serv29896 Modified Files: xpm.lisp Log Message: Fix broken type declaration. --- /project/mcclim/cvsroot/mcclim/Experimental/xpm.lisp 2006/12/17 20:00:13 1.3 +++ /project/mcclim/cvsroot/mcclim/Experimental/xpm.lisp 2006/12/19 01:53:15 1.4 @@ -159,7 +159,7 @@ (deftype xpm-data-array () `(simple-array (unsigned-byte 8) 1)) (deftype array-index () - #-sbcl '#.(integer 0 #.array-dimension-limit) + #-sbcl '(integer 0 #.array-dimension-limit) #+sbcl 'sb-int:index) (deftype xpm-pixcode () `(unsigned-byte 24)) ; Bogus upper limit for speed.. =/ From ahefner at common-lisp.net Tue Dec 19 02:16:38 2006 From: ahefner at common-lisp.net (ahefner) Date: Mon, 18 Dec 2006 21:16:38 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20061219021638.C497F301F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv836 Modified Files: medium.lisp Log Message: Resolve indirect inks to their current values before computing indexed palette. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2006/12/17 19:53:52 1.75 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2006/12/19 02:16:38 1.76 @@ -456,7 +456,15 @@ (defmethod design-gcontext ((medium clx-medium) (ink climi::indexed-pattern)) (let* ((array (slot-value ink 'climi::array)) - (inks (slot-value ink 'climi::designs)) + (inks (map 'vector + (lambda (ink) + (cond + ((eql ink +foreground-ink+) (medium-foreground medium)) + ((eql ink +background-ink+) (medium-background medium)) + ((eql ink +flipping-ink+) + (error "Flipping ink within patterns is not supported.")) + (t ink))) + (slot-value ink 'climi::designs))) (w (array-dimension array 1)) (h (array-dimension array 0))) (assert (not (zerop w))) From ahefner at common-lisp.net Tue Dec 19 04:02:14 2006 From: ahefner at common-lisp.net (ahefner) Date: Mon, 18 Dec 2006 23:02:14 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061219040214.410224D049@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv18028 Modified Files: panes.lisp text-editor-gadget.lisp Log Message: In make-pane, convert keyword types to their corresponding symbols in the CLIM package. --- /project/mcclim/cvsroot/mcclim/panes.lisp 2006/12/05 02:08:44 1.174 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2006/12/19 04:02:14 1.175 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.174 2006/12/05 02:08:44 rgoldman Exp $ +;;; $Id: panes.lisp,v 1.175 2006/12/19 04:02:14 ahefner Exp $ (in-package :clim-internals) @@ -377,6 +377,10 @@ (prin1 (pane-name pane) sink))) (defun make-pane (type &rest args) + (when (eql (symbol-package type) + (symbol-package :foo)) + (setf type (or (find-symbol (symbol-name type) (find-package :clim)) + type))) (apply #'make-pane-1 *pane-realizer* *application-frame* type args)) (defmethod medium-foreground ((pane pane)) @@ -2095,7 +2099,7 @@ (check-type scroll-bar scroll-bar-spec) ; (member :vertical :horizontal :both t nil)) (when (member scroll-bar '(:vertical :both t)) (setq vscrollbar - (make-pane 'scroll-bar-pane + (make-pane 'scroll-bar :orientation :vertical :client (first (sheet-children viewport)) :drag-callback (lambda (gadget new-value) @@ -2121,7 +2125,7 @@ (sheet-adopt-child pane vscrollbar)) (when (member scroll-bar '(:horizontal :both t)) (setq hscrollbar - (make-pane 'scroll-bar-pane + (make-pane 'scroll-bar :orientation :horizontal :client (first (sheet-children viewport)) :drag-callback (lambda (gadget new-value) --- /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp 2006/11/24 22:43:03 1.5 +++ /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp 2006/12/19 04:02:14 1.6 @@ -89,7 +89,7 @@ (setf (gadget-value object) value)) (defmethod make-pane-1 :around (fm (frame application-frame) - (type (eql :text-editor)) + (type (eql 'text-editor)) &rest args &key) (apply #'make-pane-1 fm frame :drei :drei-class 'text-editor-pane @@ -278,14 +278,14 @@ ;;; Drei/Goatee selection. (defmethod make-pane-1 :around (fm (frame application-frame) - (type (eql :text-field)) + (type (eql 'text-field)) &rest args &key) (if *use-goatee* (apply #'make-pane-1 fm frame 'goatee-text-field-pane args) (apply #'make-pane-1 fm frame 'text-field-pane args))) (defmethod make-pane-1 :around (fm (frame application-frame) - (type (eql :text-editor)) + (type (eql 'text-editor)) &rest args &key) (if *use-goatee* (apply #'make-pane-1 fm frame 'goatee-text-editor-pane args) From ahefner at common-lisp.net Tue Dec 19 04:07:15 2006 From: ahefner at common-lisp.net (ahefner) Date: Mon, 18 Dec 2006 23:07:15 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Looks Message-ID: <20061219040715.6302552002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Looks In directory clnet:/tmp/cvs-serv18507 Modified Files: pixie.lisp Log Message: Clean up the Pixie look. Make explicit which panes are implemented by pixie, rather than hacks involving find-symbol. Disable ugly menubar. Cleanup grungy pixels on the shadows of buttons, scroll-bars, and the slider gadget. --- /project/mcclim/cvsroot/mcclim/Looks/pixie.lisp 2006/03/29 10:43:50 1.16 +++ /project/mcclim/cvsroot/mcclim/Looks/pixie.lisp 2006/12/19 04:07:15 1.17 @@ -19,7 +19,25 @@ (defclass pixie-look (frame-manager) ()) #+clx (defclass pixie/clx-look (pixie-look clim-clx::clx-frame-manager) ()) -; our stub inside clim proper + +(defmacro define-pixie-gadget (abstract-type pixie-type &key (enabled t)) + `(defmethod make-pane-1 ((fm pixie-look) + (frame application-frame) + (type (eql ',abstract-type)) + &rest args) + (declare (ignorable fm frame type args)) + (format *trace-output* "~& make-pane-1 ~A => ~A~%" ',abstract-type ',pixie-type) + ,(if enabled + `(apply #'make-instance + ',pixie-type + :frame frame + :manager fm + :port (port frame) + args) + `(call-next-method)))) + +;; Let us please stop playing these stupid symbol games. +#+NIL (defmethod make-pane-1 ((fm pixie-look) (frame application-frame) type &rest args) (apply #'make-instance (or (find-symbol (concatenate 'string "PIXIE-" (symbol-name type)) :climi) @@ -68,11 +86,11 @@ (y1 (+ y1 2)) (x2 (- x2 1)) (y2 (- y2 1))) - (draw-line* pane x1 y2 (+ x2 1) y2 :ink +gray54+) ; <- not a typo - (draw-line* pane x2 y1 x2 (+ y2 1) :ink +gray54+)) + (draw-line* pane x1 y2 x2 y2 :ink +gray54+) + (draw-line* pane x2 y1 x2 y2 :ink +gray54+)) ;; now for the black outline - (draw-line* pane x1 y2 (+ x2 1) y2 :ink +black+) - (draw-line* pane x2 y1 x2 (+ y2 1) :ink +black+) + (draw-line* pane x1 y2 x2 y2 :ink +black+) + (draw-line* pane x2 y1 x2 y2 :ink +black+) (draw-label* pane x1 y1 x2 y2 :ink (pane-inking-color pane)))) @@ -88,9 +106,9 @@ (y2 (- y2 2))) (draw-line* pane x1 y1 (+ x2 1) y1 :ink +black+) (draw-line* pane x1 y1 x1 (+ y2 1) :ink +black+)) - ;; now for the black outline - (draw-line* pane x1 y2 (+ x2 1) y2 :ink +white+) - (draw-line* pane x2 y1 x2 (+ y2 1) :ink +white+) + ;; now for the white outline + (draw-line* pane x1 y2 x2 y2 :ink +white+) + (draw-line* pane x2 y1 x2 y2 :ink +white+) (draw-label* pane x1 y1 x2 y2 :ink (pane-inking-color pane))) @@ -141,6 +159,7 @@ (defconstant +pixie-slider-thumb-height+ 34) (defconstant +pixie-slider-thumb-half-width+ 8) + (defclass pixie-slider-pane (pixie-gadget draggable-arming-mixin slider-pane) ((dragging :initform nil) @@ -160,6 +179,8 @@ :border-style :inset :border-width 1)) +(define-pixie-gadget slider pixie-slider-pane) + (defmethod compose-space ((pane pixie-slider-pane) &key width height) (declare (ignore width height)) (if (eq (gadget-orientation pane) :vertical) @@ -334,8 +355,8 @@ (x1 (+ x1 2)) (x2 (- x2 3))) (draw-line* pane x1 y1 x2 y1 :ink +gray58+) - (draw-line* pane x1 y2 (+ x2 1) y2 :ink +white+) - (draw-line* pane x2 y1 x2 (+ y2 1) :ink +white+))))))))) + (draw-line* pane x1 y2 x2 y2 :ink +white+) + (draw-line* pane x2 y1 x2 y2 :ink +white+))))))))) ; Scrollbar @@ -387,6 +408,8 @@ :max-value 1 :orientation :vertical)) +(define-pixie-gadget scroll-bar pixie-scroll-bar-pane) + (defmethod compose-space ((pane pixie-scroll-bar-pane) &key width height) (declare (ignore width height)) (if (eq (gadget-orientation pane) :vertical) @@ -657,6 +680,8 @@ ; silly menu-bar isn't named pane, so this catches it (defclass pixie-menu-bar (pixie-menu-bar-pane) ()) +(define-pixie-gadget menu-bar pixie-menu-bar-pane :enabled nil) + (defmethod handle-repaint ((pane pixie-menu-bar-pane) region) (declare (ignore region)) (with-special-choices (pane) @@ -858,6 +883,8 @@ (defclass pixie-toggle-button-pane (pixie-gadget toggle-button-pane) ()) +(define-pixie-gadget toggle-button pixie-toggle-button-pane) + (defmethod draw-toggle-button-indicator ((pane pixie-toggle-button-pane) (type (eql :one-of)) value x1 y1 x2 y2) (multiple-value-bind (cx cy) (values (/ (+ x1 x2) 2) (/ (+ y1 y2) 2)) (let ((radius (/ (- y2 y1) 2))) @@ -924,6 +951,8 @@ (dragging :initform nil))) +(define-pixie-gadget push-button pixie-push-button-pane) + (defmethod compose-space ((gadget pixie-push-button-pane) &key width height) (declare (ignore width height)) (space-requirement+* (space-requirement+* (compose-label-space gadget) @@ -996,6 +1025,10 @@ (defclass pixie-text-field-pane (text-field-pane) ()) +;; Why does pixie need its own text area subclass? Leave it disabled for now. +; (define-pixie-class text-field-pane pixie-text-field-pane) + + (defmethod initialize-instance :after ((pane pixie-text-field-pane) &rest rest) (unless (getf rest :normal) (setf (slot-value pane 'current-color) +white+ From ahefner at common-lisp.net Tue Dec 19 04:08:58 2006 From: ahefner at common-lisp.net (ahefner) Date: Mon, 18 Dec 2006 23:08:58 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20061219040858.50E1254125@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv18882 Modified Files: calculator.lisp clim-fig.lisp demodemo.lisp sliderdemo.lisp Log Message: Cleanup pane names in examples - always use the abstract pane name, rather than the concrete name (push-button vs. push-button-pane), so that the frame manager can choose. --- /project/mcclim/cvsroot/mcclim/Examples/calculator.lisp 2005/02/01 03:11:39 1.18 +++ /project/mcclim/cvsroot/mcclim/Examples/calculator.lisp 2006/12/19 04:08:58 1.19 @@ -89,7 +89,7 @@ (defun make-button (label operator &key width height (max-width +fill+) min-width (max-height +fill+) min-height) - (make-pane 'push-button-pane + (make-pane 'push-button :label label :activate-callback operator :text-style *calculator-text-style* --- /project/mcclim/cvsroot/mcclim/Examples/clim-fig.lisp 2006/11/10 18:36:57 1.29 +++ /project/mcclim/cvsroot/mcclim/Examples/clim-fig.lisp 2006/12/19 04:08:58 1.30 @@ -146,7 +146,7 @@ ) (defun make-colored-button (color &key width height) - (make-pane 'push-button-pane + (make-pane 'push-button :label " " :activate-callback #'(lambda (gadget) @@ -158,7 +158,7 @@ :highlighted color)) (defun make-drawing-mode-button (label mode &key width height) - (make-pane 'push-button-pane + (make-pane 'push-button :label label :activate-callback #'(lambda (gadget) --- /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/07/03 04:58:41 1.13 +++ /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/12/19 04:08:58 1.14 @@ -91,12 +91,12 @@ (default (horizontally (:background climi::*3d-normal-color*) 30 - (make-pane 'push-button-pane :label "Okay" + (make-pane 'push-button :label "Okay" :width '(50 :mm)) '+fill+ - (make-pane 'push-button-pane :label "Cancel") + (make-pane 'push-button :label "Cancel") '+fill+ - (make-pane 'push-button-pane :label "Help") + (make-pane 'push-button :label "Help") 5 ) ))) @@ -105,10 +105,10 @@ (:layouts (default (tabling (:background +red+) - (list (make-pane 'push-button-pane :label "Last Name" :max-height +fill+) - (make-pane 'push-button-pane :label "First Name" #||:max-height +fill+||#)) - (list (make-pane 'push-button-pane :label "C 1 0") - (make-pane 'push-button-pane :label "C 1 1")) + (list (make-pane 'push-button :label "Last Name" :max-height +fill+) + (make-pane 'push-button :label "First Name" #||:max-height +fill+||#)) + (list (make-pane 'push-button :label "C 1 0") + (make-pane 'push-button :label "C 1 1")) ) ))) (defun make-test-label (ax ay) @@ -118,7 +118,7 @@ :foreground +WHITE+ :background +PALETURQUOISE4+ :text-style (make-text-style :sans-serif :roman :normal)) - (make-pane 'push-button-pane :label (format nil "~S" (list ax ay)) + (make-pane 'push-button :label (format nil "~S" (list ax ay)) :text-style (make-text-style :sans-serif :roman :normal) :max-width 1000 :max-height 1000))) @@ -131,7 +131,7 @@ :background +PALETURQUOISE4+ :text-style (make-text-style :sans-serif :roman :normal)) #+nil - (make-pane 'push-button-pane :label + (make-pane 'push-button :label :text-style (make-text-style :sans-serif :roman :normal) :max-width 1000 :max-height 1000))) --- /project/mcclim/cvsroot/mcclim/Examples/sliderdemo.lisp 2003/03/21 21:37:00 1.4 +++ /project/mcclim/cvsroot/mcclim/Examples/sliderdemo.lisp 2006/12/19 04:08:58 1.5 @@ -75,7 +75,7 @@ (setf (gadget-value *text-field*) (princ-to-string value))) (defun find-text-field (frame) - (first (member-if #'(lambda (gadget) (typep gadget 'text-field-pane)) + (first (member-if #'(lambda (gadget) (typep gadget 'text-field)) (frame-panes frame)))) (defmethod sliderdemo-frame-top-level ((frame application-frame) From thenriksen at common-lisp.net Wed Dec 20 01:37:01 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 19 Dec 2006 20:37:01 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061220013701.F03D77B01C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv23603 Modified Files: mcclim.asd Log Message: Fixed file interdependencies in the Clouseau system definition. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/12/10 19:33:28 1.39 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/12/20 01:37:01 1.40 @@ -539,8 +539,8 @@ :pathname #.(make-pathname :directory '(:relative "Apps" "Inspector")) :components ((:file "package") - (:file "disassembly") - (:file "inspector"))))) + (:file "disassembly" :depends-on ("package")) + (:file "inspector" :depends-on ("disassembly")))))) (defmethod perform :after ((op load-op) (c (eql (find-system :clim)))) (pushnew :clim *features*) From dlichteblau at common-lisp.net Wed Dec 20 12:01:36 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Wed, 20 Dec 2006 07:01:36 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061220120136.5D4A11A09D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv18295 Modified Files: gadgets.lisp Log Message: Oops, gtkairo broke non-native label panes when loaded: * gadgets.lisp ((ALLOCATE-SPACE LABEL-PANE)): Specialize on GTK-LABEL-PANE only. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/12/03 08:09:06 1.15 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/12/20 12:01:36 1.16 @@ -544,7 +544,7 @@ (gtk_widget_destroy widget) (setf (native-widget gadget) nil))))) -(defmethod allocate-space ((pane label-pane) width height) +(defmethod allocate-space ((pane gtk-label-pane) width height) (when (sheet-children pane) (move-sheet (first (sheet-children pane)) 0 0) (allocate-space (first (sheet-children pane)) From dlichteblau at common-lisp.net Wed Dec 20 12:30:44 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Wed, 20 Dec 2006 07:30:44 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20061220123044.9ACC925002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv22124 Modified Files: text-size-test.lisp Log Message: Visualize text-style-ascent, -descent, -width, -height, and -fixed-width-p. Print a legend. --- /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp 2006/05/09 20:07:54 1.3 +++ /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp 2006/12/20 12:30:44 1.4 @@ -45,7 +45,7 @@ (size (make-pane 'slider :orientation :horizontal - :value 200 + :value 160 :min-value 1 :max-value 1000))) (:layouts @@ -59,6 +59,30 @@ (labelling (:label "Size") size) canvas)))) +(defun draw-vstrecke (stream x y1 y2 &rest args &key ink &allow-other-keys) + (draw-line* stream (- x 10) y1 (+ x 10) y1 :ink ink) + (draw-line* stream (- x 10) y2 (+ x 10) y2 :ink ink) + (apply #'draw-arrow* stream x y1 x y2 args)) + +(defun draw-hstrecke (stream y x1 x2 &rest args &key ink &allow-other-keys) + (draw-line* stream x1 (- y 10) x1 (+ y 10) :ink ink) + (draw-line* stream x2 (- y 10) x2 (+ y 10) :ink ink) + (apply #'draw-arrow* stream x1 y x2 y args)) + +(defun legend-text-style () + (make-text-style :sans-serif :roman :small)) + +(defun draw-legend (stream &rest entries) + (let* ((style (legend-text-style)) + (y 2) + (h (nth-value 1 (text-size stream "dummy" :text-style style)))) + (dolist (entry entries) + (when entry + (incf y h) + (let ((y* (+ 0.5 (round (- y (/ h 2)))))) + (apply #'draw-line* stream 2 y* 35 y* (cdr entry))) + (draw-text* stream (car entry) 40 y :text-style style))))) + (defmethod display-canvas (frame stream) (window-clear stream) (let* ((pane-width (rectangle-width (sheet-region stream))) @@ -70,11 +94,59 @@ (mapcar #'gadget-id (gadget-value (find-pane-named frame 'face)))) (rectangle (gadget-id (gadget-value (find-pane-named frame 'rectangle)))) (face (if (cdr faces) '(:bold :italic) (car faces))) - (style (make-text-style family face size))) + (style (make-text-style family face size)) + (medium (sheet-medium stream))) (multiple-value-bind (width height final-x final-y baseline) (text-size stream str :text-style style) (let ((x1 (/ (- pane-width width) 2)) (y1 (/ (- pane-height height) 2))) + (draw-text* stream + (format nil "fixed-width-p: ~(~A~)" + (handler-case + (text-style-fixed-width-p style medium) + (error (c) + c))) + 2 + pane-height + :text-style (legend-text-style)) + (draw-legend stream + (list "Ascent" + ;; :line-style (make-line-style :dashes '(1.5)) + :ink +black+) + (list "Descent" :ink +black+) + (list "Height" + :line-style (make-line-style :thickness 2) + :ink +black+) + (list "Width (Avg.)" :ink +black+) + (list "Baseline" :ink +green+) + (when (eq rectangle :text-bounding-rectangle) + (list "Bounding rectangle" :ink +purple+)) + (when (eq rectangle :text-size) + (list "Text size (width/height)" :ink +red+)) + (when (eq rectangle :text-size) + (list "Text size (final x/y)" :ink +blue+))) + (draw-vstrecke stream + (- x1 20) + (+ y1 (text-style-ascent style medium)) + y1 + ;; :line-style (make-line-style :dashes '(1.5)) + :ink +black+) + (draw-vstrecke stream + (- x1 40) + (+ y1 baseline) + (+ y1 baseline (text-style-descent style medium)) + :ink +black+) + (draw-vstrecke stream + (- x1 60) + y1 + (+ y1 (text-style-height style medium)) + :line-style (make-line-style :thickness 2) + :ink +black+) + (draw-hstrecke stream + (- y1 20) + x1 + (+ x1 (text-style-width style medium)) + :ink +black+) (draw-line* stream 0 (+ y1 baseline) pane-width (+ y1 baseline) @@ -99,7 +171,7 @@ :filled nil)) ((:text-bounding-rectangle) (multiple-value-bind (left top right bottom) - (climi::text-bounding-rectangle* (sheet-medium stream) str :text-style style) + (climi::text-bounding-rectangle* medium str :text-style style) (draw-rectangle* stream (+ x1 left) (+ y1 baseline top) (+ x1 right) (+ y1 baseline bottom) From dlichteblau at common-lisp.net Wed Dec 20 14:42:51 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Wed, 20 Dec 2006 09:42:51 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20061220144251.4E6DF2E1BE@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv19514 Modified Files: text-size-test.lisp Log Message: - Show the final x/y point as a cross. - Use a TEXT-EDITOR to allow testing of multi-line DRAW-TEXT (and watch it not work in CLIM-CLX.) --- /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp 2006/12/20 12:30:44 1.4 +++ /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp 2006/12/20 14:42:51 1.5 @@ -26,7 +26,7 @@ :min-width 600 :display-time t :display-function 'display-canvas) - (text (make-pane 'text-field :value "ytmM")) + (text (make-pane 'text-editor :height 200 :value "ytmM")) (family (with-radio-box () (make-pane 'toggle-button :label "Fixed" :id :fixed) @@ -45,7 +45,7 @@ (size (make-pane 'slider :orientation :horizontal - :value 160 + :value 120 :min-value 1 :max-value 1000))) (:layouts @@ -164,11 +164,14 @@ (+ x1 width) (+ y1 height) :ink +red+ :filled nil) - (draw-rectangle* stream - x1 y1 - (+ x1 final-x) (+ y1 final-y) - :ink +blue+ - :filled nil)) + (draw-line* stream + 0 (+ y1 final-y) + pane-width (+ y1 final-y) + :ink +blue+) + (draw-line* stream + (+ x1 final-x) 0 + (+ x1 final-x) pane-height + :ink +blue+)) ((:text-bounding-rectangle) (multiple-value-bind (left top right bottom) (climi::text-bounding-rectangle* medium str :text-style style) From ahefner at common-lisp.net Wed Dec 20 16:23:49 2006 From: ahefner at common-lisp.net (ahefner) Date: Wed, 20 Dec 2006 11:23:49 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061220162349.C71921900C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv3170 Modified Files: frames.lisp Log Message: In find-frame-manager, don't choose the current or default frame managers if this would contradict the :port argument. --- /project/mcclim/cvsroot/mcclim/frames.lisp 2006/12/17 00:29:14 1.121 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2006/12/20 16:23:49 1.122 @@ -30,14 +30,21 @@ ;;; Frame-Manager class +;; FIXME: The spec says the port must "conform to options". +;; I've added a check that the ports match, but we've no +;; protocol for testing the other options. -Hefner (defun find-frame-manager (&rest options &key port &allow-other-keys) (declare (special *frame-manager*)) - (if (boundp '*frame-manager*) + (if (and (boundp '*frame-manager*) + (or (null port) + (eql port (frame-manager-port *frame-manager*)))) *frame-manager* (if (and *default-frame-manager* - (frame-manager-p *default-frame-manager*)) + (frame-manager-p *default-frame-manager*) + (or (null port) + (eql port (frame-manager-port *default-frame-manager*)))) *default-frame-manager* - (first (frame-managers (or port (apply #'find-port options))))))) + (first (frame-managers (or port (apply #'find-port options))))))) (defmacro with-frame-manager ((frame-manager) &body body) `(let ((*frame-manager* ,frame-manager)) From dlichteblau at common-lisp.net Wed Dec 20 17:33:16 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Wed, 20 Dec 2006 12:33:16 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20061220173316.F162D6200C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv14222 Modified Files: text-size-test.lisp Log Message: more arrow positioning tweaks: better output for ascent/descent/height values that don't add up --- /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp 2006/12/20 14:42:51 1.5 +++ /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp 2006/12/20 17:33:16 1.6 @@ -98,8 +98,9 @@ (medium (sheet-medium stream))) (multiple-value-bind (width height final-x final-y baseline) (text-size stream str :text-style style) - (let ((x1 (/ (- pane-width width) 2)) - (y1 (/ (- pane-height height) 2))) + (let* ((x1 (/ (- pane-width width) 2)) + (y1 (/ (- pane-height height) 2)) + (ybase (+ y1 baseline))) (draw-text* stream (format nil "fixed-width-p: ~(~A~)" (handler-case @@ -127,17 +128,17 @@ (list "Text size (final x/y)" :ink +blue+))) (draw-vstrecke stream (- x1 20) - (+ y1 (text-style-ascent style medium)) - y1 + ybase + (- ybase (text-style-ascent style medium)) ;; :line-style (make-line-style :dashes '(1.5)) :ink +black+) (draw-vstrecke stream - (- x1 40) - (+ y1 baseline) - (+ y1 baseline (text-style-descent style medium)) + (- x1 20) + ybase + (+ ybase (text-style-descent style medium)) :ink +black+) (draw-vstrecke stream - (- x1 60) + (- x1 40) y1 (+ y1 (text-style-height style medium)) :line-style (make-line-style :thickness 2) @@ -148,12 +149,16 @@ (+ x1 (text-style-width style medium)) :ink +black+) (draw-line* stream - 0 (+ y1 baseline) - pane-width (+ y1 baseline) + 0 ybase + pane-width ybase :ink +green+) - (draw-text* stream str x1 (+ y1 baseline) :text-style style) - ;; Here an attempt at testing text with newlines, results are garbage - ;; even with CLIM-CLX: + (draw-text* stream str x1 ybase :text-style style) + ;; Gtkairo's DRAW-TEXT* understands multiple lines. + ;; (CLIM-CLX doesn't like multiple lines much.) + ;; + ;; If we use WRITE-STRING instead of DRAW-TEXT, the frontend will + ;; handle the line breaks, but lines 2..n will start at x = 0 rather + ;; than x = x1, confusing our diagram. ;;; (setf (stream-cursor-position stream) (values x1 y1)) ;;; (with-text-style (stream style) ;;; (write-string str stream)) From dlichteblau at common-lisp.net Wed Dec 20 18:45:37 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Wed, 20 Dec 2006 13:45:37 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061220184537.6CD037E09F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv27072 Modified Files: ffi.lisp gtk-ffi.lisp medium.lisp package.lisp Added Files: pango.lisp Log Message: Rewrote text drawing and font metric functions using Pango. * pango.lisp: New file. * gtk-ffi.lisp (PANGO_SCALE, PangoRectangle): New. * ffi.lisp: Regenerated. * medium.lisp (METRIK-MEDIUM, WITH-CAIRO-MEDIUM): Moved to pango.lisp. (MEDIUM-DRAW-TEXT*): Rewritten using Pango. (TEXT-STYLE-ASCENT, TEXT-STYLE-DESCENT, TEXT-STYLE-FIXED-WIDTH-P, TEXT-SIZE, TEXT-BOUNDING-RECTANGLE*): Methods on METRIK-MEDIUM deleted. * package.lisp: Export new variable *DEFAULT-FONT-FAMILIES*. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/12/10 16:34:32 1.8 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/12/20 18:45:37 1.9 @@ -194,6 +194,20 @@ :GTK_WINDOW_TOPLEVEL :GTK_WINDOW_POPUP) +(defcenum PangoStyle + :PANGO_STYLE_NORMAL + :PANGO_STYLE_OBLIQUE + :PANGO_STYLE_ITALIC) + +(defcenum PangoWeight + (:PANGO_WEIGHT_ULTRALIGHT 200) + (:PANGO_WEIGHT_LIGHT 300) + (:PANGO_WEIGHT_NORMAL 400) + (:PANGO_WEIGHT_SEMIBOLD 600) + (:PANGO_WEIGHT_BOLD 700) + (:PANGO_WEIGHT_ULTRABOLD 800) + (:PANGO_WEIGHT_HEAVY 900)) + (cffi:defcstruct Screen (ext_data :pointer) ;XExtData * (display :pointer) ;struct _XDisplay * @@ -694,12 +708,22 @@ (arg2 :double) ;double ) +(defcfun "g_free" + :void + (mem :pointer) ;gpointer + ) + (defcfun "g_idle_add" :unsigned-int (function :pointer) ;GSourceFunc (data :pointer) ;gpointer ) +(defcfun "g_object_unref" + :void + (_object :pointer) ;gpointer + ) + (defcfun "g_signal_connect_data" :unsigned-long (instance :pointer) ;gpointer @@ -827,6 +851,8 @@ (gc :pointer) ;GdkGC * ) +(defcfun "gdk_pango_context_get" :pointer) + (defcfun "gdk_pixmap_new" :pointer (drawable :pointer) ;GdkDrawable * @@ -1364,3 +1390,200 @@ (window :pointer) ;GtkWindow * (title :string) ;const gchar * ) + +(defcfun "pango_cairo_create_layout" + :pointer + (cr :pointer) ;cairo_t * + ) + +(defcfun "pango_cairo_show_layout" + :void + (cr :pointer) ;cairo_t * + (layout :pointer) ;PangoLayout * + ) + +(defcfun "pango_context_get_font_map" + :pointer + (context :pointer) ;PangoContext * + ) + +(defcfun "pango_context_get_metrics" + :pointer + (context :pointer) ;PangoContext * + (desc :pointer) ;const PangoFontDescription * + (language :pointer) ;PangoLanguage * + ) + +(defcfun "pango_context_list_families" + :void + (context :pointer) ;PangoContext * + (families :pointer) ;PangoFontFamily *** + (n_families :pointer) ;int * + ) + +(defcfun "pango_context_load_font" + :pointer + (context :pointer) ;PangoContext * + (desc :pointer) ;const PangoFontDescription * + ) + +(defcfun "pango_font_describe" + :pointer + (font :pointer) ;PangoFont * + ) + +(defcfun "pango_font_description_free" + :void + (desc :pointer) ;PangoFontDescription * + ) + +(defcfun "pango_font_description_from_string" + :pointer + (str :string) ;const char * + ) + +(defcfun "pango_font_description_get_family" + :string + (desc :pointer) ;const PangoFontDescription * + ) + +(defcfun "pango_font_description_new" :pointer) + +(defcfun "pango_font_description_set_absolute_size" + :void + (desc :pointer) ;PangoFontDescription * + (size :double) ;double + ) + +(defcfun "pango_font_description_set_family" + :void + (desc :pointer) ;PangoFontDescription * + (family :string) ;const char * + ) + +(defcfun "pango_font_description_set_size" + :void + (desc :pointer) ;PangoFontDescription * + (size :int) ;gint + ) + +(defcfun "pango_font_description_set_style" + :void + (desc :pointer) ;PangoFontDescription * + (style PangoStyle)) + +(defcfun "pango_font_description_set_weight" + :void + (desc :pointer) ;PangoFontDescription * + (weight PangoWeight)) + +(defcfun "pango_font_description_to_string" + :string + (desc :pointer) ;const PangoFontDescription * + ) + +(defcfun "pango_font_family_get_name" + :string + (family :pointer) ;PangoFontFamily * + ) + +(defcfun "pango_font_family_is_monospace" + :int + (family :pointer) ;PangoFontFamily * + ) + +(defcfun "pango_font_map_load_font" + :pointer + (fontmap :pointer) ;PangoFontMap * + (context :pointer) ;PangoContext * + (desc :pointer) ;const PangoFontDescription * + ) + +(defcfun "pango_font_metrics_get_approximate_char_width" + :int + (metrics :pointer) ;PangoFontMetrics * + ) + +(defcfun "pango_font_metrics_get_ascent" + :int + (metrics :pointer) ;PangoFontMetrics * + ) + +(defcfun "pango_font_metrics_get_descent" + :int + (metrics :pointer) ;PangoFontMetrics * + ) + +(defcfun "pango_font_metrics_unref" + :void + (metrics :pointer) ;PangoFontMetrics * + ) + +(defcfun "pango_layout_get_context" + :pointer + (layout :pointer) ;PangoLayout * + ) + +(defcfun "pango_layout_get_line" + :pointer + (layout :pointer) ;PangoLayout * + (line :int) ;int + ) + +(defcfun "pango_layout_get_line_count" + :int + (layout :pointer) ;PangoLayout * + ) + +(defcfun "pango_layout_get_pixel_extents" + :void + (layout :pointer) ;PangoLayout * + (ink_rect :pointer) ;PangoRectangle * + (logical_rect :pointer) ;PangoRectangle * + ) + +(defcfun "pango_layout_get_pixel_size" + :void + (layout :pointer) ;PangoLayout * + (width :pointer) ;int * + (height :pointer) ;int * + ) + +(defcfun "pango_layout_get_size" + :void + (layout :pointer) ;PangoLayout * + (width :pointer) ;int * + (height :pointer) ;int * + ) + +(defcfun "pango_layout_line_get_pixel_extents" + :void + (layout_line :pointer) ;PangoLayoutLine * + (ink_rect :pointer) ;PangoRectangle * + (logical_rect :pointer) ;PangoRectangle * + ) + +(defcfun "pango_layout_set_font_description" + :void + (layout :pointer) ;PangoLayout * + (desc :pointer) ;const PangoFontDescription * + ) + +(defcfun "pango_layout_set_single_paragraph_mode" + :void + (layout :pointer) ;PangoLayout * + (setting :int) ;gboolean + ) + +(defcfun "pango_layout_set_spacing" + :void + (layout :pointer) ;PangoLayout * + (spacing :int) ;int + ) + +(defcfun "pango_layout_set_text" + :void + (layout :pointer) ;PangoLayout * + (text :string) ;const char * + (length :int) ;int + ) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/12/10 19:33:05 1.19 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/12/20 18:45:37 1.20 @@ -350,16 +350,26 @@ (defconstant GTK_DOUBLE_BUFFERED (ash 1 21)) (defconstant GTK_NO_SHOW_ALL (ash 1 22)) +(defconstant PANGO_SCALE 1024) + +(cffi:defcstruct PangoRectangle + (x :int) + (y :int) + (width :int) + (height :int)) + ;; magic symbols for FFI code generation (defvar *dummy* - '(GdkFunction gtkselectionmode GtkScrollType GdkEventMask GdkEventType + '(GdkFunction gtkselectionmode GtkScrollType GdkEventMask GdkEventType GtkWidgetFlags GdkModifierType GdkCrossingMode GtkWindowType GdkGrabStatus GdkWindowHints GtkStateType GdkDragAction GConnectFlags GdkDragProtocol gdk_x11_drawable_get_xid + pangostyle pangoweight PangoRectangle PangoFontMetrics + cairo_format_t cairo_operator_t cairo_fill_rule_t cairo_line_cap_t cairo_line_join_t cairo_font_slant_t cairo_font_weight_t cairo_status_t cairo_filter_t cairo_extend_t)) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/12/03 15:24:09 1.13 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/12/20 18:45:37 1.14 @@ -44,9 +44,6 @@ (unless cr (setf (last-seen-sheet instance) nil))) -(defclass metrik-medium (gtkairo-medium) - ()) - (defparameter *antialiasingp* t) (defun gtkwidget-gdkwindow (widget) @@ -56,9 +53,6 @@ (or (climi::port-lookup-mirror (port medium) (medium-sheet medium)) (error "oops, drawing operation on unmirrored sheet ~A" medium))) -(defmacro with-cairo-medium ((medium) &body body) - `(invoke-with-cairo-medium (lambda () , at body) ,medium)) - (defun invoke-with-cairo-medium (fn medium) (when (or (cr medium) (climi::port-lookup-mirror (port medium) (medium-sheet medium))) @@ -635,14 +629,15 @@ (sync-transformation medium) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) - (sync-text-style medium - (merge-text-styles (medium-text-style medium) - (medium-default-text-style medium)) - transform-glyphs) - (cairo_move_to cr (df x) (df y)) (setf end (or end (length text))) - (unless (eql start end) ;empty string breaks cairo/windows - (cairo_show_text cr (subseq text start end)))))) + (unless (eql start end) + (with-pango-cairo (layout cr + :text-style medium + :text (subseq text start end)) + (let ((y2 + (nth-value 1 (pango-layout-line-get-pixel-extents layout 0)))) + (cairo_move_to cr (df x) (df (+ y y2)))) + (pango_cairo_show_layout cr layout)))))) (defmethod medium-finish-output ((medium gtkairo-medium)) (with-cairo-medium (medium) @@ -720,103 +715,45 @@ (let ((hash (make-hash-table))) (defmethod text-style-ascent :around (text-style (medium gtkairo-medium)) - (or (gethash text-style hash) + (or #-debug-metrik (gethash text-style hash) (setf (gethash text-style hash) (call-next-method))))) (defmethod text-style-ascent (text-style (medium gtkairo-medium)) (text-style-ascent text-style (metrik-medium (port medium)))) -(defmethod text-style-ascent (text-style (medium metrik-medium)) - (with-cairo-medium (medium) - (ceiling - (with-slots (cr) medium - (sync-sheet medium) - (cairo_identity_matrix cr) - (sync-text-style medium text-style t) - (cffi:with-foreign-object (res 'cairo_font_extents) - (cairo_font_extents cr res) - (slot res 'cairo_font_extents 'ascent)))))) - ;;; TEXT-STYLE-DESCENT (let ((hash (make-hash-table))) (defmethod text-style-descent :around (text-style (medium gtkairo-medium)) - (or (gethash text-style hash) + (or #-debug-metrik (gethash text-style hash) (setf (gethash text-style hash) (call-next-method))))) (defmethod text-style-descent (text-style (medium gtkairo-medium)) (text-style-descent text-style (metrik-medium (port medium)))) -(defmethod text-style-descent (text-style (medium metrik-medium)) - (with-cairo-medium (medium) - (ceiling - (with-slots (cr) medium - (sync-sheet medium) - (cairo_identity_matrix cr) - (sync-text-style medium text-style t) - (cffi:with-foreign-object (res 'cairo_font_extents) - (cairo_font_extents cr res) - (slot res 'cairo_font_extents 'descent)))))) - ;;; TEXT-STYLE-HEIGHT (let ((hash (make-hash-table))) (defmethod text-style-height :around (text-style (medium gtkairo-medium)) - (or (gethash text-style hash) + (or #-debug-metrik (gethash text-style hash) (setf (gethash text-style hash) (call-next-method))))) (defmethod text-style-height (text-style (medium gtkairo-medium)) (text-style-height text-style (metrik-medium (port medium)))) -(defmethod text-style-height (text-style (medium metrik-medium)) -;;; (with-cairo-medium (medium) -;;; (ceiling -;;; (with-slots (cr) medium -;;; (sync-sheet medium) -;;; (cairo_identity_matrix cr) -;;; (sync-text-style medium text-style t) -;;; (cffi:with-foreign-object (res 'cairo_font_extents) -;;; (cairo_font_extents cr res) -;;; ;; ### let's hope that cairo respects -;;; ;; height = ascent + descent. -;;; ;; -;;; ;; No, it expressly doesn't. Cairo documentation states that -;;; ;; height includes additional space that is meant to give more -;;; ;; aesthetic line spacing than ascent+descent would. Is that a -;;; ;; problem for us? --DFL -;;; (slot res 'cairo_font_extents 'height))))) - ;; OK, so it _does_ matter (see bug 15). - (+ (text-style-ascent text-style medium) - (text-style-descent text-style medium))) - ;;; TEXT-STYLE-WIDTH (let ((hash (make-hash-table))) (defmethod text-style-width :around (text-style (medium gtkairo-medium)) - (or (gethash text-style hash) + (or #-debug-metrik (gethash text-style hash) (setf (gethash text-style hash) (call-next-method))))) (defmethod text-style-width (text-style (medium gtkairo-medium)) (text-style-width text-style (metrik-medium (port medium)))) -(defmethod text-style-width (text-style (medium metrik-medium)) - (with-cairo-medium (medium) - (ceiling - (with-slots (cr) medium - (sync-sheet medium) - (cairo_identity_matrix cr) - (sync-text-style medium text-style t) - ;; This didn't work well for Climacs. --DFL -;;; (cffi:with-foreign-object (res 'cairo_text_extents) -;;; (cairo_text_extents cr "m" res) -;;; (slot res 'cairo_text_extents 'width)) - (cffi:with-foreign-object (res 'cairo_font_extents) - (cairo_font_extents cr res) - (slot res 'cairo_font_extents 'max_x_advance)))))) - ;;; TEXT-STYLE-FIXED-WIDTH-P @@ -824,26 +761,12 @@ (defmethod text-style-fixed-width-p :around (text-style (medium gtkairo-medium)) - (or (gethash text-style hash) + (or #-debug-metrik (gethash text-style hash) (setf (gethash text-style hash) (call-next-method))))) (defmethod text-style-fixed-width-p (text-style (medium gtkairo-medium)) (text-style-fixed-width-p text-style (metrik-medium (port medium)))) -(defmethod text-style-fixed-width-p (text-style (medium metrik-medium)) - (with-cairo-medium (medium) - (with-slots (cr) medium - (sync-sheet medium) - (cairo_identity_matrix cr) - (sync-text-style medium text-style t) - (cffi:with-foreign-object (res 'cairo_text_extents) - (let (i m) - (cairo-text-extents cr "i" res) - (setf i (slot res 'cairo_text_extents 'width)) - (cairo-text-extents cr "m" res) - (setf m (slot res 'cairo_text_extents 'width)) - (= i m)))))) - (defmethod text-size ((medium gtkairo-medium) string &key text-style (start 0) end) (with-gtk () @@ -870,71 +793,6 @@ :start start :end (or end (length string))))) -;; FIXME: TEXT-SIZE [and presumably TEXT-BOUNDING-RECTANGLE*, too] are -;; supposed to take newlines into account. The CLX backend code was -;; written to support that but does not -- T-B-R errors out and T-S -;; doesn't return what WRITE-STRING on the sheet actually does. So -;; let's not steal code from CLIM-CLX when it's broken. Doesn't -;; actually look like anyone has been depending on this after all. -;; -- DFL - -(defmethod text-size - ((medium metrik-medium) string &key text-style (start 0) end) - (with-cairo-medium (medium) - ;; -> width height final-x final-y baseline - (when (characterp string) (setf string (string string))) - (setf text-style (or text-style (make-text-style nil nil nil))) - (setf text-style - (merge-text-styles text-style (medium-default-text-style medium))) - (with-slots (cr) medium - (cairo_identity_matrix cr) - (sync-text-style medium text-style t) - (cffi:with-foreign-object (res 'cairo_text_extents) - (cairo-text-extents cr - (subseq string start (or end (length string))) - res) - (cffi:with-foreign-slots - ((x_advance height y_bearing) res cairo_text_extents) - (values - ;; use x_advance instead of width, since CLIM wants to trailing - ;; spaces to be taken into account. - (ceiling x_advance) - (ceiling height) - ;; Sames values again here: The CLIM spec states that these - ;; values differ only for multi-line text. And y_advance is 0 - ;; for european text, which is not what we want. --DFL - (ceiling x_advance) - (ceiling height) - ;; This used to be TEXT-STYLE-ASCENT, but see comment there. - (abs (ceiling y_bearing)))))))) - -(defmethod climi::text-bounding-rectangle* - ((medium metrik-medium) string &key text-style (start 0) end) - (with-cairo-medium (medium) - ;; -> left ascent right descent - (when (characterp string) (setf string (string string))) - (setf text-style (or text-style (make-text-style nil nil nil))) - (setf text-style - (merge-text-styles text-style (medium-default-text-style medium))) - (with-slots (cr) medium - (cairo_identity_matrix cr) - (sync-text-style medium text-style t) - (cffi:with-foreign-object (res 'cairo_text_extents) - (cairo-text-extents cr - (subseq string start (or end (length string))) - res) - ;; This used to be a straight call to TEXT-SIZE. Looking at - ;; what CLIM-CLX does, this looks better to me, but I'm not sure - ;; whether it's 100% right: - ;; --DFL - (cffi:with-foreign-slots - ((width height x_advance y_advance x_bearing y_bearing) - res cairo_text_extents) - (values (floor x_bearing) - (floor y_bearing) - (ceiling (+ width (max 0 x_bearing))) - (ceiling (+ height y_bearing)))))))) - ;;;; ------------------------------------------------------------------------ ;;;; General Designs ;;;; --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/package.lisp 2006/04/17 18:40:27 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/package.lisp 2006/12/20 18:45:37 1.2 @@ -3,4 +3,5 @@ (in-package :common-lisp-user) (defpackage :clim-gtkairo - (:use :clim :clim-lisp :clim-backend)) + (:use :clim :clim-lisp :clim-backend) + (:export #:*default-font-families*)) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/pango.lisp 2006/12/20 18:45:37 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/pango.lisp 2006/12/20 18:45:37 1.1 ;;; -*- Mode: Lisp; -*- ;;; (c) copyright 2006 David Lichteblau (david at lichteblau.com) ;;; 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. (in-package :clim-gtkairo) ;;; these shouldn't be here: (defclass metrik-medium (gtkairo-medium) ()) (defmacro with-cairo-medium ((medium) &body body) `(invoke-with-cairo-medium (lambda () , at body) ,medium)) ;;;; Helper macros. (defmacro with-pango-cairo ((layout-var cr &key text-style text) &body body) `(invoke-with-pango-cairo (lambda (,layout-var) , at body) ,cr :text-style ,text-style :text ,text)) (defmacro with-text-style-font-description ((var text-style) &body body) `(invoke-with-text-style-font-description (lambda (,var) , at body) ,text-style)) (defmacro with-font-description ((var description) &body body) `(invoke-with-font-description (lambda (,var) , at body) ,description)) (defmacro with-font-metrics ((var context desc) &body body) `(invoke-with-font-metrics (lambda (,var) , at body) ,context ,desc)) (defmacro with-pango-context ((var medium) &body body) `(invoke-with-pango-context (lambda (,var) , at body) ,medium)) (defun invoke-with-pango-cairo (fn cr &key text-style text) (let ((layout (pango_cairo_create_layout cr))) (unwind-protect (progn (when text-style (with-text-style-font-description (desc (etypecase text-style (text-style text-style) (medium (merge-text-styles (medium-text-style text-style) (medium-default-text-style text-style))))) (pango_layout_set_font_description layout desc))) (when text (pango_layout_set_text layout text -1)) (funcall fn layout)) (g_object_unref layout)))) (defun invoke-with-font-description (fn desc) (unwind-protect (funcall fn desc) (pango_font_description_free desc))) (defun invoke-with-text-style-font-description (fn text-style) (with-font-description (desc (make-font-description text-style)) (funcall fn desc))) (defun invoke-with-font-metrics (fn context desc) (let ((metrics (pango_context_get_metrics context desc (cffi:null-pointer)))) (unwind-protect (funcall fn metrics) (pango_font_metrics_unref metrics)))) (defun invoke-with-pango-context (fn medium) (declare (ignore medium)) ;fixme! (let ((context (gdk_pango_context_get))) (unwind-protect (funcall fn context) (g_object_unref context)))) ;;;; Pango text drawing and metric functions. (defvar *default-font-families* ;; Finding a good monospace font isn't easy: ;; - "Free Mono" is totally broken. ;; - "Courier", "Nimbus Mono L", "Andale Mono" have weird "Bold" face ;; metrics. ;; - "Courier New" and "Bitstream Vera Sans Mono" work well. ;; (Test case is Climacs.) '(:fix "Courier New" :serif "serif" :sans-serif "sans") "A plist mapping the standard font family keywords :fix, :serif, and :sans-serif to Pango font names. Example: (setf (getf *default-font-families* :fix) \"Bitstream Vera Sans Mono\")") (defun make-font-description (text-style) (multiple-value-bind (family face size) (text-style-components (merge-text-styles text-style *default-text-style*)) (when (listp face) ;; Ein Pfusch ist das! (setf face (intern (format nil "~A-~A" (symbol-name (first face)) (symbol-name (second face))) :keyword))) (let ((desc (pango_font_description_new)) (family (or (getf *default-font-families* (if (eq family :fixed) :fix family)) (error "unknown font family: ~A" family))) (weight (ecase face ((:roman :italic :oblique) :PANGO_WEIGHT_NORMAL) ((:bold :bold-italic :italic-bold :bold-oblique :oblique-bold) :PANGO_WEIGHT_BOLD))) (style (ecase face ((:roman :bold) :PANGO_STYLE_NORMAL) ((:italic :bold-italic :italic-bold) :PANGO_STYLE_ITALIC) ((:oblique :bold-oblique :oblique-bold) :PANGO_STYLE_OBLIQUE))) (size (case size (:normal 12) (:tiny 6) (:small 10) (:very-small 8) (:large 14) (:very-large 16) (:huge 24) (otherwise (truncate size))))) (pango_font_description_set_family desc family) (pango_font_description_set_weight desc weight) (pango_font_description_set_style desc style) (pango_font_description_set_size desc (* size PANGO_SCALE)) desc))) (defun pango-layout-get-pixel-size (layout) ;;; (cffi:with-foreign-object (rect 'pangorectangle) ;;; (pango_layout_get_pixel_extents ;;; layout ;;; (cffi:null-pointer) ;;; rect) ;;; (cffi:with-foreign-slots ((x y width height) rect pangorectangle) ;;; (tr x y width height) ;;; (values width (- height y)))) (cffi:with-foreign-object (&w :int) (cffi:with-foreign-object (&h :int) (pango_layout_get_pixel_size layout &w &h) (values (cffi:mem-aref &w :int) (cffi:mem-aref &h :int))))) (defun pango-layout-line-get-pixel-extents (layout line-index) (when (minusp line-index) (incf line-index (pango_layout_get_line_count layout))) (cffi:with-foreign-object (rect 'pangorectangle) (pango_layout_line_get_pixel_extents (pango_layout_get_line layout line-index) (cffi:null-pointer) rect) (cffi:with-foreign-slots ((x y width height) rect pangorectangle) (values x y width height)))) (defun pango-layout-get-ink-rectangle (layout) (cffi:with-foreign-object (rect 'pangorectangle) (pango_layout_get_pixel_extents layout rect (cffi:null-pointer)) (cffi:with-foreign-slots ((x y width height) rect pangorectangle) (values x y width height)))) (defmethod text-size ((medium metrik-medium) string &key text-style (start 0) end) (with-cairo-medium (medium) ;; -> width height final-x final-y baseline (when (characterp string) (setf string (string string))) (setf text-style (or text-style (make-text-style nil nil nil))) (setf text-style (merge-text-styles text-style (medium-default-text-style medium))) (with-slots (cr) medium (cairo_identity_matrix cr) (with-pango-cairo (layout cr :text-style text-style :text (unless (eql start end) (subseq string start end))) (multiple-value-bind (width height) (pango-layout-get-pixel-size layout) (multiple-value-bind (first-x first-y first-width first-height) (pango-layout-line-get-pixel-extents layout 0) (declare (ignorable first-x first-y first-width first-height)) (multiple-value-bind (final-x final-y final-width final-height) (pango-layout-line-get-pixel-extents layout -1) (declare (ignorable final-x final-y final-width final-height)) (values width height final-width (- height final-height) (abs first-y))))))))) (defmethod climi::text-bounding-rectangle* ((medium metrik-medium) string &key text-style (start 0) end) (with-cairo-medium (medium) ;; -> left ascent right descent (when (characterp string) (setf string (string string))) (setf text-style (or text-style (make-text-style nil nil nil))) (setf text-style (merge-text-styles text-style (medium-default-text-style medium))) (with-slots (cr) medium (cairo_identity_matrix cr) (with-pango-cairo (layout cr :text-style text-style :text (unless (eql start end) (subseq string start end))) (multiple-value-bind (x y width height) (pango-layout-get-ink-rectangle layout) (let* ((first-y (nth-value 1 (pango-layout-line-get-pixel-extents layout 0))) (ascent (- (abs first-y) y))) (values x (ceiling (- ascent)) (ceiling (+ width (max 0 x))) (ceiling (- height ascent))))))))) ;; (pango_layout_get_context layout) (defun pango-context-list-families (context) (cffi:with-foreign-object (&families :pointer) (cffi:with-foreign-object (&n :int) (pango_context_list_families context &families &n) (let ((families (cffi:mem-aref &families :pointer))) (prog1 (loop for i from 0 below (cffi:mem-aref &n :int) collect (cffi:mem-aref families :pointer i)) (g_free families)))))) (defun resolve-font-description (context desc) (pango_font_describe (pango_context_load_font context desc))) (defun font-description-to-font-family (context desc) (with-font-description (desc* (resolve-font-description context desc)) (find (pango_font_description_get_family desc*) (pango-context-list-families context) :key #'pango_font_family_get_name :test #'equal))) (defmethod text-style-fixed-width-p (text-style (medium metrik-medium)) (with-gtk () (with-pango-context (context medium) (with-text-style-font-description (desc text-style) (let ((family (font-description-to-font-family context desc))) (assert family) (not (zerop (pango_font_family_is_monospace family)))))))) (defmethod text-style-ascent (text-style (medium metrik-medium)) (with-gtk () (with-pango-context (context medium) (with-text-style-font-description (desc text-style) (with-font-metrics (metrics context desc) (ceiling (pango_font_metrics_get_ascent metrics) PANGO_SCALE))))) ;; here's a dummy implementation guaranteing ascent+descent=height: ;; we don't seem to need it though. ;;; (multiple-value-bind (width height final-x final-y baseline) ;;; (text-size medium "foo" :text-style text-style) ;;; (declare (ignore width height final-x final-y)) ;;; baseline) ) (defmethod text-style-descent (text-style (medium metrik-medium)) (with-gtk () (with-pango-context (context medium) (with-text-style-font-description (desc text-style) (with-font-metrics (metrics context desc) (ceiling (pango_font_metrics_get_descent metrics) PANGO_SCALE))))) ;; here's a dummy implementation guaranteing ascent+descent=height: ;; we don't seem to need it though. ;;; (multiple-value-bind (width height final-x final-y baseline) ;;; (text-size medium "foo" :text-style text-style) ;;; (declare (ignore width final-x final-y)) ;;; (- height baseline)) ) (defmethod text-style-height (text-style (medium metrik-medium)) (nth-value 1 (text-size medium "foo" :text-style text-style)) ;; here's a dummy implementation guaranteing ascent+descent=height, ;; leading to less inter-line space. ;;; (+ (text-style-ascent text-style medium) ;;; (text-style-descent text-style medium)) ) (defmethod text-style-width (text-style (medium metrik-medium)) (with-gtk () (with-pango-context (context medium) (with-text-style-font-description (desc text-style) (with-font-metrics (metrics context desc) (ceiling (pango_font_metrics_get_approximate_char_width metrics) PANGO_SCALE)))))) From dlichteblau at common-lisp.net Wed Dec 20 18:45:54 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Wed, 20 Dec 2006 13:45:54 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061220184554.74645471E4@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv27156 Modified Files: mcclim.asd Log Message: Rewrote text drawing and font metric functions using Pango. * pango.lisp: New file. * gtk-ffi.lisp (PANGO_SCALE, PangoRectangle): New. * ffi.lisp: Regenerated. * medium.lisp (METRIK-MEDIUM, WITH-CAIRO-MEDIUM): Moved to pango.lisp. (MEDIUM-DRAW-TEXT*): Rewritten using Pango. (TEXT-STYLE-ASCENT, TEXT-STYLE-DESCENT, TEXT-STYLE-FIXED-WIDTH-P, TEXT-SIZE, TEXT-BOUNDING-RECTANGLE*): Methods on METRIK-MEDIUM deleted. * package.lisp: Export new variable *DEFAULT-FONT-FAMILIES*. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/12/20 01:37:01 1.40 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/12/20 18:45:54 1.41 @@ -386,6 +386,7 @@ (:file "port") (:file "event") (:file "keys") + (:file "pango") (:file "medium") (:file "pixmap") (:file "frame-manager") From dlichteblau at common-lisp.net Wed Dec 20 19:26:14 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Wed, 20 Dec 2006 14:26:14 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061220192614.025B02201E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv2627 Modified Files: ffi.lisp gtk-ffi.lisp Log Message: Restore windows buildability once again. * gtk-ffi.lisp (gdk_x11_drawable_get_xid): Moved from ffi.lisp. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/12/20 18:45:37 1.9 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/12/20 19:26:14 1.10 @@ -932,11 +932,6 @@ (invalidate_children :int) ;gboolean ) -(defcfun "gdk_x11_drawable_get_xid" - :unsigned-long - (drawable :pointer) ;GdkDrawable * - ) - (defcfun "gtk_adjustment_new" :pointer (value :double) ;gdouble --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/12/20 18:45:37 1.20 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/12/20 19:26:14 1.21 @@ -327,6 +327,12 @@ (nbytes :int) ;int ) +#-(or win32 windows mswindows) +(defcfun "gdk_x11_drawable_get_xid" + :unsigned-long + (drawable :pointer) ;GdkDrawable * + ) + (defconstant GDK_CURRENT_TIME 0) ;; fixme: GtkWidgetFlags is an enum, why is it not in the object file? From dlichteblau at common-lisp.net Wed Dec 20 19:40:11 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Wed, 20 Dec 2006 14:40:11 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061220194011.11FB022029@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv4284 Modified Files: gtk-ffi.lisp Log Message: load pango explicitly on windows --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/12/20 19:26:14 1.21 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/12/20 19:40:10 1.22 @@ -40,7 +40,9 @@ (cffi:load-foreign-library "libgthread-2.0-0.dll") (cffi:load-foreign-library "libgobject-2.0-0.dll") (cffi:load-foreign-library "libgdk-win32-2.0-0.dll") - (cffi:load-foreign-library "libgtk-win32-2.0-0.dll")) + (cffi:load-foreign-library "libgtk-win32-2.0-0.dll") + (cffi:load-foreign-library "libpangocairo-1.0-0.dll") + (cffi:load-foreign-library "libpango-1.0-0.dll")) (defmacro defcfun (name rtype &rest argtypes) (if (and (eq rtype 'cairo_status_t) From dlichteblau at common-lisp.net Wed Dec 20 20:07:10 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Wed, 20 Dec 2006 15:07:10 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061220200710.5202C2202F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv8647 Modified Files: NEWS Log Message: updated --- /project/mcclim/cvsroot/mcclim/NEWS 2006/12/14 22:02:16 1.13 +++ /project/mcclim/cvsroot/mcclim/NEWS 2006/12/20 20:07:10 1.14 @@ -6,6 +6,9 @@ *** Some bugfixes, including CMUCL support and better key event handling. *** Native implementation of context menus, list panes, label panes, and option panes. +*** Draw text using Pango. (Bug fix: Fixed-width font supported on Windows + now. Multiple lines of output in TEXT-SIZE supported now. + TEXT-STYLE-FIXED-WIDTH-P works correctly now.) ** Improvement: Added new editor substrate ("Drei"). ** Improvement: Improved the pathname presentation methods considerably. ** specification compliance: DELETE-GESTURE-NAME function now implemented. From thenriksen at common-lisp.net Wed Dec 20 22:58:20 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 20 Dec 2006 17:58:20 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061220225820.443FD1019@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv5511 Modified Files: text-editor-gadget.lisp Log Message: Fixed the `compose-space' method for Drei-based text-editor-panes to suck less and be more correct. The :nlines value will still not work properly due to McCLIM layouting brokenness. Also changed the `text-editor' gadget to use a completely standard Drei gadget-pane, without minibuffer, scrollbars and anything else. This is necessary because we need to return the actual pane object from the function, so we can't wrap it in nice things like borders, scrollbars or a minibuffer. Use the :drei gadget for the nice version. --- /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp 2006/12/19 04:02:14 1.6 +++ /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp 2006/12/20 22:58:20 1.7 @@ -97,24 +97,24 @@ args)) (defmethod compose-space ((pane text-editor-pane) &key width height) - (declare (ignore width height)) (with-sheet-medium (medium pane) (let* ((text-style (medium-text-style medium)) - (tr-height (text-style-height text-style medium)) - (tr-width (text-style-width text-style medium)) - (padding (- (bounding-rectangle-width pane) - (stream-text-margin pane)))) + (line-height (+ (text-style-height text-style medium) + (stream-vertical-spacing pane))) + (column-width (text-style-width text-style medium))) (with-accessors ((ncolumns text-editor-ncolumns) (nlines text-editor-nlines)) pane - (apply #'make-space-requirement - (append (when ncolumns - (let ((width (max (+ (* ncolumns tr-width)) - (bounding-rectangle-width (stream-current-output-record pane))))) - (list :width width :max-width width :min-width width))) - (when nlines - (let ((height (+ (* nlines tr-height) (* 2 padding) - (stream-vertical-spacing pane)))) - (list :height height :max-height height :min-height height))))))))) + (apply #'space-requirement-combine* #'(lambda (req1 req2) + (or req2 req1)) + (call-next-method) + (let ((width (if ncolumns + (+ (* ncolumns column-width)) + width)) + (height (if nlines + (+ (* nlines line-height)) + height))) + (list :width width :max-width width :min-width width + :height height :max-height height :min-height height))))))) (defmethod allocate-space ((pane text-editor-pane) w h) (resize-sheet pane w h)) @@ -289,7 +289,4 @@ &rest args &key) (if *use-goatee* (apply #'make-pane-1 fm frame 'goatee-text-editor-pane args) - (apply #'make-pane-1 fm frame :drei - :drei-class 'text-editor-pane - :minibuffer t - args))) + (apply #'make-pane-1 fm frame 'text-editor-pane args))) From thenriksen at common-lisp.net Thu Dec 21 00:38:16 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 20 Dec 2006 19:38:16 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061221003816.CC5C62E1BA@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv22119/Drei Modified Files: drei-clim.lisp Log Message: Fixed `gadget-value' to work when there are non-characters in the buffer. Also only cons up an array if there is actually a callback to invoke. And scrub the :syntax and :drei-class keyword arguments before constructing the actual Drei pane for the :drei abstract pane. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/12/04 22:31:18 1.13 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/12/21 00:38:14 1.14 @@ -227,8 +227,15 @@ (activate-gadget drei)) (defmethod gadget-value ((gadget drei-gadget-pane)) - (buffer-substring (buffer gadget) - 0 (size (buffer gadget)))) + ;; This is supposed to be a string, but a Drei buffer can contain + ;; literal objects. We return a string if we can, an array + ;; otherwise. This is a bit slow, as we cons up the array and then + ;; probably a new one for the string, most of the time. + (let ((contents (buffer-sequence (buffer gadget) + 0 (size (buffer gadget))))) + (if (every #'characterp contents) + (coerce contents 'string) + contents))) (defmethod (setf gadget-value) (new-value (gadget drei-gadget-pane) &key (invoke-callback t)) @@ -287,7 +294,8 @@ (abort-gesture () (display-message "Aborted"))) (display-drei drei) - (when (modified-p (buffer drei)) + (when (and (modified-p (buffer drei)) + (gadget-value-changed-callback drei)) (clear-modify (buffer drei)) (value-changed-callback drei (gadget-client drei) @@ -404,7 +412,8 @@ (check-type initial-contents array) (check-type border-width integer) (check-type scroll-bars (member t :both :vertical :horizontal nil)) - (with-keywords-removed (args (:minibuffer :scroll-bars :border-width :syntax)) + (with-keywords-removed (args (:minibuffer :scroll-bars :border-width + :syntax :drei-class)) (let* ((borderp (and border-width (plusp border-width))) (minibuffer-pane (cond ((eq minibuffer t) (make-pane 'drei-minibuffer-pane)) From thenriksen at common-lisp.net Thu Dec 21 10:36:40 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 21 Dec 2006 05:36:40 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061221103640.0374E5C167@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv23679 Modified Files: pointer-tracking.lisp package.lisp NEWS Log Message: Implemented `pointer-place-rubber-band-line*', `pointer-input-rectangle*' and `pointer-input-rectangle' (CLIM 2.2). --- /project/mcclim/cvsroot/mcclim/pointer-tracking.lisp 2006/03/10 21:58:13 1.17 +++ /project/mcclim/cvsroot/mcclim/pointer-tracking.lisp 2006/12/21 10:36:40 1.18 @@ -295,7 +295,7 @@ (return-from drag-output-record (values x y))))))))) (defmacro dragging-output ((&optional (stream '*standard-output*) &rest args - &key repaint finish-on-release multiple-window) + &key (repaint t) finish-on-release multiple-window) &body body) (declare (ignore repaint finish-on-release multiple-window)) (setq stream (stream-designator-symbol stream '*standard-output*)) @@ -304,4 +304,156 @@ , at body))) (drag-output-record ,stream ,record :erase-final t , at args)))) +(defun dragging-drawing (stream drawer &key (finish-on-release t) + (pointer (port-pointer (port stream))) + multiple-window) + "Draws something simple in response to pointer events for +`pointer' and returns the coordinates of the pointer when the +function finishes. The function finishes when mouse button one is +no longer held down if `finish-on-release' is true; if it is +false, it finishes when the mouse is clicked. `Drawer' should +draw something on `stream', and is called with tree arguments: +two integers, the X and the Y coordinates for the pointer motion +triggering the draw, and either the symbol `:draw' or `:erase' +signalling what the function should do. `Drawer' will be called +with the previously used coordinates whenever pointer motion +occurs, so it can erase the previous output (elegantly done by +using `+flipping-ink+' for drawing and ignoring the state +symbol)." + (with-output-recording-options (stream :draw t :record nil) + (let ((ox nil) (oy nil)) ; So we can erase the old line. + (labels ((draw (x y) + (funcall drawer x y :draw)) + (erase (x y) + (funcall drawer x y :erase)) + (motion (x y) + (when ox (erase ox oy)) + (draw x y) + (setf ox x oy y)) + (end (event x y) + (when (eql (event-sheet event) stream) + (when ox (draw ox oy)) + (return-from dragging-drawing + (values x y))))) + ;; Make an initial draw. We need to convert the screen + ;; coordinates from the pointer into sheet-local coordinates. + (multiple-value-call #'transform-position + (sheet-native-transformation stream) (pointer-position pointer)) + (tracking-pointer (stream :pointer pointer + :multiple-window multiple-window) + (:pointer-motion (window x y) + (when (eql window stream) + (motion x y))) + (:pointer-button-press (event x y) + (end event x y)) + (:pointer-button-release (event x y) + (when finish-on-release + (end event x y)))))))) +(defun pointer-place-rubber-band-line* (&key (stream *standard-output*) + (pointer (port-pointer (port stream))) + multiple-window start-x start-y + (finish-on-release t)) + "Let the user drag a line on `stream', returning the +coordinates of the line ends as four values. `Pointer' is the +pointer that will be tracked (the default should be used unless +the port has multiple pointing devices), `multiple-window' is +currently unimplemented and `start-x'/`start-y', if provided (and +both or none must be provided) are the coordinates for one end of +the line. If these arguments are not provided, the user will have +to press a mouse button to specify the beginning of the line. If +`finish-on-release' is true, the function will end when the user +releases the mouse button. If false, the user will have to click +to finish inputting the line." + (assert (not (eq (not (not start-x)) (not start-y))) nil + "You must provide either both `:start-x' and `:start-y' +or none at all") + (or start-x + (block nil + (tracking-pointer (stream :pointer pointer + :multiple-window multiple-window) + (:pointer-button-press (event x y) + (declare (ignore event)) + (setf start-x x) + (setf start-y y) + (return))))) + (assert (and (>= start-x 0) (>= start-y 0))) + (labels ((draw (x y state) + (declare (ignore state)) + (with-drawing-options (stream :ink +flipping-ink+) + (draw-line* stream start-x start-y x y)))) + (multiple-value-call #'values + (values start-x start-y) + (dragging-drawing stream #'draw :finish-on-release finish-on-release + :pointer pointer :multiple-window multiple-window)))) + +;; The CLIM 2.2 spec is slightly unclear about how the next two +;; functions are supposed to behave, especially wrt. the user +;; experience. I think these functions are supposed to present a +;; rectangle on screen and let the user drag around the edges - this +;; would make supporting both left/top and right/bottom make sense, +;; and provide a way for the :rectangle argument to +;; `pointer-input-rectangle' to make sense. However, this would be a +;; very weird user experience, so I (Troels) have instead chosen to +;; consider left/top and right/bottom to be the same thing, preferring +;; left/top if both are specified. The :rectangle argument to +;; `pointer-input-rectangle' is ignored. The user is meant to drag out +;; a rectangle with the mouse, possibly by first providing a starting +;; point. This is intuitive behavior and I see no point in supporting +;; something more complicated. These changes should be invisible to +;; the calling program. + +(defun pointer-input-rectangle* (&key (stream *standard-output*) + (pointer (port-pointer (port stream))) + multiple-window left top right bottom + (finish-on-release t)) + "Let the user drag a rectangle on `stream' and return four +values, the coordinates of the rectangle. `Pointer' is the +pointer that will be tracked (the default should be used unless +the port has multiple pointing devices), `multiple-window' is +currently unimplemented and both `left'/`top' and +`right'/`bottom' specify an initial position for a rectangle +corner. You must provide either both parts of any of these two +coordinate pairs or none at all. If you provide both `left'/`top' +and `right'/`bottom', the `left'/`top' values will be used, +otherwise, the non-nil set will be used. If neither is specified, +the user will be able to specify the origin corner of the +rectangle by clicking the mouse. If `finish-on-release' is true, +the function will end when the user releases the mouse button. If +false, the user will have to click to finish inputting the +rectangle." + (assert (not (eq (not (not top)) (not left))) nil + "You must provide either none or both of `:top' and `:left'") + (assert (not (eq (not (not right)) (not bottom))) nil + "You must provide either none or both of `:right' and `:bottom'") + (setf top (or top bottom) + left (or left right)) + (unless top + (block nil + (tracking-pointer (stream :pointer pointer + :multiple-window multiple-window) + (:pointer-button-press (event x y) + (declare (ignore event)) + (setf left x) + (setf top y) + (return))))) + (multiple-value-bind (x y) + (labels ((draw (x y state) + (declare (ignore state)) + (with-drawing-options (stream :ink +flipping-ink+) + (draw-rectangle* stream left top x y :filled nil)))) + (dragging-drawing stream #'draw :finish-on-release finish-on-release + :pointer pointer :multiple-window multiple-window)) + ;; Normalise so that x1 < x2 ^ y1 < y2. + (values (min left x) (min top y) + (max left x) (max top y)))) + +(defun pointer-input-rectangle (&rest args &key (stream *standard-output*) + (pointer (port-pointer (port stream))) + multiple-window rectangle + (finish-on-release t)) + "Like `pointer-input-rectangle*', but returns a bounding +rectangle instead of coordinates." + (declare (ignore pointer multiple-window rectangle finish-on-release)) + (with-keywords-removed (args (:rectangle)) + (apply #'make-bounding-rectangle (apply #'pointer-input-rectangle args)))) --- /project/mcclim/cvsroot/mcclim/package.lisp 2006/12/10 23:35:12 1.56 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2006/12/21 10:36:40 1.57 @@ -1110,7 +1110,10 @@ #:pointer-event-x ;generic function #:pointer-event-y ;generic function #:pointer-exit-event ;class + #:pointer-input-rectangle ;function (in franz user guide) + #:pointer-input-rectangle* ;function (in franz user guide) #:pointer-motion-event ;class + #:pointer-place-rubber-band-line* ;function (in franz user guide) #:pointer-position ;generic function #:pointer-sheet ;generic function #:pointerp ;predicate --- /project/mcclim/cvsroot/mcclim/NEWS 2006/12/20 20:07:10 1.14 +++ /project/mcclim/cvsroot/mcclim/NEWS 2006/12/21 10:36:40 1.15 @@ -18,6 +18,12 @@ implemented. ** specification compliance: DISPLAY-COMMAND-MENU function now implemented. +** specification compliance: POINTER-PLACE-RUBBER-BAND-LINE* function + now implemented. +** specification compliance: POINTER-INPUT-RECTANGLE* function now + implemented. +** specification compliance: POINTER-INPUT-RECTANGLE function now + implemented. * Changes in mcclim-0.9.3 "All Souls' Day" relative to 0.9.2: ** backend improvement: The Null backend now registers itself in the From thenriksen at common-lisp.net Thu Dec 21 12:22:03 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 21 Dec 2006 07:22:03 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc Message-ID: <20061221122203.874457B021@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv9563 Modified Files: mcclim.texi drei.texi Makefile Added Files: make-tempfiles.sh make-docstrings.lisp docstrings.lisp DOCBUILDING Log Message: Added new doc-building system that extracts docstrings from McCLIM itself. Inspired by SBCL. --- /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi 2006/11/14 18:44:27 1.2 +++ /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi 2006/12/21 12:22:02 1.3 @@ -52,6 +52,7 @@ @end macro @alias gloss = i + at alias func = code @alias class = code @alias package = code @alias gadget = code @@ -107,7 +108,7 @@ Index * Concept Index:: * Variable Index:: -* Function Index:: +* Function And Macro Index:: @end menu @node Introduction @@ -2299,18 +2300,18 @@ cosmetic fixes to McCLIM and also worked on a GTK-like gadget set. He finally started work to get the OpenGL backend operational. - at node {Concept Index} - at unnumbered {Concept Index} + at node Concept Index + at unnumbered Concept Index @printindex cp - at node {Variable Index} - at unnumbered {Variable Index} + at node Variable Index + at unnumbered Variable Index @printindex vr - at node {Function And Macro Index} - at unnumbered {Function And Macro Index} + at node Function And Macro Index + at unnumbered Function And Macro Index @printindex fn --- /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2006/11/14 18:44:27 1.1 +++ /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2006/12/21 12:22:02 1.2 @@ -8,10 +8,9 @@ @cindex text-field Drei - an acronym for @i{Drei Replaces EINE's Inheritor} - is one of the -editor substrates provided by McCLIM. It is currently disabled by -default (instead, a somewhat less sophisticated editor substrate, -Goatee, is used), but it can be activated by evaluating @code{(setf -clim-internals::*use-goatee* nil)}. +editor substrates provided by McCLIM. Drei is activated by default, but +if it gives you problem, you can disable it by evaluating @code{(setf +clim-internals::*use-goatee* t)}. @menu * Drei Concepts:: The core Drei concepts and design philosophy. @@ -126,12 +125,7 @@ @node External API @section External API - at deftp {Class} drei - -The abstract Drei class that maintains standard Drei editor state. It -should not be directly instantiated, a subclass implementing specific -behavior should be used instead. - at end deftp + at include class-drei-drei.texi @deftp {@class{drei} Initarg} {:editable-p} Whether or not the Drei instance will be editable. If @cl{NIL}, the @@ -145,94 +139,19 @@ an attempt is made to insert a newline character. @end deftp - at deffn {Generic Function} {view} drei - at deffnx {Generic Function} {(setf view)} view drei - at findex view -The CLIM view that will be used whenever @var{drei} is being -displayed. During redisplay, the @cl{stream-default-view} of the editor -pane will be temporarily bound to this value. - at end deffn - - at deffn {Generic Function} {kill-ring} drei - at deffnx {Generic Function} {(setf kill-ring)} kill-ring drei - at findex view - -The kill ring object used by @var{drei}. - at end deffn - - at deffn {Generic Function} {previous-command} drei - at deffnx {Generic Function} {(setf previous-command)} command drei - at findex previous-command - -The previous command executed by @var{drei}. - at end deffn - - at deffn {Generic Function} {minibuffer} drei - at deffnx {Generic Function} {(setf minibuffer)} pane drei - at findex minibuffer - -The minibuffer associated with @var{drei}. This may be @cl{NIL}. - at end deffn + at include macro-drei-handling-drei-conditions.texi - at defmac {handling-drei-conditions} &body body - at findex handling-drei-conditions - -Evaluate `body' while handling Drei user notification signals. The -handling consists of displaying their meaning to the user in the -minibuffer. This is the macro that ensures conditions such as - at cl{motion-before-end} does not land the user in the debugger. - at end defmac - - at defmac {with-bound-drei-special-variables} {((drei-instance &key current-buffer current-window current-mark current-point current-syntax kill-ring minibuffer command-parser partial-command-parser previous-command prompt) &body body)} - -Evaluate @var{body} with Drei special variables bound to their proper -values, taken from @var{drei-instance}. The keyword arguments can be -used to provide forms that will be used to obtain values for the -respective special variables instead of the default. This macro binds -all of the special variables listed in @ref{Special Variables}, but also -some CLIM special variables needed for ESA-style command parsing. - at end defmac - - at defmac {performing-drei-operations} {((drei &rest args &key with-undo (update-syntax t) (redisplay t)) &body body)} - -Provide various Drei convenience services around the evaluation of - at var{body}. This macro provides a convenient way to perform some -operations on a Drei, and make sure that they are properly reflected in -the undo tree, that the Drei is redisplayed, the syntax updated, -etc. Exactly what is done can be controlled via the keyword -arguments. Note that if @var{:with-undo'} is false (the default), the - at emph{entire} undo history will be cleared after @var{body} has been -evaluated. This macro expands into a call to - at cl{invoke-performing-drei-operations}. - at end defmac - - at deffn {Generic Function} {invoke-performing-drei-operations} {(drei continuation &key with-undo update-syntax redisplay)} - -Implement the behavior of @cl{performing-drei-operations}. - at end deffn + at include macro-drei-with-bound-drei-special-variables.texi - at deffn {Generic Function} {execute-drei-command} drei command + at include macro-drei-performing-drei-operations.texi -Execute @var{command} for @var{drei}. This is the standard function for -executing Drei commands - it will take care of reporting to the user if -a condition is signalled, updating the syntax, setting the - at cl{previous-command} of @var{drei} and recording the operations -performed by @var{command} for undo. - at end deffn + at include fun-drei-invoke-performing-drei-operations.texi - at defmac {accepting-from-user} ((drei) &body body) -Modidfy @var{drei} and the environment so that calls to @cl{accept} can -be done to arbitrary streams from within @var{body}. Or, at least, make -sure the Drei instance will not be a problem. When Drei calls a command, -it will be wrapped in this macro, so it should be safe to use - at cl{accept} within Drei commands. This macro expands into a call to - at cl{invoke-accepting-from-user} - at end defmac + at include macro-drei-accepting-from-user.texi - at deffn {Generic Function} {invoke-accepting-from-user} {(drei continuation)} + at include fun-drei-invoke-accepting-from-user.texi -Implement the behavior of @cl{performing-drei-operations}. - at end deffn + at include fun-drei-execute-drei-command.texi @node Standard Drei Variants @section Standard Drei Variants @@ -292,370 +211,112 @@ @node General Buffer Protocol Parts @subsubsection General Buffer Protocol Parts - at deftp {Protocol Class} buffer - -The base class for all buffers. A buffer conceptually contains a -large array of arbitrary objects. Lines of objects are separated by -newline characters. The last object of the buffer is not -necessarily a newline character. - at end deftp - - at deftp {Class} standard-buffer - -The standard instantiable class for buffers. A subclass of buffer. - at end deftp - - at deftp {Protocol Class} mark - -The base class for all marks. - at end deftp - - at deftp {@class{buffer} Initarg} :buffer - -The :buffer initarg is mandatory because no mark can exist without a -buffer. - at end deftp - - at deftp {@class{buffer} Initarg} :offset - -If an :offset initarg is given that is less than zero or greater than -the size of the buffer, a no-such-offset condition is signaled. When the -:offset initarg is not given, it defaults to zero. - at end deftp - - at deftp {Protocol Class} left-sticky-mark - -A subclass of mark. A mark of this type will "stick" to the object -to the left of it, i.e. when an object is inserted at this mark, the -mark will be positioned to the left of the object. - at end deftp - - at deftp {Protocol Class} right-sticky-mark - -A subclass of mark. A mark of this type will "stick" to the object -to the right of it, i.e. when an object is inserted at this mark, the -mark will be positioned to the right of the object. - at end deftp - - at deffn {Generic Function} {clone-mark} mark &optional stick-to - -Clone a mark. By default (when stick-to is NIL) the same type of mark -is returned. Otherwise stick-to is either :left, indicating that a -left-sticky-mark should be created, or :right indicating that a -right-sticky-mark should be created. - at end deffn - - at deffn {Generic Function} {buffer} mark - -Return the buffer that the mark is positioned in. - at end deffn + at include class-drei-buffer-buffer.texi - at deftp {Error Condition} no-such-offset + at include class-drei-buffer-standard-buffer.texi -This condition is signaled whenever an attempt is made to access an -object that is before the beginning or after the end of the buffer. - at end deftp + at include class-drei-buffer-mark.texi - at deftp {Error Condition} offset-before-beginning + at include class-drei-buffer-left-sticky-mark.texi -This condition is signaled whenever an attempt is made to access -buffer contents that is before the beginning of the buffer. -This condition is a subclass of no-such-offset - at end deftp + at include class-drei-buffer-right-sticky-mark.texi - at deftp {Error Condition} offset-after-end + at include fun-drei-buffer-offset.texi -This condition is signaled whenever an attempt is made to access -buffer contents that is after the end of the buffer. -This condition is a subclass of no-such-offset - at end deftp + at include fun-drei-buffer-setf-offset.texi - at deftp {Error Condition} invalid-motion + at include fun-drei-buffer-clone-mark.texi -This condition is signaled whenever an attempt is made to move a mark -before the beginning or after the end of the buffer. - at end deftp + at include fun-drei-buffer-buffer.texi - at deftp {Error Condition} motion-before-beginning + at include condition-drei-buffer-no-such-offset.texi -This condition is signaled whenever an attempt is made to move a mark -before the beginning of the buffer. -This condition is a subclass of invalid-motion. - at end deftp + at include condition-drei-buffer-offset-before-beginning.texi - at deftp {Error Condition} motion-after-end + at include condition-drei-buffer-offset-after-end.texi -This condition is signaled whenever an attempt is made to move a mark -after the end of the buffer. -This condition is a subclass of invalid-motion. - at end deftp + at include condition-drei-buffer-invalid-motion.texi - at deffn {Generic Function} {size} buffer + at include condition-drei-buffer-motion-before-beginning.texi -Return the number of objects in the buffer. - at end deffn + at include condition-drei-buffer-motion-after-end.texi - at deffn {Generic Function} {number-of-lines} buffer + at include fun-drei-buffer-size.texi -Return the number of lines of the buffer, or really the number of -newline characters. - at end deffn + at include fun-drei-buffer-number-of-lines.texi @node Operations Related To The Offset Of Marks @subsubsection Operations Related To The Offset Of Marks - at deffn {Generic Function} {offset} mark - -Return the offset of the mark into the buffer. - at end deffn - - at deffn {Generic Function} {(setf offset)} offset mark - -Set the offset of the mark into the buffer. A motion-before-beginning -condition is signaled if the offset is less than zero. A -motion-after-end condition is signaled if the offset is greater than -the size of the buffer. - at end deffn - - at deffn {Generic Function} {forward-object} mark &optional (count 1) - -Move the mark forward the number of positions indicated by count. -This function could be implemented by an incf on the offset of the -mark, but many buffer implementations can implement this function much -more efficiently in a different way. A motion-before-beginning -condition is signaled if the resulting offset of the mark is less than -zero. A motion-after-end condition is signaled if the resulting offset -of the mark is greater than the size of the buffer. - at end deffn - - at deffn {Generic Function} {backward-object} mark &optional (count 1) - -Move the mark backward the number of positions indicated by count. -This function could be implemented by a decf on the offset of the -mark, but many buffer implementations can implement this function much -more efficiently in a different way. A motion-before-beginning -condition is signaled if the resulting offset of the mark is less than -zero. A motion-after-end condition is signaled if the resulting offset -of the mark is greater than the size of the buffer. - at end deffn - - at deffn {Generic Function} {mark<} mark1 mark2 + at include fun-drei-buffer-forward-object.texi -Return t if the offset of mark1 is strictly less than that of mark2. -An error is signaled if the two marks are not positioned in the same -buffer. It is acceptable to pass an offset in place of one of the -marks. - at end deffn - - at deffn {Generic Function} {mark<=} mark1 mark2 - -Return t if the offset of mark1 is less than or equal to that of -mark2. An error is signaled if the two marks are not positioned in -the same buffer. It is acceptable to pass an offset in place of one -of the marks. - at end deffn - - at deffn {Generic Function} {mark>} mark1 mark2 - -Return t if the offset of mark1 is strictly greater than that of -mark2. An error is signaled if the two marks are not positioned in -the same buffer. It is acceptable to pass an offset in place of one -of the marks. - at end deffn - - at deffn {Generic Function} {mark>=} mark1 mark2 - -Return t if the offset of mark1 is greater than or equal to that of -mark2. An error is signaled if the two marks are not positioned in -the same buffer. It is acceptable to pass an offset in place of one -of the marks. - at end deffn - - at deffn {Generic Function} {mark=} mark1 mark2 - -Return t if the offset of mark1 is equal to that of mark2. An error -is signaled if the two marks are not positioned in the same buffer. -It is acceptable to pass an offset in place of one of the marks. - at end deffn - - at deffn {Generic Function} {beginning-of-buffer} mark - -Move the mark to the beginning of the buffer. This is equivalent to -(setf (offset mark) 0) - at end deffn + at include fun-drei-buffer-backward-object.texi - at deffn {Generic Function} {end-of-buffer} mark + at include fun-drei-buffer-mark=.texi -Move the mark to the end of the buffer. - at end deffn - - at deffn {Generic Function} {beginning-of-buffer-p} mark - -Return t if the mark is at the beginning of the buffer, nil -otherwise. - at end deffn - - at deffn {Generic Function} {end-of-buffer-p} mark - -Return t if the mark is at the end of the buffer, nil otherwise. - at end deffn + at include fun-drei-buffer-mark-lt.texi - at deffn {Generic Function} {beginning-of-line} mark + at include fun-drei-buffer-mark-lt=.texi -Move the mark to the beginning of the line. The mark will be -positioned either immediately after the closest preceding newline -character, or at the beginning of the buffer if no preceding newline -character exists. - at end deffn - - at deffn {Generic Function} {end-of-line} mark + at include fun-drei-buffer-mark-gt.texi -Move the mark to the end of the line. The mark will be positioned -either immediately before the closest following newline character, or -at the end of the buffer if no following newline character exists. - at end deffn + at include fun-drei-buffer-mark-gt=.texi - at deffn {Generic Function} {beginning-of-line-p} mark + at include fun-drei-buffer-beginning-of-buffer.texi -Return t if the mark is at the beginning of the line (i.e., if the -character preceding the mark is a newline character or if the mark is -at the beginning of the buffer), nil otherwise. - at end deffn + at include fun-drei-buffer-end-of-buffer.texi - at deffn {Generic Function} {end-of-line-p} mark + at include fun-drei-buffer-beginning-of-buffer-p.texi -Return t if the mark is at the end of the line (i.e., if the character -following the mark is a newline character, or if the mark is at the -end of the buffer), nil otherwise. - at end deffn + at include fun-drei-buffer-end-of-buffer-p.texi [1819 lines skipped] --- /project/mcclim/cvsroot/mcclim/Doc/Makefile 2006/11/14 18:44:27 1.5 +++ /project/mcclim/cvsroot/mcclim/Doc/Makefile 2006/12/21 12:22:03 1.6 @@ -1,51 +1,93 @@ -NAME=mcclim -NAME2=sheet-hierarchy +# This Makefile has been cribbed from SBCL. +MCCLIMTEXI:=mcclim.texi +DOCFILES:=*.texi +TMPTYPES:=aux cp cps fn fns ky log pg toc tp tps vr vrs +TMPFILES:=$(foreach target,mcclim,$(foreach type,$(TMPTYPES),$(target).$(type))) +PSFILES=mcclim.ps +PDFFILES=mcclim.pdf +INFOFILE=mcclim.info +HTMLDIRS=$(basename $(MCCLIMTEXI)) +# Place where generated documentation ends up. The value of +# DOCSTRINGDIR has to end with a slash or you lose (it's passed to +# Lisp's `pathname' function). +DOCSTRINGDIR="docstrings/" +I_FLAGS=-I $(DOCSTRINGDIR) + +# SBCL_SYSTEM is an optional argument to this make program. If this +# variable is set, its contents are used as the command line for +# invoking SBCL. + +# When passing a non-standard SBCL_SYSTEM, be sure to set the +# environment variable SBCL_HOME to a useful value, as well. + +ifeq ($(MAKEINFO),) + MAKEINFO:=makeinfo +endif + +ifeq ($(TEXI2PDF),) + TEXI2PDF:=texi2pdf +endif + +ifeq ($(DVIPS),) + DVIPS:=dvips +endif + +.PHONY: all +all: ps pdf info html + +.PHONY: dist +dist: html pdf + +# html documentation; output in $(HTMLDIRS) +.PHONY: html +html: html-stamp + +html-stamp: $(DOCFILES) docstrings + @rm -rf $(HTMLDIRS) + $(MAKEINFO) $(I_FLAGS) --html $(HTMLDIRS) + touch html-stamp + +# Postscript documentation +.PHONY: ps +ps: $(PSFILES) + +%.ps: %.dvi + dvips -o $@ $< + +# DVI generation +%.dvi: %.texi $(DOCFILES) docstrings + texi2dvi $(I_FLAGS) $< + +# PDF documentation +.PHONY: pdf +pdf: $(PDFFILES) + +%.pdf: %.texi $(DOCFILES) docstrings + texi2pdf $(I_FLAGS) $< + +# info docfiles +.PHONY: info +info: $(INFOFILE) + +%.info: %.texi $(DOCFILES) docstrings + $(MAKEINFO) $(I_FLAGS) --output=$(INFOFILE) $< + +# Texinfo docstring snippets +.PHONY: docstrings +docstrings: tempfiles-stamp + +tempfiles-stamp: + DOCSTRINGDIR=$(DOCSTRINGDIR) PACKAGES=$(PACKAGES) sh make-tempfiles.sh "$(SBCL_SYSTEM)" && touch tempfiles-stamp + + +.PHONY: clean +clean: + rm -f *~ *.bak *.orig \#*\# .\#* texput.log *.fasl + rm -rf $(HTMLDIRS) $(DOCSTRINGDIR) + rm -f variables.texi + rm -f $(PSFILES) $(PDFFILES) html-stamp tempfiles-stamp + rm -f $(TMPFILES) $(INDEXFILES) + rm -f mcclim.info mcclim.info-* -TEXFILES=$(NAME2).tex $(shell ./tex-dependencies $(NAME2).tex) -PSTEX_T=$(shell ./strip-dependence inputfig $(TEXFILES)) -VERBATIM=$(shell ./strip-dependence verbatimtabinput $(TEXFILES)) -PSTEX=$(subst .pstex_t,.pstex,$(PSTEX_T)) -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 -TARGETIMAGES=$(shell sh ./makeimages.sh -e "$(IMAGES)" "$(IMAGETARGETTYPES)") -TEXIFILES=$(NAME).texi drei.texi - -all : $(NAME).ps $(NAME2).ps - -%.pstex: %.fig - fig2dev -Lpstex -m 0.75 $< $@ - -%.pstex_t: %.fig %.pstex - fig2dev -Lpstex_t -m 0.75 -p $(basename $<).pstex $< $@ - -$(NAME).dvi: $(TEXIFILES) $(TARGETIMAGES) - texi2dvi $(NAME).texi - -$(NAME2).dvi: $(NAME2).tex $(PSTEX_T) $(VERBATIM) - latex $< - makeindex $(NAME) - latex $< - -$(TARGETIMAGES): - sh ./makeimages.sh "$(IMAGES)" "$(IMAGETARGETTYPES)" - -$(NAME).html: $(TEXIFILES) - makeinfo --html $(NAME).texi - -$(NAME).ps: $(NAME).dvi - dvips $< -o - -$(NAME2).ps: $(NAME2).dvi $(PSTEX) - dvips $< -o - -view: $(NAME).ps - gv -antialias -scale 1 $< - -clean: - rm -f *.aux *.log *~ - -spotless: - make clean - rm -f *.ps *.dvi *.pstex *.pstex_t *.toc *.idx *.ilg *.ind *pdf \ -*ky *pg *tmp *tp *tps *vr *fn *fns *info +.PHONY: distclean +distclean: clean --- /project/mcclim/cvsroot/mcclim/Doc/make-tempfiles.sh 2006/12/21 12:22:03 NONE +++ /project/mcclim/cvsroot/mcclim/Doc/make-tempfiles.sh 2006/12/21 12:22:03 1.1 #!/bin/sh # Create Texinfo snippets from the documentation of exported symbols. # I (Troels Henriksen) cribbed this script from SBCL. # # This software is in the public domain and is provided with # absolutely no warranty. See the COPYING and CREDITS files for more # information. if [ -z "$1" ] then sbclsystem=$SBCL_PWD/../../src/runtime/sbcl sbclcore=$SBCL_PWD/../../output/sbcl.core if [ -e $sbclsystem ] && [ -e $sbclcore ] then SBCLRUNTIME="$sbclsystem --core $sbclcore" else SBCLRUNTIME="`which sbcl`" fi else SBCLRUNTIME="$1" fi SBCL="$SBCLRUNTIME --noinform --no-sysinit --no-userinit --noprint --disable-debugger" # Output directory. This has to end with a slash (it's interpreted by # Lisp's `pathname' function) or you lose. This is normally set from # Makefile. DOCSTRINGDIR="${DOCSTRINGDIR:-docstrings/}" echo /creating docstring snippets from SBCL=\'$SBCLRUNTIME\' for packages \'$PACKAGES\' $SBCL <, mangled by ;;;; Nikodemus Siivola, brought to McCLIM by Troels Henriksen. ;;;; TODO ;;;; * Verbatim text ;;;; * Quotations ;;;; * Method documentation untested ;;;; * Method sorting, somehow ;;;; * Index for macros & constants? ;;;; * This is getting complicated enough that tests would be good ;;;; * Nesting (currently only nested itemizations work) ;;;; * doc -> internal form -> texinfo (so that non-texinfo format are also ;;;; easily generated) ;;;; FIXME: The description below is no longer complete. This ;;;; should possibly be turned into a contrib with proper documentation. ;;;; Formatting heuristics (tweaked to format SAVE-LISP-AND-DIE sanely): ;;;; ;;;; Formats SYMBOL and `symbol' as @code{symbol} if SYMBOL exists in ;;;; the current package, or @var{symbol} if symbol is in the argument ;;;; list of the defun / defmacro. ;;;; ;;;; Lines starting with * or - that are followed by intented lines ;;;; are marked up with @itemize. ;;;; ;;;; Lines containing only a SYMBOL that are followed by indented ;;;; lines are marked up as @table @code, with the SYMBOL as the item. (eval-when (:compile-toplevel :load-toplevel :execute) (require 'sb-introspect)) (defpackage :cl-docextractor (:use :cl :sb-mop :cl-ppcre) (:shadow #:documentation) (:export #:documentee #:document) (:documentation "Tools to generate Texinfo documentation from docstrings.")) (in-package :cl-docextractor) (defclass documentee () ((%name :accessor name :initarg :name :type string :initform "Unnamed" :documentation "The name of the thing to be documented.") (%output-directory :accessor output-directory :initarg :output-directory :type pathname :initform (error "An output directory must be provided")) (%packages :accessor packages :initarg :packages :initform '() :documentation "The packages to extract docstrings from.") (%ignored-packages :accessor ignored-packages :initarg :ignored-packages :initform '() :documentation "A list of packages whose contents will be ignored when printing class-precedence-lists.") (%output-filetype :accessor output-filetype :initarg :filetype :initform "texinfo" :documentation "The file type used for the output files.")) (:documentation "A `documentee' is a set of packages to create Texinfo documentation from, a number of rules describing how to parse the docstrings and an output pathname.")) ;;;; various specials and parameters (defvar *texinfo-output*) (defvar *texinfo-variables*) (defvar *documentation-package*) (defvar *verbose-output* t "If true, print status information to `*standard-output*' while running.") (defparameter *documentee* nil "Bound to the `documentee' object currently being worked on.") (defparameter *documentation-types* '(compiler-macro function method-combination setf ;;structure ; also handled by `type' type variable) "A list of symbols accepted as second argument of `documentation'") (defparameter *character-replacements* '((#\* . "star") (#\/ . "slash") (#\+ . "plus") (#\< . "lt") (#\> . "gt")) "Characters and their replacement names that `alphanumize' uses. If the replacements contain any of the chars they're supposed to replace, you deserve to lose.") (defparameter *characters-to-drop* '(#\\ #\` #\') "Characters that should be removed by `alphanumize'.") (defparameter *texinfo-escaped-chars* "@{}" "Characters that must be escaped with #\@ for Texinfo.") (defparameter *itemize-start-characters* '(#\* #\-) "Characters that might start an itemization in docstrings when at the start of a line.") (defparameter *symbol-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ*:-+&" "List of characters that make up symbols in a docstring.") (defparameter *symbol-delimiters* " ,.!?;") (defparameter *ordered-documentation-kinds* '(package type structure condition class macro)) ;;;; utilities (defun flatten (list) (cond ((null list) nil) ((consp (car list)) (nconc (flatten (car list)) (flatten (cdr list)))) ((null (cdr list)) (cons (car list) nil)) (t (cons (car list) (flatten (cdr list)))))) (defun whitespacep (char) (find char #(#\tab #\space #\page))) (defun setf-name-p (name) (or (symbolp name) (and (listp name) (= 2 (length name)) (eq (car name) 'setf)))) (defgeneric specializer-name (specializer)) (defmethod specializer-name ((specializer eql-specializer)) (list 'eql (eql-specializer-object specializer))) (defmethod specializer-name ((specializer class)) (class-name specializer)) (defun specialized-lambda-list (method) ;; courtecy of AMOP p. 61 (let* ((specializers (method-specializers method)) (lambda-list (method-lambda-list method)) (n-required (length specializers))) (append (mapcar (lambda (arg specializer) (if (eq specializer (find-class 't)) arg `(,arg ,(specializer-name specializer)))) (subseq lambda-list 0 n-required) specializers) (subseq lambda-list n-required)))) (defun required-arguments (lambda-list) "Return the required arguments of `lambda-list'. Will not work if &env or the like is the first parameter." (loop for parameter in lambda-list until (find parameter lambda-list-keywords) collecting parameter)) (defun string-lines (string) "Lines in STRING as a vector." (coerce (with-input-from-string (s string) (loop for line = (read-line s nil nil) while line collect line)) 'vector)) (defun indentation (line) "Position of first non-SPACE character in LINE." (position-if-not (lambda (c) (char= c #\Space)) line)) (defun docstring (x doc-type) (cl:documentation x doc-type)) (defun flatten-to-string (list) (format nil "~{~A~^-~}" (flatten list))) (defun alphanumize (original) "Construct a string without characters like *`' that will f-star-ck up filename handling. See `*character-replacements*' and `*characters-to-drop*' for customization." (let ((name (remove-if (lambda (x) (member x *characters-to-drop*)) (if (listp original) (flatten-to-string original) (string original)))) (chars-to-replace (mapcar #'car *character-replacements*))) (flet ((replacement-delimiter (index) [684 lines skipped] --- /project/mcclim/cvsroot/mcclim/Doc/DOCBUILDING 2006/12/21 12:22:03 NONE +++ /project/mcclim/cvsroot/mcclim/Doc/DOCBUILDING 2006/12/21 12:22:03 1.1 [718 lines skipped] From thenriksen at common-lisp.net Thu Dec 21 12:39:54 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 21 Dec 2006 07:39:54 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc Message-ID: <20061221123954.C660333003@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv12667 Modified Files: Makefile Log Message: Restored the image-building code. --- /project/mcclim/cvsroot/mcclim/Doc/Makefile 2006/12/21 12:22:03 1.6 +++ /project/mcclim/cvsroot/mcclim/Doc/Makefile 2006/12/21 12:39:52 1.7 @@ -7,6 +7,10 @@ PDFFILES=mcclim.pdf INFOFILE=mcclim.info 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 +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 # Lisp's `pathname' function). @@ -38,9 +42,12 @@ .PHONY: dist dist: html pdf +$(TARGETIMAGES): + sh ./makeimages.sh "$(IMAGES)" "$(IMAGETARGETTYPES)" + # html documentation; output in $(HTMLDIRS) .PHONY: html -html: html-stamp +html: html-stamp $(TARGETIMAGES) html-stamp: $(DOCFILES) docstrings @rm -rf $(HTMLDIRS) @@ -49,20 +56,20 @@ # Postscript documentation .PHONY: ps -ps: $(PSFILES) +ps: $(PSFILES) $(TARGETIMAGES) -%.ps: %.dvi +%.ps: %.dvi $(TARGETIMAGES) dvips -o $@ $< # DVI generation -%.dvi: %.texi $(DOCFILES) docstrings +%.dvi: %.texi $(DOCFILES) docstrings $(TARGETIMAGES) texi2dvi $(I_FLAGS) $< # PDF documentation .PHONY: pdf -pdf: $(PDFFILES) +pdf: $(PDFFILES) $(TARGETIMAGES) -%.pdf: %.texi $(DOCFILES) docstrings +%.pdf: %.texi $(DOCFILES) docstrings $(TARGETIMAGES) texi2pdf $(I_FLAGS) $< # info docfiles From thenriksen at common-lisp.net Thu Dec 21 23:14:20 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 21 Dec 2006 18:14:20 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061221231420.857E733003@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv31502 Modified Files: dialog.lisp Log Message: Do some compile-time analysis to remove unreachable-code warnings at compile-time for uses of `accepting-values'. --- /project/mcclim/cvsroot/mcclim/dialog.lisp 2006/12/13 15:31:07 1.24 +++ /project/mcclim/cvsroot/mcclim/dialog.lisp 2006/12/21 23:14:20 1.25 @@ -164,18 +164,22 @@ x-position y-position width height command-table frame-class)) (setq stream (stream-designator-symbol stream '*standard-input*)) (with-gensyms (accepting-values-continuation) - (let ((return-form - `(flet ((,accepting-values-continuation (,stream) - , at body)) - (invoke-accepting-values ,stream - #',accepting-values-continuation - , at args)) - )) - `(if ,own-window - (with-stream-in-own-window (,stream *standard-input* *standard-output*) - (,label) - ,return-form) - ,return-form)))) + (let* ((return-form + `(flet ((,accepting-values-continuation (,stream) + , at body)) + (invoke-accepting-values ,stream + #',accepting-values-continuation + , at args))) + (true-form `(with-stream-in-own-window (,stream *standard-input* *standard-output*) + (,label) + ,return-form))) + ;; To avoid unreachable-code warnings, if `own-window' is a + ;; boolean constant, don't generate the `if' form. + (cond ((eq own-window t) true-form) + ((eq own-window nil) return-form) + (t `(if ,own-window + ,true-form + ,return-form)))))) (defun invoke-accepting-values (stream body From thenriksen at common-lisp.net Fri Dec 22 15:34:46 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 22 Dec 2006 10:34:46 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061222153446.AE7B05B05C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv20572/Drei Modified Files: packages.lisp Log Message: Added new, shiny DREI-USER package and some other package docstrings. --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/12/10 19:28:49 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/12/22 15:34:46 1.11 @@ -421,12 +421,16 @@ #:replace-rectangle-line #:insert-in-rectangle-line #:delete-rectangle-line-whitespace - #:with-narrowed-buffer)) + #:with-narrowed-buffer) + (:documentation "Implementation of much syntax-aware, yet no +syntax-specific, core functionality of Drei.")) (defpackage :drei-fundamental-syntax (:use :clim-lisp :clim :drei-buffer :drei-base :drei-syntax :flexichain :drei) - (:export #:fundamental-syntax #:scan)) + (:export #:fundamental-syntax #:scan) + (:documentation "Implementation of the basic syntax module for +editing plain text.")) (defpackage :drei-lisp-syntax (:use :clim-lisp :clim :clim-extensions :drei-buffer :drei-base @@ -438,7 +442,9 @@ #:form #:form-to-object #:form-conversion-error) - (:shadow clim:form)) + (:shadow clim:form) + (:documentation "Implementation of the syntax module used for +editing Common Lisp code.")) (defpackage :drei-commands (:use :clim-lisp :drei-base :drei-buffer @@ -447,4 +453,14 @@ :esa-utils :drei-core :drei-undo) (:export #:define-motion-commands #:define-deletion-commands - #:define-editing-commands)) + #:define-editing-commands) + (:documentation "Command definitions that are not tied to +specific syntaxes.")) + +(defpackage :drei-user + (:use :clim-lisp :clim :clim-extensions :drei-buffer :drei-base + :drei-syntax :drei-fundamental-syntax :flexichain :drei + :drei-motion :drei-editing :esa-utils :esa :drei-core :esa-io + :drei-commands) + (:documentation "The package intended for user-made +customizations and extensions.")) From thenriksen at common-lisp.net Fri Dec 22 15:37:33 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 22 Dec 2006 10:37:33 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc Message-ID: <20061222153733.3B53C5C167@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv20973/Doc Modified Files: drei.texi Log Message: Added mention of DREI-USER package. --- /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2006/12/21 12:22:02 1.2 +++ /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2006/12/22 15:37:33 1.3 @@ -1177,11 +1177,11 @@ A common text editing task is to repeat the word at point, but for some reason, Drei does not come with a command to do this, so we need to -write our own. Fortunately, Drei is extensible software. We're going to -put our command in the @package{DREI-COMMANDS} package, though, -strictly, that is an internal package. We're going to create a standard -CLIM command named @cl{com-repeat-word} in the command table - at cl{editing-table}. We'll clone the current point, move it a word +write our own. Fortunately, Drei is extensible software, and to that +end, a @package{DREI-USER} package is provided that is intended for user +customizations. We're going to create a standard CLIM command named + at cl{com-repeat-word} in the command table @cl{editing-table}. The +implementation consists of cloning the current point, move it a word backward, and insert into the buffer the sequence delimited by point and our moved mark. Our command takes no arguments. From ahefner at common-lisp.net Sat Dec 23 11:41:24 2006 From: ahefner at common-lisp.net (ahefner) Date: Sat, 23 Dec 2006 06:41:24 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061223114124.DB05A3E008@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv17575 Modified Files: graphics.lisp Log Message: Fix draw-pattern* on streams with non-translation transformations, according to my reading of the spec. --- /project/mcclim/cvsroot/mcclim/graphics.lisp 2006/11/17 20:33:24 1.55 +++ /project/mcclim/cvsroot/mcclim/graphics.lisp 2006/12/23 11:41:23 1.56 @@ -1008,12 +1008,18 @@ (defmethod medium-draw-pattern* (medium pattern x y) (let ((width (pattern-width pattern)) (height (pattern-height pattern))) - #+NIL ;; debugging aid. - (draw-rectangle* medium x y (+ x width) (+ y height) - :filled t - :ink +red+) - (draw-rectangle* medium x y (+ x width) (+ y height) - :filled t - :ink (transform-region - (make-translation-transformation x y) - pattern)))) + ;; As I read the spec, the pattern itself is not transformed, so + ;; we should draw the full (untransformed) pattern at the tranformed + ;; x/y coordinates. This requires we revert to the identity transformation + ;; before drawing the rectangle. -Hefner + (with-transformed-position ((medium-transformation medium) x y) + (with-identity-transformation (medium) + #+NIL ;; debugging aid. + (draw-rectangle* medium x y (+ x width) (+ y height) + :filled t + :ink +red+) + (draw-rectangle* medium x y (+ x width) (+ y height) + :filled t + :ink (transform-region + (make-translation-transformation x y) + pattern)))))) From ahefner at common-lisp.net Sat Dec 23 11:42:43 2006 From: ahefner at common-lisp.net (ahefner) Date: Sat, 23 Dec 2006 06:42:43 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061223114243.029E53E053@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv17637 Modified Files: panes.lisp Log Message: Move the vertical scroll bar to the right-hand side of the window. --- /project/mcclim/cvsroot/mcclim/panes.lisp 2006/12/19 04:02:14 1.175 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2006/12/23 11:42:43 1.176 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.175 2006/12/19 04:02:14 ahefner Exp $ +;;; $Id: panes.lisp,v 1.176 2006/12/23 11:42:43 ahefner Exp $ (in-package :clim-internals) @@ -1983,15 +1983,13 @@ (when vscrollbar (setf (sheet-transformation vscrollbar) - (make-translation-transformation 0 0)) + (make-translation-transformation (- width *scrollbar-thickness*) 0)) (allocate-space vscrollbar *scrollbar-thickness* (if hscrollbar (- height *scrollbar-thickness*) height))) (when hscrollbar (move-sheet hscrollbar - (if vscrollbar - *scrollbar-thickness* - 0) + 0 (- height *scrollbar-thickness*)) (allocate-space hscrollbar (if vscrollbar (- width *scrollbar-thickness*) width) @@ -2026,7 +2024,7 @@ (when viewport (setf (sheet-transformation viewport) (make-translation-transformation - (+ x-spacing (if vscrollbar *scrollbar-thickness* 0)) + (+ x-spacing 0) (+ y-spacing 0))) (allocate-space viewport (- viewport-width (* 2 x-spacing)) From ahefner at common-lisp.net Sat Dec 23 11:52:27 2006 From: ahefner at common-lisp.net (ahefner) Date: Sat, 23 Dec 2006 06:52:27 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061223115227.7E3473E008@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv17747 Modified Files: menu.lisp Log Message: Further hacking to polish the "pixie" look. Enabled pixie-style menus, revamped various compose-space and handle-repaint methods. Minor changes to menu.lisp allowing pixie to customize the decoration of submenu windows, and to detect when menu buttons are in a vertical menu (versus the menu bar). Changed drawing of the arrow widget on scroll bars and submenu buttons to use a small bitmap rather than polygon drawing, as the polygon drawing was awkward and (due to rounding?) did not look right. On CLX, Pixie can be invoked as follows: (setf *default-frame-manager* (make-instance 'climi::pixie/clx-look :port (find-port))) --- /project/mcclim/cvsroot/mcclim/menu.lisp 2006/12/14 19:43:51 1.37 +++ /project/mcclim/cvsroot/mcclim/menu.lisp 2006/12/23 11:52:27 1.38 @@ -119,6 +119,12 @@ (sheet-children (first (sheet-children (frame-panes submenu-frame)))) '()))) +(defclass submenu-border (border-pane) ()) + +(defclass submenu-border-pane (raised-pane) + () + (:default-initargs :border-width 2 :background *3d-normal-color*)) + (defun create-substructure (sub-menu client) (let* ((frame *application-frame*) (manager (frame-manager frame)) @@ -130,7 +136,7 @@ 'menu))) (rack (make-pane-1 manager frame 'vrack-pane :background *3d-normal-color* :contents items)) - (raised (make-pane-1 manager frame 'raised-pane :border-width 2 :background *3d-normal-color* :contents (list rack)))) + (raised (make-pane-1 manager frame 'submenu-border :contents (list rack)))) (with-slots (bottomp) sub-menu (multiple-value-bind (xmin ymin xmax ymax) (bounding-rectangle* (sheet-region sub-menu)) @@ -277,6 +283,7 @@ :label name :text-style *enabled-text-style* :client client + :vertical vertical :value-changed-callback #'(lambda (gadget val) (declare (ignore gadget val)) @@ -285,6 +292,7 @@ :label name :text-style *disabled-text-style* :client client + :vertical vertical :value-changed-callback #'(lambda (gadget val) (declare (ignore gadget val)) @@ -296,6 +304,7 @@ :label name :text-style *enabled-text-style* :client client + :vertical vertical :value-changed-callback #'(lambda (gadget val) (declare (ignore gadget val)) @@ -308,6 +317,7 @@ (:divider (make-pane-1 manager frame 'menu-divider-leaf-pane :label name + :vertical vertical :client client)) (:menu (make-pane-1 manager frame (if vertical @@ -315,6 +325,7 @@ 'menu-button-submenu-pane) :label name :client client + :vertical vertical :frame-manager manager :command-table value :bottomp bottomp)) @@ -372,7 +383,7 @@ (append (loop for item in menu collect - (make-menu-button-from-menu-item + (make-menu-button-from-menu-item item nil :bottomp t :vertical nil From ahefner at common-lisp.net Sat Dec 23 11:52:27 2006 From: ahefner at common-lisp.net (ahefner) Date: Sat, 23 Dec 2006 06:52:27 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Looks Message-ID: <20061223115227.C0BBD3F002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Looks In directory clnet:/tmp/cvs-serv17747/Looks Modified Files: pixie.lisp Log Message: Further hacking to polish the "pixie" look. Enabled pixie-style menus, revamped various compose-space and handle-repaint methods. Minor changes to menu.lisp allowing pixie to customize the decoration of submenu windows, and to detect when menu buttons are in a vertical menu (versus the menu bar). Changed drawing of the arrow widget on scroll bars and submenu buttons to use a small bitmap rather than polygon drawing, as the polygon drawing was awkward and (due to rounding?) did not look right. On CLX, Pixie can be invoked as follows: (setf *default-frame-manager* (make-instance 'climi::pixie/clx-look :port (find-port))) --- /project/mcclim/cvsroot/mcclim/Looks/pixie.lisp 2006/12/19 04:07:15 1.17 +++ /project/mcclim/cvsroot/mcclim/Looks/pixie.lisp 2006/12/23 11:52:27 1.18 @@ -14,6 +14,12 @@ ; ;;; +;;; TODO: Add units label to slider pane +;;; TODO: Matching repaint method for the list pane +;;; TODO: Is there a locking bug, and does it somehow involve pixie? +;;; (Or is my computer still haunted?) +;;; TODO: Colors of buttons in clim-fig are wrong + (export '(pixie-look #+clx pixie/clx-look)) (defclass pixie-look (frame-manager) ()) @@ -26,7 +32,6 @@ (type (eql ',abstract-type)) &rest args) (declare (ignorable fm frame type args)) - (format *trace-output* "~& make-pane-1 ~A => ~A~%" ',abstract-type ',pixie-type) ,(if enabled `(apply #'make-instance ',pixie-type @@ -50,13 +55,45 @@ :port (port frame) args)) +;;; Scroll button patterns + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter +pixie-arrow-pattern+ + #2a((0 0 0 1 0 0 0) + (0 0 1 1 1 0 0) + (0 1 1 1 1 1 0) + (1 1 1 1 1 1 1))) + + (flet ((rotate (array) + (let ((new-array (make-array (reverse (array-dimensions array))))) + (dotimes (i (array-dimension array 0)) + (dotimes (j (array-dimension array 1)) + (setf (aref new-array j (- (array-dimension array 0) i 1)) + (aref array i j)))) + new-array))) + (let* ((up +pixie-arrow-pattern+) + (right (rotate up)) + (down (rotate right)) + (left (rotate down))) + (macrolet ((def (var) + `(defparameter ,(intern (format nil "~A~A~A" + (symbol-name '#:+pixie-) + (symbol-name var) + (symbol-name '#:-arrow+)) + (find-package :climi)) + (make-pattern ,var (list +transparent-ink+ +black+))))) + (def up) + (def right) + (def down) + (def left))))) + ; Standard ; TODO - clean up all of this colour nonsense ; which should involve some sensible ideas about tints vs' inks -(defclass pixie-gadget () ( - (highlighted :initarg :highlight +(defclass pixie-gadget () + ((highlighted :initarg :highlight :initform +gray93+ :reader pane-highlight) (paper-color :initarg :paper-color @@ -74,7 +111,6 @@ ; Convenience - (defun draw-up-box (pane x1 y1 x2 y2 foreground) (let ((x2 (- x2 1))) (draw-rectangle* pane x1 y1 x2 y2 :ink foreground) @@ -112,7 +148,7 @@ (draw-label* pane x1 y1 x2 y2 :ink (pane-inking-color pane))) -; Highlighting (could the defaults be less horrible?) +; Highlighting (defmethod gadget-highlight-background ((gadget pixie-gadget)) +gray93+) @@ -625,26 +661,17 @@ :border-width 1) ;; draw up arrow (with-bounding-rectangle* (x1 y1 x2 y2) gadget-up-region - (if (eq (slot-value pane 'armed) :up) + (if (eq (slot-value pane 'armed) :up) (draw-down-box pane x1 y1 x2 y2 +gray83+) (draw-up-box pane x1 y1 x2 y2 +gray83+)) ;; draw decoration in the region - ;; for this, we want to have an odd width and height - (flet ((oddify (v) (let ((v (floor v))) (if (oddp v) v (+ v 1))))) - (let* ((width (oddify (- x2 x1))) - (height (oddify (- y2 y1))) - (arrow (list (make-point (floor (/ (+ x1 x2) 2)) - (floor (+ y1 (* height 5/13)))) - (make-point (floor (+ x1 (* width 4/13))) - (floor (- y2 (* height 6/13)))) - (make-point (floor (+ x1 (* width 4/13))) - (floor (- y2 (* height 5/13)))) - (make-point (floor (- x2 (* width 4/13))) - (floor (- y2 (* height 5/13)))) - (make-point (floor (- x2 (* width 4/13))) - (floor (- y2 (* height 6/13))))))) - (draw-polygon pane arrow :filled t :ink +black+)))) - ; old + (multiple-value-bind (pattern fudge-x fudge-y) + (if (eq (gadget-orientation pane) :vertical) + (values +pixie-up-arrow+ -1 1) + (values +pixie-left-arrow+ -1 1)) + (draw-pattern* pane pattern + (+ fudge-x (floor (- (+ x1 x2) (pattern-width pattern)) 2)) + (+ fudge-y (floor (- (+ y1 y2) (pattern-height pattern)) 2))))) ;; draw down arrow (with-bounding-rectangle* (x1 y1 x2 y2) gadget-down-region @@ -652,20 +679,13 @@ (draw-down-box pane x1 y1 x2 y2 +gray83+) (draw-up-box pane x1 y1 x2 y2 +gray83+)) ;; draw decoration in the region - (flet ((oddify (v) (let ((v (floor v))) (if (oddp v) v (+ v 1))))) - (let* ((width (oddify (- x2 x1))) - (height (oddify (- y2 y1))) - (arrow (list (make-point (floor (/ (+ x1 x2) 2)) - (floor (- y2 (* height 5/13)))) - (make-point (floor (+ x1 (* width 4/13))) - (floor (+ y1 (* height 6/13)))) - (make-point (floor (+ x1 (* width 4/13))) - (floor (+ y1 (* height 5/13)))) - (make-point (floor (- x2 (* width 4/13))) - (floor (+ y1 (* height 5/13)))) - (make-point (floor (- x2 (* width 4/13))) - (floor (+ y1 (* height 6/13))))))) - (draw-polygon pane arrow :filled t :ink +black+)))) + (multiple-value-bind (pattern fudge-x fudge-y) + (if (eq (gadget-orientation pane) :vertical) + (values +pixie-down-arrow+ -1 1) + (values +pixie-right-arrow+ -1 2)) + (draw-pattern* pane pattern + (+ fudge-x (floor (- (+ x1 x2) (pattern-width pattern)) 2)) + (+ fudge-y (floor (- (+ y1 y2) (pattern-height pattern)) 2))))) ;; draw thumb (with-bounding-rectangle* (x1 y1 x2 y2) gadget-thumb-region @@ -677,36 +697,43 @@ (defclass pixie-menu-bar-pane (pixie-gadget menu-bar) ()) -; silly menu-bar isn't named pane, so this catches it -(defclass pixie-menu-bar (pixie-menu-bar-pane) ()) - -(define-pixie-gadget menu-bar pixie-menu-bar-pane :enabled nil) +(define-pixie-gadget menu-bar pixie-menu-bar-pane :enabled t) (defmethod handle-repaint ((pane pixie-menu-bar-pane) region) (declare (ignore region)) (with-special-choices (pane) (let* ((region (sheet-region pane)) (frame (polygon-points (bounding-rectangle region)))) - (draw-polygon pane frame :ink +Blue+ :filled t) + #+NIL (draw-polygon pane frame :ink +Blue+ :filled t) (draw-bordered-polygon pane frame :style :outset :border-width 1)))) -(defmethod compose-space ((gadget pixie-menu-bar-pane) &key width height) - (declare (ignore width height)) - (multiple-value-bind (width min-width max-width height min-height max-height) - (space-requirement-components (call-next-method)) - (make-space-requirement - :width width - :min-width min-width - :max-width max-width - :height min-height - :min-height min-height - :max-height min-height))) +(define-pixie-gadget menu-button pixie-menu-button-pane) -(defclass pixie-menu-button-pane (pixie-gadget menu-button-pane) () +(defclass pixie-menu-button-pane (pixie-gadget menu-button-pane) + ((left-margin :reader left-margin) + (right-margin :reader right-margin)) (:default-initargs :align-x :left :align-y :center)) +(defparameter *pixie-menu-button-left-margin* 26) +(defparameter *pixie-menu-button-right-margin* 26) +(defparameter *pixie-menubar-item-left-margin* 8) +(defparameter *pixie-menubar-item-right-margin* 8) +(defparameter *pixie-menubar-item-spacing* 0) + +(defmethod initialize-instance :after ((pane pixie-menu-button-pane) + &rest args &key vertical &allow-other-keys) + (declare (ignore args)) + (with-slots (left-margin right-margin) pane + (setf (values left-margin right-margin) + (if (or (typep (slot-value pane 'client) 'menu-bar) + (not vertical)) + (values *pixie-menubar-item-left-margin* *pixie-menubar-item-right-margin*) + (values *pixie-menu-button-left-margin* *pixie-menu-button-right-margin*))))) + +;; What even uses this? All the subclasses have their own handle-repaint methods! +#+NIL (defmethod handle-repaint ((pane pixie-menu-button-pane) region) (declare (ignore region)) (with-special-choices (pane) @@ -724,25 +751,23 @@ :border-width 1))) (t (draw-polygon pane frame :filled t :ink (effective-gadget-foreground pane)))) - (draw-label* pane (+ x1 5) y1 x2 y2 :ink (pane-inking-color pane)))))) + (draw-label* pane (+ x1 (left-margin pane)) y1 (- x2 (right-margin pane)) y2 :ink +red+ #+NIL (pane-inking-color pane)))))) (defmethod compose-space ((gadget pixie-menu-button-pane) &key width height) (declare (ignore width height)) - (space-requirement+* (space-requirement+* (compose-label-space gadget :wider 5 :higher 10) - :min-width (* 2 (pane-x-spacing gadget)) - :width (* 2 (pane-x-spacing gadget)) - :max-width +fill+ - :min-height (* 2 (pane-y-spacing gadget)) - :height (* 2 (pane-y-spacing gadget)) - :max-height (* 2 (pane-y-spacing gadget))) - :min-width (+ 17 (* 2 *3d-border-thickness*)) - :width (+ 17 (* 2 *3d-border-thickness*)) + (space-requirement+* (compose-label-space gadget + :wider (+ (left-margin gadget) + (right-margin gadget)) + :higher (+ 6 (* 2 *3d-border-thickness*))) + :min-width 0 + :width 0 :max-width +fill+ - :min-height (* 2 *3d-border-thickness*) - :height (* 2 *3d-border-thickness*) - :max-height (* 2 *3d-border-thickness*))) + :min-height 0 + :height 0 + :max-height 0)) (defclass pixie-menu-button-leaf-pane (pixie-menu-button-pane menu-button-leaf-pane) ()) +(define-pixie-gadget menu-button-leaf-pane pixie-menu-button-leaf-pane) (defmethod handle-repaint ((pane pixie-menu-button-leaf-pane) region) (declare (ignore region)) @@ -759,25 +784,26 @@ :filled t) (when armed (draw-edges-lines* pane +white+ 0 0 +black+ (1- w) (1- h))) - (draw-label* pane (+ x1 8) y1 (- x2 17) y2 :ink +black+)))))))) + (let ((x1 (+ x1 (left-margin pane))) + (x2 (- x2 (right-margin pane)))) + (if (gadget-active-p pane) + (draw-label* pane x1 y1 x2 y2 :ink +black+) + (draw-engraved-label* pane x1 y1 x2 y2)))))))))) (defclass pixie-menu-button-submenu-pane (pixie-menu-button-pane menu-button-submenu-pane) ()) +(define-pixie-gadget menu-button-submenu-pane pixie-menu-button-submenu-pane) +(define-pixie-gadget menu-button-vertical-submenu-pane pixie-menu-button-submenu-pane) + + (defmethod compose-space ((gadget pixie-menu-button-submenu-pane) &key width height) (declare (ignore width height)) - (space-requirement+* (space-requirement+* (compose-label-space gadget :wider 5 :higher 10) - :min-width (* 2 (pane-x-spacing gadget)) - :width (* 2 (pane-x-spacing gadget)) - :max-width +fill+ - :min-height (* 2 (pane-y-spacing gadget)) - :height (* 2 (pane-y-spacing gadget)) - :max-height (* 2 (pane-y-spacing gadget))) - :min-width (+ 17 (* 2 *3d-border-thickness*)) - :width (+ 17 (* 2 *3d-border-thickness*)) - :max-width +fill+ - :min-height (* 2 *3d-border-thickness*) - :height (* 2 *3d-border-thickness*) - :max-height (* 2 *3d-border-thickness*))) + (if (typep (slot-value gadget 'client) 'menu-bar) ; XXX + (compose-label-space gadget + :wider (+ (left-margin gadget) + (right-margin gadget)) + :higher 10) + (call-next-method))) (defmethod handle-repaint ((pane pixie-menu-button-submenu-pane) region) (declare (ignore region)) @@ -793,28 +819,18 @@ :filled t) (when submenu-frame (draw-edges-lines* pane +white+ 0 0 +black+ (1- w) (1- h))) + + (if (typep client 'menu-button) + (let ((pattern +pixie-right-arrow+)) + (draw-label* pane (+ x1 (left-margin pane)) y1 + (- x2 (right-margin pane)) y2 :ink +black+) + (draw-pattern* pane pattern (- x2 10) (+ y1 (floor (- h (pattern-height pattern)) 2)))) + (draw-label* pane + (+ x1 (left-margin pane)) y1 + (- x2 (right-margin pane)) y2 + :ink +black+))))))))) + - (draw-label* pane (+ x1 8) y1 (- x2 17) y2 :ink +black+) - - (when (typep client 'menu-button-pane) - (let* ((x1 (- x2 17)) - (ym (/ (+ y1 y2) 2)) - (y1 (- ym 8)) - (y2 (+ ym 8))) - (flet ((oddify (v) (let ((v (floor v))) (if (oddp v) v (+ v 1))))) - (let* ((width (oddify (- x2 x1))) - (height (oddify (- y2 y1))) - (arrow (list (make-point (floor (- x2 (* width 5/13))) - (floor (/ (+ y1 y2) 2))) - (make-point (floor (+ x1 (* width 6/13))) - (floor (+ y1 (* height 4/13)))) - (make-point (floor (+ x1 (* width 5/13))) - (floor (+ y1 (* height 4/13)))) - (make-point (floor (+ x1 (* width 5/13))) - (floor (- y2 (* height 4/13)))) - (make-point (floor (+ x1 (* width 6/13))) - (floor (- y2 (* height 4/13))))))) - (draw-polygon pane arrow :filled t :ink +black+)))))))))))) ; Image pane @@ -823,6 +839,7 @@ ; This is just test/proof-of-concept code :] +#+NIL (defclass pixie-image-pane (pixie-gadget basic-gadget) ( (image-pathname :initarg :pathname) (image-mask-pathname :initarg :mask-pathname :initform nil) @@ -837,6 +854,7 @@ (image-stencil :initform nil))) ; TODO: allow pixmaps to be realized from unrealized media +#+NIL (defmethod initialize-instance :after ((pane pixie-image-pane) &rest args) (declare (ignore args)) (with-slots (image-pathname image-image image-width image-height) pane @@ -851,6 +869,7 @@ (let* ((data (image:read-image-file image-mask-pathname))) (setf image-stencil (make-stencil data)))))) +#+NIL (defmethod handle-repaint ((pane pixie-image-pane) region) (declare (ignore region)) (with-slots (image-pixmap image-width image-height) pane @@ -870,6 +889,7 @@ :clipping-region (make-rectangle* 0 0 image-width image-height)))))) (copy-from-pixmap image-pixmap 0 0 image-width image-height pane 0 0))) +#+NIL (defmethod compose-space ((pane pixie-image-pane) &key width height) (declare (ignore width height)) (with-slots (image-width image-height) pane @@ -1021,13 +1041,30 @@ (pressedp (draw-down-box pane x1 y1 x2 y2 (effective-gadget-foreground pane))))))))) +(defclass pixie-submenu-border-pane (submenu-border) + () + (:default-initargs :border-width 2)) + +(define-pixie-gadget submenu-border pixie-submenu-border-pane) + +(defmethod handle-repaint ((pane pixie-submenu-border-pane) region) + (declare (ignore region)) + (with-slots (border-width) pane + (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane) + (draw-rectangle* pane x1 y1 x2 y2 :filled nil :ink +black+) + ;; Why, having incremented the coordinates, and despite setting + ;; the border-width to 2, do I now get a single pixel border ? + ;; It's fine, that's the result I want, but an explanation is in order. + (draw-bordered-rectangle* pane (1+ x1) (1+ y1) (1- x2) (1- y2) + :style :outset + :border-width border-width)))) + ; Text Area (defclass pixie-text-field-pane (text-field-pane) ()) ;; Why does pixie need its own text area subclass? Leave it disabled for now. -; (define-pixie-class text-field-pane pixie-text-field-pane) - +(define-pixie-gadget text-field-pane pixie-text-field-pane :enabled nil) (defmethod initialize-instance :after ((pane pixie-text-field-pane) &rest rest) (unless (getf rest :normal) @@ -1052,11 +1089,6 @@ (display-gadget-background pane (gadget-current-color pane) 0 0 (- x2 x1) (- y2 y1)) (goatee::redisplay-all (area pane)))))) - [7 lines skipped] From dlichteblau at common-lisp.net Sat Dec 23 13:26:54 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sat, 23 Dec 2006 08:26:54 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061223132654.6489B49050@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv3975 Modified Files: pango.lisp Log Message: Fix presentation highlighting (among other issues) in beirc. * pango.lisp (text-style-ascent, text-style-descent): Compute dummy values from TEXT-SIZE instead of asking the font. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/pango.lisp 2006/12/20 18:45:37 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/pango.lisp 2006/12/23 13:26:54 1.2 @@ -272,37 +272,31 @@ (not (zerop (pango_font_family_is_monospace family)))))))) (defmethod text-style-ascent (text-style (medium metrik-medium)) - (with-gtk () - (with-pango-context (context medium) - (with-text-style-font-description (desc text-style) - (with-font-metrics (metrics context desc) - (ceiling (pango_font_metrics_get_ascent metrics) PANGO_SCALE))))) +;;; (with-gtk () +;;; (with-pango-context (context medium) +;;; (with-text-style-font-description (desc text-style) +;;; (with-font-metrics (metrics context desc) +;;; (ceiling (pango_font_metrics_get_ascent metrics) PANGO_SCALE))))) ;; here's a dummy implementation guaranteing ascent+descent=height: - ;; we don't seem to need it though. -;;; (multiple-value-bind (width height final-x final-y baseline) -;;; (text-size medium "foo" :text-style text-style) -;;; (declare (ignore width height final-x final-y)) -;;; baseline) - ) + (multiple-value-bind (width height final-x final-y baseline) + (text-size medium "foo" :text-style text-style) + (declare (ignore width height final-x final-y)) + baseline)) (defmethod text-style-descent (text-style (medium metrik-medium)) - (with-gtk () - (with-pango-context (context medium) - (with-text-style-font-description (desc text-style) - (with-font-metrics (metrics context desc) - (ceiling (pango_font_metrics_get_descent metrics) PANGO_SCALE))))) +;;; (with-gtk () +;;; (with-pango-context (context medium) +;;; (with-text-style-font-description (desc text-style) +;;; (with-font-metrics (metrics context desc) +;;; (ceiling (pango_font_metrics_get_descent metrics) PANGO_SCALE))))) ;; here's a dummy implementation guaranteing ascent+descent=height: - ;; we don't seem to need it though. -;;; (multiple-value-bind (width height final-x final-y baseline) -;;; (text-size medium "foo" :text-style text-style) -;;; (declare (ignore width final-x final-y)) -;;; (- height baseline)) - ) + (multiple-value-bind (width height final-x final-y baseline) + (text-size medium "foo" :text-style text-style) + (declare (ignore width final-x final-y)) + (- height baseline))) (defmethod text-style-height (text-style (medium metrik-medium)) (nth-value 1 (text-size medium "foo" :text-style text-style)) - ;; here's a dummy implementation guaranteing ascent+descent=height, - ;; leading to less inter-line space. ;;; (+ (text-style-ascent text-style medium) ;;; (text-style-descent text-style medium)) ) From dlichteblau at common-lisp.net Sat Dec 23 21:44:03 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sat, 23 Dec 2006 16:44:03 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061223214403.BBBB333002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv20070 Modified Files: gadgets.lisp package.lisp Log Message: Implement (SETF LIST-PANE-ITEMS) as discussed on IRC. * package.lisp (CLIM-EXTENSIONS): Export LIST-PANE-ITEMS. * Examples/demodemo.lisp: Extend the LIST-TEST to demonstrate the new functionality. * gadgets.lisp ((SETF LIST-PANE-ITEMS)): Add a new generic function. Implement it for GENERIC-LIST-PANE, with some general code specialized on META-LIST-PANE. * Backends/gtkairo/gadgets.lisp: Implement (SETF LIST-PANE-ITEMS) for GTK-LIST, too. * Backends/gtkairo/ffi.lisp: regenerated. --- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2006/11/08 01:18:22 1.101 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2006/12/23 21:44:03 1.102 @@ -2175,6 +2175,48 @@ (generic-list-pane-handle-click-from-event pane event)) (when (next-method-p) (call-next-method)))) +(defgeneric (setf list-pane-items) + (newval pane &key invoke-callback) + (:documentation + "Set the current list of items for this list pane. +The current GADGET-VALUE will be adjusted by removing values not +specified by the new items. VALUE-CHANGED-CALLBACK will be called +if INVOKE-CALLBACK is given.")) + +(defmethod (setf list-pane-items) + (newval (pane meta-list-pane) &key invoke-callback) + (declare (ignore invoke-callback)) + (setf (slot-value pane 'items) newval)) + +(defmethod (setf list-pane-items) + :after + (newval (pane meta-list-pane) &key invoke-callback) + (when (slot-boundp pane 'value) + (let ((new-values + (coerce (climi::generic-list-pane-item-values pane) 'list)) + (test (list-pane-test pane))) + (setf (gadget-value pane :invoke-callback invoke-callback) + (if (list-pane-exclusive-p pane) + (if (find (gadget-value pane) new-values :test test) + (gadget-value pane) + nil) + (intersection (gadget-value pane) new-values :test test)))))) + +(defmethod (setf list-pane-items) + (newval (pane generic-list-pane) &key invoke-callback) + (call-next-method) + (with-slots (items items-length item-strings item-values) pane + (setf items-length (length newval)) + (setf item-strings nil) + (setf item-values nil))) + +(defmethod (setf list-pane-items) :after + (newval (pane generic-list-pane) &key invoke-callback) + (change-space-requirements + pane + :height (space-requirement-height (compose-space pane))) + (handle-repaint pane +everywhere+)) + ;;; OPTION-PANE (define-abstract-pane-mapping 'option-pane 'generic-option-pane) --- /project/mcclim/cvsroot/mcclim/package.lisp 2006/12/21 10:36:40 1.57 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2006/12/23 21:44:03 1.58 @@ -1921,7 +1921,8 @@ #:compose-space-aux #:simple-event-loop #:pointer-motion-hint-event - #:frame-display-pointer-documentation-string)) + #:frame-display-pointer-documentation-string + #:list-pane-items)) ;;; Symbols that must be defined by a backend. ;;; From dlichteblau at common-lisp.net Sat Dec 23 21:44:04 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sat, 23 Dec 2006 16:44:04 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061223214404.0EDF238005@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv20070/Backends/gtkairo Modified Files: ffi.lisp gadgets.lisp Log Message: Implement (SETF LIST-PANE-ITEMS) as discussed on IRC. * package.lisp (CLIM-EXTENSIONS): Export LIST-PANE-ITEMS. * Examples/demodemo.lisp: Extend the LIST-TEST to demonstrate the new functionality. * gadgets.lisp ((SETF LIST-PANE-ITEMS)): Add a new generic function. Implement it for GENERIC-LIST-PANE, with some general code specialized on META-LIST-PANE. * Backends/gtkairo/gadgets.lisp: Implement (SETF LIST-PANE-ITEMS) for GTK-LIST, too. * Backends/gtkairo/ffi.lisp: regenerated. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/12/20 19:26:14 1.10 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/12/23 21:44:03 1.11 @@ -1042,6 +1042,11 @@ (iter :pointer) ;GtkTreeIter * ) +(defcfun "gtk_list_store_clear" + :void + (list_store :pointer) ;GtkListStore * + ) + (defcfun "gtk_list_store_newv" :pointer (n_columns :int) ;gint @@ -1215,6 +1220,11 @@ (tree_view :pointer) ;GtkTreeView * ) +(defcfun "gtk_tree_view_get_model" + :pointer + (tree_view :pointer) ;GtkTreeView * + ) + (defcfun "gtk_tree_view_get_selection" :pointer (tree_view :pointer) ;GtkTreeView * --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/12/20 12:01:36 1.16 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/12/23 21:44:03 1.17 @@ -49,7 +49,9 @@ (defclass gtk-list (native-widget-mixin list-pane climi::meta-list-pane) ((title :initarg :title :initform "" :accessor list-pane-title) - (tree-view :accessor list-pane-tree-view))) + (tree-view :accessor list-pane-tree-view)) + ;; fixme? + (:default-initargs :value nil)) (defclass gtk-option-pane (native-widget-mixin option-pane climi::meta-list-pane) @@ -151,7 +153,6 @@ (setf (cffi:mem-aref types :long 1) 0) (let* ((model (gtk_list_store_newv 1 types)) (tv (gtk_tree_view_new_with_model model)) - (name-key (climi::list-pane-name-key sheet)) (column (gtk_tree_view_column_new)) (renderer (gtk_cell_renderer_text_new))) (setf (list-pane-tree-view sheet) tv) @@ -159,15 +160,7 @@ (gtk_tree_view_insert_column tv column -1) (gtk_tree_view_column_add_attribute column renderer "text" 0) (gtk_tree_view_column_set_title column (list-pane-title sheet)) - (cffi:with-foreign-object (&iter 'gtktreeiter) - (dolist (i (climi::list-pane-items sheet)) - (gtk_list_store_append model &iter) - (cffi:with-foreign-string (n (funcall name-key i)) - (cffi:with-foreign-object (&value 'gvalue) - (setf (cffi:foreign-slot-value &value 'gvalue 'type) 0) - (g_value_init &value +g-type-string+) - (g_value_set_string &value n) - (gtk_list_store_set_value model &iter 0 &value))))) + (reset-list-pane-items sheet) (gtk_tree_selection_set_mode (list-pane-selection sheet) (if (eq (climi::list-pane-mode sheet) :exclusive) @@ -192,6 +185,20 @@ (cffi:null-pointer)) result)))) +(defun reset-list-pane-items (sheet) + (let ((model (gtk_tree_view_get_model (list-pane-tree-view sheet))) + (name-key (climi::list-pane-name-key sheet))) + (gtk_list_store_clear model) + (cffi:with-foreign-object (&iter 'gtktreeiter) + (dolist (i (climi::list-pane-items sheet)) + (gtk_list_store_append model &iter) + (cffi:with-foreign-string (n (funcall name-key i)) + (cffi:with-foreign-object (&value 'gvalue) + (setf (cffi:foreign-slot-value &value 'gvalue 'type) 0) + (g_value_init &value +g-type-string+) + (g_value_set_string &value n) + (gtk_list_store_set_value model &iter 0 &value))))))) + (defmethod realize-native-widget ((sheet gtk-option-pane)) (let* ((widget (gtk_combo_box_new_text)) (name-key (climi::list-pane-name-key sheet))) @@ -216,7 +223,8 @@ (gtk_tree_selection_unselect_all (list-pane-selection sheet)) (let ((value (gadget-value sheet))) (if (eq (climi::list-pane-mode sheet) :exclusive) - (gtk-list-select-value sheet value) + (when value ;fixme? + (gtk-list-select-value sheet value)) (dolist (v value) (gtk-list-select-value sheet v))))) @@ -228,6 +236,17 @@ (when mirror (gtk-list-reset-selection gadget))))) +(defmethod (setf climi::list-pane-items) + (newval (pane gtk-list) &key invoke-callback) + (declare (ignore invoke-callback)) + (call-next-method) + (with-gtk () + (reset-list-pane-items pane))) + +(defmethod climi::generic-list-pane-item-values ((pane gtk-list)) + (mapcar (climi::list-pane-value-key pane) + (climi::list-pane-items pane))) + (defun option-pane-set-active (sheet widget) (gtk_combo_box_set_active widget From dlichteblau at common-lisp.net Sat Dec 23 21:44:04 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sat, 23 Dec 2006 16:44:04 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20061223214404.483CB38005@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv20070/Examples Modified Files: demodemo.lisp Log Message: Implement (SETF LIST-PANE-ITEMS) as discussed on IRC. * package.lisp (CLIM-EXTENSIONS): Export LIST-PANE-ITEMS. * Examples/demodemo.lisp: Extend the LIST-TEST to demonstrate the new functionality. * gadgets.lisp ((SETF LIST-PANE-ITEMS)): Add a new generic function. Implement it for GENERIC-LIST-PANE, with some general code specialized on META-LIST-PANE. * Backends/gtkairo/gadgets.lisp: Implement (SETF LIST-PANE-ITEMS) for GTK-LIST, too. * Backends/gtkairo/ffi.lisp: regenerated. --- /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/12/19 04:08:58 1.14 +++ /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/12/23 21:44:04 1.15 @@ -205,16 +205,32 @@ (define-application-frame list-test () () + (:panes + (substring :text-field :value "INTER") + (result-list + (make-pane 'list-pane + :value 'clim:region-intersection + :items (apropos-list "INTER" :clim t) + :name-key (lambda (x) (format nil "~(~S~)" x))))) (:layouts (defaults (labelling (:label "Matching symbols" :text-style (make-text-style :sans-serif :roman :normal)) - (scrolling (:height 200) - (make-pane 'list-pane - :value 'clim:region-intersection - :items (apropos-list "INTER" :clim t) - :name-key (lambda (x) (format nil "~(~S~)" x)) - )))))) + (vertically () + (scrolling (:height 200) + result-list) + (horizontally () + substring + (make-pane 'push-button + :label "Update" + :activate-callback 'update-list-test))))))) + +(defun update-list-test (pane) + (declare (ignore pane)) + (setf (list-pane-items (find-pane-named *application-frame* 'result-list)) + (apropos-list (gadget-value + (find-pane-named *application-frame* 'substring)) + :clim t))) From dlichteblau at common-lisp.net Sun Dec 24 11:31:00 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 24 Dec 2006 06:31:00 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061224113100.40B264F007@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv17970 Modified Files: ffi.lisp gadgets.lisp gtk-ffi.lisp Log Message: Show GTK+ list pane scroll bars only when needed. * Backends/gtkairo/gadgets.lisp ((REALIZE-NATIVE-WIDGET GTK-LIST)): Set scroll bar policy. * Backends/gtkairo/ffi.lisp: Regenerated. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/12/23 21:44:03 1.11 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/12/24 11:30:59 1.12 @@ -158,6 +158,11 @@ (:GDK_HINT_USER_POS 128) (:GDK_HINT_USER_SIZE 256)) +(defcenum GtkPolicyType + :GTK_POLICY_ALWAYS + :GTK_POLICY_AUTOMATIC + :GTK_POLICY_NEVER) + (defcenum GtkScrollType :GTK_SCROLL_NONE :GTK_SCROLL_JUMP @@ -1143,6 +1148,12 @@ (vadjustment :pointer) ;GtkAdjustment * ) +(defcfun "gtk_scrolled_window_set_policy" + :void + (scrolled_window :pointer) ;GtkScrolledWindow * + (hscrollbar_policy GtkPolicyType) + (vscrollbar_policy GtkPolicyType)) + (defcfun "gtk_separator_menu_item_new" :pointer) (defcfun "gtk_toggle_button_set_active" --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/12/23 21:44:03 1.17 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/12/24 11:30:59 1.18 @@ -175,6 +175,9 @@ (let ((wrapper (gtk_scrolled_window_new (gtk_tree_view_get_hadjustment tv) (gtk_tree_view_get_vadjustment tv)))) + (gtk_scrolled_window_set_policy wrapper + GTK_POLICY_AUTOMATIC + GTK_POLICY_AUTOMATIC) (gtk_container_add wrapper tv) (setf result wrapper)) (setf (list-pane-tree-view sheet) tv) ;?! --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/12/20 19:40:10 1.22 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/12/24 11:30:59 1.23 @@ -372,7 +372,7 @@ '(GdkFunction gtkselectionmode GtkScrollType GdkEventMask GdkEventType GtkWidgetFlags GdkModifierType GdkCrossingMode GtkWindowType GdkGrabStatus GdkWindowHints GtkStateType GdkDragAction GConnectFlags - GdkDragProtocol + GdkDragProtocol GtkPolicyType gdk_x11_drawable_get_xid From dlichteblau at common-lisp.net Sun Dec 24 12:54:19 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 24 Dec 2006 07:54:19 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc Message-ID: <20061224125419.3D05653035@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv27773 Modified Files: Makefile Log Message: - Ddon't hang with errors in texi2dvi - Split up the "clean" target into "softclean" and "clean", the former leaves the docstrings in place. Easier for users who don't generate them those through make. --- /project/mcclim/cvsroot/mcclim/Doc/Makefile 2006/12/21 12:39:52 1.7 +++ /project/mcclim/cvsroot/mcclim/Doc/Makefile 2006/12/24 12:54:19 1.8 @@ -63,7 +63,7 @@ # DVI generation %.dvi: %.texi $(DOCFILES) docstrings $(TARGETIMAGES) - texi2dvi $(I_FLAGS) $< + texi2dvi -b $(I_FLAGS) $< # PDF documentation .PHONY: pdf @@ -87,14 +87,19 @@ DOCSTRINGDIR=$(DOCSTRINGDIR) PACKAGES=$(PACKAGES) sh make-tempfiles.sh "$(SBCL_SYSTEM)" && touch tempfiles-stamp -.PHONY: clean -clean: +.PHONY: softclean +softclean: rm -f *~ *.bak *.orig \#*\# .\#* texput.log *.fasl - rm -rf $(HTMLDIRS) $(DOCSTRINGDIR) + rm -rf $(HTMLDIRS) rm -f variables.texi - rm -f $(PSFILES) $(PDFFILES) html-stamp tempfiles-stamp + rm -f $(PSFILES) $(PDFFILES) html-stamp rm -f $(TMPFILES) $(INDEXFILES) rm -f mcclim.info mcclim.info-* +.PHONY: clean +clean: softclean + rm -rf $(DOCSTRINGDIR) + rm -f tempfiles-stamp + .PHONY: distclean distclean: clean From dlichteblau at common-lisp.net Sun Dec 24 13:01:10 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 24 Dec 2006 08:01:10 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc Message-ID: <20061224130110.64C8B36009@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv30774 Modified Files: drei.texi Log Message: Added a @bye at the end of drei.texi, otherwise texi2dvi hangs. Is this the right fix? --- /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2006/12/22 15:37:33 1.3 +++ /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2006/12/24 13:01:08 1.4 @@ -1248,3 +1248,5 @@ specific context (for example, a large editor application adding a Show Macroexpansion command to Lisp syntax), their modus operandi is general enough to be used for all conditional activity of command tables. + + at bye From dlichteblau at common-lisp.net Sun Dec 24 14:27:43 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 24 Dec 2006 09:27:43 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061224142743.F30F2702EB@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv16855 Modified Files: mcclim.asd medium.lisp package.lisp ports.lisp Log Message: Enable support for extended text styles using strings for family and face, as already implemented in CLIM-CLX. Teach Gtkairo do the same. Add an API for font listing (implemented in CLX and Gtkairo, plus a trivial fallback implementation for other backends) and a font selection dialog as an example. * Doc/mcclim.texi: New chapter "Fonts and Extended Text Styles" * Examples/font-selector.lisp: New file. * Examples/demodemo.lisp: Added a button for the font selector. * mcclim.asd (CLIM-EXAMPLES): Added font-selector.lisp. * package.lisp (CLIM-EXTENSIONS): Export new symbols font-family font-face port-all-font-families font-family-name font-family-port font-family-all-faces font-face-name font-face-family font-face-all-sizes font-face-scalable-p font-face-text-style. * medium.lisp (MAKE-TEXT-STYLE, TEXT-STYLE-EQUALP): Allow strings for family and face. (MAKE-TEXT-STYLE-1): New helper function. * ports.lisp (FONT-FAMILY, FONT-FACE): New classes. (port-all-font-families font-family-name font-family-port font-family-all-faces font-face-name font-face-family font-face-all-sizes font-face-scalable-p font-face-text-style): New generic functions and default methods. * Backends/CLX/port.lisp (FONT-FAMILIES): New slot in the port. (CLX-FONT-FAMILY, CLX-FONT-FACE): New classes. (port-all-font-families font-family-name font-family-port font-family-all-faces font-face-name font-face-family font-face-all-sizes font-face-scalable-p font-face-text-style): New methods. (SPLIT-FONT-NAME, RELOAD-FONT-TABLE, MAKE-UNFRIEDLY-NAME): New helper functions. * Backends/gtkairo/pango.lisp (MAKE-FONT-DESCRIPTION): Support strings for family and face. (PANGO-FONT-FAMILY, PANGO-FONT-FACE): New classes. (port-all-font-families font-family-name font-family-port font-family-all-faces font-face-name font-face-family font-face-all-sizes font-face-scalable-p font-face-text-style): New methods. (INVOKE-LISTER, pango-font-family-list-faces, pango-font-face-list-sizes): New helper functions. * Backends/gtkairo/port.lisp (GLOBAL-PANGO-CONTEXT): New slot in the port. ((INITIALIZE-INSTANCE GTKAIRO-PORT)): Set the pango context. * Backends/gtkairo/ffi.lisp: regenerated. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/12/20 18:45:54 1.41 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/12/24 14:27:43 1.42 @@ -465,7 +465,8 @@ (:file "text-size-test") (:file "drawing-benchmark") (:file "logic-cube") - (:file "views"))) + (:file "views") + (:file "font-selector"))) (:module "Goatee" :components ((:file "goatee-test"))))) --- /project/mcclim/cvsroot/mcclim/medium.lisp 2006/05/05 10:24:02 1.60 +++ /project/mcclim/cvsroot/mcclim/medium.lisp 2006/12/24 14:27:43 1.61 @@ -126,14 +126,25 @@ (defvar *text-style-hash-table* (make-hash-table :test #'eql))) (defun make-text-style (family face size) - (let ((key (text-style-key family face size))) - (declare (type fixnum key)) - (or (gethash key *text-style-hash-table*) - (setf (gethash key *text-style-hash-table*) - (make-instance 'standard-text-style - :text-family family - :text-face face - :text-size size))))) + (if (and (symbolp family) + (or (symbolp face) + (and (listp face) (every #'symbolp face)))) + ;; Portable text styles have always been cached in McCLIM like this: + ;; (as permitted by the CLIM spec for immutable objects, section 2.4) + (let ((key (text-style-key family face size))) + (declare (type fixnum key)) + (or (gethash key *text-style-hash-table*) + (setf (gethash key *text-style-hash-table*) + (make-text-style-1 family face size)))) + ;; Extended text styles using string components could be cached using + ;; an appropriate hash table, but for now we just re-create them: + (make-text-style-1 family face size))) + +(defun make-text-style-1 (family face size) + (make-instance 'standard-text-style + :text-family family + :text-face face + :text-size size)) ) ; end eval-when @@ -143,8 +154,8 @@ (defmethod text-style-equalp ((style1 standard-text-style) (style2 standard-text-style)) - (and (eql (text-style-family style1) (text-style-family style2)) - (eql (text-style-face style1) (text-style-face style2)) + (and (equal (text-style-family style1) (text-style-family style2)) + (equal (text-style-face style1) (text-style-face style2)) (eql (text-style-size style1) (text-style-size style2)))) (defconstant *default-text-style* (make-text-style :fix :roman :normal)) --- /project/mcclim/cvsroot/mcclim/package.lisp 2006/12/23 21:44:03 1.58 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2006/12/24 14:27:43 1.59 @@ -1922,7 +1922,19 @@ #:simple-event-loop #:pointer-motion-hint-event #:frame-display-pointer-documentation-string - #:list-pane-items)) + #:list-pane-items + ;; Font listing extension: + #:font-family + #:font-face + #:port-all-font-families + #:font-family-name + #:font-family-port + #:font-family-all-faces + #:font-face-name + #:font-face-family + #:font-face-all-sizes + #:font-face-scalable-p + #:font-face-text-style)) ;;; Symbols that must be defined by a backend. ;;; --- /project/mcclim/cvsroot/mcclim/ports.lisp 2006/07/01 21:31:41 1.53 +++ /project/mcclim/cvsroot/mcclim/ports.lisp 2006/12/24 14:27:43 1.54 @@ -322,3 +322,122 @@ (defmethod set-sheet-pointer-cursor ((port basic-port) sheet cursor) (declare (ignore sheet cursor)) (warn "Port ~A has not implemented sheet pointer cursors." port)) + +;;;; +;;;; Font listing extension +;;;; + +(defgeneric port-all-font-families + (port &key invalidate-cache &allow-other-keys) + (:documentation + "Returns the list of all FONT-FAMILY instances known by PORT. +With INVALIDATE-CACHE, cached font family information is discarded, if any.")) + +(defgeneric font-family-name (font-family) + (:documentation + "Return the font family's name. This name is meant for user display, +and does not, at the time of this writing, necessarily the same string +used as the text style family for this port.")) + +(defgeneric font-family-port (font-family) + (:documentation "Return the port this font family belongs to.")) + +(defgeneric font-family-all-faces (font-family) + (:documentation + "Return the list of all font-face instances for this family.")) + +(defgeneric font-face-name (font-face) + (:documentation + "Return the font face's name. This name is meant for user display, +and does not, at the time of this writing, necessarily the same string +used as the text style face for this port.")) + +(defgeneric font-face-family (font-face) + (:documentation "Return the font family this face belongs to.")) + +(defgeneric font-face-all-sizes (font-face) + (:documentation + "Return the list of all font sizes known to be valid for this font, +if the font is restricted to particular sizes. For scalable fonts, arbitrary +sizes will work, and this list represents only a subset of the valid sizes. +See font-face-scalable-p.")) + +(defgeneric font-face-scalable-p (font-face) + (:documentation + "Return true if this font is scalable, as opposed to a bitmap font. For +a scalable font, arbitrary font sizes are expected to work.")) + +(defgeneric font-face-text-style (font-face &optional size) + (:documentation + "Return an extended text style describing this font face in the specified +size. If size is nil, the resulting text style does not specify a size.")) + +(defclass font-family () + ((font-family-port :initarg :port :reader font-family-port) + (font-family-name :initarg :name :reader font-family-name)) + (:documentation "The protocol class for font families. Each backend +defines a subclass of font-family and implements its accessors. Font +family instances are never created by user code. Use port-all-font-families +to list all instances available on a port.")) + +(defmethod print-object ((object font-family) stream) + (print-unreadable-object (object stream :type t :identity nil) + (format stream "~A" (font-family-name object)))) + +(defclass font-face () + ((font-face-family :initarg :family :reader font-face-family) + (font-face-name :initarg :name :reader font-face-name)) + (:documentation "The protocol class for font faces Each backend +defines a subclass of font-face and implements its accessors. Font +face instances are never created by user code. Use font-family-all-faces +to list all faces of a font family.")) + +(defmethod print-object ((object font-face) stream) + (print-unreadable-object (object stream :type t :identity nil) + (format stream "~A, ~A" + (font-family-name (font-face-family object)) + (font-face-name object)))) + +;;; fallback font listing implementation: + +(defclass basic-font-family (font-family) ()) +(defclass basic-font-face (font-face) ()) + +(defmethod port-all-font-families ((port basic-port) &key invalidate-cache) + (declare (ignore invalidate-cache)) + (flet ((make-basic-font-family (name) + (make-instance 'basic-font-family :port port :name name))) + (list (make-basic-font-family "FIX") + (make-basic-font-family "SERIF") + (make-basic-font-family "SANS-SERIF")))) + +(defmethod font-family-all-faces ((family basic-font-family)) + (flet ((make-basic-font-face (name) + (make-instance 'basic-font-face :family family :name name))) + (list (make-basic-font-face "ROMAN") + (make-basic-font-face "BOLD") + (make-basic-font-face "BOLD-ITALIC") + (make-basic-font-face "ITALIC")))) + +(defmethod font-face-all-sizes ((face basic-font-face)) + (list 1 2 3 4 5 6 7)) + +(defmethod font-face-scalable-p ((face basic-font-face)) + nil) + +(defmethod font-face-text-style ((face basic-font-face) &optional size) + (make-text-style + (find-symbol (string-upcase (font-family-name (font-face-family face))) + :keyword) + (if (string-equal (font-face-name face) "BOLD-ITALIC") + '(:bold :italic) + (find-symbol (string-upcase (font-face-name face)) :keyword)) + (ecase size + ((nil) nil) + (1 :tiny) + (2 :very-small) + (3 :small) + (4 :normal) + (5 :large) + (6 :very-large) + (7 :huge)))) From dlichteblau at common-lisp.net Sun Dec 24 14:27:45 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 24 Dec 2006 09:27:45 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20061224142745.74450B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv16855/Backends/CLX Modified Files: port.lisp Log Message: Enable support for extended text styles using strings for family and face, as already implemented in CLIM-CLX. Teach Gtkairo do the same. Add an API for font listing (implemented in CLX and Gtkairo, plus a trivial fallback implementation for other backends) and a font selection dialog as an example. * Doc/mcclim.texi: New chapter "Fonts and Extended Text Styles" * Examples/font-selector.lisp: New file. * Examples/demodemo.lisp: Added a button for the font selector. * mcclim.asd (CLIM-EXAMPLES): Added font-selector.lisp. * package.lisp (CLIM-EXTENSIONS): Export new symbols font-family font-face port-all-font-families font-family-name font-family-port font-family-all-faces font-face-name font-face-family font-face-all-sizes font-face-scalable-p font-face-text-style. * medium.lisp (MAKE-TEXT-STYLE, TEXT-STYLE-EQUALP): Allow strings for family and face. (MAKE-TEXT-STYLE-1): New helper function. * ports.lisp (FONT-FAMILY, FONT-FACE): New classes. (port-all-font-families font-family-name font-family-port font-family-all-faces font-face-name font-face-family font-face-all-sizes font-face-scalable-p font-face-text-style): New generic functions and default methods. * Backends/CLX/port.lisp (FONT-FAMILIES): New slot in the port. (CLX-FONT-FAMILY, CLX-FONT-FACE): New classes. (port-all-font-families font-family-name font-family-port font-family-all-faces font-face-name font-face-family font-face-all-sizes font-face-scalable-p font-face-text-style): New methods. (SPLIT-FONT-NAME, RELOAD-FONT-TABLE, MAKE-UNFRIEDLY-NAME): New helper functions. * Backends/gtkairo/pango.lisp (MAKE-FONT-DESCRIPTION): Support strings for family and face. (PANGO-FONT-FAMILY, PANGO-FONT-FACE): New classes. (port-all-font-families font-family-name font-family-port font-family-all-faces font-face-name font-face-family font-face-all-sizes font-face-scalable-p font-face-text-style): New methods. (INVOKE-LISTER, pango-font-family-list-faces, pango-font-face-list-sizes): New helper functions. * Backends/gtkairo/port.lisp (GLOBAL-PANGO-CONTEXT): New slot in the port. ((INITIALIZE-INSTANCE GTKAIRO-PORT)): Set the pango context. * Backends/gtkairo/ffi.lisp: regenerated. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2006/11/09 20:24:21 1.125 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2006/12/24 14:27:44 1.126 @@ -163,7 +163,8 @@ (pointer :reader port-pointer) (pointer-grab-sheet :accessor pointer-grab-sheet :initform nil) (selection-owner :initform nil :accessor selection-owner) - (selection-timestamp :initform nil :accessor selection-timestamp))) + (selection-timestamp :initform nil :accessor selection-timestamp) + (font-families :accessor font-families))) (defun parse-clx-server-path (path) (pop path) @@ -1434,3 +1435,95 @@ (if (streamp stream) stream (error "Cannot connect to server: ~A:~D" host display)))) + + +;;;; Font listing implementation: + +(defclass clx-font-family (clim-extensions:font-family) + ((all-faces :initform nil + :accessor all-faces + :reader clim-extensions:font-family-all-faces))) + +(defclass clx-font-face (clim-extensions:font-face) + ((all-sizes :initform nil + :accessor all-sizes + :reader clim-extensions:font-face-all-sizes))) + +(defun split-font-name (name) + (loop + repeat 12 + for next = (position #\- name :start 0) + :then (position #\- name :start (1+ next)) + and prev = nil then next + while next + when prev + collect (subseq name (1+ prev) next))) + +(defun reload-font-table (port) + (let ((table (make-hash-table :test 'equal))) + (dolist (font (xlib:list-font-names (clx-port-display port) "*")) + (destructuring-bind + (&optional foundry family weight slant setwidth style pixelsize + &rest ignore ;pointsize xresolution yresolution + ;spacing averagewidth registry encoding + ) + (split-font-name font) + (declare (ignore setwidth style ignore)) + (when family + (let* ((family-name (format nil "~A ~A" foundry family)) + (family-instance + (or (gethash family-name table) + (setf (gethash family-name table) + (make-instance 'clx-font-family + :port port + :name family-name)))) + (face-name (format nil "~A ~A" weight slant)) + (face-instance + (find face-name (all-faces family-instance) + :key #'clim-extensions:font-face-name + :test #'equal))) + (unless face-instance + (setf face-instance + (make-instance 'clx-font-face + :family family-instance + :name face-name)) + (push face-instance (all-faces family-instance))) + (pushnew (parse-integer + ;; FIXME: Python thinks pixelsize is NIL, resulting + ;; in a full WARNING. Let's COERCE to make it work. + (coerce pixelsize 'string)) + (all-sizes face-instance)))))) + (setf (font-families port) + (sort (loop + for family being each hash-value in table + do + (setf (all-faces family) + (sort (all-faces family) + #'string< + :key #'clim-extensions:font-face-name)) + (dolist (face (all-faces family)) + (setf (all-sizes face) (sort (all-sizes face) #'<))) + collect family) + #'string< + :key #'clim-extensions:font-family-name)))) + +(defmethod clim-extensions:port-all-font-families + ((port clx-port) &key invalidate-cache) + (when (or (not (slot-boundp port 'font-families)) invalidate-cache) + (reload-font-table port)) + (font-families port)) + +(defmethod clim-extensions:font-face-scalable-p ((face clx-font-face)) + nil) + +(defun make-unfriendly-name (str) + (substitute #\- #\space str)) + +(defmethod clim-extensions:font-face-text-style + ((face clx-font-face) &optional size) + (make-text-style (make-unfriendly-name + (clim-extensions:font-family-name + (clim-extensions:font-face-family face))) + (make-unfriendly-name + (clim-extensions:font-face-name face)) + size)) From dlichteblau at common-lisp.net Sun Dec 24 14:27:48 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 24 Dec 2006 09:27:48 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061224142748.2ABBC1900B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv16855/Backends/gtkairo Modified Files: ffi.lisp pango.lisp port.lisp Log Message: Enable support for extended text styles using strings for family and face, as already implemented in CLIM-CLX. Teach Gtkairo do the same. Add an API for font listing (implemented in CLX and Gtkairo, plus a trivial fallback implementation for other backends) and a font selection dialog as an example. * Doc/mcclim.texi: New chapter "Fonts and Extended Text Styles" * Examples/font-selector.lisp: New file. * Examples/demodemo.lisp: Added a button for the font selector. * mcclim.asd (CLIM-EXAMPLES): Added font-selector.lisp. * package.lisp (CLIM-EXTENSIONS): Export new symbols font-family font-face port-all-font-families font-family-name font-family-port font-family-all-faces font-face-name font-face-family font-face-all-sizes font-face-scalable-p font-face-text-style. * medium.lisp (MAKE-TEXT-STYLE, TEXT-STYLE-EQUALP): Allow strings for family and face. (MAKE-TEXT-STYLE-1): New helper function. * ports.lisp (FONT-FAMILY, FONT-FACE): New classes. (port-all-font-families font-family-name font-family-port font-family-all-faces font-face-name font-face-family font-face-all-sizes font-face-scalable-p font-face-text-style): New generic functions and default methods. * Backends/CLX/port.lisp (FONT-FAMILIES): New slot in the port. (CLX-FONT-FAMILY, CLX-FONT-FACE): New classes. (port-all-font-families font-family-name font-family-port font-family-all-faces font-face-name font-face-family font-face-all-sizes font-face-scalable-p font-face-text-style): New methods. (SPLIT-FONT-NAME, RELOAD-FONT-TABLE, MAKE-UNFRIEDLY-NAME): New helper functions. * Backends/gtkairo/pango.lisp (MAKE-FONT-DESCRIPTION): Support strings for family and face. (PANGO-FONT-FAMILY, PANGO-FONT-FACE): New classes. (port-all-font-families font-family-name font-family-port font-family-all-faces font-face-name font-face-family font-face-all-sizes font-face-scalable-p font-face-text-style): New methods. (INVOKE-LISTER, pango-font-family-list-faces, pango-font-face-list-sizes): New helper functions. * Backends/gtkairo/port.lisp (GLOBAL-PANGO-CONTEXT): New slot in the port. ((INITIALIZE-INSTANCE GTKAIRO-PORT)): Set the pango context. * Backends/gtkairo/ffi.lisp: regenerated. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/12/24 11:30:59 1.12 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/12/24 14:27:45 1.13 @@ -1498,6 +1498,18 @@ (desc :pointer) ;const PangoFontDescription * ) +(defcfun "pango_font_face_get_face_name" + :string + (face :pointer) ;PangoFontFace * + ) + +(defcfun "pango_font_face_list_sizes" + :void + (face :pointer) ;PangoFontFace * + (sizes :pointer) ;int ** + (n_sizes :pointer) ;int * + ) + (defcfun "pango_font_family_get_name" :string (family :pointer) ;PangoFontFamily * @@ -1508,6 +1520,13 @@ (family :pointer) ;PangoFontFamily * ) +(defcfun "pango_font_family_list_faces" + :void + (family :pointer) ;PangoFontFamily * + (faces :pointer) ;PangoFontFace *** + (n_faces :pointer) ;int * + ) + (defcfun "pango_font_map_load_font" :pointer (fontmap :pointer) ;PangoFontMap * --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/pango.lisp 2006/12/23 13:26:54 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/pango.lisp 2006/12/24 14:27:45 1.3 @@ -123,23 +123,11 @@ (symbol-name (first face)) (symbol-name (second face))) :keyword))) - (let ((desc (pango_font_description_new)) - (family (or (getf *default-font-families* - (if (eq family :fixed) :fix family)) - (error "unknown font family: ~A" family))) - (weight (ecase face - ((:roman :italic :oblique) - :PANGO_WEIGHT_NORMAL) - ((:bold :bold-italic :italic-bold :bold-oblique - :oblique-bold) - :PANGO_WEIGHT_BOLD))) - (style (ecase face - ((:roman :bold) - :PANGO_STYLE_NORMAL) - ((:italic :bold-italic :italic-bold) - :PANGO_STYLE_ITALIC) - ((:oblique :bold-oblique :oblique-bold) - :PANGO_STYLE_OBLIQUE))) + (let ((family (if (stringp family) + family + (or (getf *default-font-families* + (if (eq family :fixed) :fix family)) + (error "unknown font family: ~A" family)))) (size (case size (:normal 12) (:tiny 6) @@ -148,10 +136,28 @@ (:large 14) (:very-large 16) (:huge 24) - (otherwise (truncate size))))) + (otherwise (truncate size)))) + desc) + (if (stringp face) + (setf desc (pango_font_description_from_string + (concatenate 'string ", " face))) + (let ((weight (ecase face + ((:roman :italic :oblique) + :PANGO_WEIGHT_NORMAL) + ((:bold :bold-italic :italic-bold :bold-oblique + :oblique-bold) + :PANGO_WEIGHT_BOLD))) + (style (ecase face + ((:roman :bold) + :PANGO_STYLE_NORMAL) + ((:italic :bold-italic :italic-bold) + :PANGO_STYLE_ITALIC) + ((:oblique :bold-oblique :oblique-bold) + :PANGO_STYLE_OBLIQUE)))) + (setf desc (pango_font_description_new)) + (pango_font_description_set_weight desc weight) + (pango_font_description_set_style desc style))) (pango_font_description_set_family desc family) - (pango_font_description_set_weight desc weight) - (pango_font_description_set_style desc style) (pango_font_description_set_size desc (* size PANGO_SCALE)) desc))) @@ -242,17 +248,6 @@ ;; (pango_layout_get_context layout) -(defun pango-context-list-families (context) - (cffi:with-foreign-object (&families :pointer) - (cffi:with-foreign-object (&n :int) - (pango_context_list_families context &families &n) - (let ((families (cffi:mem-aref &families :pointer))) - (prog1 - (loop - for i from 0 below (cffi:mem-aref &n :int) - collect (cffi:mem-aref families :pointer i)) - (g_free families)))))) - (defun resolve-font-description (context desc) (pango_font_describe (pango_context_load_font context desc))) @@ -308,3 +303,81 @@ (with-font-metrics (metrics context desc) (ceiling (pango_font_metrics_get_approximate_char_width metrics) PANGO_SCALE)))))) + + +;; font listing + +(defclass pango-font-family (clim-extensions:font-family) + ((native-family :initarg :native-family :accessor native-family))) + +(defclass pango-font-face (clim-extensions:font-face) + ((native-face :initarg :native-face :accessor native-face))) + +(defun invoke-lister (fn type) + (cffi:with-foreign-object (&array :pointer) + (cffi:with-foreign-object (&n :int) + (funcall fn &array &n) + (let ((array (cffi:mem-aref &array :pointer))) + (if (cffi:null-pointer-p array) + :null + (prog1 + (loop + for i from 0 below (cffi:mem-aref &n :int) + collect (cffi:mem-aref array type i)) + (g_free array))))))) + +(defun pango-context-list-families (context) + (invoke-lister (lambda (&families &n) + (pango_context_list_families context &families &n)) + :pointer)) + +(defun pango-font-family-list-faces (family) + (invoke-lister (lambda (&faces &n) + (pango_font_family_list_faces family &faces &n)) + :pointer)) + +(defun pango-font-face-list-sizes (face) + (invoke-lister (lambda (&sizes &n) + (pango_font_face_list_sizes face &sizes &n)) + :int)) + +(defmethod clim-extensions:port-all-font-families + ((port gtkairo-port) &key invalidate-cache) + (declare (ignore invalidate-cache)) + (sort (mapcar (lambda (native-family) + (make-instance 'pango-font-family + :native-family native-family + :port port + :name (pango_font_family_get_name native-family))) + (pango-context-list-families (global-pango-context port))) + #'string< + :key #'clim-extensions:font-family-name)) + +(defmethod clim-extensions:font-family-all-faces ((family pango-font-family)) + (sort (mapcar (lambda (native-face) + (make-instance 'pango-font-face + :native-face native-face + :family family + :name (pango_font_face_get_face_name native-face))) + (pango-font-family-list-faces (native-family family))) + #'string< + :key #'clim-extensions:font-face-name)) + +(defmethod clim-extensions:font-face-all-sizes ((face pango-font-face)) + (let ((sizes (pango-font-face-list-sizes (native-face face)))) + (if (eq sizes :null) + (loop for i from 0 below 200 collect i) + (mapcar (lambda (p) + ;; das mit dem round kommt mir aber nicht koscher vor + (round (/ p PANGO_SCALE))) + sizes)))) + +(defmethod clim-extensions:font-face-scalable-p ((face pango-font-face)) + (eq :null (pango-font-face-list-sizes (native-face face)))) + +(defmethod clim-extensions:font-face-text-style + ((face pango-font-face) &optional size) + (make-text-style (clim-extensions:font-family-name + (clim-extensions:font-face-family face)) + (clim-extensions:font-face-name face) + size)) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/12/03 15:24:09 1.12 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/12/24 14:27:45 1.13 @@ -49,7 +49,8 @@ (widgets->sheets :initform (make-hash-table) :accessor widgets->sheets) (dirty-mediums :initform (make-hash-table) :accessor dirty-mediums) (metrik-medium :accessor metrik-medium) - (pointer-grab-sheet :accessor pointer-grab-sheet :initform nil))) + (pointer-grab-sheet :accessor pointer-grab-sheet :initform nil) + (global-pango-context :accessor global-pango-context))) ;;;(defmethod print-object ((object gtkairo-port) stream) ;;; (print-unreadable-object (object stream :identity t :type t) @@ -85,7 +86,8 @@ (gdk_screen_get_root_window (gdk_screen_get_default))))) (set-antialias cr) (setf (metrik-medium port) - (make-instance 'metrik-medium :port port :cr cr)))) + (make-instance 'metrik-medium :port port :cr cr))) + (setf (global-pango-context port) (gdk_pango_context_get))) (when clim-sys:*multiprocessing-p* (start-event-thread port))) From dlichteblau at common-lisp.net Sun Dec 24 14:27:48 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 24 Dec 2006 09:27:48 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc Message-ID: <20061224142748.675A21A09B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv16855/Doc Modified Files: mcclim.texi Log Message: Enable support for extended text styles using strings for family and face, as already implemented in CLIM-CLX. Teach Gtkairo do the same. Add an API for font listing (implemented in CLX and Gtkairo, plus a trivial fallback implementation for other backends) and a font selection dialog as an example. * Doc/mcclim.texi: New chapter "Fonts and Extended Text Styles" * Examples/font-selector.lisp: New file. * Examples/demodemo.lisp: Added a button for the font selector. * mcclim.asd (CLIM-EXAMPLES): Added font-selector.lisp. * package.lisp (CLIM-EXTENSIONS): Export new symbols font-family font-face port-all-font-families font-family-name font-family-port font-family-all-faces font-face-name font-face-family font-face-all-sizes font-face-scalable-p font-face-text-style. * medium.lisp (MAKE-TEXT-STYLE, TEXT-STYLE-EQUALP): Allow strings for family and face. (MAKE-TEXT-STYLE-1): New helper function. * ports.lisp (FONT-FAMILY, FONT-FACE): New classes. (port-all-font-families font-family-name font-family-port font-family-all-faces font-face-name font-face-family font-face-all-sizes font-face-scalable-p font-face-text-style): New generic functions and default methods. * Backends/CLX/port.lisp (FONT-FAMILIES): New slot in the port. (CLX-FONT-FAMILY, CLX-FONT-FACE): New classes. (port-all-font-families font-family-name font-family-port font-family-all-faces font-face-name font-face-family font-face-all-sizes font-face-scalable-p font-face-text-style): New methods. (SPLIT-FONT-NAME, RELOAD-FONT-TABLE, MAKE-UNFRIEDLY-NAME): New helper functions. * Backends/gtkairo/pango.lisp (MAKE-FONT-DESCRIPTION): Support strings for family and face. (PANGO-FONT-FAMILY, PANGO-FONT-FACE): New classes. (port-all-font-families font-family-name font-family-port font-family-all-faces font-face-name font-face-family font-face-all-sizes font-face-scalable-p font-face-text-style): New methods. (INVOKE-LISTER, pango-font-family-list-faces, pango-font-face-list-sizes): New helper functions. * Backends/gtkairo/port.lisp (GLOBAL-PANGO-CONTEXT): New slot in the port. ((INITIALIZE-INSTANCE GTKAIRO-PORT)): Set the pango context. * Backends/gtkairo/ffi.lisp: regenerated. --- /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi 2006/12/21 12:22:02 1.3 +++ /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi 2006/12/24 14:27:48 1.4 @@ -96,6 +96,7 @@ * File Selector Gadget:: * PostScript Backend:: * Drei:: +* Fonts and Extended Text Styles:: Utility Programs * Listener:: @@ -1556,12 +1557,12 @@ @chapter PostScript Backend @menu -* Fonts:: +* Postscript Fonts:: * Additional functions:: @end menu - at node Fonts - at section Fonts + at node Postscript Fonts + at section Postscript Fonts Font mapping is a cons, the car of which is the name of the font (FontName field in the AFM file), and the cdr is the size in points. @@ -1580,6 +1581,86 @@ @include drei.texi + at node Fonts and Extended Text Styles + at chapter Fonts and Extended Text Styles + + at menu +* Extended Text Styles:: +* Listing Fonts:: + at end menu + + at node Extended Text Styles + at section Extended Text Styles + +McCLIM extends the legal values for the @cl{family} and @cl{face} +arguments to @cl{make-text-style} to include strings (in additional to +the portable keyword symbols), as permitted by the CLIM spec, section +11.1. + +Each backend defines its own specific syntax for these family and face +names. + +The CLX backend maps the text style family to the X font's + at emph{foundry} and @emph{family} values, separated by a dash. The +face is mapped to @emph{weight} and @emph{slant} in the same way. For +example, the following form creates a text style for + at emph{-misc-fixed-bold-r-*-*-18-*-*-*-*-*-*-*}: + + at lisp +(make-text-style "misc-fixed" "bold-r" 18) + at end lisp + +In the GTK backend, the text style family and face are used directly +as the Pango font family and face name. Please refer to Pango +documentation for details on the syntax of face names. Example: + + at lisp +(make-text-style "Bitstream Vera Sans" "Bold Oblique" 54) + at end lisp + + at node Listing Fonts + at section Listing Fonts + +McCLIM's font listing functions allow applications to list all +available fonts available on a @class{port} and create text style +instances for them. + +Example: + + at lisp +* (find "Bitstream Vera Sans Mono" + (clim-extensions:port-all-font-families (clim:find-port)) + :key #'clim-extensions:font-family-name + :test #'equal) +# + +* (clim-extensions:font-family-all-faces *) +(# + # + # + #) + +* (clim-extensions:font-face-scalable-p (car *)) +T + +* (clim-extensions:font-face-text-style (car **) 50) +# + at end lisp + + at include class-clim-extensions-font-family.texi + at include class-clim-extensions-font-face.texi + + at include fun-clim-extensions-port-all-font-families.texi + + at include fun-clim-extensions-font-family-name.texi + at include fun-clim-extensions-font-family-port.texi + at include fun-clim-extensions-font-family-all-faces.texi + + at include fun-clim-extensions-font-face-name.texi + at include fun-clim-extensions-font-face-family.texi + at include fun-clim-extensions-font-face-all-sizes.texi + at include fun-clim-extensions-font-face-text-style.texi + @c @node Utility Programs @c @part Utility Programs From dlichteblau at common-lisp.net Sun Dec 24 14:27:48 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 24 Dec 2006 09:27:48 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20061224142748.B72DF1A09B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv16855/Examples Modified Files: demodemo.lisp Added Files: font-selector.lisp Log Message: Enable support for extended text styles using strings for family and face, as already implemented in CLIM-CLX. Teach Gtkairo do the same. Add an API for font listing (implemented in CLX and Gtkairo, plus a trivial fallback implementation for other backends) and a font selection dialog as an example. * Doc/mcclim.texi: New chapter "Fonts and Extended Text Styles" * Examples/font-selector.lisp: New file. * Examples/demodemo.lisp: Added a button for the font selector. * mcclim.asd (CLIM-EXAMPLES): Added font-selector.lisp. * package.lisp (CLIM-EXTENSIONS): Export new symbols font-family font-face port-all-font-families font-family-name font-family-port font-family-all-faces font-face-name font-face-family font-face-all-sizes font-face-scalable-p font-face-text-style. * medium.lisp (MAKE-TEXT-STYLE, TEXT-STYLE-EQUALP): Allow strings for family and face. (MAKE-TEXT-STYLE-1): New helper function. * ports.lisp (FONT-FAMILY, FONT-FACE): New classes. (port-all-font-families font-family-name font-family-port font-family-all-faces font-face-name font-face-family font-face-all-sizes font-face-scalable-p font-face-text-style): New generic functions and default methods. * Backends/CLX/port.lisp (FONT-FAMILIES): New slot in the port. (CLX-FONT-FAMILY, CLX-FONT-FACE): New classes. (port-all-font-families font-family-name font-family-port font-family-all-faces font-face-name font-face-family font-face-all-sizes font-face-scalable-p font-face-text-style): New methods. (SPLIT-FONT-NAME, RELOAD-FONT-TABLE, MAKE-UNFRIEDLY-NAME): New helper functions. * Backends/gtkairo/pango.lisp (MAKE-FONT-DESCRIPTION): Support strings for family and face. (PANGO-FONT-FAMILY, PANGO-FONT-FACE): New classes. (port-all-font-families font-family-name font-family-port font-family-all-faces font-face-name font-face-family font-face-all-sizes font-face-scalable-p font-face-text-style): New methods. (INVOKE-LISTER, pango-font-family-list-faces, pango-font-face-list-sizes): New helper functions. * Backends/gtkairo/port.lisp (GLOBAL-PANGO-CONTEXT): New slot in the port. ((INITIALIZE-INSTANCE GTKAIRO-PORT)): Set the pango context. * Backends/gtkairo/ffi.lisp: regenerated. --- /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/12/23 21:44:04 1.15 +++ /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/12/24 14:27:48 1.16 @@ -67,7 +67,14 @@ (make-demo-button "Colorslider" 'colorslider) (make-demo-button "Goatee Test" 'goatee::goatee-test) (make-demo-button "D&D Translator" 'drag-test) - (make-demo-button "Draggable Graph" 'draggable-graph-demo))) + (make-demo-button "Draggable Graph" 'draggable-graph-demo) + (make-pane 'push-button + :label "Font Selector" + :activate-callback + (lambda (&rest ignore) + (declare (ignore ignore)) + (format *trace-output* "~&You chose: ~A~%" + (select-font)))))) (labelling (:label "Tests") (vertically (:equalize-width t) (make-demo-button "Label Test" 'label-test) --- /project/mcclim/cvsroot/mcclim/Examples/font-selector.lisp 2006/12/24 14:27:48 NONE +++ /project/mcclim/cvsroot/mcclim/Examples/font-selector.lisp 2006/12/24 14:27:48 1.1 ;;; -*- Mode: Lisp; show-trailing-whitespace: t; indent-tabs: nil -*- ;;; A font selection dialog. #| (clim-demo::select-font) (clim-demo::select-font :port (clim:find-port :server-path (list :ps :stream *standard-output*))) |# ;;; (c) 2006 David Lichteblau (david at lichteblau.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) (defun select-font (&key (port (find-port))) (let ((frame (make-application-frame 'font-selector :font-selector-port port))) (run-frame-top-level frame) (font-selector-text-style frame))) (define-application-frame font-selector () ((font-selector-port :initarg :font-selector-port :accessor font-selector-port) (font-selector-text-style :accessor font-selector-text-style)) (:menu-bar nil) (:panes (canvas :application :height 150 :scroll-bars nil :display-time t :display-function 'display-font-preview) (family (make-pane 'list-pane :items nil :name-key #'font-family-name :value-changed-callback 'family-changed)) (face (make-pane 'list-pane :items nil :name-key #'font-face-name :value-changed-callback 'face-changed)) (size (make-pane 'list-pane :items nil :value-changed-callback 'size-changed))) (:layouts (default (vertically (:height 400 :width 600) (horizontally () (labelling (:label "Family") (scrolling () family)) (labelling (:label "Face") (scrolling () face)) (labelling (:label "Size") (scrolling () size))) canvas (horizontally () +fill+ (make-pane 'push-button :label "OK" :activate-callback (lambda (ignore) ignore (frame-exit *application-frame*))) (make-pane 'push-button :label "Cancel" :activate-callback (lambda (ignore) ignore (setf (font-selector-text-style *application-frame*) nil) (frame-exit *application-frame*)))))))) (defmethod generate-panes :after (fm (frame font-selector)) (reset-list-pane (find-pane-named frame 'family) (port-all-font-families (font-selector-port *application-frame*)))) (defun family-changed (pane value) (declare (ignore pane)) (let* ((face-list (find-pane-named *application-frame* 'face)) (old-face (and (slot-boundp face-list 'climi::value) (gadget-value face-list))) (new-faces (font-family-all-faces value))) (reset-list-pane face-list new-faces) (when old-face (setf (gadget-value face-list :invoke-callback t) (find (font-face-name old-face) new-faces :key #'font-face-name :test #'equal))))) (defun face-changed (pane value) (declare (ignore pane)) (let ((sizes (if value (font-face-all-sizes value) nil))) (reset-list-pane (find-pane-named *application-frame* 'size) sizes (or (position-if (lambda (x) (>= x 20)) sizes) 0)))) (defun size-changed (pane value) (declare (ignore pane)) (setf (font-selector-text-style *application-frame*) (let ((face (gadget-value (find-pane-named *application-frame* 'face)))) (if (and face value) (font-face-text-style face value) nil))) (display-font-preview *application-frame* (frame-standard-output *application-frame*))) (defun reset-list-pane (pane items &optional (index 0)) (setf (climi::list-pane-items pane :invoke-callback nil) items) (setf (gadget-value pane :invoke-callback t) (or (and (slot-boundp pane 'climi::value) (gadget-value pane)) (let ((values (climi::generic-list-pane-item-values pane))) (if (plusp (length values)) (elt values index) nil))))) (defmethod display-font-preview (frame stream) (window-clear stream) (let* ((pane-width (rectangle-width (sheet-region stream))) (pane-height (rectangle-height (sheet-region stream))) (str "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") (style (font-selector-text-style frame)) (ok nil)) (cond ((not (eq (port frame) (font-selector-port frame))) (setf str (format nil "Cannot preview font for ~A" (font-selector-port frame))) (setf style (make-text-style :sans-serif :italic :normal))) ((null style) (setf str "Error: Text style is null") (setf style (make-text-style :sans-serif :italic :normal))) (t (setf ok t))) (multiple-value-bind (width height final-x final-y baseline) (text-size stream str :text-style style) (declare (ignore final-x final-y)) (let* ((x1 (/ (- pane-width width) 2)) (y1 (/ (- pane-height height) 2)) (y2 (+ y1 height)) (ybase (+ y1 baseline))) (when ok (draw-line* stream 0 ybase pane-width ybase :ink +green+) (draw-line* stream 0 y1 pane-width y1 :ink +blue+) (draw-line* stream 0 y2 pane-width y2 :ink +blue+)) (handler-case (draw-text* stream str x1 ybase :text-style style) (error (c) (princ c))))))) From dlichteblau at common-lisp.net Mon Dec 25 12:37:39 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Mon, 25 Dec 2006 07:37:39 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061225123739.0F5A71C009@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv31141 Modified Files: keygen.lisp keys.lisp Log Message: Keyboard handling, third try. * Backends/gtkairo/keygen.lisp (COLLECT-KEY-TABLE-2): Generate events only for the modifiers we are planning to support. (DO-MODIFIERS): New. (PRINT-KEY-TABLE): Sort keys.lisp by keysym number. * Backends/gtkairo/keys.lisp: Regenerated. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/keygen.lisp 2006/12/10 16:34:32 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/keygen.lisp 2006/12/25 12:37:38 1.2 @@ -66,6 +66,13 @@ (collect-key-table-2 clx gtk table)) (setf (fdefinition 'key-handler-impl) real-handler)))) +(defmacro do-modifiers ((var) &rest body) + `(dolist (.shift. '(0 1)) + (dolist (.meta. '(0 4)) + (dolist (.control. '(0 8)) + (let ((,var (logior .shift. .meta. .control.))) + , at body))))) + (defun collect-key-table-2 (clx gtk native-events) (let* ((clx-target (find-pane-named clx 'target)) (clx-win (clim:sheet-mirror clx-target)) @@ -87,7 +94,7 @@ (gtk-events (make-hash-table))) (format t "Waiting for windows to come up...~%") (sleep 5) - (dotimes (state 64) + (do-modifiers (state) (format t "Sending events for state ~D...~%" state) (loop for code from min to max do (dolist (type '(:key-press :key-release)) @@ -191,8 +198,13 @@ (write-line ";; autogenerated by keygen.lisp" s) (print '(in-package :clim-gtkairo) s) (loop - for value being each hash-key in table - using (hash-value spec) + for (value . spec) + :in (sort (loop + for value being each hash-key in table + using (hash-value spec) + collect (cons value spec)) + #'< + :key #'car) do (print `(define-key ,value ,@(simplify-spec spec)) s))))) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/keys.lisp 2006/12/10 16:34:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/keys.lisp 2006/12/25 12:37:38 1.2 @@ -2,224 +2,170 @@ (IN-PACKAGE :CLIM-GTKAIRO) (DEFINE-KEY 0 ((0) THROW-AWAY THROW-AWAY) (T NIL NIL)) -(DEFINE-KEY 65307 (T :ESCAPE NIL)) -(DEFINE-KEY 49 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|1| #\1) - (T :! #\!)) -(DEFINE-KEY 50 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|2| #\2) - (T :@ #\@)) -(DEFINE-KEY 51 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|3| #\3) - (T :|#| #\#)) -(DEFINE-KEY 52 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|4| #\4) - (T :$ #\$)) -(DEFINE-KEY 53 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|5| #\5) - (T :% #\%)) -(DEFINE-KEY 54 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|6| #\6) - (T :DEAD-CIRCUMFLEX NIL)) -(DEFINE-KEY 55 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|7| #\7) - (T :& #\&)) -(DEFINE-KEY 56 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|8| #\8) - (T :* #\*)) -(DEFINE-KEY 57 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|9| #\9) - (T :|(| #\()) -(DEFINE-KEY 48 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|0| #\0) - (T :|)| #\))) -(DEFINE-KEY 91 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :[ #\[) - (T :{ #\{)) -(DEFINE-KEY 93 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :] #\]) - (T :} #\})) -(DEFINE-KEY 65288 (T :BACKSPACE #\Backspace)) -(DEFINE-KEY 65289 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :TAB #\Tab) - (T :ISO-LEFT-TAB NIL)) -(DEFINE-KEY 39 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|'| #\') - (T :|"| #\")) -(DEFINE-KEY 44 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|,| #\,) - (T :< #\<)) -(DEFINE-KEY 46 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|.| #\.) - (T :> #\>)) -(DEFINE-KEY 112 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|p| #\p) - (T :P #\P)) -(DEFINE-KEY 121 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|y| #\y) - (T :Y #\Y)) -(DEFINE-KEY 102 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|f| #\f) - (T :F #\F)) -(DEFINE-KEY 103 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|g| #\g) - (T :G #\G)) -(DEFINE-KEY 99 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|c| #\c) - (T :C #\C)) -(DEFINE-KEY 114 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|r| #\r) - (T :R #\R)) -(DEFINE-KEY 108 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|l| #\l) - (T :L #\L)) -(DEFINE-KEY 47 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :/ #\/) - (T :? #\?)) -(DEFINE-KEY 61 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) := #\=) - (T :+ #\+)) -(DEFINE-KEY 65293 (T :RETURN #\Return)) -(DEFINE-KEY 65509 (T :CAPS-LOCK NIL)) -(DEFINE-KEY 97 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|a| #\a) - (T :A #\A)) -(DEFINE-KEY 111 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|o| #\o) - (T :O #\O)) -(DEFINE-KEY 101 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|e| #\e) - (T :E #\E)) -(DEFINE-KEY 117 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|u| #\u) - (T :U #\U)) -(DEFINE-KEY 105 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|i| #\i) - (T :I #\I)) -(DEFINE-KEY 100 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|d| #\d) - (T :D #\D)) -(DEFINE-KEY 104 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|h| #\h) - (T :H #\H)) -(DEFINE-KEY 116 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|t| #\t) - (T :T #\T)) -(DEFINE-KEY 110 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|n| #\n) - (T :N #\N)) -(DEFINE-KEY 115 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|s| #\s) - (T :S #\S)) -(DEFINE-KEY 45 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :- #\-) - (T :_ #\_)) -(DEFINE-KEY 96 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|`| #\`) - (T :DEAD-TILDE NIL)) -(DEFINE-KEY 65505 (T :SHIFT-LEFT NIL)) -(DEFINE-KEY 65508 (T :CONTROL-RIGHT NIL)) -(DEFINE-KEY 58 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|:| #\:) - (T :|;| #\;)) -(DEFINE-KEY 113 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|q| #\q) - (T :Q #\Q)) -(DEFINE-KEY 106 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|j| #\j) - (T :J #\J)) -(DEFINE-KEY 107 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|k| #\k) - (T :K #\K)) -(DEFINE-KEY 120 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|x| #\x) - (T :X #\X)) -(DEFINE-KEY 98 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|b| #\b) - (T :B #\B)) -(DEFINE-KEY 109 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|m| #\m) - (T :M #\M)) -(DEFINE-KEY 119 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|w| #\w) - (T :W #\W)) -(DEFINE-KEY 118 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|v| #\v) - (T :V #\V)) -(DEFINE-KEY 122 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|z| #\z) - (T :Z #\Z)) -(DEFINE-KEY 65506 (T :SHIFT-RIGHT NIL)) -(DEFINE-KEY 65450 (T :KP-MULTIPLY NIL)) -(DEFINE-KEY 65511 (T :META-LEFT NIL)) (DEFINE-KEY 32 (T :| | #\ )) -(DEFINE-KEY 65507 (T :CONTROL-LEFT NIL)) -(DEFINE-KEY 65470 (T :F1 NIL)) -(DEFINE-KEY 65471 (T :F2 NIL)) -(DEFINE-KEY 65472 (T :F3 NIL)) -(DEFINE-KEY 65473 (T :F4 NIL)) -(DEFINE-KEY 65474 (T :F5 NIL)) -(DEFINE-KEY 65475 (T :F6 NIL)) -(DEFINE-KEY 65476 (T :F7 NIL)) -(DEFINE-KEY 65477 (T :F8 NIL)) -(DEFINE-KEY 65478 (T :F9 NIL)) -(DEFINE-KEY 65479 (T :F10 NIL)) -(DEFINE-KEY 65407 - ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :NUM-LOCK NIL) - (T :POINTER-ENABLE-KEYS NIL)) -(DEFINE-KEY 65300 (T :SCROLL-LOCK NIL)) -(DEFINE-KEY 65429 ((44 40 36 32 12 8 4 0) :KP-HOME NIL) (T :KP-7 NIL)) -(DEFINE-KEY 65431 ((44 40 36 32 12 8 4 0) :KP-UP NIL) (T :KP-8 NIL)) -(DEFINE-KEY 65434 ((44 40 36 32 12 8 4 0) :KP-PRIOR NIL) (T :KP-9 NIL)) -(DEFINE-KEY 65453 (T :KP-SUBTRACT NIL)) -(DEFINE-KEY 65430 ((44 40 36 32 12 8 4 0) :KP-LEFT NIL) (T :KP-4 NIL)) -(DEFINE-KEY 65437 ((44 40 36 32 12 8 4 0) :KP-BEGIN NIL) (T :KP-5 NIL)) -(DEFINE-KEY 65432 ((44 40 36 32 12 8 4 0) :KP-RIGHT NIL) (T :KP-6 NIL)) -(DEFINE-KEY 65451 (T :KP-ADD NIL)) -(DEFINE-KEY 65436 ((44 40 36 32 12 8 4 0) :KP-END NIL) (T :KP-1 NIL)) -(DEFINE-KEY 65433 ((44 40 36 32 12 8 4 0) :KP-DOWN NIL) (T :KP-2 NIL)) -(DEFINE-KEY 65435 ((44 40 36 32 12 8 4 0) :KP-NEXT NIL) (T :KP-3 NIL)) -(DEFINE-KEY 65438 ((44 40 36 32 12 8 4 0) :KP-INSERT NIL) (T :KP-0 NIL)) -(DEFINE-KEY 65439 ((44 40 36 32 12 8 4 0) :KP-DELETE NIL) (T :KP-DECIMAL NIL)) -(DEFINE-KEY 65377 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :PRINT NIL) - (T :SYS-REQ NIL)) -(DEFINE-KEY 60 ((62 58 54 50 46 42 38 34 30 26 22 18 14 10 6 2) :> #\>) - (T :< #\<)) -(DEFINE-KEY 65480 (T :F11 NIL)) -(DEFINE-KEY 65312 (T :MULTI-KEY NIL)) -(DEFINE-KEY 65360 (T :HOME NIL)) -(DEFINE-KEY 65362 (T :UP NIL)) -(DEFINE-KEY 65365 (T :PRIOR NIL)) -(DEFINE-KEY 65361 (T :LEFT NIL)) -(DEFINE-KEY 65363 (T :RIGHT NIL)) -(DEFINE-KEY 65367 (T :END NIL)) -(DEFINE-KEY 65364 (T :DOWN NIL)) -(DEFINE-KEY 65366 (T :NEXT NIL)) -(DEFINE-KEY 65379 (T :INSERT NIL)) -(DEFINE-KEY 65535 (T :DELETE #\Rubout)) -(DEFINE-KEY 65421 (T :KP-ENTER NIL)) -(DEFINE-KEY 92 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :|\\| #\\) - (T :|\|| #\|)) -(DEFINE-KEY 65299 ((60 56 52 48 44 40 36 32 28 24 20 16 12 8 4 0) :PAUSE NIL) - (T :BREAK NIL)) -(DEFINE-KEY 65455 (T :KP-DIVIDE NIL)) -(DEFINE-KEY 65512 (T :META-RIGHT NIL)) -(DEFINE-KEY 65383 (T :MENU NIL)) -(DEFINE-KEY 268828536 (T :SUN-AUDIO-MUTE NIL)) -(DEFINE-KEY 268828535 (T :SUN-AUDIO-LOWER-VOLUME NIL)) -(DEFINE-KEY 268828537 (T :SUN-AUDIO-RAISE-VOLUME NIL)) (DEFINE-KEY 33 (T :! #\!)) -(DEFINE-KEY 64 (T :@ #\@)) +(DEFINE-KEY 34 (T :|"| #\")) (DEFINE-KEY 35 (T :|#| #\#)) (DEFINE-KEY 36 (T :$ #\$)) (DEFINE-KEY 37 (T :% #\%)) -(DEFINE-KEY 65106 (T :DEAD-CIRCUMFLEX NIL)) (DEFINE-KEY 38 (T :& #\&)) -(DEFINE-KEY 42 (T :* #\*)) +(DEFINE-KEY 39 (T :|'| #\')) (DEFINE-KEY 40 (T :|(| #\()) (DEFINE-KEY 41 (T :|)| #\))) -(DEFINE-KEY 123 (T :{ #\{)) -(DEFINE-KEY 125 (T :} #\})) -(DEFINE-KEY 65056 (T :ISO-LEFT-TAB NIL)) -(DEFINE-KEY 34 (T :|"| #\")) +(DEFINE-KEY 42 (T :* #\*)) +(DEFINE-KEY 43 (T :+ #\+)) +(DEFINE-KEY 44 (T :|,| #\,)) +(DEFINE-KEY 45 (T :- #\-)) +(DEFINE-KEY 46 (T :|.| #\.)) +(DEFINE-KEY 47 (T :/ #\/)) +(DEFINE-KEY 48 (T :|0| #\0)) +(DEFINE-KEY 49 (T :|1| #\1)) +(DEFINE-KEY 50 (T :|2| #\2)) +(DEFINE-KEY 51 (T :|3| #\3)) +(DEFINE-KEY 52 (T :|4| #\4)) +(DEFINE-KEY 53 (T :|5| #\5)) +(DEFINE-KEY 54 (T :|6| #\6)) +(DEFINE-KEY 55 (T :|7| #\7)) +(DEFINE-KEY 56 (T :|8| #\8)) +(DEFINE-KEY 57 (T :|9| #\9)) +(DEFINE-KEY 58 (T :|:| #\:)) +(DEFINE-KEY 59 (T :|;| #\;)) +(DEFINE-KEY 60 (T :< #\<)) +(DEFINE-KEY 61 (T := #\=)) (DEFINE-KEY 62 (T :> #\>)) -(DEFINE-KEY 80 (T :P #\P)) -(DEFINE-KEY 89 (T :Y #\Y)) -(DEFINE-KEY 70 (T :F #\F)) -(DEFINE-KEY 71 (T :G #\G)) -(DEFINE-KEY 67 (T :C #\C)) -(DEFINE-KEY 82 (T :R #\R)) -(DEFINE-KEY 76 (T :L #\L)) (DEFINE-KEY 63 (T :? #\?)) -(DEFINE-KEY 43 (T :+ #\+)) +(DEFINE-KEY 64 (T :@ #\@)) (DEFINE-KEY 65 (T :A #\A)) -(DEFINE-KEY 79 (T :O #\O)) -(DEFINE-KEY 69 (T :E #\E)) -(DEFINE-KEY 85 (T :U #\U)) -(DEFINE-KEY 73 (T :I #\I)) +(DEFINE-KEY 66 (T :B #\B)) +(DEFINE-KEY 67 (T :C #\C)) (DEFINE-KEY 68 (T :D #\D)) +(DEFINE-KEY 69 (T :E #\E)) +(DEFINE-KEY 70 (T :F #\F)) +(DEFINE-KEY 71 (T :G #\G)) (DEFINE-KEY 72 (T :H #\H)) -(DEFINE-KEY 84 (T :T #\T)) -(DEFINE-KEY 78 (T :N #\N)) -(DEFINE-KEY 83 (T :S #\S)) -(DEFINE-KEY 95 (T :_ #\_)) -(DEFINE-KEY 65107 (T :DEAD-TILDE NIL)) -(DEFINE-KEY 59 (T :|;| #\;)) -(DEFINE-KEY 81 (T :Q #\Q)) +(DEFINE-KEY 73 (T :I #\I)) (DEFINE-KEY 74 (T :J #\J)) (DEFINE-KEY 75 (T :K #\K)) -(DEFINE-KEY 88 (T :X #\X)) -(DEFINE-KEY 66 (T :B #\B)) +(DEFINE-KEY 76 (T :L #\L)) (DEFINE-KEY 77 (T :M #\M)) -(DEFINE-KEY 87 (T :W #\W)) +(DEFINE-KEY 78 (T :N #\N)) +(DEFINE-KEY 79 (T :O #\O)) +(DEFINE-KEY 80 (T :P #\P)) +(DEFINE-KEY 81 (T :Q #\Q)) +(DEFINE-KEY 82 (T :R #\R)) +(DEFINE-KEY 83 (T :S #\S)) +(DEFINE-KEY 84 (T :T #\T)) +(DEFINE-KEY 85 (T :U #\U)) (DEFINE-KEY 86 (T :V #\V)) +(DEFINE-KEY 87 (T :W #\W)) +(DEFINE-KEY 88 (T :X #\X)) +(DEFINE-KEY 89 (T :Y #\Y)) (DEFINE-KEY 90 (T :Z #\Z)) +(DEFINE-KEY 91 (T :[ #\[)) +(DEFINE-KEY 92 (T :|\\| #\\)) +(DEFINE-KEY 93 (T :] #\])) +(DEFINE-KEY 95 (T :_ #\_)) +(DEFINE-KEY 96 (T :|`| #\`)) +(DEFINE-KEY 97 (T :|a| #\a)) +(DEFINE-KEY 98 (T :|b| #\b)) +(DEFINE-KEY 99 (T :|c| #\c)) +(DEFINE-KEY 100 (T :|d| #\d)) +(DEFINE-KEY 101 (T :|e| #\e)) +(DEFINE-KEY 102 (T :|f| #\f)) +(DEFINE-KEY 103 (T :|g| #\g)) +(DEFINE-KEY 104 (T :|h| #\h)) +(DEFINE-KEY 105 (T :|i| #\i)) +(DEFINE-KEY 106 (T :|j| #\j)) +(DEFINE-KEY 107 (T :|k| #\k)) +(DEFINE-KEY 108 (T :|l| #\l)) +(DEFINE-KEY 109 (T :|m| #\m)) +(DEFINE-KEY 110 (T :|n| #\n)) +(DEFINE-KEY 111 (T :|o| #\o)) +(DEFINE-KEY 112 (T :|p| #\p)) +(DEFINE-KEY 113 (T :|q| #\q)) +(DEFINE-KEY 114 (T :|r| #\r)) +(DEFINE-KEY 115 (T :|s| #\s)) +(DEFINE-KEY 116 (T :|t| #\t)) +(DEFINE-KEY 117 (T :|u| #\u)) +(DEFINE-KEY 118 (T :|v| #\v)) +(DEFINE-KEY 119 (T :|w| #\w)) +(DEFINE-KEY 120 (T :|x| #\x)) +(DEFINE-KEY 121 (T :|y| #\y)) +(DEFINE-KEY 122 (T :|z| #\z)) +(DEFINE-KEY 123 (T :{ #\{)) +(DEFINE-KEY 124 (T :|\|| #\|)) +(DEFINE-KEY 125 (T :} #\})) +(DEFINE-KEY 65056 (T :ISO-LEFT-TAB NIL)) +(DEFINE-KEY 65106 (T :DEAD-CIRCUMFLEX NIL)) +(DEFINE-KEY 65107 (T :DEAD-TILDE NIL)) (DEFINE-KEY 65273 (T :POINTER-ENABLE-KEYS NIL)) -(DEFINE-KEY 65463 ((60 56 52 48 28 24 20 16) :KP-HOME NIL) (T :KP-7 NIL)) -(DEFINE-KEY 65464 ((60 56 52 48 28 24 20 16) :KP-UP NIL) (T :KP-8 NIL)) -(DEFINE-KEY 65465 ((60 56 52 48 28 24 20 16) :KP-PRIOR NIL) (T :KP-9 NIL)) -(DEFINE-KEY 65460 ((60 56 52 48 28 24 20 16) :KP-LEFT NIL) (T :KP-4 NIL)) -(DEFINE-KEY 65461 ((60 56 52 48 28 24 20 16) :KP-BEGIN NIL) (T :KP-5 NIL)) -(DEFINE-KEY 65462 ((60 56 52 48 28 24 20 16) :KP-RIGHT NIL) (T :KP-6 NIL)) -(DEFINE-KEY 65457 ((60 56 52 48 28 24 20 16) :KP-END NIL) (T :KP-1 NIL)) -(DEFINE-KEY 65458 ((60 56 52 48 28 24 20 16) :KP-DOWN NIL) (T :KP-2 NIL)) -(DEFINE-KEY 65459 ((60 56 52 48 28 24 20 16) :KP-NEXT NIL) (T :KP-3 NIL)) -(DEFINE-KEY 65456 ((60 56 52 48 28 24 20 16) :KP-INSERT NIL) (T :KP-0 NIL)) -(DEFINE-KEY 65454 ((60 56 52 48 28 24 20 16) :KP-DELETE NIL) - (T :KP-DECIMAL NIL)) +(DEFINE-KEY 65288 (T :BACKSPACE #\Backspace)) +(DEFINE-KEY 65289 (T :TAB #\Tab)) +(DEFINE-KEY 65293 (T :RETURN #\Return)) +(DEFINE-KEY 65299 ((9 1) :BREAK NIL) (T :PAUSE NIL)) +(DEFINE-KEY 65300 (T :SCROLL-LOCK NIL)) (DEFINE-KEY 65301 (T :SYS-REQ NIL)) -(DEFINE-KEY 124 (T :|\|| #\|)) -(DEFINE-KEY 65387 ((60 52 44 36 28 20 12 4) :PAUSE NIL) (T :BREAK NIL)) \ No newline at end of file +(DEFINE-KEY 65307 (T :ESCAPE NIL)) +(DEFINE-KEY 65312 (T :MULTI-KEY NIL)) +(DEFINE-KEY 65360 (T :HOME NIL)) +(DEFINE-KEY 65361 (T :LEFT NIL)) +(DEFINE-KEY 65362 (T :UP NIL)) +(DEFINE-KEY 65363 (T :RIGHT NIL)) +(DEFINE-KEY 65364 (T :DOWN NIL)) +(DEFINE-KEY 65365 (T :PRIOR NIL)) +(DEFINE-KEY 65366 (T :NEXT NIL)) +(DEFINE-KEY 65367 (T :END NIL)) +(DEFINE-KEY 65377 ((12 4 8 0) :PRINT NIL) (T :SYS-REQ NIL)) +(DEFINE-KEY 65379 (T :INSERT NIL)) +(DEFINE-KEY 65383 (T :MENU NIL)) +(DEFINE-KEY 65387 ((12 4) :PAUSE NIL) (T :BREAK NIL)) +(DEFINE-KEY 65407 (T :NUM-LOCK NIL)) +(DEFINE-KEY 65421 (T :KP-ENTER NIL)) +(DEFINE-KEY 65429 (T :KP-HOME NIL)) +(DEFINE-KEY 65430 (T :KP-LEFT NIL)) +(DEFINE-KEY 65431 (T :KP-UP NIL)) +(DEFINE-KEY 65432 (T :KP-RIGHT NIL)) +(DEFINE-KEY 65433 (T :KP-DOWN NIL)) +(DEFINE-KEY 65434 (T :KP-PRIOR NIL)) +(DEFINE-KEY 65435 (T :KP-NEXT NIL)) +(DEFINE-KEY 65436 (T :KP-END NIL)) +(DEFINE-KEY 65437 (T :KP-BEGIN NIL)) +(DEFINE-KEY 65438 (T :KP-INSERT NIL)) +(DEFINE-KEY 65439 (T :KP-DELETE NIL)) +(DEFINE-KEY 65450 (T :KP-MULTIPLY NIL)) +(DEFINE-KEY 65451 (T :KP-ADD NIL)) +(DEFINE-KEY 65453 (T :KP-SUBTRACT NIL)) +(DEFINE-KEY 65454 (T :KP-DECIMAL NIL)) +(DEFINE-KEY 65455 (T :KP-DIVIDE NIL)) +(DEFINE-KEY 65456 (T :KP-0 NIL)) +(DEFINE-KEY 65457 (T :KP-1 NIL)) +(DEFINE-KEY 65458 (T :KP-2 NIL)) +(DEFINE-KEY 65459 (T :KP-3 NIL)) +(DEFINE-KEY 65460 (T :KP-4 NIL)) +(DEFINE-KEY 65461 (T :KP-5 NIL)) +(DEFINE-KEY 65462 (T :KP-6 NIL)) +(DEFINE-KEY 65463 (T :KP-7 NIL)) +(DEFINE-KEY 65464 (T :KP-8 NIL)) +(DEFINE-KEY 65465 (T :KP-9 NIL)) +(DEFINE-KEY 65470 (T :F1 NIL)) +(DEFINE-KEY 65471 (T :F2 NIL)) +(DEFINE-KEY 65472 (T :F3 NIL)) +(DEFINE-KEY 65473 (T :F4 NIL)) +(DEFINE-KEY 65474 (T :F5 NIL)) +(DEFINE-KEY 65475 (T :F6 NIL)) +(DEFINE-KEY 65476 (T :F7 NIL)) +(DEFINE-KEY 65477 (T :F8 NIL)) +(DEFINE-KEY 65478 (T :F9 NIL)) +(DEFINE-KEY 65479 (T :F10 NIL)) +(DEFINE-KEY 65480 (T :F11 NIL)) +(DEFINE-KEY 65505 (T :SHIFT-LEFT NIL)) +(DEFINE-KEY 65506 (T :SHIFT-RIGHT NIL)) +(DEFINE-KEY 65507 (T :CONTROL-LEFT NIL)) +(DEFINE-KEY 65508 (T :CONTROL-RIGHT NIL)) +(DEFINE-KEY 65509 (T :CAPS-LOCK NIL)) +(DEFINE-KEY 65511 (T :META-LEFT NIL)) +(DEFINE-KEY 65512 (T :META-RIGHT NIL)) +(DEFINE-KEY 65535 (T :DELETE #\Rubout)) +(DEFINE-KEY 268828535 (T :SUN-AUDIO-LOWER-VOLUME NIL)) +(DEFINE-KEY 268828536 (T :SUN-AUDIO-MUTE NIL)) +(DEFINE-KEY 268828537 (T :SUN-AUDIO-RAISE-VOLUME NIL)) \ No newline at end of file From dlichteblau at common-lisp.net Mon Dec 25 12:43:49 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Mon, 25 Dec 2006 07:43:49 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061225124349.8ECBF232B8@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv326 Modified Files: NEWS Log Message: note font listing --- /project/mcclim/cvsroot/mcclim/NEWS 2006/12/21 10:36:40 1.15 +++ /project/mcclim/cvsroot/mcclim/NEWS 2006/12/25 12:43:49 1.16 @@ -24,6 +24,8 @@ implemented. ** specification compliance: POINTER-INPUT-RECTANGLE function now implemented. +** Improvement: Added font listing support, see section "Fonts and Extended + Text Styles" in the manual. * Changes in mcclim-0.9.3 "All Souls' Day" relative to 0.9.2: ** backend improvement: The Null backend now registers itself in the From dlichteblau at common-lisp.net Mon Dec 25 19:41:46 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Mon, 25 Dec 2006 14:41:46 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061225194146.9007261026@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv1435 Modified Files: gadgets.lisp Log Message: Bugfix: * Backends/gtkairo/gadgets.lisp (UPDATE-SCROLL-BAR-ADJUSTMENT): Ignore unmirrored scroll bars. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/12/24 11:30:59 1.18 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/12/25 19:41:46 1.19 @@ -630,14 +630,15 @@ ;; not a ratio but given in value units? Why is min==max all the time? ;; And why doesn't this work! :-( (defun update-scrollbar-adjustment (sheet) - (with-gtk () - (let* ((min (df (gadget-min-value sheet))) - (value (df (gadget-value sheet))) - (page-size (df (climi::scroll-bar-thumb-size sheet))) - (max (+ (df (gadget-max-value sheet)) page-size))) - (gtk_range_set_adjustment - (mirror-widget (sheet-direct-mirror sheet)) - (gtk_adjustment_new value min max 0.0d0 0.0d0 page-size))))) + (when (sheet-direct-mirror sheet) + (with-gtk () + (let* ((min (df (gadget-min-value sheet))) + (value (df (gadget-value sheet))) + (page-size (df (climi::scroll-bar-thumb-size sheet))) + (max (+ (df (gadget-max-value sheet)) page-size))) + (gtk_range_set_adjustment + (mirror-widget (sheet-direct-mirror sheet)) + (gtk_adjustment_new value min max 0.0d0 0.0d0 page-size)))))) (defmethod (setf gadget-min-value) :after (new-value (pane native-scrollbar)) (declare (ignore new-value)) From dlichteblau at common-lisp.net Mon Dec 25 19:55:11 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Mon, 25 Dec 2006 14:55:11 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061225195511.8D6C33002E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv3180 Modified Files: mcclim.asd Log Message: Added a GDK medium, for more CLX-like output. Set CLIM-GTKAIRO::*MEDIUM-TYPE* to :GDK or :CAIRO to choose. * mcclim.asd: Added gdk.lisp. * Backends/gtkairo/gdk.lisp: New file. * Backends/gtkairo/ffi.lisp: Regenerated. * Backends/gtkairo/gtk-ffi.lisp (gdkpoint): New struct definition. * Backends/gtkairo/medium.lisp (CAIRO-MEDIUM): Renamed from gtkairo-medium. (GTKAIRO-MEDIUM): New superclass. (INVOKE-WITH-CAIRO-MEDIUM): Renamed to INVOKE-WITH-MEDIUM, now generic. (METRIK-MEDIUM-FOR): New function. (*MEDIUM-TYPE*): New variable. (MAKE-MEDIUM): Dispatch on *medium-type*. (SYNC-TEXT-STYLE, ASSERT-FONT-STATUS, CAIRO-TEXT-EXTENTS): Removed. (SYNC-SHEET, all MEDIUM-foo-bar functions): s/with-medium/with-medium/ and s/gtkairo-medium/cairo-medium/. (INVOKE-WITH-PANGO-LAYOUT): New. (MEDIUM-DRAW-TEXT*): s/with-pango-cairo/with-pango-layout/. (TEXT-SIZE, TEXT-BOUNDING-RECTANGLE): Use METRIK-MEDIUM-FOR. (TEXT-STYLE-foo): Use METRIK-MEDIUM-FOR. Perform caching in the primary method. Put the class name into the hash key. (DESTROY-SURFACE-MEDIUM): Renamed from destroy-cairo-medium. (DESTROY-MEDIUM): New generic function and method. (...) Etc. pp. * pango.lisp (METRIK-MEDIUM-MIXIN): Renamed from metrik-medium. (CAIRO-METRIK-MEDIUM, GDK-METRIK-MEDIUM): New classes. (WITH-MEDIUM): Renamed from WITH-CAIRO-MEDIUM. (WITH-PANGO-LAYOUT): Renamed from with-pango-cairo. (CONFIGURE-PANGO-LAYOUT, INVOKE-WITH-PANGO-LAYOUT, INVOKE-WITH-PANGO-CAIRO): Replaced the latter. (TEXT-SIZE, TEXT-BOUNDING-RECTANGLE*): Split up into into methods for cairo and gdk. (TEXT-STYLE-foo): s/metrik-medium/metrik-medium-mixin/. * pixmap.lisp (%medium-copy-area): Factor cairo calls out into combining methods. * port.lisp (GDK-METRIK-MEDIUM): New slot in the port. (CAIRO-METRIK-MEDIUM): Renamed from metrik-medium. (INITIALIZE-INSTANCE): Install gdk-metrik-medium. (INVOKE-WITH-GDKCOLOR, WITH-GDKCOLOR): New, based on gtk-widget-modify-bg. (DESTROY-MEDIUMS, RESET-MEDIUMS): Call destroy-medium. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/12/24 14:27:43 1.42 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/12/25 19:55:05 1.43 @@ -388,6 +388,7 @@ (:file "keys") (:file "pango") (:file "medium") + (:file "gdk") (:file "pixmap") (:file "frame-manager") (:file "gadgets"))))) From dlichteblau at common-lisp.net Mon Dec 25 20:50:06 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Mon, 25 Dec 2006 15:50:06 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061225205006.B00F252018@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv11309 Modified Files: clim-fix.lisp Log Message: Fix non-cairo presentation highlighting when gtkairo is loaded. * clim-fix.lisp (HIGHLIGHT-OUTPUT-RECORD-RECTANGLE): Move the lower and right borders 0.5 px inwards instead of outwards. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/clim-fix.lisp 2006/11/05 17:22:23 1.5 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/clim-fix.lisp 2006/12/25 20:50:06 1.6 @@ -49,8 +49,8 @@ (draw-rectangle* (sheet-medium stream) (+ (ceiling x1) 0.5d0) (+ (ceiling y1) 0.5d0) - (+ (floor (1- x2)) 0.5d0) - (+ (floor (1- y2)) 0.5d0) + (- (floor (1- x2)) 0.5d0) + (- (floor (1- y2)) 0.5d0) ;; XXX +FLIPPING-INK+? :filled nil :ink +foreground-ink+)) (:unhighlight From dlichteblau at common-lisp.net Mon Dec 25 21:34:57 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Mon, 25 Dec 2006 16:34:57 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061225213457.C241824065@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv17603 Modified Files: port.lisp Log Message: Enable double buffering for panes created with :DOUBLE-BUFFERING T only. Gsharp already uses this method. * Backends/gtkairo/port.lisp (*DOUBLE-BUFFERING-P*): Removed. (MIRROR-DRAWABLE): Use PANE-DOUBLE-BUFFERING, not *d-b-p*. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/12/25 19:55:11 1.14 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/12/25 21:34:57 1.15 @@ -143,36 +143,23 @@ (defmethod mirror-real-drawable ((mirror widget-mirror)) (gtkwidget-gdkwindow (mirror-widget mirror))) -(defvar *double-buffering-p* - #+(or win32 windows mswindows) t - #-(or win32 windows mswindows) nil) - -#+(or) -(setf *double-buffering-p* nil) - (defmethod mirror-drawable ((mirror widget-mirror)) - (if *double-buffering-p* - (or (mirror-buffering-pixmap mirror) - (setf (mirror-buffering-pixmap mirror) - (let* ((window (mirror-real-drawable mirror)) - (region (climi::sheet-mirror-region - (climi::port-lookup-sheet - (mirror-port mirror) - mirror))) - (width (floor (bounding-rectangle-max-x region))) - (height (floor (bounding-rectangle-max-y region))) - (pixmap (gdk_pixmap_new window width height -1)) - (cr (gdk_cairo_create pixmap))) - (set-antialias cr) - (cairo_set_source_rgba cr - 1.0d0 - 1.0d0 - 1.0d0 - 1.0d0) - (cairo_paint cr) - (cairo_destroy cr) - pixmap))) - (mirror-real-drawable mirror))) + (let ((sheet (climi::port-lookup-sheet (mirror-port mirror) mirror))) + (if (climi::pane-double-buffering sheet) + (or (mirror-buffering-pixmap mirror) + (setf (mirror-buffering-pixmap mirror) + (let* ((window (mirror-real-drawable mirror)) + (region (climi::sheet-mirror-region sheet)) + (width (floor (bounding-rectangle-max-x region))) + (height (floor (bounding-rectangle-max-y region))) + (pixmap (gdk_pixmap_new window width height -1)) + (cr (gdk_cairo_create pixmap))) + (set-antialias cr) + (cairo_set_source_rgba cr 1.0d0 1.0d0 1.0d0 1.0d0) + (cairo_paint cr) + (cairo_destroy cr) + pixmap))) + (mirror-real-drawable mirror)))) (defun widget->sheet (widget port) (gethash (cffi:pointer-address widget) (widgets->sheets port))) From dlichteblau at common-lisp.net Tue Dec 26 12:11:04 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Tue, 26 Dec 2006 07:11:04 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061226121104.9BD8022018@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv28245 Modified Files: mcclim.asd Log Message: Split up gtkairo/medium.lisp, moving the cairo medium into its own file. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/12/25 19:55:05 1.43 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/12/26 12:11:04 1.44 @@ -386,8 +386,9 @@ (:file "port") (:file "event") (:file "keys") - (:file "pango") (:file "medium") + (:file "pango") + (:file "cairo") (:file "gdk") (:file "pixmap") (:file "frame-manager") From dlichteblau at common-lisp.net Tue Dec 26 12:11:04 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Tue, 26 Dec 2006 07:11:04 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061226121104.E3A3B22018@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv28245/Backends/gtkairo Modified Files: gtk-ffi.lisp medium.lisp pango.lisp Added Files: cairo.lisp Log Message: Split up gtkairo/medium.lisp, moving the cairo medium into its own file. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/12/25 19:55:11 1.24 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/12/26 12:11:04 1.25 @@ -118,6 +118,9 @@ (defmacro with-cairo-floats ((&optional) &body body) `(progn , at body)) +(defmacro slot (o c s) + `(cffi:foreign-slot-value ,o ,c ,s)) + ;; Note: There's no need for locking in single threaded mode for most ;; functions, except that the main loop functions try to release the ;; lock temporarily, so those need to be called with locking. Let's do --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/12/25 19:55:11 1.15 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/12/26 12:11:04 1.16 @@ -32,21 +32,16 @@ (defclass gtkairo-medium (climi::basic-medium clim:medium) ((port :initarg :port :accessor port))) -(defclass cairo-medium (gtkairo-medium) - ((cr :initform nil :initarg :cr :accessor cr) - (flipping-original-cr :initform nil :accessor flipping-original-cr) - (flipping-pixmap :initform nil :accessor flipping-pixmap) - (flipping-region :accessor flipping-region) - (surface :initarg :surface :accessor surface) - (last-seen-sheet :accessor last-seen-sheet) - (last-seen-region :accessor last-seen-region))) - -(defmethod initialize-instance :after - ((instance cairo-medium) &key cr) - (unless cr - (setf (last-seen-sheet instance) nil))) +(defclass metrik-medium-mixin () ()) +(defclass cairo-metrik-medium (metrik-medium-mixin cairo-medium) ()) +(defclass gdk-metrik-medium (metrik-medium-mixin gdk-medium) ()) -(defparameter *antialiasingp* t) +(defgeneric invoke-with-medium (fn medium)) + +(defmacro with-medium ((medium) &body body) + `(invoke-with-medium (lambda () , at body) ,medium)) + +(defgeneric metrik-medium-for (medium)) (defun gtkwidget-gdkwindow (widget) (cffi:foreign-slot-value widget 'gtkwidget 'gdkwindow)) @@ -55,55 +50,6 @@ (or (climi::port-lookup-mirror (port medium) (medium-sheet medium)) (error "oops, drawing operation on unmirrored sheet ~A" medium))) -(defmethod invoke-with-medium (fn (medium cairo-medium)) - (when (or (cr medium) - (climi::port-lookup-mirror (port medium) (medium-sheet medium))) - (with-gtk () - (multiple-value-prog1 - (funcall fn) - (when (flipping-original-cr medium) - (apply-flipping-ink medium)))))) - -(defun sheet-changed-behind-our-back-p (medium) - (and (slot-boundp medium 'last-seen-sheet) - (or (not (eq (last-seen-sheet medium) (medium-sheet medium))) - (not (region-equal (last-seen-region medium) - (sheet-region (medium-sheet medium))))))) - -(defmethod metrik-medium-for ((medium cairo-medium)) - (cairo-metrik-medium (port medium))) - -(defun set-antialias (cr) - (cairo_set_antialias cr - (if *antialiasingp* - :CAIRO_ANTIALIAS_DEFAULT - :CAIRO_ANTIALIAS_NONE))) - -(defun sync-sheet (medium) - (when (medium-sheet medium) ;ignore the metrik-medium - (setf (gethash medium (dirty-mediums (port medium))) t)) - (when (or (null (cr medium)) - (sheet-changed-behind-our-back-p medium)) - (with-medium (medium) - (let* ((mirror (medium-mirror medium)) - (drawable (mirror-drawable mirror))) - (setf (cr medium) (gdk_cairo_create drawable)) - (dispose-flipping-pixmap medium) - (pushnew medium (mirror-mediums mirror)) - (set-antialias (cr medium))) - (setf (last-seen-sheet medium) (medium-sheet medium)) - (setf (last-seen-region medium) (sheet-region (medium-sheet medium)))))) - -(defun dispose-flipping-pixmap (medium) - (when (flipping-pixmap medium) - (gdk_drawable_unref (flipping-pixmap medium)) - (setf (flipping-pixmap medium) nil))) - - -;;;; ------------------------------------------------------------------------ -;;;; 8.3 Output Protocol -;;;; - (defmethod engraft-medium :after ((medium gtkairo-medium) port sheet) ) @@ -125,169 +71,6 @@ :port port :sheet sheet)) -;;;; ------------------------------------------------------------------------ -;;;; Drawing Options -;;;; - -(defun sync-transformation (medium &optional extra-transformation) - (with-slots (cr) medium - (cffi:with-foreign-object (matrix 'cairo_matrix_t) - (let ((tr - (if (medium-sheet medium) - (sheet-native-transformation (medium-sheet medium)) - clim:+identity-transformation+))) - (when extra-transformation - (setf tr (compose-transformations extra-transformation tr))) - (multiple-value-bind (mxx mxy myx myy tx ty) - (climi::get-transformation tr) - ;; Make sure not to hand transformations to cairo that it won't - ;; like, since debugging gets ugly once a cairo context goes - ;; into an error state: - (invert-transformation tr) - (cairo_matrix_init matrix - (df mxx) (df mxy) (df myx) (df myy) - (df tx) (df ty)) - (cairo_set_matrix cr matrix)))))) - -(defmacro with-cairo-matrix ((matrix transformation) &body body) - `(cffi:with-foreign-object (,matrix 'cairo_matrix_t) - (multiple-value-bind (mxx mxy myx myy tx ty) - (climi::get-transformation ,transformation) - (cairo_matrix_init ,matrix - (df mxx) (df mxy) (df myx) (df myy) - (df tx) (df ty)) - (locally , at body)))) - -;;; ink - -(defmethod sync-ink :before (medium new-value) - (with-slots (cr) medium - (cairo_set_operator cr :over))) - -(defmethod sync-ink (medium (new-value (eql clim:+foreground-ink+))) - (sync-ink medium (clim:medium-foreground medium))) ;### circles? - -(defmethod sync-ink (medium (new-value (eql clim:+background-ink+))) - (sync-ink medium (clim:medium-background medium))) ;### circles? - -(defmethod sync-ink (medium (new-value clim:opacity)) - (with-slots (cr) medium - (cond ((= 0 (opacity-value new-value)) - (cairo_set_source_rgba cr 0d0 0d0 0d0 0d0)) - ((= 1 (opacity-value new-value)) - (sync-ink medium (clim:medium-foreground medium))) - (t - (sync-ink medium (clim:compose-in (clim:medium-foreground medium) - new-value)))))) - -(defmethod sync-ink (medium (new-value climi::uniform-compositum)) - (with-slots (cr) medium - (with-slots ((ink climi::ink) (mask climi::mask)) new-value - (multiple-value-bind (red green blue) (clim:color-rgb ink) - (cairo_set_source_rgba cr - (df red) - (df green) - (df blue) - (df (clim:opacity-value mask))))))) - -(defmethod sync-ink (medium (new-value clim:color)) - (with-slots (cr) medium - (multiple-value-bind (red green blue) (clim:color-rgb new-value) - (cairo_set_source_rgba cr (df red) (df green) (df blue) (df 1.0d0))))) - -(defvar *pattern-hash* - (make-hash-table)) - -(defun pattern-cairo-pattern (medium pattern) - (or (gethash pattern *pattern-hash*) - (setf (gethash pattern *pattern-hash*) - (let ((s (make-cairo-surface medium - (pattern-width pattern) - (pattern-height pattern)))) - (draw-design s pattern) - (cairo_pattern_create_for_surface (slot-value s 'surface)))))) - -(defmethod sync-ink (medium (pattern climi::indexed-pattern)) - (with-slots (cr) medium - (let ((s (make-cairo-surface medium - (pattern-width pattern) - (pattern-height pattern)))) - (draw-design s pattern) - (let ((p (cairo_pattern_create_for_surface (slot-value s 'surface)))) - (cairo_set_source cr p) - p)))) - -(defmethod sync-ink (medium (pattern climi::indexed-pattern)) - (with-slots (cr) medium - (let ((p (pattern-cairo-pattern medium pattern))) - (cairo_set_source cr p) - p))) - -(defmethod sync-ink (medium (design clim-internals::transformed-design)) - (with-slots ((design climi::design) (transformation climi::transformation)) - design - ;; ### hmm - (let ((p (sync-ink medium design))) - (with-cairo-matrix (matrix (invert-transformation transformation)) - (cairo_pattern_set_matrix p matrix)) - p))) - -(defun apply-flipping-ink (medium) - (let ((from-surface (cairo_get_target (cr medium))) - (from-drawable (flipping-pixmap medium)) - (to-surface (cairo_get_target (flipping-original-cr medium))) - (to-drawable (medium-gdkdrawable medium))) - (cairo_surface_flush from-surface) - (cairo_surface_flush to-surface) - (let ((gc (gdk_gc_new to-drawable)) - (region (flipping-region medium))) - (gdk_gc_set_function gc :GDK_XOR) - (gdk_draw_drawable to-drawable gc from-drawable - (floor (bounding-rectangle-min-x region)) - (floor (bounding-rectangle-min-y region)) - (floor (bounding-rectangle-min-x region)) - (floor (bounding-rectangle-min-y region)) - (ceiling (bounding-rectangle-max-x region)) - (ceiling (bounding-rectangle-max-y region))) - (gdk_gc_unref gc)) - (cairo_surface_mark_dirty to-surface)) - (cairo_destroy (cr medium)) - (setf (cr medium) (flipping-original-cr medium)) - (setf (flipping-original-cr medium) nil)) - -(defmethod sync-ink (medium (design climi::standard-flipping-ink)) - (setf (flipping-original-cr medium) (cr medium)) - (let* ((mirror (medium-mirror medium)) - (drawable (mirror-drawable mirror))) - (let* ((region (climi::sheet-mirror-region (medium-sheet medium))) - (width (floor (bounding-rectangle-max-x region))) - (height (floor (bounding-rectangle-max-y region))) - (pixmap - (or (flipping-pixmap medium) - (setf (flipping-pixmap medium) - (gdk_pixmap_new drawable width height -1))))) - (setf (cr medium) (gdk_cairo_create pixmap)) - (set-antialias (cr medium)) - (setf (flipping-region medium) region) - (cairo_paint (cr medium)) - (sync-transformation medium) - (sync-ink medium +white+)))) - -(defmethod sync-ink (medium new-value) - (warn "SYNC-INK lost ~S." new-value)) - -;;; clipping region - -(defun sync-clipping-region (medium region) - (with-slots (cr) medium - (cairo_reset_clip cr) - (unless (eq region +everywhere+) - (unless (eq region +nowhere+) - (loop for (x y w h) in (clipping-region->rect-seq region) do - (cairo_rectangle cr (df x) (df y) (df w) (df h)))) - (cairo_clip cr)) - (cairo_new_path cr))) - ;; copy&paste from medium.lisp|CLX: ;; this seems to work, but find out why all of these +nowhere+s are coming from ;; and kill them at the source... @@ -305,67 +88,6 @@ (- (round-coordinate (rectangle-max-x rectangle)) clip-x) (- (round-coordinate (rectangle-max-y rectangle)) clip-y)))) -;;; line-style - -(defun sync-line-style (medium line-style) - (with-slots (cr) medium - (cairo_set_line_cap cr - (case (line-style-cap-shape line-style) - (:butt :butt) - (:square :square) - (:round :round) - (:no-end-point :round))) ;### - (cond ((null (line-style-dashes line-style)) - (cairo_set_dash cr (cffi:null-pointer) 0 0d0)) ;hmm - ((eq t (line-style-dashes line-style)) - (let ((d 10)) - (cairo-set-dash* cr - (case (line-style-unit line-style) - ((:point :normal) - (map 'vector (lambda (x) - (untransform-size - (medium-transformation - medium) x)) - (list d))) - (:coordinate - (list d)))))) - (t - ;; line-style-unit! - (cairo-set-dash* cr - (case (line-style-unit line-style) - ((:point :normal) - (map 'vector (lambda (x) - (untransform-size - (medium-transformation medium) - x)) - (line-style-dashes line-style))) - (:coordinate - (line-style-dashes line-style)))))) - (cairo_set_line_join cr - (case (line-style-joint-shape line-style) - (:miter :miter) - (:bevel :bevel) - (:round :round) - (:none :round))) ;### - (cairo_set_line_width cr - (max 1.0d0 - (df - (case (line-style-unit line-style) - ((:point :normal) - (untransform-size - (medium-transformation medium) - (line-style-thickness line-style))) - (:coordinate - (line-style-thickness line-style)))))) )) - -(defun cairo-set-dash* (cr dashes) - (let ((ndash (length dashes))) - (cffi:with-foreign-object (adashes :double ndash) - (loop - for i below ndash do - (setf (cffi:mem-aref adashes :double i) (df (elt dashes i)))) - (cairo_set_dash cr adashes ndash 0d0)))) - (defun untransform-size (transformation size) (multiple-value-bind (dx dy) (untransform-distance transformation size 0) (sqrt (+ (expt dx 2) (expt dy 2))))) @@ -374,242 +96,6 @@ (multiple-value-bind (dx dy) (transform-distance transformation size 0) (sqrt (+ (expt dx 2) (expt dy 2))))) -(defun sync-drawing-options (medium) - (sync-transformation medium) - (sync-ink medium (medium-ink medium)) - (sync-clipping-region medium (medium-clipping-region medium)) - (sync-line-style medium (medium-line-style medium))) - -;;;; ------------------------------------------------------------------------ -;;;; Drawing Operations -;;;; - -(defmethod medium-draw-point* ((medium cairo-medium) x y) - (with-medium (medium) - (sync-sheet medium) - (sync-transformation medium) - (sync-ink medium (medium-ink medium)) - (sync-clipping-region medium (medium-clipping-region medium)) - (sync-line-style medium (medium-line-style medium)) - (with-slots (cr) medium - (cairo_set_line_cap cr :round) - (setf x (df x)) - (setf y (df y)) - (cairo_move_to cr x y) - (cairo_line_to cr (+ x 0.5) (+ y 0.5)) - (cairo_stroke cr)))) - -(defmethod medium-draw-points* ((medium cairo-medium) coord-seq) - (with-medium (medium) - (sync-sheet medium) - (sync-transformation medium) - (sync-ink medium (medium-ink medium)) - (sync-clipping-region medium (medium-clipping-region medium)) - (sync-line-style medium (medium-line-style medium)) - (with-slots (cr) medium - (cairo_set_line_cap cr :round) - (loop for i below (length coord-seq) by 2 do - (let ((x (df (elt coord-seq (+ i 0)))) - (y (df (elt coord-seq (+ i 1))))) - (cairo_move_to cr x y) - (cairo_line_to cr (+ x 0.5) (+ y 0.5)) - (cairo_stroke cr)))))) - -(defmethod medium-draw-line* ((medium cairo-medium) x1 y1 x2 y2) - (with-medium (medium) - (sync-sheet medium) - (sync-transformation medium) - (sync-ink medium (medium-ink medium)) - (sync-clipping-region medium (medium-clipping-region medium)) - (sync-line-style medium (medium-line-style medium)) - (with-slots (cr) medium - (cairo_move_to cr (df x1) (df y1)) - (cairo_line_to cr (df x2) (df y2)) - (cairo_stroke cr)))) - -(defmethod medium-draw-lines* ((medium cairo-medium) position-seq) - (with-medium (medium) - (sync-sheet medium) - (sync-transformation medium) - (sync-ink medium (medium-ink medium)) - (sync-clipping-region medium (medium-clipping-region medium)) - (sync-line-style medium (medium-line-style medium)) - (with-slots (cr) medium - (loop for i below (length position-seq) by 4 do - (cairo_move_to cr - (df (elt position-seq (+ i 0))) - (df (elt position-seq (+ i 1)))) - (cairo_line_to cr - (df (elt position-seq (+ i 2))) - (df (elt position-seq (+ i 3))))) - (cairo_stroke cr)))) [353 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/pango.lisp 2006/12/25 19:55:11 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/pango.lisp 2006/12/26 12:11:04 1.5 @@ -24,20 +24,6 @@ (in-package :clim-gtkairo) -;;; these shouldn't be here: - -(defclass metrik-medium-mixin () ()) -(defclass cairo-metrik-medium (metrik-medium-mixin cairo-medium) ()) -(defclass gdk-metrik-medium (metrik-medium-mixin gdk-medium) ()) - -(defgeneric invoke-with-medium (fn medium)) - -(defmacro with-medium ((medium) &body body) - `(invoke-with-medium (lambda () , at body) ,medium)) - -(defgeneric metrik-medium-for (medium)) - - ;;;; Helper macros. (defmacro with-pango-layout --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo.lisp 2006/12/26 12:11:04 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo.lisp 2006/12/26 12:11:04 1.1 ;;; -*- Mode: Lisp; -*- ;;; (c) copyright 2005 by Gilbert Baumann ;;; (c) copyright 2006 David Lichteblau (david at lichteblau.com) ;;; 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. (in-package :clim-gtkairo) ;;; Locking rule for this file: Dokumented entry points in the CLIM ;;; package use WITH-GTK, internal functions can rely on that. (defclass cairo-medium (gtkairo-medium) ((cr :initform nil :initarg :cr :accessor cr) (flipping-original-cr :initform nil :accessor flipping-original-cr) (flipping-pixmap :initform nil :accessor flipping-pixmap) (flipping-region :accessor flipping-region) (surface :initarg :surface :accessor surface) (last-seen-sheet :accessor last-seen-sheet) (last-seen-region :accessor last-seen-region))) (defmethod initialize-instance :after ((instance cairo-medium) &key cr) (unless cr (setf (last-seen-sheet instance) nil))) (defparameter *antialiasingp* t) (defmethod invoke-with-medium (fn (medium cairo-medium)) (when (or (cr medium) (climi::port-lookup-mirror (port medium) (medium-sheet medium))) (with-gtk () (multiple-value-prog1 (funcall fn) (when (flipping-original-cr medium) (apply-flipping-ink medium)))))) (defun sheet-changed-behind-our-back-p (medium) (and (slot-boundp medium 'last-seen-sheet) (or (not (eq (last-seen-sheet medium) (medium-sheet medium))) (not (region-equal (last-seen-region medium) (sheet-region (medium-sheet medium))))))) (defmethod metrik-medium-for ((medium cairo-medium)) (cairo-metrik-medium (port medium))) (defun set-antialias (cr) (cairo_set_antialias cr (if *antialiasingp* :CAIRO_ANTIALIAS_DEFAULT :CAIRO_ANTIALIAS_NONE))) (defun sync-sheet (medium) (when (medium-sheet medium) ;ignore the metrik-medium (setf (gethash medium (dirty-mediums (port medium))) t)) (when (or (null (cr medium)) (sheet-changed-behind-our-back-p medium)) (with-medium (medium) (let* ((mirror (medium-mirror medium)) (drawable (mirror-drawable mirror))) (setf (cr medium) (gdk_cairo_create drawable)) (dispose-flipping-pixmap medium) (pushnew medium (mirror-mediums mirror)) (set-antialias (cr medium))) (setf (last-seen-sheet medium) (medium-sheet medium)) (setf (last-seen-region medium) (sheet-region (medium-sheet medium)))))) (defun dispose-flipping-pixmap (medium) (when (flipping-pixmap medium) (gdk_drawable_unref (flipping-pixmap medium)) (setf (flipping-pixmap medium) nil))) ;;;; ------------------------------------------------------------------------ ;;;; Drawing Options ;;;; (defun sync-transformation (medium &optional extra-transformation) (with-slots (cr) medium (cffi:with-foreign-object (matrix 'cairo_matrix_t) (let ((tr (if (medium-sheet medium) (sheet-native-transformation (medium-sheet medium)) clim:+identity-transformation+))) (when extra-transformation (setf tr (compose-transformations extra-transformation tr))) (multiple-value-bind (mxx mxy myx myy tx ty) (climi::get-transformation tr) ;; Make sure not to hand transformations to cairo that it won't ;; like, since debugging gets ugly once a cairo context goes ;; into an error state: (invert-transformation tr) (cairo_matrix_init matrix (df mxx) (df mxy) (df myx) (df myy) (df tx) (df ty)) (cairo_set_matrix cr matrix)))))) (defmacro with-cairo-matrix ((matrix transformation) &body body) `(cffi:with-foreign-object (,matrix 'cairo_matrix_t) (multiple-value-bind (mxx mxy myx myy tx ty) (climi::get-transformation ,transformation) (cairo_matrix_init ,matrix (df mxx) (df mxy) (df myx) (df myy) (df tx) (df ty)) (locally , at body)))) ;;; ink (defmethod sync-ink :before (medium new-value) (with-slots (cr) medium (cairo_set_operator cr :over))) (defmethod sync-ink (medium (new-value (eql clim:+foreground-ink+))) (sync-ink medium (clim:medium-foreground medium))) ;### circles? (defmethod sync-ink (medium (new-value (eql clim:+background-ink+))) (sync-ink medium (clim:medium-background medium))) ;### circles? (defmethod sync-ink (medium (new-value clim:opacity)) (with-slots (cr) medium (cond ((= 0 (opacity-value new-value)) (cairo_set_source_rgba cr 0d0 0d0 0d0 0d0)) ((= 1 (opacity-value new-value)) (sync-ink medium (clim:medium-foreground medium))) (t (sync-ink medium (clim:compose-in (clim:medium-foreground medium) new-value)))))) (defmethod sync-ink (medium (new-value climi::uniform-compositum)) (with-slots (cr) medium (with-slots ((ink climi::ink) (mask climi::mask)) new-value (multiple-value-bind (red green blue) (clim:color-rgb ink) (cairo_set_source_rgba cr (df red) (df green) (df blue) (df (clim:opacity-value mask))))))) (defmethod sync-ink (medium (new-value clim:color)) (with-slots (cr) medium (multiple-value-bind (red green blue) (clim:color-rgb new-value) (cairo_set_source_rgba cr (df red) (df green) (df blue) (df 1.0d0))))) (defvar *pattern-hash* (make-hash-table)) (defun pattern-cairo-pattern (medium pattern) (or (gethash pattern *pattern-hash*) (setf (gethash pattern *pattern-hash*) (let ((s (make-cairo-surface medium (pattern-width pattern) (pattern-height pattern)))) (draw-design s pattern) (cairo_pattern_create_for_surface (slot-value s 'surface)))))) (defmethod sync-ink (medium (pattern climi::indexed-pattern)) (with-slots (cr) medium (let ((s (make-cairo-surface medium (pattern-width pattern) (pattern-height pattern)))) (draw-design s pattern) (let ((p (cairo_pattern_create_for_surface (slot-value s 'surface)))) (cairo_set_source cr p) p)))) (defmethod sync-ink (medium (pattern climi::indexed-pattern)) (with-slots (cr) medium (let ((p (pattern-cairo-pattern medium pattern))) (cairo_set_source cr p) p))) (defmethod sync-ink (medium (design clim-internals::transformed-design)) (with-slots ((design climi::design) (transformation climi::transformation)) design ;; ### hmm (let ((p (sync-ink medium design))) (with-cairo-matrix (matrix (invert-transformation transformation)) (cairo_pattern_set_matrix p matrix)) p))) (defun apply-flipping-ink (medium) (let ((from-surface (cairo_get_target (cr medium))) (from-drawable (flipping-pixmap medium)) (to-surface (cairo_get_target (flipping-original-cr medium))) (to-drawable (medium-gdkdrawable medium))) (cairo_surface_flush from-surface) (cairo_surface_flush to-surface) (let ((gc (gdk_gc_new to-drawable)) (region (flipping-region medium))) (gdk_gc_set_function gc :GDK_XOR) (gdk_draw_drawable to-drawable gc from-drawable (floor (bounding-rectangle-min-x region)) (floor (bounding-rectangle-min-y region)) (floor (bounding-rectangle-min-x region)) (floor (bounding-rectangle-min-y region)) (ceiling (bounding-rectangle-max-x region)) (ceiling (bounding-rectangle-max-y region))) (gdk_gc_unref gc)) (cairo_surface_mark_dirty to-surface)) (cairo_destroy (cr medium)) (setf (cr medium) (flipping-original-cr medium)) (setf (flipping-original-cr medium) nil)) (defmethod sync-ink (medium (design climi::standard-flipping-ink)) (setf (flipping-original-cr medium) (cr medium)) (let* ((mirror (medium-mirror medium)) (drawable (mirror-drawable mirror))) (let* ((region (climi::sheet-mirror-region (medium-sheet medium))) (width (floor (bounding-rectangle-max-x region))) (height (floor (bounding-rectangle-max-y region))) (pixmap (or (flipping-pixmap medium) (setf (flipping-pixmap medium) (gdk_pixmap_new drawable width height -1))))) (setf (cr medium) (gdk_cairo_create pixmap)) (set-antialias (cr medium)) (setf (flipping-region medium) region) (cairo_paint (cr medium)) (sync-transformation medium) (sync-ink medium +white+)))) (defmethod sync-ink (medium new-value) (warn "SYNC-INK lost ~S." new-value)) ;;; clipping region (defun sync-clipping-region (medium region) (with-slots (cr) medium (cairo_reset_clip cr) (unless (eq region +everywhere+) (unless (eq region +nowhere+) (loop for (x y w h) in (clipping-region->rect-seq region) do (cairo_rectangle cr (df x) (df y) (df w) (df h)))) (cairo_clip cr)) (cairo_new_path cr))) ;;; line-style (defun sync-line-style (medium line-style) (with-slots (cr) medium (cairo_set_line_cap cr (case (line-style-cap-shape line-style) (:butt :butt) (:square :square) (:round :round) (:no-end-point :round))) ;### (cond ((null (line-style-dashes line-style)) (cairo_set_dash cr (cffi:null-pointer) 0 0d0)) ;hmm ((eq t (line-style-dashes line-style)) (let ((d 10)) (cairo-set-dash* cr (case (line-style-unit line-style) ((:point :normal) (map 'vector (lambda (x) (untransform-size (medium-transformation medium) x)) (list d))) (:coordinate (list d)))))) (t ;; line-style-unit! (cairo-set-dash* cr (case (line-style-unit line-style) ((:point :normal) (map 'vector (lambda (x) (untransform-size (medium-transformation medium) x)) (line-style-dashes line-style))) (:coordinate (line-style-dashes line-style)))))) (cairo_set_line_join cr (case (line-style-joint-shape line-style) (:miter :miter) (:bevel :bevel) (:round :round) (:none :round))) ;### (cairo_set_line_width cr (max 1.0d0 (df (case (line-style-unit line-style) ((:point :normal) (untransform-size (medium-transformation medium) (line-style-thickness line-style))) (:coordinate (line-style-thickness line-style)))))) )) (defun cairo-set-dash* (cr dashes) (let ((ndash (length dashes))) (cffi:with-foreign-object (adashes :double ndash) (loop for i below ndash do (setf (cffi:mem-aref adashes :double i) (df (elt dashes i)))) (cairo_set_dash cr adashes ndash 0d0)))) (defun sync-drawing-options (medium) (sync-transformation medium) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium))) ;;;; ------------------------------------------------------------------------ ;;;; Drawing Operations ;;;; (defmethod medium-draw-point* ((medium cairo-medium) x y) (with-medium (medium) (sync-sheet medium) (sync-transformation medium) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium)) (with-slots (cr) medium (cairo_set_line_cap cr :round) (setf x (df x)) (setf y (df y)) (cairo_move_to cr x y) (cairo_line_to cr (+ x 0.5) (+ y 0.5)) (cairo_stroke cr)))) (defmethod medium-draw-points* ((medium cairo-medium) coord-seq) (with-medium (medium) (sync-sheet medium) (sync-transformation medium) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium)) (with-slots (cr) medium (cairo_set_line_cap cr :round) (loop for i below (length coord-seq) by 2 do (let ((x (df (elt coord-seq (+ i 0)))) (y (df (elt coord-seq (+ i 1))))) (cairo_move_to cr x y) (cairo_line_to cr (+ x 0.5) (+ y 0.5)) (cairo_stroke cr)))))) (defmethod medium-draw-line* ((medium cairo-medium) x1 y1 x2 y2) (with-medium (medium) (sync-sheet medium) (sync-transformation medium) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium)) (with-slots (cr) medium (cairo_move_to cr (df x1) (df y1)) (cairo_line_to cr (df x2) (df y2)) (cairo_stroke cr)))) (defmethod medium-draw-lines* ((medium cairo-medium) position-seq) (with-medium (medium) (sync-sheet medium) (sync-transformation medium) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium)) (with-slots (cr) medium (loop for i below (length position-seq) by 4 do (cairo_move_to cr (df (elt position-seq (+ i 0))) [328 lines skipped] From dlichteblau at common-lisp.net Tue Dec 26 16:44:45 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Tue, 26 Dec 2006 11:44:45 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061226164445.7D50150026@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv14010 Modified Files: NEWS mcclim.asd Added Files: bezier.lisp Log Message: With Robert Strandh's permission, move gsharp/bezier.lisp into McCLIM. All symbols are still in the CLIMI package and undocumented, but should ultimately move into CLIME or a new package. Try CLIM-FIG or gsharp to test. * NEWS: updated. * mcclim.asd (CLIM-BASIC): Depend on flexichain. Added bezier.lisp * bezier.lisp: New file, from gsharp. Postscript methods taken out. * Backends/PostScript/graphics.lisp (MEDIUM-DRAW-BEZIER-DESIGN*): New methods, from gsharp/bezier.lisp. * Backends/gtkairo/cairo.lisp (MEDIUM-DRAW-BEZIER-DESIGN*): New methods. * Backends/gtkairo/ffi.lisp: regenerated. * Examples/clim-fig.lisp (DRAW-FIGURE, HANDLE-DRAW-OBJECT): Added a bezier drawing mode. --- /project/mcclim/cvsroot/mcclim/NEWS 2006/12/25 12:43:49 1.16 +++ /project/mcclim/cvsroot/mcclim/NEWS 2006/12/26 16:44:45 1.17 @@ -26,6 +26,8 @@ implemented. ** Improvement: Added font listing support, see section "Fonts and Extended Text Styles" in the manual. +** Improvement: Added support for bezier splines (Robert Strandh). + To be documented. * Changes in mcclim-0.9.3 "All Souls' Day" relative to 0.9.2: ** backend improvement: The Null backend now registers itself in the --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/12/26 12:11:04 1.44 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/12/26 16:44:45 1.45 @@ -104,7 +104,7 @@ (:file "package" :depends-on ("Lisp-Dep" "patch")))) (defsystem :clim-basic - :depends-on (:clim-lisp :spatial-trees) + :depends-on (:clim-lisp :spatial-trees :flexichain) :components ((:file "decls") (:file "protocol-classes" :depends-on ("decls")) (:module "Lisp-Dep" @@ -152,7 +152,8 @@ (:file "text-selection" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "X11-colors" "medium" "output" "transforms" "sheets" "stream-output" "ports" "recording" "regions" - "events")))) + "events")) + (:file "bezier" :depends-on ("recording")))) (defsystem :goatee-core :depends-on (:clim-basic) --- /project/mcclim/cvsroot/mcclim/bezier.lisp 2006/12/26 16:44:45 NONE +++ /project/mcclim/cvsroot/mcclim/bezier.lisp 2006/12/26 16:44:45 1.1 (in-package :clim-internals) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Utilities (defun point-to-complex (point) "convert a point to a complex number" (complex (point-x point) (point-y point))) (defun complex-to-point (complex) "convert a complex number to a point" (make-point (realpart complex) (imagpart complex))) (defun distance (p0 p1) "return the euclidian distance between two points" (multiple-value-bind (x0 y0) (point-position p0) (multiple-value-bind (x1 y1) (point-position p1) (let* ((dx (- x1 x0)) (dx2 (* dx dx)) (dy (- y1 y0)) (dy2 (* dy dy))) (sqrt (+ dx2 dy2)))))) (defun part-way (p0 p1 alpha) "return a point that is part way between two other points" (multiple-value-bind (x0 y0) (point-position p0) (multiple-value-bind (x1 y1) (point-position p1) (make-point (+ (* (- 1 alpha) x0) (* alpha x1)) (+ (* (- 1 alpha) y0) (* alpha y1)))))) (defun dot-dist (p p0 p1) "dot distance between a point and a line" (let ((dx (- (point-x p1) (point-x p0))) (dy (- (point-y p1) (point-y p0)))) (- (* (point-x p) dy) (* (point-y p) dx)))) (defun solve-quadratic (a2 a1 a0 &key complex-roots multiple-roots) (when (zerop a2) (return-from solve-quadratic (- (/ a0 a1)))) (unless (= a2 1) (setf a1 (/ a1 a2) a0 (/ a0 a2))) (let* ((-a1/2 (- (/ a1 2.0))) (r (- (* -a1/2 -a1/2) a0))) (cond ((zerop r) (if multiple-roots (values -a1/2 -a1/2) -a1/2)) ((minusp r) (if complex-roots (values (+ -a1/2 (sqrt r)) (- -a1/2 (sqrt r))) (values))) (t (values (+ -a1/2 (sqrt r)) (- -a1/2 (sqrt r))))))) (defun dist (v z) "compute the distance between a point and a vector represented as a complex number" (- (* (realpart z) (point-y v)) (* (imagpart z) (point-x v)))) (defclass bezier-design (design) ()) (defgeneric medium-draw-bezier-design* (stream design)) (defclass bezier-design-output-record (standard-graphics-displayed-output-record) ((stream :initarg :stream) (design :initarg :design))) (defmethod initialize-instance :after ((record bezier-design-output-record) &key) (with-slots (design) record (setf (rectangle-edges* record) (bounding-rectangle* design)))) (defmethod medium-draw-bezier-design* :around ((stream output-recording-stream) design) (with-sheet-medium (medium stream) (let ((transformed-design (transform-region (medium-transformation medium) design))) (when (stream-recording-p stream) (let ((record (make-instance 'bezier-design-output-record :stream stream :design transformed-design))) (stream-add-output-record stream record))) (when (stream-drawing-p stream) (medium-draw-bezier-design* medium design))))) (defmethod replay-output-record ((record bezier-design-output-record) stream &optional (region +everywhere+) (x-offset 0) (y-offset 0)) (declare (ignore x-offset y-offset region)) (with-slots (design) record (medium-draw-bezier-design* (sheet-medium stream) design))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Bezier curves and areas (defclass bezier-segment () ((p0 :initarg :p0) (p1 :initarg :p1) (p2 :initarg :p2) (p3 :initarg :p3))) (defun make-bezier-segment (p0 p1 p2 p3) (make-instance 'bezier-segment :p0 p0 :p1 p1 :p2 p2 :p3 p3)) (defclass bounding-rectangle-mixin () ((min-x) (min-y) (max-x) (max-y))) (defmethod bounding-rectangle* ((region bounding-rectangle-mixin)) (with-slots (min-x min-y max-x max-y) region (values min-x min-y max-x max-y))) (defclass segments-mixin (bounding-rectangle-mixin) ((%segments :initarg :segments :initform '() :reader segments))) (defun compute-bounding-rectangle* (segments-mixin) (multiple-value-bind (final-min-x final-min-y final-max-x final-max-y) (segment-bounding-rectangle (car (segments segments-mixin))) (loop for segment in (cdr (segments segments-mixin)) do (multiple-value-bind (min-x min-y max-x max-y) (segment-bounding-rectangle segment) (setf final-min-x (min final-min-x min-x) final-min-y (min final-min-y min-y) final-max-x (max final-max-x max-x) final-max-y (max final-max-y max-y)))) (values final-min-x final-min-y final-max-x final-max-y))) (defmethod initialize-instance :after ((region segments-mixin) &rest args) (declare (ignore args)) (multiple-value-bind (computed-min-x computed-min-y computed-max-x computed-max-y) (compute-bounding-rectangle* region) (with-slots (min-x min-y max-x max-y) region (setf min-x computed-min-x min-y computed-min-y max-x computed-max-x max-y computed-max-y)))) ;;; a path defined as a sequence of Bezier curve segments (defclass bezier-curve (path segments-mixin bounding-rectangle-mixin) ()) (defun make-bezier-thing (class point-seq) (assert (= (mod (length point-seq) 3) 1)) (make-instance class :segments (loop for (p0 p1 p2 p3) on point-seq by #'cdddr until (null p1) collect (make-bezier-segment p0 p1 p2 p3)))) (defun make-bezier-thing* (class coord-seq) (assert (= (mod (length coord-seq) 6) 2)) (make-instance class :segments (loop for (x0 y0 x1 y1 x2 y2 x3 y3 x4 y4) on coord-seq by #'(lambda (x) (nthcdr 6 x)) until (null x1) collect (make-bezier-segment (make-point x0 y0) (make-point x1 y1) (make-point x2 y2) (make-point x3 y3))))) (defun make-bezier-curve (point-seq) (make-bezier-thing 'bezier-curve point-seq)) (defun make-bezier-curve* (coord-seq) (make-bezier-thing* 'bezier-curve coord-seq)) (defun transform-segment (transformation segment) (with-slots (p0 p1 p2 p3) segment (make-bezier-segment (transform-region transformation p0) (transform-region transformation p1) (transform-region transformation p2) (transform-region transformation p3)))) (defmethod transform-region (transformation (path bezier-curve)) (make-instance 'bezier-curve :segments (mapcar (lambda (segment) (transform-segment transformation segment)) (segments path)))) (defmethod region-equal ((p1 point) (p2 point)) (let ((coordinate-epsilon (* #.(expt 2 10) double-float-epsilon))) (and (<= (abs (- (point-x p1) (point-x p2))) coordinate-epsilon) (<= (abs (- (point-y p1) (point-y p2))) coordinate-epsilon)))) (defmethod region-union ((r1 bezier-curve) (r2 bezier-curve)) (let ((p (slot-value (car (last (segments r1))) 'p3)) (seg (car (segments r2)))) (if (region-equal p (slot-value seg 'p0)) (with-slots (p1 p2 p3) seg (make-instance 'bezier-curve :segments (append (segments r1) (cons (make-bezier-segment p p1 p2 p3) (cdr (segments r2)))))) (call-next-method)))) ;;; A region that translates a different region (defclass translated-bezier-design (region bezier-design) ((%translation :initarg :translation :reader translation) (%region :initarg :region :reader original-region))) (defmethod bounding-rectangle* ((region translated-bezier-design)) (let ((translation (translation region))) (multiple-value-bind (min-x min-y max-x max-y) (bounding-rectangle* (original-region region)) (multiple-value-bind (final-min-x final-min-y) (transform-position translation min-x min-y) (multiple-value-bind (final-max-x final-max-y) (transform-position translation max-x max-y) (values final-min-x final-min-y final-max-x final-max-y)))))) (defgeneric really-transform-region (transformation region)) ;;; an area defined as a closed path of Bezier curve segments (defclass bezier-area (area bezier-design segments-mixin bounding-rectangle-mixin) ()) (defgeneric close-path (path)) (defmethod close-path ((path bezier-curve)) (let ((segments (segments path))) (assert (region-equal (slot-value (car segments) 'p0) (slot-value (car (last segments)) 'p3))) (make-instance 'bezier-area :segments segments))) (defun path-start (path) (slot-value (car (segments path)) 'p0)) (defun path-end (path) (slot-value (car (last (segments path))) 'p3)) (defun make-bezier-area (point-seq) (assert (region-equal (car point-seq) (car (last point-seq)))) (make-bezier-thing 'bezier-area point-seq)) (defun make-bezier-area* (coord-seq) (assert (and (coordinate= (car coord-seq) (car (last coord-seq 2))) (coordinate= (cadr coord-seq) (car (last coord-seq))))) (make-bezier-thing* 'bezier-area coord-seq)) (defmethod really-transform-region (transformation (area bezier-area)) (make-instance 'bezier-area :segments (mapcar (lambda (segment) (transform-segment transformation segment)) (segments area)))) (defmethod transform-region (transformation (area bezier-area)) (if (translation-transformation-p transformation) (make-instance 'translated-bezier-design :translation transformation :region area) (really-transform-region transformation area))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Special cases of combined Bezier areas ;;; A union of bezier areas. This is not itself a bezier area. (defclass bezier-union (area bezier-design) ((%areas :initarg :areas :initform '() :reader areas))) (defmethod really-transform-region (transformation (area bezier-union)) (let ((areas (loop for area in (areas area) collect (transform-region transformation area)))) (make-instance 'bezier-union :areas areas))) (defmethod transform-region (transformation (area bezier-union)) (if (translation-transformation-p transformation) (make-instance 'translated-bezier-design :translation transformation :region area) (really-transform-region transformation area))) (defun bounding-rectangle-of-areas (areas) (multiple-value-bind (final-min-x final-min-y final-max-x final-max-y) (bounding-rectangle* (car areas)) (loop for area in (cdr areas) do (multiple-value-bind (min-x min-y max-x max-y) (bounding-rectangle* area) (setf final-min-x (min final-min-x min-x) final-min-y (min final-min-y min-y) final-max-x (max final-max-x max-x) final-max-y (max final-max-y max-y)))) (values final-min-x final-min-y final-max-x final-max-y))) (defmethod bounding-rectangle* ((design bezier-union)) (bounding-rectangle-of-areas (areas design))) (defmethod region-union ((r1 bezier-area) (r2 bezier-area)) (make-instance 'bezier-union :areas (list r1 r2))) (defmethod region-union ((r1 bezier-union) (r2 bezier-area)) (make-instance 'bezier-union :areas (cons r2 (areas r1)))) (defmethod region-union ((r1 bezier-area) (r2 bezier-union)) (make-instance 'bezier-union :areas (cons r1 (areas r2)))) (defmethod region-union ((r1 bezier-union) (r2 bezier-union)) (make-instance 'bezier-union :areas (append (areas r1) (areas r2)))) (defclass bezier-difference (area bezier-design) ((%positive-areas :initarg :positive-areas :initform '() :reader positive-areas) (%negative-areas :initarg :negative-areas :initform '() :reader negative-areas))) (defmethod really-transform-region (transformation (area bezier-difference)) (let ((pareas (loop for area in (positive-areas area) collect (transform-region transformation area))) (nareas (loop for area in (negative-areas area) collect (transform-region transformation area)))) (make-instance 'bezier-difference :positive-areas pareas :negative-areas nareas))) (defmethod transform-region (transformation (area bezier-difference)) (if (translation-transformation-p transformation) (make-instance 'translated-bezier-design :translation transformation :region area) (really-transform-region transformation area))) (defmethod bounding-rectangle* ((design bezier-difference)) (bounding-rectangle-of-areas (positive-areas design))) (defmethod region-difference ((r1 bezier-area) (r2 bezier-area)) (make-instance 'bezier-difference :positive-areas (list r1) :negative-areas (list r2))) (defmethod region-difference ((r1 bezier-area) (r2 bezier-union)) (make-instance 'bezier-difference :positive-areas (list r1) :negative-areas (areas r2))) (defmethod region-difference ((r1 bezier-union) (r2 bezier-area)) (make-instance 'bezier-difference :positive-areas (areas r1) :negative-areas (list r2))) (defmethod region-difference ((r1 bezier-union) (r2 bezier-union)) (make-instance 'bezier-difference :positive-areas (areas r1) :negative-areas (areas r2))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Converting a path to a polyline or an area to a polygon ;;; convert a cubic bezier segment to a list of ;;; line segments (defun %polygonalize (p0 p1 p2 p3 &key (precision 0.01)) (if (< (- (+ (distance p0 p1) (distance p1 p2) (distance p2 p3)) (distance p0 p3)) precision) (list p3) (let* ((p01 (part-way p0 p1 0.5)) (p12 (part-way p1 p2 0.5)) (p23 (part-way p2 p3 0.5)) (p012 (part-way p01 p12 0.5)) (p123 (part-way p12 p23 0.5)) (p0123 (part-way p012 p123 0.5))) (nconc (%polygonalize p0 p01 p012 p0123 :precision precision) (%polygonalize p0123 p123 p23 p3 :precision precision))))) (defgeneric polygonalize (thing)) (defmethod polygonalize ((segment bezier-segment)) (with-slots (p0 p1 p2 p3) segment (%polygonalize p0 p1 p2 p3))) (defmethod polygonalize ((path bezier-curve)) (let ((segments (segments path))) (make-polyline (cons (slot-value (car segments) 'p0) (mapcan #'polygonalize segments))))) (defmethod polygonalize ((area bezier-area)) (let ((segments (segments area))) (make-polygon (mapcan #'polygonalize segments)))) [479 lines skipped] From dlichteblau at common-lisp.net Tue Dec 26 16:44:45 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Tue, 26 Dec 2006 11:44:45 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/PostScript Message-ID: <20061226164445.AF58350026@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/PostScript In directory clnet:/tmp/cvs-serv14010/Backends/PostScript Modified Files: graphics.lisp Log Message: With Robert Strandh's permission, move gsharp/bezier.lisp into McCLIM. All symbols are still in the CLIMI package and undocumented, but should ultimately move into CLIME or a new package. Try CLIM-FIG or gsharp to test. * NEWS: updated. * mcclim.asd (CLIM-BASIC): Depend on flexichain. Added bezier.lisp * bezier.lisp: New file, from gsharp. Postscript methods taken out. * Backends/PostScript/graphics.lisp (MEDIUM-DRAW-BEZIER-DESIGN*): New methods, from gsharp/bezier.lisp. * Backends/gtkairo/cairo.lisp (MEDIUM-DRAW-BEZIER-DESIGN*): New methods. * Backends/gtkairo/ffi.lisp: regenerated. * Examples/clim-fig.lisp (DRAW-FIGURE, HANDLE-DRAW-OBJECT): Added a bezier drawing mode. --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/graphics.lisp 2006/03/29 10:43:38 1.17 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/graphics.lisp 2006/12/26 16:44:45 1.18 @@ -544,3 +544,39 @@ (moveto* file-stream x y)) (format file-stream "(~A) show~%" (postscript-escape-string string)))))) + +;;; Bezier support + +(defmethod climi::medium-draw-bezier-design* + ((medium clim-postscript::postscript-medium) (design climi::bezier-area)) + (let ((stream (clim-postscript::postscript-medium-file-stream medium)) + (clim-postscript::*transformation* (sheet-native-transformation (medium-sheet medium)))) + (clim-postscript::postscript-actualize-graphics-state stream medium :color) + (format stream "newpath~%") + (let ((p0 (slot-value (car (climi::segments design)) 'climi::p0))) + (clim-postscript::write-coordinates stream (point-x p0) (point-y p0)) + (format stream "moveto~%")) + (loop for segment in (climi::segments design) + do (with-slots (climi::p1 climi::p2 climi::p3) segment + (clim-postscript::write-coordinates stream (point-x climi::p1) (point-y climi::p1)) + (clim-postscript::write-coordinates stream (point-x climi::p2) (point-y climi::p2)) + (clim-postscript::write-coordinates stream (point-x climi::p3) (point-y climi::p3)) + (format stream "curveto~%"))) + (format stream "fill~%"))) + +(defmethod climi::medium-draw-bezier-design* + ((medium clim-postscript::postscript-medium) (design climi::bezier-union)) + (dolist (area (climi::areas design)) + (climi::medium-draw-bezier-design* medium area))) + +(defmethod climi::medium-draw-bezier-design* + ((medium clim-postscript::postscript-medium) (design climi::bezier-difference)) + (dolist (area (climi::positive-areas design)) + (climi::medium-draw-bezier-design* medium area)) + (with-drawing-options (medium :ink +background-ink+) + (dolist (area (climi::negative-areas design)) + (climi::medium-draw-bezier-design* medium area)))) + +(defmethod climi::medium-draw-bezier-design* + ((medium clim-postscript::postscript-medium) (design climi::translated-bezier-design)) + (climi::medium-draw-bezier-design* medium (climi::really-transform-region (climi::translation design) (climi::original-region design)))) From dlichteblau at common-lisp.net Tue Dec 26 16:44:46 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Tue, 26 Dec 2006 11:44:46 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061226164446.C50F35002A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv14010/Backends/gtkairo Modified Files: cairo.lisp ffi.lisp Log Message: With Robert Strandh's permission, move gsharp/bezier.lisp into McCLIM. All symbols are still in the CLIMI package and undocumented, but should ultimately move into CLIME or a new package. Try CLIM-FIG or gsharp to test. * NEWS: updated. * mcclim.asd (CLIM-BASIC): Depend on flexichain. Added bezier.lisp * bezier.lisp: New file, from gsharp. Postscript methods taken out. * Backends/PostScript/graphics.lisp (MEDIUM-DRAW-BEZIER-DESIGN*): New methods, from gsharp/bezier.lisp. * Backends/gtkairo/cairo.lisp (MEDIUM-DRAW-BEZIER-DESIGN*): New methods. * Backends/gtkairo/ffi.lisp: regenerated. * Examples/clim-fig.lisp (DRAW-FIGURE, HANDLE-DRAW-OBJECT): Added a bezier drawing mode. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo.lisp 2006/12/26 12:11:04 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo.lisp 2006/12/26 16:44:46 1.2 @@ -703,3 +703,51 @@ design (draw-design medium background) (draw-design medium foreground)))) + + +;;;; Bezier support + +(defmethod climi::medium-draw-bezier-design* + ((medium cairo-medium) (design climi::bezier-area)) + (with-medium (medium) + (sync-sheet medium) + (sync-transformation medium) + (sync-ink medium (medium-ink medium)) + (sync-clipping-region medium (medium-clipping-region medium)) + (sync-line-style medium (medium-line-style medium)) + (with-slots (cr) medium + (let ((p0 (slot-value (car (climi::segments design)) 'climi::p0))) + (cairo_move_to cr (df (point-x p0)) (df (point-y p0)))) + (dolist (segment (climi::segments design)) + (with-slots (climi::p1 climi::p2 climi::p3) segment + (cairo_curve_to cr + (df (point-x climi::p1)) (df (point-y climi::p1)) + (df (point-x climi::p2)) (df (point-y climi::p2)) + (df (point-x climi::p3)) (df (point-y climi::p3))))) + (cairo_fill cr)))) + +(defmethod climi::medium-draw-bezier-design* + ((medium cairo-medium) (design climi::bezier-union)) + (dolist (area (climi::areas design)) + (climi::medium-draw-bezier-design* medium area))) + +(defmethod climi::medium-draw-bezier-design* + ((medium cairo-medium) (design climi::bezier-difference)) + (dolist (area (climi::positive-areas design)) + (climi::medium-draw-bezier-design* medium area)) + (with-drawing-options (medium :ink +background-ink+) + (dolist (area (climi::negative-areas design)) + (climi::medium-draw-bezier-design* medium area)))) + +(defmethod climi::medium-draw-bezier-design* + ((medium cairo-medium) (design climi::translated-bezier-design)) + (let ((tx (climi::translation design))) + (setf tx + ;; + ;; FIXME: needed for gsharp, doesn't make sense to me + ;; + (compose-transformations tx (medium-transformation medium))) + (climi::medium-draw-bezier-design* medium + (climi::really-transform-region + tx + (climi::original-region design))))) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/12/25 19:55:11 1.14 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/12/26 16:44:46 1.15 @@ -317,6 +317,11 @@ (arg4 :pointer) ;double * ) +(defcfun "cairo_fill_preserve" + :pointer + (arg0 :pointer) ;cairo_t * + ) + (defcfun "cairo_font_extents" :void (arg0 :pointer) ;cairo_t * @@ -672,6 +677,11 @@ (arg0 :pointer) ;cairo_t * ) +(defcfun "cairo_stroke_preserve" + :void + (arg0 :pointer) ;cairo_t * + ) + (defcfun "cairo_stroke_extents" :void (arg0 :pointer) ;cairo_t * From dlichteblau at common-lisp.net Tue Dec 26 16:44:49 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Tue, 26 Dec 2006 11:44:49 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20061226164449.556275411F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv14010/Examples Modified Files: clim-fig.lisp Log Message: With Robert Strandh's permission, move gsharp/bezier.lisp into McCLIM. All symbols are still in the CLIMI package and undocumented, but should ultimately move into CLIME or a new package. Try CLIM-FIG or gsharp to test. * NEWS: updated. * mcclim.asd (CLIM-BASIC): Depend on flexichain. Added bezier.lisp * bezier.lisp: New file, from gsharp. Postscript methods taken out. * Backends/PostScript/graphics.lisp (MEDIUM-DRAW-BEZIER-DESIGN*): New methods, from gsharp/bezier.lisp. * Backends/gtkairo/cairo.lisp (MEDIUM-DRAW-BEZIER-DESIGN*): New methods. * Backends/gtkairo/ffi.lisp: regenerated. * Examples/clim-fig.lisp (DRAW-FIGURE, HANDLE-DRAW-OBJECT): Added a bezier drawing mode. --- /project/mcclim/cvsroot/mcclim/Examples/clim-fig.lisp 2006/12/19 04:08:58 1.30 +++ /project/mcclim/cvsroot/mcclim/Examples/clim-fig.lisp 2006/12/26 16:44:46 1.31 @@ -31,7 +31,7 @@ (setf (gadget-value (clim-fig-status *application-frame*)) string)) -(defun draw-figure (pane x y x1 y1 &key fastp) +(defun draw-figure (pane x y x1 y1 &key fastp cp-x1 cp-y1 cp-x2 cp-y2) (with-slots (line-style current-color fill-mode constrict-mode) *application-frame* (let* ((radius-x (- x1 x)) @@ -70,7 +70,23 @@ (:ellipse (draw-ellipse* pane x y radius-x 0 0 radius-y :filled fill-mode - :ink current-color :line-style line-style)))))) + :ink current-color :line-style line-style)) + (:bezier + (when fastp + (draw-text* pane + "[Use the middle and right mouse button to set control points]" + 0 + 20)) + (let* ((cp-x1 (or cp-x1 x)) + (cp-y1 (or cp-y1 y1)) + (cp-x2 (or cp-x2 x1)) + (cp-y2 (or cp-y2 y)) + (design (climi::make-bezier-thing* + 'climi::bezier-area + (list x y cp-x1 cp-y1 cp-x2 cp-y2 x1 y1)))) + (climi::draw-bezier-design* pane design) + (draw-line* pane x y cp-x1 cp-y1 :ink +red+) + (draw-line* pane x1 y1 cp-x2 cp-y2 :ink +blue+))))))) (defun signum-1 (value) (if (zerop value) @@ -87,7 +103,8 @@ (defun handle-draw-object (pane x1 y1) (let* ((pixmap-width (round (bounding-rectangle-width (sheet-region pane)))) (pixmap-height (round (bounding-rectangle-height (sheet-region pane)))) - (canvas-pixmap (allocate-pixmap pane pixmap-width pixmap-height))) + (canvas-pixmap (allocate-pixmap pane pixmap-width pixmap-height)) + cp-x1 cp-y1 cp-x2 cp-y2) (copy-to-pixmap pane 0 0 pixmap-width pixmap-height canvas-pixmap) (multiple-value-bind (x y) (block processor @@ -105,17 +122,29 @@ (copy-from-pixmap canvas-pixmap 0 0 pixmap-width pixmap-height pane 0 0) (draw-figure pane x1 y1 x y - :fastp t))) - (:pointer-button-release (&key event x y) + :fastp t + :cp-x1 cp-x1 :cp-y1 cp-y1 + :cp-x2 cp-x2 :cp-y2 cp-y2))) + (:pointer-button-release (&key event x y) (when (= (pointer-event-button event) +pointer-left-button+) - (return-from processor (values x y))))))) + (return-from processor (values x y)))) + (:pointer-button-press (&key event x y) + (cond + ((= (pointer-event-button event) + +pointer-right-button+) + (setf cp-x1 x cp-y1 y)) + ((= (pointer-event-button event) + +pointer-middle-button+) + (setf cp-x2 x cp-y2 y))))))) (set-status-line " ") (copy-from-pixmap canvas-pixmap 0 0 pixmap-width pixmap-height pane 0 0) (deallocate-pixmap canvas-pixmap) (with-output-as-presentation (pane nil 'figure :single-box t) - (draw-figure pane x1 y1 x y)) + (draw-figure pane x1 y1 x y + :cp-x1 cp-x1 :cp-y1 cp-y1 + :cp-x2 cp-x2 :cp-y2 cp-y2)) (setf (clim-fig-redo-list *application-frame*) nil)))) (defun handle-move-object (pane figure first-point-x first-point-y) @@ -248,6 +277,7 @@ (arrow-button (make-drawing-mode-button "Arrow" :arrow)) (rectangle-button (make-drawing-mode-button "Rectangle" :rectangle)) (ellipse-button (make-drawing-mode-button "Ellipse" :ellipse)) + (bezier-button (make-drawing-mode-button "Bezier" :bezier)) ;; Colors (black-button (make-colored-button +black+)) @@ -293,7 +323,8 @@ round-shape-toggle (horizontally () fill-mode-toggle constrict-toggle) point-button line-button arrow-button - ellipse-button rectangle-button) + ellipse-button rectangle-button + bezier-button) (scrolling (:width 600 :height 400) canvas)) (horizontally (:height 30) clear undo redo) status))) From dlichteblau at common-lisp.net Tue Dec 26 17:29:49 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Tue, 26 Dec 2006 12:29:49 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061226172949.B55062D0B8@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv20946 Modified Files: cairo.lisp Log Message: Repair "Show Directory" on the cairo medium. * Backends/gtkairo/cairo.lisp (make-cairo-surface): Updated enum name. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo.lisp 2006/12/26 16:44:46 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo.lisp 2006/12/26 17:29:49 1.3 @@ -555,8 +555,8 @@ ;;;; General Designs ;;;; -(defun make-cairo-surface - (compatible-medium width height &optional (format :argb32)) +(defun make-cairo-surface (compatible-medium width height + &optional (format :CAIRO_CONTENT_COLOR_ALPHA)) (let* ((s (cairo_surface_create_similar (cairo_get_target (cr compatible-medium)) format width height)) From dlichteblau at common-lisp.net Wed Dec 27 14:47:23 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Wed, 27 Dec 2006 09:47:23 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061227144723.D0F1A59001@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv17453 Modified Files: gadgets.lisp Log Message: As an extension, recognize an initarg :PRESENTATION-TYPE-KEY to the list pane. Like :VALUE-KEY and :NAME-KEY, it can specify a function to be called for each list item. The presentation type key can return NIL, or a presentation type to be used for the item. If such a type is returned, selection of the item will throw a presentation of that type before the value-change callback is called. In addition, right click will be recognized on the list pane and open a presentation menu. * gadgets.lisp (META-LIST-PANE): New slot presentation-type-key. ((VALUE-CHANGED-CALLBACK :BEFORE META-LIST-PANE)): Optionally throw a presentation. (AD-HOC-PRESENTATION, OUTPUT-RECORD-HIT-DETECTION-RECTANGLE*): New class and method. (GENERIC-LIST-PANE-HANDLE-RIGHT-CLICK, META-LIST-PANE-CALL-PRESENTATION-MENU): New functions. ((HANDLE-EVENT GENERIC-LIST-PANE)): Handle right clicks. * Examples/demodemo.lisp (list-pane-test): Modified to demonstrate presentation-type-key. * Backends/gtkairo/event.lisp (HANDLE-EVENT-P): New generic function. (BUTTON-HANDLER): Trap the event only if handle-event-p returns true. * Backends/gtkairo/gadgets.lisp ((HANDLE-EVENT-P GTK-LIST), (CONNECT-NATIVE-SIGNALS GTK-LIST)): Handle right clicks. (GTK-LIST-ONE-VALUE): New function. ((HANDLE-EVENT GTK-LIST)): Call meta-list-pane-call-presentation-menu. --- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2006/12/23 21:44:03 1.102 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2006/12/27 14:47:23 1.103 @@ -1917,7 +1917,11 @@ :initform #'identity :reader list-pane-value-key :documentation "A function to be applied to items to gain its value - for the purpose of GADGET-VALUE.") + for the purpose of GADGET-VALUE.") + (presentation-type-key :initarg :presentation-type-key + :initform (constantly nil) + :reader list-pane-presentation-type-key + :documentation "A function to be applied to items to find the presentation types for their values, or NIL.") (test :initarg :test :initform #'eql :reader list-pane-test @@ -1970,6 +1974,16 @@ (> (length (gadget-value gadget)) 1)) (error "An 'exclusive' list-pane cannot be initialized with more than one item selected."))) +(defmethod value-changed-callback + :before + ((gadget meta-list-pane) client gadget-id value) + (declare (ignore client gadget-id)) + (let* ((i (position value (generic-list-pane-item-values gadget))) + (item (elt (list-pane-items gadget) i)) + (ptype (funcall (list-pane-presentation-type-key gadget) item))) + (when ptype + (throw-object-ptype value ptype)))) + (defun list-pane-exclusive-p (pane) (or (eql (list-pane-mode pane) :exclusive) (eql (list-pane-mode pane) :one-of))) @@ -2163,11 +2177,47 @@ (multiple-value-bind (x y) (values (pointer-event-x event) (pointer-event-y event)) (generic-list-pane-handle-click pane x y (event-modifier-state event)))) +(defclass ad-hoc-presentation (standard-presentation) ()) + +(defmethod output-record-hit-detection-rectangle* + ((presentation ad-hoc-presentation)) + (values most-negative-fixnum most-negative-fixnum + most-positive-fixnum most-positive-fixnum)) + +(defun generic-list-pane-handle-right-click (pane event) + (multiple-value-bind (x y) + (values (pointer-event-x event) (pointer-event-y event)) + (multiple-value-bind (item-value index) + (generic-list-pane-item-from-x-y pane x y) + (let* ((item (elt (list-pane-items pane) index))) + (meta-list-pane-call-presentation-menu pane item))))) + +(defun meta-list-pane-call-presentation-menu (pane item) + (let ((ptype (funcall (list-pane-presentation-type-key pane) item))) + (when ptype + (let ((presentation + (make-instance 'ad-hoc-presentation + :object (funcall (list-pane-value-key pane) item) + :single-box t + :type ptype))) + (call-presentation-menu + presentation + *input-context* + *application-frame* + pane + 42 42 + :for-menu t + :label (format nil "Operation on ~A" ptype)))))) + (defmethod handle-event ((pane generic-list-pane) (event pointer-button-press-event)) - (if (eql (pointer-event-button event) +pointer-left-button+) - (progn (generic-list-pane-handle-click-from-event pane event) - (setf (slot-value pane 'armed) nil)) - (when (next-method-p) (call-next-method)))) + (case (pointer-event-button event) + (#.+pointer-left-button+ + (generic-list-pane-handle-click-from-event pane event) + (setf (slot-value pane 'armed) nil)) + (#.+pointer-right-button+ + (generic-list-pane-handle-right-click pane event)) + (t + (when (next-method-p) (call-next-method))))) (defmethod handle-event ((pane generic-list-pane) (event pointer-button-release-event)) (if (eql (pointer-event-button event) +pointer-left-button+) From dlichteblau at common-lisp.net Wed Dec 27 14:47:24 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Wed, 27 Dec 2006 09:47:24 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061227144724.3656059001@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv17453/Backends/gtkairo Modified Files: event.lisp gadgets.lisp Log Message: As an extension, recognize an initarg :PRESENTATION-TYPE-KEY to the list pane. Like :VALUE-KEY and :NAME-KEY, it can specify a function to be called for each list item. The presentation type key can return NIL, or a presentation type to be used for the item. If such a type is returned, selection of the item will throw a presentation of that type before the value-change callback is called. In addition, right click will be recognized on the list pane and open a presentation menu. * gadgets.lisp (META-LIST-PANE): New slot presentation-type-key. ((VALUE-CHANGED-CALLBACK :BEFORE META-LIST-PANE)): Optionally throw a presentation. (AD-HOC-PRESENTATION, OUTPUT-RECORD-HIT-DETECTION-RECTANGLE*): New class and method. (GENERIC-LIST-PANE-HANDLE-RIGHT-CLICK, META-LIST-PANE-CALL-PRESENTATION-MENU): New functions. ((HANDLE-EVENT GENERIC-LIST-PANE)): Handle right clicks. * Examples/demodemo.lisp (list-pane-test): Modified to demonstrate presentation-type-key. * Backends/gtkairo/event.lisp (HANDLE-EVENT-P): New generic function. (BUTTON-HANDLER): Trap the event only if handle-event-p returns true. * Backends/gtkairo/gadgets.lisp ((HANDLE-EVENT-P GTK-LIST), (CONNECT-NATIVE-SIGNALS GTK-LIST)): Handle right clicks. (GTK-LIST-ONE-VALUE): New function. ((HANDLE-EVENT GTK-LIST)): Call meta-list-pane-call-presentation-menu. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/12/10 19:33:05 1.17 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/12/27 14:47:24 1.18 @@ -269,31 +269,43 @@ (defvar *last-seen-button* 3) -(define-signal button-handler (widget event) +(defgeneric handle-event-p (sheet event)) + +(defmethod handle-event-p (sheet event) + t) + +(define-signal (button-handler :return-type :int) (widget event) (cffi:with-foreign-slots ((type time button state x y x_root y_root) event gdkeventbutton) (when (eql type GDK_BUTTON_PRESS) ;; Hack alert: Menus don't work without this. (gdk_pointer_ungrab GDK_CURRENT_TIME)) (setf *last-seen-button* button) - (enqueue - (make-instance (if (eql type GDK_BUTTON_PRESS) - 'pointer-button-press-event - 'pointer-button-release-event) - :pointer 0 - :button (ecase button - (1 +pointer-left-button+) - (2 +pointer-middle-button+) - (3 +pointer-right-button+) - (4 +pointer-wheel-up+) - (5 +pointer-wheel-down+)) - :x (truncate x) - :y (truncate y) - :graft-x (truncate x_root) - :graft-y (truncate y_root) - :sheet (widget->sheet widget *port*) - :modifier-state (gdkmodifiertype->modifier-state state) - :timestamp time)))) + (let* ((sheet (widget->sheet widget *port*)) + (event + (make-instance (if (eql type GDK_BUTTON_PRESS) + 'pointer-button-press-event + 'pointer-button-release-event) + :pointer 0 + :button (ecase button + (1 +pointer-left-button+) + (2 +pointer-middle-button+) + (3 +pointer-right-button+) + (4 +pointer-wheel-up+) + (5 +pointer-wheel-down+)) + :x (truncate x) + :y (truncate y) + :graft-x (truncate x_root) + :graft-y (truncate y_root) + :sheet sheet + :modifier-state (gdkmodifiertype->modifier-state state) + :timestamp time))) + (cond + ((handle-event-p sheet event) + (enqueue event) + 1) + (t + 0))))) (define-signal enter-handler (widget event) (cffi:with-foreign-slots --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/12/25 19:41:46 1.19 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/12/27 14:47:24 1.20 @@ -250,6 +250,33 @@ (mapcar (climi::list-pane-value-key pane) (climi::list-pane-items pane))) +(defmethod handle-event-p + ((pane gtk-list) (event pointer-button-press-event)) + (eql (pointer-event-button event) +pointer-right-button+)) + +(defun gtk-list-one-value (pane) + (if (eq (climi::list-pane-mode pane) :exclusive) + (if (and (slot-boundp pane 'climi::value) + ;; FIXME: we still assume NIL == no value + (gadget-value pane)) + (values (gadget-value pane) t) + (values nil nil)) + (if (and (slot-boundp pane 'climi::value) + (eql 1 (length (gadget-value pane)))) + (values (car (gadget-value pane)) t) + (values nil nil)))) + +(defmethod handle-event ((pane gtk-list) (event pointer-button-press-event)) + (multiple-value-bind (value valuep) (gtk-list-one-value pane) + (when valuep + (let* ((i (position value (climi::generic-list-pane-item-values pane))) + (item (elt (climi::list-pane-items pane) i))) + (climi::meta-list-pane-call-presentation-menu pane item))))) + +(defmethod handle-event-p + ((pane gtk-list) (event pointer-button-release-event)) + nil) + (defun option-pane-set-active (sheet widget) (gtk_combo_box_set_active widget @@ -422,8 +449,10 @@ ) (defmethod connect-native-signals ((sheet gtk-list) widget) - ;; no signals - ) + (setf (widget->sheet (list-pane-tree-view sheet) (port sheet)) sheet) + (connect-signal (list-pane-tree-view sheet) + "button-press-event" + 'button-handler)) (defmethod connect-native-signals ((sheet gtk-label-pane) widget) ;; no signals From dlichteblau at common-lisp.net Wed Dec 27 14:47:24 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Wed, 27 Dec 2006 09:47:24 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20061227144724.6C2205903E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv17453/Examples Modified Files: demodemo.lisp Log Message: As an extension, recognize an initarg :PRESENTATION-TYPE-KEY to the list pane. Like :VALUE-KEY and :NAME-KEY, it can specify a function to be called for each list item. The presentation type key can return NIL, or a presentation type to be used for the item. If such a type is returned, selection of the item will throw a presentation of that type before the value-change callback is called. In addition, right click will be recognized on the list pane and open a presentation menu. * gadgets.lisp (META-LIST-PANE): New slot presentation-type-key. ((VALUE-CHANGED-CALLBACK :BEFORE META-LIST-PANE)): Optionally throw a presentation. (AD-HOC-PRESENTATION, OUTPUT-RECORD-HIT-DETECTION-RECTANGLE*): New class and method. (GENERIC-LIST-PANE-HANDLE-RIGHT-CLICK, META-LIST-PANE-CALL-PRESENTATION-MENU): New functions. ((HANDLE-EVENT GENERIC-LIST-PANE)): Handle right clicks. * Examples/demodemo.lisp (list-pane-test): Modified to demonstrate presentation-type-key. * Backends/gtkairo/event.lisp (HANDLE-EVENT-P): New generic function. (BUTTON-HANDLER): Trap the event only if handle-event-p returns true. * Backends/gtkairo/gadgets.lisp ((HANDLE-EVENT-P GTK-LIST), (CONNECT-NATIVE-SIGNALS GTK-LIST)): Handle right clicks. (GTK-LIST-ONE-VALUE): New function. ((HANDLE-EVENT GTK-LIST)): Call meta-list-pane-call-presentation-menu. --- /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/12/24 14:27:48 1.16 +++ /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/12/27 14:47:24 1.17 @@ -218,7 +218,9 @@ (make-pane 'list-pane :value 'clim:region-intersection :items (apropos-list "INTER" :clim t) - :name-key (lambda (x) (format nil "~(~S~)" x))))) + :presentation-type-key (constantly 'list-test-symbol) + :name-key (lambda (x) (format nil "~(~S~)" x)))) + (interactor :interactor :height 200)) (:layouts (defaults (labelling (:label "Matching symbols" @@ -230,7 +232,17 @@ substring (make-pane 'push-button :label "Update" - :activate-callback 'update-list-test))))))) + :activate-callback 'update-list-test)) + interactor))))) + +(define-presentation-type list-test-symbol ()) + +(define-list-test-command com-describe-symbol + ((sym 'list-test-symbol :gesture :select)) + ;; Let's print only three lines, we don't have space for more. + (with-input-from-string (s (with-output-to-string (s) (describe sym s))) + (dotimes (x 3) + (write-line (read-line s nil "") *standard-input*)))) (defun update-list-test (pane) (declare (ignore pane)) From ahefner at common-lisp.net Thu Dec 28 19:26:34 2006 From: ahefner at common-lisp.net (ahefner) Date: Thu, 28 Dec 2006 14:26:34 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20061228192634.4015F3E055@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv28249 Modified Files: medium.lisp Log Message: Fix scrambled pixmap masks on big-endian hosts. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2006/12/19 02:16:38 1.76 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2006/12/28 19:26:33 1.77 @@ -430,6 +430,8 @@ ;; Create an xlib "image" and copy it to our pixmap. ;; I do this because I'm not smart enough to operate xlib:put-raw-image. (let ((image (xlib:create-image :bits-per-pixel (* 8 bytes-per-pixel) :depth depth + :bit-lsb-first-p t + :byte-lsb-first-p t :width w :height h :format :z-pixmap :data converted-data))) From ahefner at common-lisp.net Thu Dec 28 19:30:40 2006 From: ahefner at common-lisp.net (ahefner) Date: Thu, 28 Dec 2006 14:30:40 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20061228193040.7C8DE47143@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv28511 Modified Files: medium.lisp Log Message: Really fix scrambled pixmap masks. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2006/12/28 19:26:33 1.77 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2006/12/28 19:30:40 1.78 @@ -430,8 +430,6 @@ ;; Create an xlib "image" and copy it to our pixmap. ;; I do this because I'm not smart enough to operate xlib:put-raw-image. (let ((image (xlib:create-image :bits-per-pixel (* 8 bytes-per-pixel) :depth depth - :bit-lsb-first-p t - :byte-lsb-first-p t :width w :height h :format :z-pixmap :data converted-data))) @@ -450,6 +448,8 @@ ;; We can use image upload for the mask in either case. (let ((mask-image (xlib:create-image :bits-per-pixel 1 :depth 1 + :bit-lsb-first-p t + :byte-lsb-first-p t :width w :height h :data mask-data))) (xlib:put-image mask mask-gc mask-image From dlichteblau at common-lisp.net Fri Dec 29 18:10:48 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Fri, 29 Dec 2006 13:10:48 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061229181048.BC40E4F019@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv17226 Modified Files: pango.lisp Log Message: Readable rendering in Closure. * Backends/gtkairo/pango.lisp (MAKE-FONT-DESCRIPTION): Interpret font sizes as pixels again, not points. Default font sizes would have been too -small- now, adjust them a little. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/pango.lisp 2006/12/26 12:11:04 1.5 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/pango.lisp 2006/12/29 18:10:48 1.6 @@ -119,13 +119,22 @@ (if (eq family :fixed) :fix family)) (error "unknown font family: ~A" family)))) (size (case size - (:normal 12) - (:tiny 6) - (:small 10) - (:very-small 8) - (:large 14) - (:very-large 16) - (:huge 24) + ;; points: +;;; (:tiny 6) +;;; (:very-small 8) +;;; (:small 10) +;;; (:normal 12) +;;; (:large 14) +;;; (:very-large 16) +;;; (:huge 24) + ;; pixels: + (:tiny 8) + (:very-small 11) + (:small 13) + (:normal 16) + (:large 18) + (:very-large 21) + (:huge 32) (otherwise (truncate size)))) desc) (if (stringp face) @@ -148,7 +157,7 @@ (pango_font_description_set_weight desc weight) (pango_font_description_set_style desc style))) (pango_font_description_set_family desc family) - (pango_font_description_set_size desc (* size PANGO_SCALE)) + (pango_font_description_set_absolute_size desc (df (* size PANGO_SCALE))) desc))) (defun pango-layout-get-pixel-size (layout)