From ahefner at common-lisp.net Sun Apr 13 07:32:40 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 13 Apr 2008 03:32:40 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080413073240.858FA28043@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv28221 Modified Files: recording.lisp Log Message: Fix the zero coordinate kludge in output-record-children in the case where a a max coordinate is less than zero, which previously resulted in an invalid rectangle. --- /project/mcclim/cvsroot/mcclim/recording.lisp 2008/02/03 22:54:13 1.140 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2008/04/13 07:32:40 1.141 @@ -991,23 +991,24 @@ (remhash entry (%tree-record-children-cache record))) (defmethod output-record-children ((record standard-tree-output-record)) - (map 'list - #'tree-output-record-entry-record - (spatial-trees:search - (%record-to-spatial-tree-rectangle record) - ;; The form below intends to fix output-record-children not - ;; reporting empty children, which may lie outside the reported - ;; bounding rectangle of their parent. - ;; Assumption: null bounding records are always at the origin. - ;; I've never noticed this violated, but it's out of line with - ;; what null-bounding-rectangle-p checks, and setf of - ;; output-record-position may invalidate it. Seems to work, but - ;; fix that and try again later. - #+NIL - (rectangles:make-rectangle - :lows (list 0 0) #| `(,(bounding-rectangle-min-x r) ,(bounding-rectangle-min-y r)) |# - :highs `(,(bounding-rectangle-max-x record) ,(bounding-rectangle-max-y record))) - (%tree-record-children record)))) + (with-bounding-rectangle* (min-x min-y max-x max-y) record + (map 'list + #'tree-output-record-entry-record + (spatial-trees:search + ;; Originally, (%record-to-spatial-tree-rectangle record). + ;; The form below intends to fix output-record-children not + ;; reporting empty children, which may lie outside the reported + ;; bounding rectangle of their parent. + ;; Assumption: null bounding records are always at the origin. + ;; I've never noticed this violated, but it's out of line with + ;; what null-bounding-rectangle-p checks, and setf of + ;; output-record-position may invalidate it. Seems to work, but + ;; fix that and try again later. + ;; Note that max x or y may be less than zero.. + (rectangles:make-rectangle + :lows (list (min 0 min-x) (min 0 min-y)) + :highs (list (max 0 max-x) (max 0 max-y))) + (%tree-record-children record))))) (defmethod add-output-record (child (record standard-tree-output-record)) (let ((entry (make-tree-output-record-entry child (incf (last-insertion-nr record))))) From thenriksen at common-lisp.net Mon Apr 14 16:45:49 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 14 Apr 2008 12:45:49 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Extensions/Bitmap-formats Message-ID: <20080414164549.2C73835011@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats In directory clnet:/tmp/cvs-serv15106/Extensions/Bitmap-formats Log Message: Directory /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats added to the repository From thenriksen at common-lisp.net Mon Apr 14 16:46:28 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 14 Apr 2008 12:46:28 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080414164628.526F525115@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv15385/Apps/Listener Modified Files: dev-commands.lisp icons.lisp Log Message: Converted MCCLIM-IMAGES to CLIM 2.2 bitmap functions (with extensions). Includes new demo application. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/02/04 03:17:39 1.52 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/04/14 16:46:28 1.53 @@ -1420,7 +1420,7 @@ (object) (list object)) -(define-command (com-display-image :name t :command-table filesystem-commands +#+nil(define-command (com-display-image :name t :command-table filesystem-commands :menu t) ((image-pathname 'pathname :default (user-homedir-pathname) :insert-default t)) --- /project/mcclim/cvsroot/mcclim/Apps/Listener/icons.lisp 2008/01/14 06:52:00 1.7 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/icons.lisp 2008/04/14 16:46:28 1.8 @@ -34,7 +34,8 @@ (defmacro deficon (var pathname) `(eval-when (:load-toplevel :execute) - (defparameter ,var (mcclim-images:load-image ,(merge-pathnames pathname *icon-path*))))) + (defparameter ,var (make-pattern-from-bitmap-file + ,(merge-pathnames pathname *icon-path*) :format :xpm)))) (defvar *icon-cache* (make-hash-table :test #'equal)) @@ -42,9 +43,10 @@ "Loads an icon from the *icon-path*, caching it by name in *icon-cache*" (or (gethash filename *icon-cache*) (setf (gethash filename *icon-cache*) - (mcclim-images:load-image + (make-pattern-from-bitmap-file (merge-pathnames (parse-namestring filename) - *icon-path*))))) + *icon-path*) + :format :xpm)))) ;; Don't particularly need these any more.. (deficon *folder-icon* #P"folder.xpm") @@ -58,8 +60,9 @@ (defun draw-icon (stream pattern &key (extra-spacing 0) ) (let ((stream (if (eq stream t) *standard-output* stream))) - (mcclim-images:draw-image stream pattern) - (stream-increment-cursor-position stream (+ (mcclim-images:image-width pattern) extra-spacing) 0))) + (multiple-value-bind (x y) (stream-cursor-position stream) + (draw-pattern* stream pattern x y) + (stream-increment-cursor-position stream (+ (pattern-width pattern) extra-spacing) 0)))) (defun precache-icons () (let ((pathnames (remove-if #'directoryp From thenriksen at common-lisp.net Mon Apr 14 16:46:28 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 14 Apr 2008 12:46:28 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20080414164628.9668825118@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv15385/Examples Modified Files: demodemo.lisp Added Files: image-viewer.lisp Log Message: Converted MCCLIM-IMAGES to CLIM 2.2 bitmap functions (with extensions). Includes new demo application. --- /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2007/02/05 03:26:28 1.19 +++ /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2008/04/14 16:46:28 1.20 @@ -67,6 +67,7 @@ ;(make-demo-button "Colorslider" 'colorslider) (make-demo-button "D&D Translator" 'drag-test) (make-demo-button "Draggable Graph" 'draggable-graph-demo) + (make-demo-button "Image viewer" 'image-viewer) (make-pane 'push-button :label "Font Selector" :activate-callback --- /project/mcclim/cvsroot/mcclim/Examples/image-viewer.lisp 2008/04/14 16:46:28 NONE +++ /project/mcclim/cvsroot/mcclim/Examples/image-viewer.lisp 2008/04/14 16:46:28 1.1 ;;; -*- Mode: Lisp; Package: CLIM-DEMO -*- ;;; (c) copyright 2008 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. ;;; A simple program for displaying images of formats known to McCLIM. (in-package :clim-demo) (defclass image-viewer-gadget (value-gadget) () (:documentation "An abstract gadget for displaying images. The value of the gadget is the image being displayed.") (:default-initargs :value nil)) (defmethod (setf gadget-value) :after (new-value (gadget image-viewer-gadget) &key &allow-other-keys) (handle-repaint gadget (or (pane-viewport-region gadget) (sheet-region gadget)))) (defclass image-viewer-pane (image-viewer-gadget basic-gadget) () (:documentation "A concrete gadget for displaying images. The value of the gadget is the image being displayed.")) (defmethod handle-repaint ((pane image-viewer-pane) region) (declare (ignore region)) ;; Clear the old image. (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane) (draw-rectangle* (sheet-medium pane) x1 y1 x2 y2 :ink +background-ink+)) (when (gadget-value pane) ;; Try to ensure there is room for the new image. (change-space-requirements pane :height (pattern-height (gadget-value pane)) :width (pattern-width (gadget-value pane))) ;; Draw the new one, if there is one. (handler-case (draw-pattern* pane (gadget-value pane) 0 0) (error () (with-text-style (pane (make-text-style nil :italic nil)) (draw-text* pane (format nil "Error while drawing image") 0 0 :align-y :top)))))) (define-application-frame image-viewer () ((%image-pathname :accessor image-pathname :initarg :image-pathname :initform nil)) (:menu-bar t) (:panes (viewer (make-pane 'image-viewer-pane)) (interactor :interactor :text-style (make-text-style :sans-serif nil nil) :min-height 100)) (:layouts (default (vertically () (4/5 (labelling (:label "Image") viewer)) (1/5 interactor)))) (:top-level ((lambda (frame) (default-frame-top-level frame))))) (define-image-viewer-command (com-display-image :name t :menu t) ((image-pathname 'pathname :default (user-homedir-pathname) :insert-default t)) (if (probe-file image-pathname) (let* ((type (funcall (case (readtable-case *readtable*) (:upcase #'string-upcase) (:downcase #'string-downcase) (t #'identity)) (pathname-type image-pathname))) (format (find-symbol type (find-package :keyword))) (viewer (find-pane-named *application-frame* 'viewer))) (handler-case (progn (setf (gadget-value viewer) (make-pattern-from-bitmap-file image-pathname :format format) (image-pathname *application-frame*) image-pathname) (format t "~A image loaded succesfully" type)) (unsupported-bitmap-format () (format t "Image format ~A not recognized" type)))) (format t "No such file: ~A" image-pathname))) (defun image-viewer (&key (new-process t)) (flet ((run () (let ((frame (make-application-frame 'image-viewer))) (run-frame-top-level frame)))) (if new-process (clim-sys:make-process #'run :name "Image viewer") (run)))) From thenriksen at common-lisp.net Mon Apr 14 16:46:30 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 14 Apr 2008 12:46:30 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Experimental Message-ID: <20080414164630.46C2E25118@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental In directory clnet:/tmp/cvs-serv15385/Experimental Removed Files: xpm.lisp Log Message: Converted MCCLIM-IMAGES to CLIM 2.2 bitmap functions (with extensions). Includes new demo application. From thenriksen at common-lisp.net Mon Apr 14 16:46:30 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 14 Apr 2008 12:46:30 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Extensions/Bitmap-formats Message-ID: <20080414164630.DA4D425118@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats In directory clnet:/tmp/cvs-serv15385/Extensions/Bitmap-formats Added Files: gif.lisp jpeg.lisp Log Message: Converted MCCLIM-IMAGES to CLIM 2.2 bitmap functions (with extensions). Includes new demo application. --- /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats/gif.lisp 2008/04/14 16:46:30 NONE +++ /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats/gif.lisp 2008/04/14 16:46:30 1.1 ;;; -*- Mode: Lisp; Package: MCCLIM-IMAGES -*- ;;; (c) copyright 2008 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. (in-package :clim-internals) (define-bitmap-file-reader :gif (image-pathname) (let* ((data-stream (skippy:load-data-stream image-pathname)) (first-image (aref (skippy:images data-stream) 0)) (image-height (skippy:height first-image)) (image-width (skippy:width first-image)) (pattern-array (make-array (list image-height image-width))) (designs (coerce (loop with color-table = (skippy:color-table data-stream) with transparency-index = (skippy:transparency-index first-image) for i below (skippy:color-table-size color-table) when (and transparency-index (= i transparency-index)) collect +transparent-ink+ else collect (multiple-value-bind (r g b) (skippy:color-rgb (skippy:color-table-entry color-table i)) (make-rgb-color (/ r 255) (/ g 255) (/ b 255)))) 'vector))) (dotimes (y image-height) (dotimes (x image-width) (setf (aref pattern-array y x) (skippy:pixel-ref first-image x y)))) (values pattern-array designs))) --- /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats/jpeg.lisp 2008/04/14 16:46:30 NONE +++ /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats/jpeg.lisp 2008/04/14 16:46:30 1.1 ;;; -*- Mode: Lisp; Package: MCCLIM-IMAGES -*- ;;; (c) copyright 2008 ;;; Eric Marsden ;;; (c) copyright 2008 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. (in-package :clim-internals) (define-bitmap-file-reader :jpeg (pathname) (with-open-file (stream pathname :direction :input) (multiple-value-bind (rgb height width) (jpeg::decode-image stream) (let* ((array (make-array (list height width) :element-type '(unsigned-byte 32)))) (dotimes (x width) (dotimes (y height) (let ((blue (aref rgb (+ (* x 3) (* y width 3)))) (green (aref rgb (+ (* x 3) (* y width 3) 1))) (red (aref rgb (+ (* x 3) (* y width 3) 2)))) (setf (aref array y x) (dpb red (byte 8 0) (dpb green (byte 8 8) (dpb blue (byte 8 16) (dpb (- 255 0) (byte 8 24) 0)))))))) array)))) (define-bitmap-file-reader :jpg (pathname) (read-bitmap-file pathname :format :jpeg)) From thenriksen at common-lisp.net Mon Apr 14 16:46:37 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 14 Apr 2008 12:46:37 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Extensions/Images Message-ID: <20080414164637.9E0052511F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Extensions/Images In directory clnet:/tmp/cvs-serv15385/Extensions/Images Removed Files: gif.lisp image-viewer.lisp images.lisp jpeg.lisp package.lisp xpm.lisp Log Message: Converted MCCLIM-IMAGES to CLIM 2.2 bitmap functions (with extensions). Includes new demo application. From thenriksen at common-lisp.net Mon Apr 14 16:46:39 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 14 Apr 2008 12:46:39 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080414164639.D09C32511A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv15385 Modified Files: NEWS clim-examples.asd clim-listener.asd decls.lisp design.lisp graphics.lisp mcclim.asd package.lisp Added Files: mcclim-gif-bitmaps.asd mcclim-jpeg-bitmaps.asd xpm.lisp Log Message: Converted MCCLIM-IMAGES to CLIM 2.2 bitmap functions (with extensions). Includes new demo application. --- /project/mcclim/cvsroot/mcclim/NEWS 2008/01/31 10:47:07 1.34 +++ /project/mcclim/cvsroot/mcclim/NEWS 2008/04/14 16:46:37 1.35 @@ -4,8 +4,9 @@ ** Bug fix: Some missing methods and functions have been implemented for the Null backend, allowing headless operation for many applications. -** New extension: MCCLIM-IMAGES. This extension makes it easy to use - McCLIM for loading and displaying images of various formats. +** Specification compliance: READ-BITMAP-FILE and + MAKE-PATTERN-FROM-BITMAP-FILE from CLIM 2.2. Includes new example + program, IMAGE-VIEWER. ** Drei improvements *** New redisplay engine that is faster and has more features. *** Support for "views" concept. --- /project/mcclim/cvsroot/mcclim/clim-examples.asd 2007/02/05 03:47:40 1.3 +++ /project/mcclim/cvsroot/mcclim/clim-examples.asd 2008/04/14 16:46:37 1.4 @@ -37,7 +37,8 @@ (:file "font-selector") (:file "tabdemo") (:file "bordered-output-examples") - (:file "misc-tests"))) + (:file "misc-tests") + (:file "image-viewer"))) (:module "Goatee" :components ((:file "goatee-test"))))) --- /project/mcclim/cvsroot/mcclim/clim-listener.asd 2008/01/06 15:32:12 1.3 +++ /project/mcclim/cvsroot/mcclim/clim-listener.asd 2008/04/14 16:46:37 1.4 @@ -6,13 +6,10 @@ (in-package :clim-listener.system) (defsystem :clim-listener - :depends-on (:mcclim #+sbcl :sb-posix :mcclim-images :mcclim-images-xpm) + :depends-on (:mcclim #+sbcl :sb-posix) :components - ((:file "Experimental/xpm" - :pathname #.(make-pathname :directory '(:relative "Experimental") :name "xpm" :type "lisp")) - (:module "Apps/Listener" + ((:module "Apps/Listener" :pathname #.(make-pathname :directory '(:relative "Apps" "Listener")) - :depends-on ("Experimental/xpm") :components ((:file "package") (:file "util" :depends-on ("package")) @@ -22,4 +19,4 @@ (:file "wholine" :depends-on ("package" "dev-commands" "util")) (:file "listener" :depends-on ("package" "wholine" "file-types" "icons" "dev-commands" "util")) - #+CMU (:file "cmu-hacks" :depends-on ("package")))))) \ No newline at end of file + #+CMU (:file "cmu-hacks" :depends-on ("package")))))) --- /project/mcclim/cvsroot/mcclim/decls.lisp 2008/01/19 20:35:47 1.49 +++ /project/mcclim/cvsroot/mcclim/decls.lisp 2008/04/14 16:46:37 1.50 @@ -400,6 +400,21 @@ (defgeneric medium-clear-area (medium left top right bottom)) (defgeneric medium-beep (medium)) +;;;; 14.2 + +(defgeneric pattern-width (pattern) + (:documentation "Return the width of `pattern'.")) + +(defgeneric pattern-height (pattern) + (:documentation "Return the height of `pattern'.")) + +(defgeneric pattern-array (pattern) + (:documentation "Returns the array associated with `pattern'.")) + +(defgeneric pattern-designs (pattern) + (:documentation "Returns the array of designs associated with +`pattern'.")) + ;;;; 14.5 (defgeneric draw-design (medium design --- /project/mcclim/cvsroot/mcclim/design.lisp 2008/01/21 20:54:48 1.28 +++ /project/mcclim/cvsroot/mcclim/design.lisp 2008/04/14 16:46:37 1.29 @@ -2,7 +2,7 @@ ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac at mikemac.com) ;;; (c) copyright 2000 by Robert Strandh (strandh at labri.u-bordeaux.fr) -;;; (c) copyright 2002 by Gilbert Baumann +;;; (c) copyright 1998,2002 by Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -402,6 +402,73 @@ (defgeneric compose-in (ink mask)) (defgeneric compose-out (ink mask)) +;;; RGB image designs, efficient support for truecolor images. ARGB +;;; image data represented as an (unsigned-byte 32) array + +(defclass rgb-image () + ((width :initarg :width :accessor image-width) + (height :initarg :height :accessor image-height) + (data :initarg :data + :accessor image-data + :type (or null (simple-array (unsigned-byte 32) (* *)))) + (alphap :initarg :alphap + :initform nil + :accessor image-alpha-p))) + +;; Applications (closure in particular) might want to cache any +;; backend-specific data required to draw an RGB-IMAGE. +;; +;; To implement this caching, designs must be created separately for each +;; medium, so that mediums can put their own data into them. + +(defclass rgb-image-design (design) + ((medium :initform nil :initarg :medium) + (image :reader image + :initarg :image) + (medium-data :initform nil))) + +(defun make-rgb-image-design (image) + (make-instance 'rgb-image-design :image image)) + + +;; Protocol to free cached data + +(defgeneric medium-free-image-design (medium design)) + +(defun free-image-design (design) + (medium-free-image-design (slot-value design 'medium) design)) + + +;; Drawing protocol + +(defgeneric medium-draw-image-design* (medium design x y)) + +;; Fetching protocol + +(defun sheet-rgb-image (sheet &key x y width height) + (multiple-value-bind (data alphap) + (sheet-rgb-data (port sheet) + sheet + :x x + :y y + :width width + :height height) + (destructuring-bind (height width) + (array-dimensions data) + (make-instance 'rgb-image + :width width + :height height + :data data + :alphap alphap)))) + +(defgeneric sheet-rgb-data (port sheet &key x y width height)) + +(defmethod draw-design + (medium (design rgb-image-design) &rest options + &key (x 0) (y 0) &allow-other-keys) + (with-medium-options (medium options) + (medium-draw-image-design* medium design x y))) + ;; PATTERN is just the an abstract class of all pattern-like design. ;; For performance might consider to sort out pattern, which consists @@ -410,23 +477,17 @@ (define-protocol-class pattern (design)) (defclass indexed-pattern (pattern) - ((array :initarg :array) - (designs :initarg :designs))) + ((array :initarg :array :reader pattern-array) + (designs :initarg :designs :reader pattern-designs))) (defun make-pattern (array designs) (make-instance 'indexed-pattern :array array :designs designs)) -(defgeneric pattern-width (pattern)) - (defmethod pattern-width ((pattern indexed-pattern)) - (with-slots (array) pattern - (array-dimension array 1))) - -(defgeneric pattern-height (pattern)) + (array-dimension (pattern-array pattern) 1)) (defmethod pattern-height ((pattern indexed-pattern)) - (with-slots (array) pattern - (array-dimension array 0))) + (array-dimension (pattern-array pattern) 0)) (defclass stencil (pattern) ((array :initarg :array))) @@ -442,6 +503,37 @@ (with-slots (array) pattern (array-dimension array 0))) +;; These methods are included mostly for completeness and are likely +;; of little use in practice. +(defmethod pattern-array ((pattern stencil)) + (let ((array (make-array (list (pattern-height pattern) + (pattern-width pattern))))) + (dotimes (i (pattern-height pattern)) + (dotimes (j (pattern-width pattern)) + (setf (aref array i j) (+ (* i (array-dimension array 1)) j)))) + array)) + +(defmethod pattern-designs ((pattern stencil)) + (with-slots (array) pattern + (let ((designs (make-array (* (pattern-height pattern) + (pattern-width pattern))))) + (dotimes (i (length designs)) + (setf (aref designs i) (make-opacity (row-major-aref array i)))) + array))) + +(defclass rgb-pattern (pattern rgb-image-design) + ()) + +(defmethod pattern-width ((pattern rgb-pattern)) + (image-width (image pattern))) + +(defmethod pattern-height ((pattern rgb-pattern)) + (image-height (image pattern))) + +;; RGB-PATTERNs must be treated specially... +(defmethod medium-draw-pattern* (medium (pattern rgb-pattern) x y) + (medium-draw-image-design* medium pattern x y)) + ;;; (defclass transformed-design (design) --- /project/mcclim/cvsroot/mcclim/graphics.lisp 2008/01/21 01:26:42 1.60 +++ /project/mcclim/cvsroot/mcclim/graphics.lisp 2008/04/14 16:46:37 1.61 @@ -902,6 +902,23 @@ align-x align-y toward-x toward-y transform-glyphs)) +;;; Some image junk... + +(defmethod medium-free-image-design ((sheet sheet-with-medium-mixin) design) + (medium-free-image-design (sheet-medium sheet) design)) + +(defmethod medium-draw-image-design* :before (current-medium design x y) + (with-slots (medium medium-data) design + (unless (eq medium current-medium) + (when medium + (medium-free-image-design medium design)) + (setf medium current-medium) + (setf medium-data nil)))) + +(defmethod medium-draw-image-design* + ((medium sheet-with-medium-mixin) design x y) + (medium-draw-image-design* (sheet-medium medium) design x y)) + ;;;; ;;;; DRAW-DESIGN ;;;; @@ -995,6 +1012,14 @@ ;;;; +(defmethod draw-design + (medium (design rgb-image-design) &rest options + &key (x 0) (y 0) &allow-other-keys) + (with-medium-options (medium options) + (medium-draw-image-design* medium design x y))) + +;;;; + (defmethod draw-design (medium (pattern pattern) &key clipping-region transformation &allow-other-keys) (draw-pattern* medium pattern 0 0 @@ -1101,3 +1126,92 @@ :radius-left :radius-right :radius-top :radius-bottom)) args))) + +;;; Bitmap images +;;; +;;; Based on CLIM 2.2, with an extension permitting the definition of +;;; new image formats by the user. + +(defvar *bitmap-file-readers* (make-hash-table :test 'equalp) + "A hash table mapping keyword symbols naming bitmap image +formats to a function that can read an image of that format. The +functions will be called with one argument, the pathname of the +file to be read. The functions should return two values as per +`read-bitmap-file'.") + +(defmacro define-bitmap-file-reader (bitmap-format (&rest args) &body body) + "Define a method for reading bitmap images of format +BITMAP-FORMAT that will be used by `read-bitmap-file' and +MAKE-PATTERN-FROM-BITMAP-FILE. BODY should return two values as +per `read-bitmap-file'." + `(setf (gethash ,bitmap-format *bitmap-file-readers*) + #'(lambda (, at args) + , at body))) + +(defun bitmap-format-supported-p (format) + "Return true if FORMAT is supported by `read-bitmap-file'." + (not (null (gethash format *bitmap-file-readers*)))) + +(define-condition unsupported-bitmap-format (error) + ((%format :reader bitmap-format + :initarg :bitmap-format + :initform (error "The bitmap format must be supplied") + :documentation "The bitmap format that cannot be loaded")) + (:report (lambda (condition stream) + (format + stream "Cannot read bitmap of unknown format \"~A\"" + (bitmap-format condition)))) + (:documentation "This exception is signalled when +`read-bitmap-file' is called on an bitmap of a type that no reader +has been defined for.")) + +(defun unsupported-bitmap-format (format) + "Signal an error of type `unsupported-bitmap-format' for the +bitmap format `format'." + (error 'unsupported-bitmap-format :bitmap-format format)) + +(defun read-bitmap-file (pathname &key (format :bitmap) (port (find-port))) + "Read a bitmap file named by `pathname'. `Port' specifies the +port that the bitmap is to be used on. `Format' is a keyword +symbol naming any defined bitmap file format defined by +`clim-extensions:define-bitmap-file-reader'. Two values are +returned: a two-dimensional array of pixel values and an array of +either colors or color names. If the second value is non-NIL, the +pixel values are assumed to be indexes into this +array. Otherwise, the pixel values are taken to be RGB values +encoded in 32 bit unsigned integers, with the three most +significant octets being the values R, G and B, in order." + (declare (ignore port)) ; XXX? + (funcall (or (gethash format *bitmap-file-readers*) + (unsupported-bitmap-format format)) + pathname)) + +(defun make-pattern-from-bitmap-file (pathname &key designs + (format :bitmap) (port (find-port))) + "Read a bitmap file named by `pathname'. `Port' specifies the +port that the bitmap is to be used on. `Format' is a keyword +symbol naming any defined bitmap file format defined by +`clim-extensions:define-bitmap-file-reader'. Two values are +returned: a two-dimensional array of pixel values and an array of +either colors or color names. If the second value is non-NIL, the +pixel values are assumed to be indexes into this +array. Otherwise, the pixel values are taken to be RGB values +encoded in 32 bit unsigned integers, with the three most +significant octets being the values R, G and B, in order." + (multiple-value-bind (res read-designs) + (read-bitmap-file pathname :format format :port port) + (if read-designs + (make-pattern res (or designs read-designs)) + (make-instance 'rgb-pattern :image (make-instance 'rgb-image + :width (array-dimension res 0) + :height (array-dimension res 1) + :data res))))) + +(define-bitmap-file-reader :xpm (pathname) + (xpm-parse-file pathname)) + +(define-bitmap-file-reader :pixmap (pathname) + (read-bitmap-file pathname :format :xpm)) + +(define-bitmap-file-reader :pixmap-3 (pathname) + (read-bitmap-file pathname :format :xpm)) --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/03/28 19:53:19 1.77 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/04/14 16:46:37 1.78 @@ -219,6 +219,7 @@ :components ((:file "text-formatting") (:file "defresource") (:file "presentations") + (:file "xpm") (:file "bordered-output" :depends-on ("presentations")) (:file "table-formatting" :depends-on ("presentations")) (:file "input-editing" :depends-on ("presentations" "bordered-output" "table-formatting")) @@ -362,8 +363,6 @@ (:file "input-editing-goatee") (:file "input-editing-drei") (:file "text-editor-gadget") - (:file "Extensions/rgb-image" :pathname #.(make-pathname :directory '(:relative "Extensions") - :name "rgb-image")) (:file "Extensions/tab-layout" :pathname #.(make-pathname :directory '(:relative "Extensions") :name "tab-layout")))) @@ -547,35 +546,6 @@ (:file "Looks/pixie" :pathname #.(make-pathname :directory '(:relative "Looks") :name "pixie" :type "lisp")))) -(defsystem :mcclim-images - :depends-on (:clim) - :components ((:module "Extensions/Images" - :pathname #.(make-pathname :directory '(:relative "Extensions" "Images")) - :components ((:file "package") - (:file "images" :depends-on ("package")) - (:file "image-viewer" :depends-on ("images")))))) - -(defmacro support-format (format &rest depends-on) - "Generate the ASDF `defsystem' form for a single-file system -consisting of a file with the name `format' in -Extensions/Images. It will depend on the ASDF systems listed in -`depends-on' as well as MCCLIM-IMAGES." - `(defsystem ,(intern (format nil "MCCLIM-IMAGES-~A" (string-upcase format)) - (find-package :keyword)) - :depends-on (:mcclim-images , at depends-on) - :components - ((:file ,format - :pathname ,(make-pathname :directory '(:relative "Extensions" "Images") - :name format))))) - -(defmacro support-formats (&rest formats) - "Generate the ASDF `defsystem' forms for supporting -`formats'." - `(progn ,@(loop for (format . depends-on) in formats - collecting `(support-format ,format , at depends-on)))) - -(support-formats ("gif" :skippy) ("xpm") ("jpeg" :cl-jpeg)) - ;;; The actual McCLIM system that people should to use in their ASDF ;;; package dependency lists. (defsystem :mcclim --- /project/mcclim/cvsroot/mcclim/package.lisp 2008/02/03 18:49:57 1.67 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2008/04/14 16:46:38 1.68 @@ -1648,6 +1648,8 @@ #:+list-pane-view+ ;constant #:option-pane-view ;class #:+option-pane-view+ ;constant + #:pattern-array ;generic function (in franz user guide) + #:pattern-designs ;generic function (in franz user guide) #:pointer-input-rectangle ;function (in franz user guide) #:pointer-input-rectangle* ;function (in franz user guide) #:pointer-place-rubber-band-line* ;function (in franz user guide) @@ -1657,6 +1659,7 @@ #:+push-button-view+ ;constant #:radio-box-view ;class #:+radio-box-view+ ;class + #:read-bitmap-file ;function #:slider-view ;slider-view #:+slider-view+ ;constant #:text-editor-view ;class @@ -1963,7 +1966,11 @@ #:font-face-family #:font-face-all-sizes #:font-face-scalable-p - #:font-face-text-style)) + #:font-face-text-style + + #:define-bitmap-file-reader + #:unsupported-bitmap-format + #:bitmap-format)) ;;; Symbols that must be defined by a backend. ;;; --- /project/mcclim/cvsroot/mcclim/mcclim-gif-bitmaps.asd 2008/04/14 16:46:39 NONE +++ /project/mcclim/cvsroot/mcclim/mcclim-gif-bitmaps.asd 2008/04/14 16:46:39 1.1 ;;; -*- Mode: Lisp -*- ;;; (c) copyright 2008 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:defpackage :mcclim-gif-bitmaps.system (:use :asdf :cl)) (cl:in-package :mcclim-gif-bitmaps.system) (defsystem :mcclim-gif-bitmaps :description "Support for GIF images in McCLIM bitmap reading functions." :depends-on (:mcclim :skippy) :components ((:file "gif" :pathname #P"Extensions/Bitmap-formats/gif"))) --- /project/mcclim/cvsroot/mcclim/mcclim-jpeg-bitmaps.asd 2008/04/14 16:46:39 NONE +++ /project/mcclim/cvsroot/mcclim/mcclim-jpeg-bitmaps.asd 2008/04/14 16:46:39 1.1 ;;; -*- Mode: Lisp -*- ;;; (c) copyright 2008 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:defpackage :mcclim-gif-bitmaps.system (:use :asdf :cl)) (cl:in-package :mcclim-gif-bitmaps.system) (defsystem :mcclim-jpeg-bitmaps :description "Support for JPEG images in McCLIM bitmap reading functions." :depends-on (:mcclim :cl-jpeg) :components ((:file "gif" :pathname #P"Extensions/Bitmap-formats/jpeg"))) --- /project/mcclim/cvsroot/mcclim/xpm.lisp 2008/04/14 16:46:39 NONE +++ /project/mcclim/cvsroot/mcclim/xpm.lisp 2008/04/14 16:46:39 1.1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-INTERNALS; -*- ;;; --------------------------------------------------------------------------- ;;; Title: XPM Parser ;;; Created: 2003-05-25 ;;; 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 ;;; 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-internals) ;;;; 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. ;; ;; - We need a little refactoring: ;; ;; . The list of colors below is now actually the second place we have ;; that. ;; ;; . Parsing of #rgb style colors is now the upteens place we have ;; that in general. ;; ;; => Put that in utils.lisp and document its interface. ;; ;; - The ASCII-centric approach of XPM makes it suitable for embedding ;; it into sources files. I want a macro which takes a list of ;; strings according the XPM format and turns it into a make-pattern ;; call. ;; ;; - This needs to be incorporated into READ-BITMAP-FILE or what ever ;; that is called. ;; ;; - We might be interested in the hot spot also. ;; ;; --GB 2003-05-25 ;;;; Summary of the File Format ;; [as of the XPM-3.4i documentation by Arnaud Le Hors]. ;; | The XPM Format ;; | ;; | The XPM format presents a C syntax, in order to provide the ability to ;; | include XPM files in C and C++ programs. It is in fact an array of ;; | strings composed of six different sections as follows: ;; | ;; | /* XPM */ ;; | static char* [] = { ;; | ;; | ;; | ;; | ;; | }; ;; | ;; | The words are separated by a white space which can be composed of ;; | space and tabulation characters. The section is a string ;; | containing four or six integers in base 10 that correspond to: the ;; | pixmap width and height, the number of colors, the number of ;; | characters per pixel (so there is no limit on the number of colors), ;; | and, optionally the hotspot coordinates and the XPMEXT tag if there is ;; | any extension following the section. ;; | ;; | [ ] [XPMEXT] ;; | ;; | The Colors section contains as many strings as there are colors, and ;; | each string is as follows: ;; | ;; | { }+ ;; | ;; | Where is the length string (not surrounded ;; | by anything) representing the pixels, is the specified color, ;; | and is a keyword describing in which context this color should ;; | be used. Currently the keys may have the following values: ;; | ;; | m for mono visual ;; | s for symbolic name ;; | g4 for 4-level grayscale ;; | g for grayscale with more than 4 levels ;; | c for color visual ;; | ;; | Colors can be specified by giving the colorname, a # followed by the ;; | RGB code in hexadecimal, or a % followed by the HSV code (not ;; | implemented). The symbolic name provides the ability of specifying the ;; | colors at load time and not to hardcode them in the file. ;; | ;; | Also the string None can be given as a colorname to mean ;; | ``transparent''. Transparency is supported by the XPM library by ;; | providing a masking bitmap in addition to the pixmap. This mask can ;; | then be used either as a clip-mask of an Xlib GC, or a shape-mask of a ;; | window using the X11 Nonrectangular Window Shape Extension [XShape]. ;; | The section is composed by strings of * ;; | characters, where every length ;; | string must be one of the previously defined groups in the ;; | section. ;; | ;; | Then follows the section which must be labeled, if not ;; | empty, in the section as previously described. This section ;; | may be composed by several subsections which may be of two ;; | types: ;; | ;; | . one stand alone string composed as follows: ;; | ;; | XPMEXT ;; | ;; | . or a block composed by several strings: ;; | ;; | XPMEXT ;; | ;; | ;; | Finally, if not empty, this section must end by the following string: ;; | ;; | XPMENDEXT ;; | ;; | Extensions can be used to store any type of data one might want to ;; | store along with a pixmap, as long as they are properly encoded so ;; | they do not conflict with the general syntax. To avoid possible ;; | conflicts with extension names in shared files, they should be ;; | prefixed by the name of the company. This would ensure uniqueness. ;; | (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." (map 'string #'code-char (subseq data color-token-end string-end)))) (values code color (1+ string-end)))) (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)))) (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+) ((= key 99) (xpm-parse-single-color-2 data start end)) (t (error "Unimplemented key type ~A" key)))) (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) [893 lines skipped] From thenriksen at common-lisp.net Mon Apr 14 16:55:05 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 14 Apr 2008 12:55:05 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080414165505.5452028143@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv16730/Apps/Listener Modified Files: dev-commands.lisp Log Message: Restored Display Image command in Listener. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/04/14 16:46:28 1.53 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/04/14 16:55:05 1.54 @@ -1420,16 +1420,22 @@ (object) (list object)) -#+nil(define-command (com-display-image :name t :command-table filesystem-commands +(define-command (com-display-image :name t :command-table filesystem-commands :menu t) ((image-pathname 'pathname :default (user-homedir-pathname) :insert-default t)) (if (probe-file image-pathname) - (handler-case - (with-room-for-graphics () - (mcclim-images:draw-image *standard-output* (mcclim-images:load-image image-pathname))) - (mcclim-images:unsupported-image-format (c) - (format t "Image format ~A not recognized" (mcclim-images:image-format c)))) + (let* ((type (funcall (case (readtable-case *readtable*) + (:upcase #'string-upcase) + (:downcase #'string-downcase) + (t #'identity)) + (pathname-type image-pathname))) + (format (find-symbol type (find-package :keyword)))) + (handler-case (let ((pattern (make-pattern-from-bitmap-file image-pathname :format format))) + (with-room-for-graphics () + (draw-pattern* *standard-output* pattern 0 0))) + (unsupported-bitmap-format () + (format t "Image format ~A not recognized" type)))) (format t "No such file: ~A" image-pathname))) (define-command (com-edit-definition :name "Edit Definition" From thenriksen at common-lisp.net Tue Apr 15 09:19:45 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 15 Apr 2008 05:19:45 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080415091945.473E72510F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv25435/Drei Modified Files: drei-redisplay.lisp Log Message: Removed last trace of gone visible-region code. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/03/07 12:11:22 1.69 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/04/15 09:19:43 1.70 @@ -1291,5 +1291,3 @@ (defmethod full-redisplay ((pane drei-pane)) (setf (full-redisplay-p (view pane)) t)) - -(defgeneric display-region (pane syntax)) From thenriksen at common-lisp.net Tue Apr 15 10:19:21 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 15 Apr 2008 06:19:21 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20080415101921.5140225115@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv10125/Examples Modified Files: image-viewer.lisp Log Message: Improved the image-viewer demo. --- /project/mcclim/cvsroot/mcclim/Examples/image-viewer.lisp 2008/04/14 16:46:28 1.1 +++ /project/mcclim/cvsroot/mcclim/Examples/image-viewer.lisp 2008/04/15 10:19:21 1.2 @@ -43,17 +43,23 @@ ;; Clear the old image. (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane) (draw-rectangle* (sheet-medium pane) x1 y1 x2 y2 :ink +background-ink+)) + ;; Draw the new one, if there is one. (when (gadget-value pane) - ;; Try to ensure there is room for the new image. - (change-space-requirements pane - :height (pattern-height (gadget-value pane)) - :width (pattern-width (gadget-value pane))) - ;; Draw the new one, if there is one. - (handler-case (draw-pattern* pane (gadget-value pane) 0 0) - (error () - (with-text-style (pane (make-text-style nil :italic nil)) - (draw-text* pane (format nil "Error while drawing image") - 0 0 :align-y :top)))))) + (let ((image-height (pattern-height (gadget-value pane))) + (image-width (pattern-width (gadget-value pane)))) + ;; Try to ensure there is room for the new image. + (change-space-requirements pane :height image-height :width image-width) + ;; Draw it in the center. + (handler-case (draw-pattern* + pane (gadget-value pane) + (/ (- (bounding-rectangle-width pane) image-width) + 2) + (/ (- (bounding-rectangle-height pane) image-height) + 2)) + (error () + (with-text-style (pane (make-text-style nil :italic nil)) + (draw-text* pane (format nil "Error while drawing image") + 0 0 :align-y :top))))))) (define-application-frame image-viewer () ((%image-pathname :accessor image-pathname @@ -93,6 +99,10 @@ (format t "Image format ~A not recognized" type)))) (format t "No such file: ~A" image-pathname))) +(define-image-viewer-command (com-blank-image :name t :menu t) + () + (setf (gadget-value (find-pane-named *application-frame* 'viewer)) nil)) + (defun image-viewer (&key (new-process t)) (flet ((run () (let ((frame (make-application-frame 'image-viewer))) From thenriksen at common-lisp.net Tue Apr 15 19:28:04 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 15 Apr 2008 15:28:04 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080415192804.A9FAB6923E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv26788 Modified Files: stream-output.lisp Log Message: Fixed output bug where :end-of-line-action is :wrap and there isn't room for even a single character. Acts as :allow in this case, would infinitely recurse previously. --- /project/mcclim/cvsroot/mcclim/stream-output.lisp 2006/12/10 23:35:12 1.61 +++ /project/mcclim/cvsroot/mcclim/stream-output.lisp 2008/04/15 19:28:04 1.62 @@ -305,7 +305,10 @@ (when (>= (+ cx width) margin) (ecase (stream-end-of-line-action stream) (:wrap - (setq split (find-split (- margin cx)))) + ;; Let's prevent infinite recursion if there isn't + ;; room for even a single character. + (setq split (max (find-split (- margin cx)) + (1+ start)))) (:scroll (scroll-horizontal stream width)) (:allow))) From thenriksen at common-lisp.net Tue Apr 15 19:52:57 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 15 Apr 2008 15:52:57 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080415195257.049B163032@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv31942 Modified Files: commands.lisp Log Message: Fixed the addition of menu items to empty menus. --- /project/mcclim/cvsroot/mcclim/commands.lisp 2008/02/02 00:10:18 1.77 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2008/04/15 19:52:57 1.78 @@ -415,18 +415,20 @@ (defun %add-menu-item (command-table item after) (with-slots (menu) command-table + (when (null menu) + (setf after :start)) (case after (:start (push item menu)) ((:end nil) (setf menu (nconc menu (list item)))) (:sort (setf menu (sort (cons item menu) - #'string-lessp - :key #'command-menu-item-name))) + #'string-lessp + :key #'command-menu-item-name))) (t (push item - (cdr (member after menu - :key #'command-menu-item-name - :test #'string-equal)))))) + (cdr (member after menu + :key #'command-menu-item-name + :test #'string-equal)))))) (when (and (slot-boundp item 'keystroke) - (slot-value item 'keystroke)) + (slot-value item 'keystroke)) (%add-keystroke-item command-table (slot-value item 'keystroke) item nil))) From thenriksen at common-lisp.net Tue Apr 15 21:15:23 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 15 Apr 2008 17:15:23 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080415211523.23073620A9@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv17042 Modified Files: menu.lisp Log Message: Made command menu panes less broken. --- /project/mcclim/cvsroot/mcclim/menu.lisp 2008/01/29 19:13:07 1.39 +++ /project/mcclim/cvsroot/mcclim/menu.lisp 2008/04/15 21:15:22 1.40 @@ -461,9 +461,9 @@ (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))))))) + (let ((name (command-menu-item-name item))) + (with-output-as-presentation (stream (command-menu-item-value item) 'command) + (write-string name stream))))))) command-table))) (defmethod display-command-menu (frame (stream fundamental-output-stream) From thenriksen at common-lisp.net Fri Apr 18 11:22:29 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 18 Apr 2008 07:22:29 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080418112229.769E237080@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv29836/Drei Modified Files: search-commands.lisp Log Message: Fixed silly bug in Drei search/replace. --- /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2008/01/30 11:48:40 1.8 +++ /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2008/04/18 11:22:29 1.9 @@ -424,7 +424,7 @@ (occurrences occurrences) (targets targets)) state (let ((string1-length (length string1)) - (mark (point (drei-instance targets)))) + (mark (point (view (drei-instance targets))))) (backward-object mark string1-length) (replace-one-string mark string1-length @@ -443,7 +443,7 @@ (occurrences occurrences) (targets targets)) state (let ((string1-length (length string1)) - (mark (point (drei-instance targets)))) + (mark (point (view (drei-instance targets))))) (loop do (backward-object mark string1-length) (replace-one-string mark string1-length From thenriksen at common-lisp.net Fri Apr 18 11:46:41 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 18 Apr 2008 07:46:41 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080418114641.2484414160@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv2123/Apps/Listener Modified Files: icons.lisp Log Message: Explicitly provide a :port nil argument to make-pattern-from-bitmap-file so that no port thread will be started by the Listener at load-time. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/icons.lisp 2008/04/14 16:46:28 1.8 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/icons.lisp 2008/04/18 11:46:40 1.9 @@ -35,7 +35,8 @@ (defmacro deficon (var pathname) `(eval-when (:load-toplevel :execute) (defparameter ,var (make-pattern-from-bitmap-file - ,(merge-pathnames pathname *icon-path*) :format :xpm)))) + ,(merge-pathnames pathname *icon-path*) + :format :xpm :port nil)))) (defvar *icon-cache* (make-hash-table :test #'equal)) @@ -46,7 +47,7 @@ (make-pattern-from-bitmap-file (merge-pathnames (parse-namestring filename) *icon-path*) - :format :xpm)))) + :format :xpm :port nil)))) ;; Don't particularly need these any more.. (deficon *folder-icon* #P"folder.xpm") From thenriksen at common-lisp.net Sat Apr 19 07:51:23 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 19 Apr 2008 03:51:23 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080419075123.8868A14160@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv24668 Modified Files: presentation-defs.lisp Log Message: Fix the utterly broken ACCEPT-FROM-STRING to at least work for common cases. Still WIP. --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2008/02/01 17:02:55 1.75 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2008/04/19 07:51:22 1.76 @@ -964,6 +964,102 @@ (declare (ignore type view other-args)) nil) +;;; For ACCEPT-FROM-STRING, use this barebones input-editing-stream. +(defclass string-input-editing-stream (input-editing-stream fundamental-character-input-stream) + ((input-buffer :accessor stream-input-buffer) + (insertion-pointer :accessor stream-insertion-pointer + :initform 0 + :documentation "This is not used for anything at any point.") + (scan-pointer :accessor stream-scan-pointer + :initform 0 + :documentation "This is not used for anything at any point.")) + (:documentation "An implementation of the input-editing stream +protocol retrieving gestures from a provided string.")) + +(defmethod initialize-instance :after ((stream string-input-editing-stream) + &key (string (error "A string must be provided")) + (start 0) (end (length string)) + &allow-other-keys) + (setf (stream-input-buffer stream) + (replace (make-array (- end start) :fill-pointer (- end start)) + string :start1 start :end2 end))) + +(defmethod stream-element-type ((stream string-input-editing-stream)) + 'character) + +(defmethod close ((stream string-input-editing-stream) &key abort) + (declare (ignore abort))) + +(defmethod stream-peek-char ((stream string-input-editing-stream)) + (let ((char (read-char-no-hang stream nil nil))) + (when char + (unread-char char stream)) + (or char :eof))) + +(defmethod stream-read-char-no-hang ((stream string-input-editing-stream)) + (if (> (stream-scan-pointer stream) (length (stream-input-buffer stream))) + :eof + (stream-read-gesture stream))) + +(defmethod stream-read-char ((stream string-input-editing-stream)) + (stream-read-gesture stream)) + +(defmethod stream-listen ((stream string-input-editing-stream)) + (< (stream-scan-pointer stream) (length (stream-input-buffer stream)))) + +(defmethod stream-unread-char ((stream string-input-editing-stream) char) + (stream-unread-gesture stream char)) + +(defmethod invoke-with-input-editor-typeout ((stream string-input-editing-stream) continuation + &key erase) + (declare (ignore erase))) + +(defmethod input-editor-format ((stream string-input-editing-stream) format-string + &rest args) + (declare (ignore args))) + +(defmethod stream-rescanning-p ((stream string-input-editing-stream)) + t) + +(defmethod reset-scan-pointer ((stream string-input-editing-stream) + &optional scan-pointer) + (declare (ignore scan-pointer))) + +(defmethod immediate-rescan ((stream string-input-editing-stream))) + +(defmethod queue-rescan ((stream string-input-editing-stream))) + +(defmethod rescan-if-necessary ((stream string-input-editing-stream) + &optional inhibit-activation) + (declare (ignore inhibit-activation))) + +(defmethod erase-input-buffer ((stream string-input-editing-stream) + &optional start-position) + (declare (ignore start-position))) + +(defmethod redraw-input-buffer ((stream string-input-editing-stream) + &optional start-position) + (declare (ignore start-position))) + +(defmethod stream-process-gesture ((stream string-input-editing-stream) gesture type) + (when (characterp gesture) + (values gesture type))) + +(defmethod stream-read-gesture ((stream string-input-editing-stream) + &key peek-p &allow-other-keys) + (prog1 (if (= (stream-scan-pointer stream) (length (stream-input-buffer stream))) + (second (first (gethash (first *activation-gestures*) + climi::*gesture-names*))) ; XXX - will always be non-NIL? + (aref (stream-input-buffer stream) (stream-scan-pointer stream))) + (unless peek-p + (incf (stream-scan-pointer stream))))) + +(defmethod stream-unread-gesture ((stream string-input-editing-stream) gesture) + (decf (stream-scan-pointer stream))) + +(defmethod stream-accept ((stream string-input-editing-stream) type &rest args) + (apply #'accept-1 stream type args)) + ;;; XXX This needs work! It needs to do everything that accept does for ;;; expanding ptypes and setting up recursive call procesusing (defun accept-from-string (type string @@ -982,7 +1078,7 @@ (start 0) (end (length string))) (declare (ignore view)) - ;;; XXX work in progress here. + ;; XXX work in progress here. (with-activation-gestures ((if additional-activations-p additional-activation-gestures activation-gestures) @@ -999,13 +1095,12 @@ type) 0)) (simple-parse-error "Empty string"))) - (let ((index 0)) + (let ((stream (make-instance 'string-input-editing-stream + :string string :start start :end end))) (multiple-value-bind (val ptype) - (with-input-from-string (stream string :start start :end end - :index index) - (with-keywords-removed (args (:start :end)) - (apply #'stream-accept stream type :view +textual-view+ args))) - (values val ptype index)))) + (with-keywords-removed (args (:start :end)) + (apply #'stream-accept stream type :history nil :view +textual-view+ args)) + (values val ptype (+ (stream-scan-pointer stream) start))))) (define-presentation-generic-function %presentation-refined-position-test presentation-refined-position-test From thenriksen at common-lisp.net Sat Apr 19 09:26:50 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 19 Apr 2008 05:26:50 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080419092650.6CE6937014@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv11778 Modified Files: presentation-defs.lisp Log Message: Fixed STRING-INPUT-EDITING-STREAM to not fail on many common use cases. --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2008/04/19 07:51:22 1.76 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2008/04/19 09:26:49 1.77 @@ -1047,12 +1047,13 @@ (defmethod stream-read-gesture ((stream string-input-editing-stream) &key peek-p &allow-other-keys) - (prog1 (if (= (stream-scan-pointer stream) (length (stream-input-buffer stream))) - (second (first (gethash (first *activation-gestures*) - climi::*gesture-names*))) ; XXX - will always be non-NIL? - (aref (stream-input-buffer stream) (stream-scan-pointer stream))) - (unless peek-p - (incf (stream-scan-pointer stream))))) + (unless (> (stream-scan-pointer stream) (length (stream-input-buffer stream))) + (prog1 (if (= (stream-scan-pointer stream) (length (stream-input-buffer stream))) + (second (first (gethash (first *activation-gestures*) + climi::*gesture-names*))) ; XXX - will always be non-NIL? + (aref (stream-input-buffer stream) (stream-scan-pointer stream))) + (unless peek-p + (incf (stream-scan-pointer stream)))))) (defmethod stream-unread-gesture ((stream string-input-editing-stream) gesture) (decf (stream-scan-pointer stream))) From ahefner at common-lisp.net Sun Apr 20 00:34:10 2008 From: ahefner at common-lisp.net (ahefner) Date: Sat, 19 Apr 2008 20:34:10 -0400 (EDT) Subject: [mcclim-cvs] CVS playpen Message-ID: <20080420003410.3CA585002@common-lisp.net> Update of /project/mcclim/cvsroot/playpen In directory clnet:/tmp/cvs-serv12245 Log Message: Initial import. Status: Vendor Tag: initial Release Tags: start N playpen/playpen.asd N playpen/scratch.text N playpen/src/package.lisp N playpen/src/windowing.h N playpen/src/wtest_1.c N playpen/src/x11.c No conflicts created by this import From ahefner at gmail.com Sun Apr 20 00:38:34 2008 From: ahefner at gmail.com (Andy Hefner) Date: Sat, 19 Apr 2008 20:38:34 -0400 Subject: [mcclim-cvs] CVS playpen In-Reply-To: <20080420003410.3CA585002@common-lisp.net> References: <20080420003410.3CA585002@common-lisp.net> Message-ID: <31ffd3c40804191738y13f35306rddaa93012252921b@mail.gmail.com> Sorry, that was meant to go into my private hacks, not the mcclim CVS. I guess I've learned a lesson about keeping CVSROOT set in my environment and forgetting to use -d... On 4/19/08, ahefner wrote: > Update of /project/mcclim/cvsroot/playpen > In directory clnet:/tmp/cvs-serv12245 > > Log Message: > Initial import. > > Status: > > Vendor Tag: initial > Release Tags: start > > N playpen/playpen.asd > N playpen/scratch.text > N playpen/src/package.lisp > N playpen/src/windowing.h > N playpen/src/wtest_1.c > N playpen/src/x11.c > > No conflicts created by this import > > > > _______________________________________________ > mcclim-cvs mailing list > mcclim-cvs at common-lisp.net > http://common-lisp.net/cgi-bin/mailman/listinfo/mcclim-cvs > From thenriksen at common-lisp.net Sun Apr 20 07:19:10 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 20 Apr 2008 03:19:10 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080420071910.86B9C66001@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv4340 Modified Files: commands.lisp Log Message: Fixed broken :insert-default t in command parameters. It wasn't being passed along in the call to ACCEPT in the acceptor. I feel a bit odd about this fix, because I vaguely recall that this used to work, at least in Climacs, but the code pretty obviously filtered :insert-default keywords away. --- /project/mcclim/cvsroot/mcclim/commands.lisp 2008/04/15 19:52:57 1.78 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2008/04/20 07:19:10 1.79 @@ -663,7 +663,7 @@ (defun accept-form-for-argument (stream arg) (let ((accept-keys '(:default :default-type :display-default - :prompt :documentation))) + :prompt :documentation :insert-default))) (destructuring-bind (name ptype &rest key-args &key (mentioned-default nil mentioned-default-p) &allow-other-keys) @@ -692,7 +692,7 @@ (defun accept-form-for-argument-partial (stream ptype-arg command-arg original-command-arg ) (let ((accept-keys '(:default :default-type :display-default - :prompt :documentation))) + :prompt :documentation :insert-default))) (destructuring-bind (name ptype &rest key-args) ptype-arg (declare (ignore name)) From ahefner at common-lisp.net Mon Apr 21 06:13:26 2008 From: ahefner at common-lisp.net (ahefner) Date: Mon, 21 Apr 2008 02:13:26 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080421061326.C2C2B5832C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv2698 Modified Files: NEWS Log Message: My changes. --- /project/mcclim/cvsroot/mcclim/NEWS 2008/04/14 16:46:37 1.35 +++ /project/mcclim/cvsroot/mcclim/NEWS 2008/04/21 06:13:26 1.36 @@ -24,6 +24,15 @@ CLIM 2.2 semantics. The :keystrokes value is not handled yet. ** Specification compliance: :PRINTER functions for MENU-CHOOSE are now called with the menu item, not the display object. +** Improvement: Faster drawing and AA text rendering. AA text requires + a fix to the Xrender support of CLX, available in Christophe Rhodes's + current CLX distribution from darcs. +** Improvement: Look up arbitrary truetype fonts by name via fontconfig. +** New extension: mcclim-truetype: provides a 100% lisp path for + AA fonts with CLX using cl-vectors and zpb-ttf, as an alternative + to mcclim-freetype. +** Bug fix: correct computation of bounding rectangle after + clear-output-record and recompute-extent-for-new-child. * Changes in mcclim-0.9.5 relative to 0.9.4: ** Installation: the systems clim-listener, clim-examples, From afuchs at common-lisp.net Wed Apr 23 11:36:05 2008 From: afuchs at common-lisp.net (afuchs) Date: Wed, 23 Apr 2008 07:36:05 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080423113605.AD87A4610B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv12460 Modified Files: mcclim.asd Log Message: Prepare for the 0.9.6 release. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/04/14 16:46:37 1.78 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/04/23 11:36:05 1.79 @@ -549,7 +549,7 @@ ;;; The actual McCLIM system that people should to use in their ASDF ;;; package dependency lists. (defsystem :mcclim - :version "0.9.6-dev" + :version "0.9.6" :depends-on (:clim-looks)) (defmethod perform :after ((op load-op) (c (eql (find-system :clim)))) From afuchs at common-lisp.net Wed Apr 23 11:36:05 2008 From: afuchs at common-lisp.net (afuchs) Date: Wed, 23 Apr 2008 07:36:05 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Doc Message-ID: <20080423113605.EBF544610B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv12460/Doc Modified Files: mcclim.texi Log Message: Prepare for the 0.9.6 release. --- /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi 2007/09/02 18:55:28 1.10 +++ /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi 2008/04/23 11:36:05 1.11 @@ -6,10 +6,10 @@ @setfilename mcclim @settitle McCLIM User's Manual - at set MCCLIMVERSION 0.9.6-dev + at set MCCLIMVERSION 0.9.6 @copying -Copyright @copyright{} 2004,2005,2006 the McCLIM hackers. +Copyright @copyright{} 2004,2005,2006,2007,2008 the McCLIM hackers. @end copying @dircategory Common Lisp From afuchs at common-lisp.net Wed Apr 23 11:36:06 2008 From: afuchs at common-lisp.net (afuchs) Date: Wed, 23 Apr 2008 07:36:06 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/ReleaseNotes Message-ID: <20080423113606.3387D46180@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ReleaseNotes In directory clnet:/tmp/cvs-serv12460/ReleaseNotes Added Files: 0-9-6-st-george's-day Log Message: Prepare for the 0.9.6 release. --- /project/mcclim/cvsroot/mcclim/ReleaseNotes/0-9-6-st-george's-day 2008/04/23 11:36:06 NONE +++ /project/mcclim/cvsroot/mcclim/ReleaseNotes/0-9-6-st-george's-day 2008/04/23 11:36:06 1.1 From afuchs at common-lisp.net Wed Apr 23 11:46:30 2008 From: afuchs at common-lisp.net (afuchs) Date: Wed, 23 Apr 2008 07:46:30 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim-website Message-ID: <20080423114630.B357B6101F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim-website In directory clnet:/tmp/cvs-serv15125 Modified Files: index.html Log Message: Update website for 0.9.6 --- /project/mcclim/cvsroot/mcclim-website/index.html 2008/02/11 19:26:32 1.5 +++ /project/mcclim/cvsroot/mcclim-website/index.html 2008/04/23 11:46:30 1.6 @@ -67,9 +67,9 @@

Releases

- The most recent release of McCLIM is 0.9.5, in September 2007, + The most recent release of McCLIM is 0.9.6, in April 2008, available here: mcclim-0.9.5.tar.gz. It + href="downloads/mcclim-0.9.6.tar.gz">mcclim-0.9.6.tar.gz. It is also available via ASDF-INSTALL.

@@ -77,6 +77,9 @@

Recent News

+ 2007-04-23: McCLIM 0.9.6 "St. George's Day" released. +

+

2007-09-02: McCLIM 0.9.5 "Eastern Orthodox Lithurgical New Year" released.

@@ -145,7 +148,7 @@
-$Date: 2008/02/11 19:26:32 $ +$Date: 2008/04/23 11:46:30 $ From afuchs at common-lisp.net Wed Apr 23 11:46:30 2008 From: afuchs at common-lisp.net (afuchs) Date: Wed, 23 Apr 2008 07:46:30 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim-website/downloads Message-ID: <20080423114630.E58FB6101F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim-website/downloads In directory clnet:/tmp/cvs-serv15125/downloads Modified Files: index.html Log Message: Update website for 0.9.6 --- /project/mcclim/cvsroot/mcclim-website/downloads/index.html 2008/01/26 17:27:49 1.1.1.1 +++ /project/mcclim/cvsroot/mcclim-website/downloads/index.html 2008/04/23 11:46:30 1.2 @@ -43,7 +43,7 @@

Tarballs

Releases

-

The most recent release of McCLIM is 0.9.5, in September 2007, available here: mcclim-0.9.5.tar.gz. It is also available via ASDF-INSTALL.

+

The most recent release of McCLIM is 0.9.6, in April 2008, available here: mcclim-0.9.6.tar.gz. It is also available via ASDF-INSTALL.

A compressed tar file of the repository is made nightly.

@@ -52,7 +52,7 @@
-$Date: 2008/01/26 17:27:49 $ +$Date: 2008/04/23 11:46:30 $ From afuchs at common-lisp.net Wed Apr 23 12:05:36 2008 From: afuchs at common-lisp.net (afuchs) Date: Wed, 23 Apr 2008 08:05:36 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080423120536.C5169314C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv23626 Modified Files: NEWS mcclim.asd Log Message: Update the version numbers to 0.9.7-dev. Tree is unfrozen now. --- /project/mcclim/cvsroot/mcclim/NEWS 2008/04/21 06:13:26 1.36 +++ /project/mcclim/cvsroot/mcclim/NEWS 2008/04/23 12:05:28 1.37 @@ -1,3 +1,6 @@ +* Changes in mcclim-0.9.7 relative to 0.9.6: + + * Changes in mcclim-0.9.6 relative to 0.9.5: ** Bug fix: ESA's help commands are better at finding bindings and describing them --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/04/23 11:36:05 1.79 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/04/23 12:05:30 1.80 @@ -549,7 +549,7 @@ ;;; The actual McCLIM system that people should to use in their ASDF ;;; package dependency lists. (defsystem :mcclim - :version "0.9.6" + :version "0.9.7-dev" :depends-on (:clim-looks)) (defmethod perform :after ((op load-op) (c (eql (find-system :clim)))) From afuchs at common-lisp.net Wed Apr 23 12:05:37 2008 From: afuchs at common-lisp.net (afuchs) Date: Wed, 23 Apr 2008 08:05:37 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Doc Message-ID: <20080423120537.02A151F00F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv23626/Doc Modified Files: mcclim.texi Log Message: Update the version numbers to 0.9.7-dev. Tree is unfrozen now. --- /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi 2008/04/23 11:36:05 1.11 +++ /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi 2008/04/23 12:05:36 1.12 @@ -6,7 +6,7 @@ @setfilename mcclim @settitle McCLIM User's Manual - at set MCCLIMVERSION 0.9.6 + at set MCCLIMVERSION 0.9.7-dev @copying Copyright @copyright{} 2004,2005,2006,2007,2008 the McCLIM hackers. From thenriksen at common-lisp.net Sat Apr 26 21:19:59 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 26 Apr 2008 17:19:59 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080426211959.C7908161C8@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv18250/Apps/Listener Modified Files: package.lisp Log Message: Use the CLIM-EXTENSIONS package in CLIM-LISTENER so that Display Image works. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/package.lisp 2006/11/24 18:37:54 1.3 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/package.lisp 2008/04/26 21:19:59 1.4 @@ -2,7 +2,7 @@ (in-package :cl-user) (defpackage "CLIM-LISTENER" - (:use "CLIM" "CLIM-LISP") + (:use "CLIM" "CLIM-LISP" "CLIM-EXTENSIONS") (:export #:run-listener #:dev-commands)) (in-package :clim-listener) From thenriksen at common-lisp.net Mon Apr 28 20:48:55 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 28 Apr 2008 16:48:55 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20080428204855.8D7AA25136@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv5400/Backends/CLX Modified Files: keysyms.lisp Log Message: Filter shift modifier state in CLX backend. Also updated a bunch of key bindings to not specify :SHIFT anymore. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/keysyms.lisp 2004/08/01 14:09:01 1.10 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/keysyms.lisp 2008/04/28 20:48:55 1.11 @@ -42,31 +42,38 @@ (defun x-event-to-key-name-and-modifiers (port event-key keycode state) (multiple-value-bind (clim-modifiers shift-lock? caps-lock? mode-switch?) (clim-xcommon:x-event-state-modifiers port state) + ;; We filter away the shift state if there is a difference between + ;; the shifted and unshifted keysym. This is so eg. #\A will not + ;; look like "#\A with a Shift modifier", as this makes gesture + ;; processing more difficult. (let* ((display (clx-port-display port)) (shift? (logtest +shift-key+ clim-modifiers)) - (keysym (xlib:keycode->keysym display keycode - (+ (if (if shift-lock? - (not shift?) - (if caps-lock? t shift?)) - 1 0) - (if mode-switch? - 2 0)))) - (keysym-keyword (clim-xcommon:lookup-keysym keysym)) - (char (xlib:keysym->character display keysym - (+ (if (if shift-lock? - (not shift?) - (if caps-lock? t shift?)) - 1 0) - (if mode-switch? - 2 0))))) - (values char - (clim-xcommon:x-keysym-to-clim-modifiers port - event-key - char - (clim-xcommon:lookup-keysym - keysym) - state) - keysym-keyword)))) + (shift-modifier? (if shift-lock? + (not shift?) + (if caps-lock? t shift?))) + (shifted-keysym (xlib:keycode->keysym display keycode + (+ 1 (if mode-switch? + 2 0)))) + (unshifted-keysym (xlib:keycode->keysym display keycode + (if mode-switch? + 2 0))) + (keysym (if shift-modifier? + shifted-keysym + unshifted-keysym))) + (let* ((keysym-keyword (clim-xcommon:lookup-keysym keysym)) + (char (xlib:keysym->character display keysym + (+ (if shift-modifier? + 1 0) + (if mode-switch? + 2 0)))) + (modifiers (clim-xcommon:x-keysym-to-clim-modifiers + port event-key char (clim-xcommon:lookup-keysym keysym) + state))) + (values char + (if (= shifted-keysym unshifted-keysym) + modifiers + (logandc2 modifiers +shift-key+)) + keysym-keyword))))) ;;;; From thenriksen at common-lisp.net Mon Apr 28 20:48:55 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 28 Apr 2008 16:48:55 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080428204855.01D2A25132@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv5400/Drei Modified Files: basic-commands.lisp core-commands.lisp misc-commands.lisp search-commands.lisp unicode-commands.lisp Log Message: Filter shift modifier state in CLX backend. Also updated a bunch of key bindings to not specify :SHIFT anymore. --- /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2008/02/03 08:55:01 1.13 +++ /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2008/04/28 20:48:55 1.14 @@ -242,7 +242,7 @@ (set-key `(com-backward-paragraph ,*numeric-argument-marker*) 'movement-table - '((#\{ :shift :meta))) + '((#\{ :meta))) (set-key `(com-backward-paragraph ,*numeric-argument-marker*) 'movement-table @@ -250,7 +250,7 @@ (set-key `(com-forward-paragraph ,*numeric-argument-marker*) 'movement-table - '((#\} :shift :meta))) + '((#\} :meta))) (set-key `(com-forward-paragraph ,*numeric-argument-marker*) 'movement-table --- /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2008/02/03 07:16:49 1.17 +++ /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2008/04/28 20:48:55 1.18 @@ -156,7 +156,7 @@ (set-key `(com-mark-word ,*numeric-argument-marker*) 'marking-table - '((#\@ :meta :shift))) + '((#\@ :meta))) (set-key `(com-mark-paragraph ,*numeric-argument-marker*) 'marking-table @@ -264,7 +264,7 @@ (set-key 'com-delete-indentation 'indent-table - '((#\^ :shift :meta))) + '((#\^ :meta))) (define-command (com-auto-fill-mode :name t :command-table fill-table) () (let ((view (current-view))) @@ -297,7 +297,7 @@ (set-key 'com-beginning-of-buffer 'movement-table - '((#\< :shift :meta))) + '((#\< :meta))) (set-key 'com-beginning-of-buffer 'movement-table @@ -331,7 +331,7 @@ (set-key 'com-end-of-buffer 'movement-table - '((#\> :shift :meta))) + '((#\> :meta))) (set-key 'com-end-of-buffer 'movement-table @@ -510,7 +510,7 @@ (set-key 'com-undo 'editing-table - '((#\_ :shift :control))) + '((#\_ :control))) (set-key 'com-undo 'editing-table @@ -522,7 +522,7 @@ (set-key 'com-redo 'editing-table - '((#\_ :shift :meta))) + '((#\_ :meta))) (set-key 'com-redo 'editing-table --- /project/mcclim/cvsroot/mcclim/Drei/misc-commands.lisp 2007/12/19 11:02:01 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/misc-commands.lisp 2008/04/28 20:48:55 1.5 @@ -68,7 +68,7 @@ (set-key `(com-eval-expression ,*unsupplied-argument-marker* ,*numeric-argument-marker*) 'editor-table - '((#\: :shift :meta))) + '((#\: :meta))) (set-key 'com-count-lines-page 'info-table --- /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2008/04/18 11:22:29 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2008/04/28 20:48:55 1.10 @@ -393,7 +393,7 @@ (set-key 'com-query-replace 'search-table - '((#\% :shift :meta))) + '((#\% :meta))) (define-command (com-query-replace-replace :name t :command-table query-replace-drei-table) () (let ((state (query-replace-state (drei-instance)))) --- /project/mcclim/cvsroot/mcclim/Drei/unicode-commands.lisp 2007/12/19 11:02:01 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/unicode-commands.lisp 2008/04/28 20:48:55 1.3 @@ -49,11 +49,11 @@ (set-dead-grave-key (code &rest sequence) `(set-charcode-key ,code ((:dead-grave) , at sequence))) (set-dead-diaresis-key (code &rest sequence) - `(set-charcode-key ,code ((:dead-diaresis :shift) , at sequence))) + `(set-charcode-key ,code ((:dead-diaeresis) , at sequence))) (set-dead-tilde-key (code &rest sequence) - `(set-charcode-key ,code ((:dead-tilde :shift) , at sequence))) + `(set-charcode-key ,code ((:dead-tilde) , at sequence))) (set-dead-circumflex-key (code &rest sequence) - `(set-charcode-key ,code ((:dead-circumflex :shift) , at sequence)))) + `(set-charcode-key ,code ((:dead-circumflex) , at sequence)))) (set-dead-acute-key 193 (#\A)) (set-dead-acute-key 201 (#\E)) (set-dead-acute-key 205 (#\I)) From thenriksen at common-lisp.net Tue Apr 29 16:27:41 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 29 Apr 2008 12:27:41 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080429162741.C51A64814A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv10422/Drei Removed Files: unicode-commands.lisp Log Message: Improved dead key handling for ESAs (well, some of them). Now uses a clever state machine to merge dead keys, rather than the old command table hack. From thenriksen at common-lisp.net Tue Apr 29 16:27:42 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 29 Apr 2008 12:27:42 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20080429162742.D6DBE4814A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv10422/ESA Modified Files: esa.lisp packages.lisp utils.lisp Added Files: dead-keys.lisp Log Message: Improved dead key handling for ESAs (well, some of them). Now uses a clever state machine to merge dead keys, rather than the old command table hack. --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/02/03 08:38:26 1.19 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/04/29 16:27:42 1.20 @@ -550,21 +550,25 @@ (end-command-loop (overriding-handler command-processor))) (setf (overriding-handler (super-command-processor command-processor)) nil)) -(defmethod process-gesture :around ((command-processor command-loop-command-processor) gesture) - (cond ((find gesture *abort-gestures* - :test #'gesture-matches-gesture-name-p) - ;; It is to be expected that the abort function might signal - ;; `abort-gesture'. If that happens, we must end the command - ;; loop, but ONLY if this is signalled. - (handler-case (funcall (abort-function command-processor)) - (abort-gesture (c) - (end-command-loop command-processor) - (signal c)))) - (t - (call-next-method) - (when (funcall (end-condition command-processor)) - (funcall (end-function command-processor)) - (end-command-loop command-processor))))) +(defmethod process-gesture ((command-processor command-loop-command-processor) gesture) + (handling-dead-keys (gesture) + (cond ((find gesture *abort-gestures* + :test #'gesture-matches-gesture-name-p) + ;; It is to be expected that the abort function might signal + ;; `abort-gesture'. If that happens, we must end the command + ;; loop, but ONLY if this is signalled. + (handler-case (funcall (abort-function command-processor)) + (abort-gesture (c) + (end-command-loop command-processor) + (signal c)))) + (t + (setf (accumulated-gestures command-processor) + (nconc (accumulated-gestures command-processor) + (list gesture))) + (process-gestures command-processor) + (when (funcall (end-condition command-processor)) + (funcall (end-function command-processor)) + (end-command-loop command-processor)))))) (defun process-gestures-for-numeric-argument (gestures) "Processes a list of gestures for numeric argument --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/02/03 08:38:26 1.17 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/04/29 16:27:42 1.18 @@ -46,6 +46,7 @@ #:capitalize #:ensure-array-size #:values-max-min + #:retaining-value #:build-menu #:define-menu-table #:observable-mixin #:add-observer #:remove-observer --- /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2008/01/29 22:59:30 1.11 +++ /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2008/04/29 16:27:42 1.12 @@ -261,6 +261,18 @@ `(call-method ,(first around) (,@(rest around) (make-method ,form))) form)))) +(defmacro retaining-value ((bound-symbol &optional initial-value) &body body) + "Evaluate `body' with `bound-symbol' bound to +`initial-value' (default NIL). Th next time `body' is evaluated, +`bound-symbol' will be bound to whatever its value was the last +time evaluation of `body' ended." + (let ((symbol (gensym))) + `(progn (unless (boundp ',symbol) + (setf (symbol-value ',symbol) ,initial-value)) + (let ((,bound-symbol (symbol-value ',symbol))) + (unwind-protect (progn , at body) + (setf (symbol-value ',symbol) ,bound-symbol)))))) + (defun build-menu (command-tables &rest commands) "Create a command table inheriting commands from `command-tables', which must be a list of command table --- /project/mcclim/cvsroot/mcclim/ESA/dead-keys.lisp 2008/04/29 16:27:42 NONE +++ /project/mcclim/cvsroot/mcclim/ESA/dead-keys.lisp 2008/04/29 16:27:42 1.1 ;;; -*- Mode: Lisp; Package: ESA -*- ;;; (c) copyright 2008 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. ;;; Elegantly handle dead keys by collapsing into single characters. (in-package :esa) (defvar *dead-key-table* (make-hash-table :test 'equal) "A hash table mapping keyboard event names and characters to either a similar hash table or characters.") (defun set-dead-key-combination (character gestures table) "Set `gestures' to result in `character' in the hash table `table' (see `*dead-key-table*' for the format of the hash table)." (assert (not (null gestures))) (if (null (rest gestures)) ;; Just add it directly to this table. (setf (gethash (first gestures) table) character) ;; Ensure that the subtable exists. (let ((new-table (setf (gethash (first gestures) table) (gethash (first gestures) table (make-hash-table :test 'equal))))) (set-dead-key-combination character (rest gestures) new-table)))) (defmacro define-dead-key-combination (character (&rest gestures)) "Define a dead key combination that results in `character' when `gestures' (either characters or key names) is entered." (assert (>= (length gestures) 2)) `(set-dead-key-combination ,character ',gestures *dead-key-table*)) (define-dead-key-combination (code-char 193) (:dead-acute #\a)) (define-dead-key-combination (code-char 201) (:dead-acute #\e)) (define-dead-key-combination (code-char 205) (:dead-acute #\i)) (define-dead-key-combination (code-char 211) (:dead-acute #\o)) (define-dead-key-combination (code-char 218) (:dead-acute #\u)) (define-dead-key-combination (code-char 221) (:dead-acute #\y)) (define-dead-key-combination (code-char 225) (:dead-acute #\a)) (define-dead-key-combination (code-char 233) (:dead-acute #\e)) (define-dead-key-combination (code-char 237) (:dead-acute #\i)) (define-dead-key-combination (code-char 243) (:dead-acute #\o)) (define-dead-key-combination (code-char 250) (:dead-acute #\u)) (define-dead-key-combination (code-char 253) (:dead-acute #\y)) (define-dead-key-combination (code-char 199) (:dead-acute #\c)) (define-dead-key-combination (code-char 231) (:dead-acute #\c)) (define-dead-key-combination (code-char 215) (:dead-acute #\x)) (define-dead-key-combination (code-char 247) (:dead-acute #\-)) (define-dead-key-combination (code-char 222) (:dead-acute #\t)) (define-dead-key-combination (code-char 254) (:dead-acute #\t)) (define-dead-key-combination (code-char 223) (:dead-acute #\s)) (define-dead-key-combination (code-char 39) (:dead-acute #\space)) (define-dead-key-combination (code-char 197) (:dead-acute :dead-acute #\a)) (define-dead-key-combination (code-char 229) (:dead-acute :dead-acute #\a)) (define-dead-key-combination (code-char 192) (:dead-grave #\a)) (define-dead-key-combination (code-char 200) (:dead-grave #\e)) (define-dead-key-combination (code-char 204) (:dead-grave #\i)) (define-dead-key-combination (code-char 210) (:dead-grave #\o)) (define-dead-key-combination (code-char 217) (:dead-grave #\u)) (define-dead-key-combination (code-char 224) (:dead-grave #\a)) (define-dead-key-combination (code-char 232) (:dead-grave #\e)) (define-dead-key-combination (code-char 236) (:dead-grave #\i)) (define-dead-key-combination (code-char 242) (:dead-grave #\o)) (define-dead-key-combination (code-char 249) (:dead-grave #\u)) (define-dead-key-combination (code-char 96) (:dead-grave #\space)) (define-dead-key-combination (code-char 196) (:dead-diaeresis #\a)) (define-dead-key-combination (code-char 203) (:dead-diaeresis #\e)) (define-dead-key-combination (code-char 207) (:dead-diaeresis #\i)) (define-dead-key-combination (code-char 214) (:dead-diaeresis #\o)) (define-dead-key-combination (code-char 220) (:dead-diaeresis #\u)) (define-dead-key-combination (code-char 228) (:dead-diaeresis #\a)) (define-dead-key-combination (code-char 235) (:dead-diaeresis #\e)) (define-dead-key-combination (code-char 239) (:dead-diaeresis #\i)) (define-dead-key-combination (code-char 246) (:dead-diaeresis #\o)) (define-dead-key-combination (code-char 252) (:dead-diaeresis #\u)) (define-dead-key-combination (code-char 255) (:dead-diaeresis #\y)) (define-dead-key-combination (code-char 34) (:dead-diaeresis #\space)) (define-dead-key-combination (code-char 195) (:dead-tilde #\a)) (define-dead-key-combination (code-char 209) (:dead-tilde #\n)) (define-dead-key-combination (code-char 227) (:dead-tilde #\a)) (define-dead-key-combination (code-char 241) (:dead-tilde #\n)) (define-dead-key-combination (code-char 198) (:dead-tilde #\e)) (define-dead-key-combination (code-char 230) (:dead-tilde #\e)) (define-dead-key-combination (code-char 208) (:dead-tilde #\d)) (define-dead-key-combination (code-char 240) (:dead-tilde #\d)) (define-dead-key-combination (code-char 245) (:dead-tilde #\o)) (define-dead-key-combination (code-char 126) (:dead-tilde #\space)) (define-dead-key-combination (code-char 194) (:dead-circumflex #\a)) (define-dead-key-combination (code-char 202) (:dead-circumflex #\e)) (define-dead-key-combination (code-char 206) (:dead-circumflex #\i)) (define-dead-key-combination (code-char 212) (:dead-circumflex #\o)) (define-dead-key-combination (code-char 219) (:dead-circumflex #\u)) (define-dead-key-combination (code-char 226) (:dead-circumflex #\a)) (define-dead-key-combination (code-char 234) (:dead-circumflex #\e)) (define-dead-key-combination (code-char 238) (:dead-circumflex #\i)) (define-dead-key-combination (code-char 244) (:dead-circumflex #\o)) (define-dead-key-combination (code-char 251) (:dead-circumflex #\u)) (define-dead-key-combination (code-char 94) (:dead-circumflex #\space)) (defmacro handling-dead-keys ((gesture) &body body) "Accumulate dead keys and subsequent characters. `Gesture' should be a symbol bound to either a gesture or an input event. When it has been determined that a sequence of `gesture's either does or doesn't result in a full gesture, `body' will be evaluated with `gesture' bound to that gesture." (with-gensyms (state-sym) `(retaining-value (,state-sym *dead-key-table*) (flet ((invoke-body (,gesture) (setf ,state-sym *dead-key-table*) , at body)) (if (typep gesture '(or keyboard-event character)) (let ((value (gethash (if (characterp ,gesture) ,gesture (keyboard-event-key-name ,gesture)) ,state-sym))) (etypecase value (null (if (eq ,state-sym *dead-key-table*) (invoke-body ,gesture) (setf ,state-sym *dead-key-table*))) (character (invoke-body value)) (hash-table (setf ,state-sym value)))) (invoke-body ,gesture)))))) From thenriksen at common-lisp.net Tue Apr 29 16:27:43 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 29 Apr 2008 12:27:43 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080429162743.29D5753191@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv10422 Modified Files: mcclim.asd Log Message: Improved dead key handling for ESAs (well, some of them). Now uses a clever state machine to merge dead keys, rather than the old command table hack. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/04/23 12:05:30 1.80 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/04/29 16:27:42 1.81 @@ -259,7 +259,8 @@ :components ((:file "packages") (:file "utils" :depends-on ("packages")) (:file "colors" :depends-on ("packages")) - (:file "esa" :depends-on ("colors" "packages" "utils")) + (:file "dead-keys" :depends-on ("utils")) + (:file "esa" :depends-on ("colors" "packages" "utils" "dead-keys")) (:file "esa-buffer" :depends-on ("packages" "esa")) (:file "esa-io" :depends-on ("packages" "esa" "esa-buffer")) (:file "esa-command-parser" :depends-on ("packages" "esa")))))) @@ -319,7 +320,6 @@ :pathname #p"Persistent/persistent-undo.lisp" :depends-on ("packages" "buffer" "persistent-buffer" "undo")) (:file "misc-commands" :depends-on ("basic-commands")) - (:file "unicode-commands" :depends-on ("core" "drei-clim")) (:file "search-commands" :depends-on ("core" "targets" "drei-clim")) (:file "lr-syntax" :depends-on ("fundamental-syntax" "core" "drawing-options")) (:file "lisp-syntax" :depends-on ("lr-syntax" "motion" "core")) From thenriksen at common-lisp.net Tue Apr 29 20:52:04 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 29 Apr 2008 16:52:04 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080429205204.E839A392C0@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv30176/Drei Modified Files: drei-clim.lisp Log Message: Actually fix dead keys. Turns out I got confused in my own maze of command processors. Still needs a proper design decision about what to do wrt. abort gestures (C-g). --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/02/16 21:33:40 1.42 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/04/29 20:52:02 1.43 @@ -296,11 +296,12 @@ (*abort-gestures* *esa-abort-gestures*) (*standard-input* drei)) (accepting-from-user (drei) - (handler-case (process-gesture drei gesture) - (unbound-gesture-sequence (c) - (display-message "~A is unbound" (gesture-name (gestures c)))) - (abort-gesture () - (display-message "Aborted"))) + (handling-dead-keys (gesture) + (handler-case (process-gesture drei gesture) + (unbound-gesture-sequence (c) + (display-message "~A is unbound" (gesture-name (gestures c)))) + (abort-gesture () + (display-message "Aborted")))) (display-drei drei :redisplay-minibuffer t) (when (modified-p (view drei)) (when (gadget-value-changed-callback drei) From thenriksen at common-lisp.net Tue Apr 29 20:52:05 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 29 Apr 2008 16:52:05 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20080429205205.4FEA83A047@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv30176/ESA Modified Files: dead-keys.lisp esa.lisp packages.lisp Log Message: Actually fix dead keys. Turns out I got confused in my own maze of command processors. Still needs a proper design decision about what to do wrt. abort gestures (C-g). --- /project/mcclim/cvsroot/mcclim/ESA/dead-keys.lisp 2008/04/29 16:27:42 1.1 +++ /project/mcclim/cvsroot/mcclim/ESA/dead-keys.lisp 2008/04/29 20:52:04 1.2 @@ -113,18 +113,26 @@ (define-dead-key-combination (code-char 251) (:dead-circumflex #\u)) (define-dead-key-combination (code-char 94) (:dead-circumflex #\space)) -(defmacro handling-dead-keys ((gesture) &body body) +(defmacro handling-dead-keys ((gesture &optional restart) &body body) "Accumulate dead keys and subsequent characters. `Gesture' should be a symbol bound to either a gesture or an input event. When it has been determined that a sequence of `gesture's either does or doesn't result in a full gesture, `body' will be -evaluated with `gesture' bound to that gesture." +evaluated with `gesture' bound to that gesture. If `restart' is +true, start over with a new accumulation. If an `abort-gesture' +condition is signalled in `body', the accumulation will be +cleared." (with-gensyms (state-sym) `(retaining-value (,state-sym *dead-key-table*) + (when ,restart + (setf ,state-sym *dead-key-table*)) (flet ((invoke-body (,gesture) (setf ,state-sym *dead-key-table*) - , at body)) - (if (typep gesture '(or keyboard-event character)) + (handler-case (progn , at body) + (abort-gesture (c) + (setf ,state-sym *dead-key-table*) + (signal c))))) + (if (typep ,gesture '(or keyboard-event character)) (let ((value (gethash (if (characterp ,gesture) ,gesture (keyboard-event-key-name ,gesture)) --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/04/29 16:27:42 1.20 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/04/29 20:52:05 1.21 @@ -550,7 +550,7 @@ (end-command-loop (overriding-handler command-processor))) (setf (overriding-handler (super-command-processor command-processor)) nil)) -(defmethod process-gesture ((command-processor command-loop-command-processor) gesture) +(defmethod process-gesture :around ((command-processor command-loop-command-processor) gesture) (handling-dead-keys (gesture) (cond ((find gesture *abort-gestures* :test #'gesture-matches-gesture-name-p) @@ -562,10 +562,7 @@ (end-command-loop command-processor) (signal c)))) (t - (setf (accumulated-gestures command-processor) - (nconc (accumulated-gestures command-processor) - (list gesture))) - (process-gestures command-processor) + (call-next-method) (when (funcall (end-condition command-processor)) (funcall (end-function command-processor)) (end-command-loop command-processor)))))) @@ -777,11 +774,12 @@ ;; well, something that either requires this kind of repeated ;; rescanning of accumulated input data or some yet-unimplemented ;; complex state retaining mechanism (such as continuations). - (loop - (setf *current-gesture* - (esa-read-gesture :command-processor command-processor)) - (unless (process-gesture command-processor *current-gesture*) - (return)))) + (loop for gesture = (esa-read-gesture :command-processor command-processor) + for first = t then nil + do (handling-dead-keys (gesture first) + (let ((*current-gesture* gesture)) + (unless (process-gesture command-processor *current-gesture*) + (return)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/04/29 16:27:42 1.18 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/04/29 20:52:05 1.19 @@ -89,6 +89,7 @@ #:find-applicable-command-table #:esa-command-parser #:esa-partial-command-parser + #:handling-dead-keys #:gesture-matches-gesture-name-p #:meta-digit #:proper-gesture-p From thenriksen at common-lisp.net Wed Apr 30 21:27:46 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 30 Apr 2008 17:27:46 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080430212746.D862459082@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv7853/Drei Modified Files: drei-clim.lisp input-editor.lisp Log Message: Really Fix dead keys. Now integrated with the gesture reading machinery in standard-extended-input-steeam, so it can be circumvented if you really don't want it by handling events manually. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/04/29 20:52:02 1.43 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/04/30 21:27:46 1.44 @@ -392,6 +392,10 @@ (declare (ignore args)) (display-drei-area drei)) +(defmethod execute-drei-command ((drei drei-area) command) + (let ((*standard-input* (or *minibuffer* *standard-input*))) + (call-next-method))) + ;;; Implementation of the displayed-output-record and region protocol ;;; for Drei areas. The redisplay-related stuff is in ;;; drei-redisplay.lisp. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/08 13:24:48 1.46 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/04/30 21:27:46 1.47 @@ -565,32 +565,37 @@ (old-buffer-contents (buffer-sequence buffer 0 (size buffer)))) (with-bound-drei-special-variables (drei :prompt "M-x ") (update-drei-buffer stream) - ;; 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 last object before - ;; input-position, so the user will not be able to - ;; delete arguments prompts or other things. - (drei-core:with-narrowed-buffer (drei - (loop for index from - (1- (input-position stream)) above 0 - when (typep (buffer-object buffer index) - 'noise-string) - return (1+ index) - finally (return 0)) - 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)) + ;; Since we have an unread gesture in the encapsulated stream, + ;; we should use that for further input. *standard-input* is + ;; bound back to the minibuffer (maybe) when an actual command + ;; is executed. + (let ((*standard-input* (encapsulating-stream-stream stream))) + ;; 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 last object before + ;; input-position, so the user will not be able to + ;; delete arguments prompts or other things. + (drei-core:with-narrowed-buffer (drei + (loop for index from + (1- (input-position stream)) above 0 + when (typep (buffer-object buffer index) + 'noise-string) + return (1+ index) + finally (return 0)) + 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))) (let ((first-mismatch (buffer-array-mismatch buffer old-buffer-contents))) (display-drei drei :redisplay-minibuffer t) (cond ((null first-mismatch) From thenriksen at common-lisp.net Wed Apr 30 21:27:48 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 30 Apr 2008 17:27:48 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20080430212748.2C5DF5D088@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv7853/ESA Modified Files: esa.lisp Removed Files: dead-keys.lisp Log Message: Really Fix dead keys. Now integrated with the gesture reading machinery in standard-extended-input-steeam, so it can be circumvented if you really don't want it by handling events manually. --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/04/29 20:52:05 1.21 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/04/30 21:27:46 1.22 @@ -551,21 +551,20 @@ (setf (overriding-handler (super-command-processor command-processor)) nil)) (defmethod process-gesture :around ((command-processor command-loop-command-processor) gesture) - (handling-dead-keys (gesture) - (cond ((find gesture *abort-gestures* - :test #'gesture-matches-gesture-name-p) - ;; It is to be expected that the abort function might signal - ;; `abort-gesture'. If that happens, we must end the command - ;; loop, but ONLY if this is signalled. - (handler-case (funcall (abort-function command-processor)) - (abort-gesture (c) - (end-command-loop command-processor) - (signal c)))) - (t - (call-next-method) - (when (funcall (end-condition command-processor)) - (funcall (end-function command-processor)) - (end-command-loop command-processor)))))) + (cond ((find gesture *abort-gestures* + :test #'gesture-matches-gesture-name-p) + ;; It is to be expected that the abort function might signal + ;; `abort-gesture'. If that happens, we must end the command + ;; loop, but ONLY if this is signalled. + (handler-case (funcall (abort-function command-processor)) + (abort-gesture (c) + (end-command-loop command-processor) + (signal c)))) + (t + (call-next-method) + (when (funcall (end-condition command-processor)) + (funcall (end-function command-processor)) + (end-command-loop command-processor))))) (defun process-gestures-for-numeric-argument (gestures) "Processes a list of gestures for numeric argument @@ -774,12 +773,9 @@ ;; well, something that either requires this kind of repeated ;; rescanning of accumulated input data or some yet-unimplemented ;; complex state retaining mechanism (such as continuations). - (loop for gesture = (esa-read-gesture :command-processor command-processor) - for first = t then nil - do (handling-dead-keys (gesture first) - (let ((*current-gesture* gesture)) - (unless (process-gesture command-processor *current-gesture*) - (return)))))) + (loop (let ((*current-gesture* (esa-read-gesture :command-processor command-processor))) + (unless (process-gesture command-processor *current-gesture*) + (return))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From thenriksen at common-lisp.net Wed Apr 30 21:27:48 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 30 Apr 2008 17:27:48 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080430212748.6F6EA5D088@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv7853 Modified Files: mcclim.asd stream-input.lisp Added Files: dead-keys.lisp Log Message: Really Fix dead keys. Now integrated with the gesture reading machinery in standard-extended-input-steeam, so it can be circumvented if you really don't want it by handling events manually. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/04/29 16:27:42 1.81 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/04/30 21:27:48 1.82 @@ -164,6 +164,7 @@ "stream-output" "recording")) (:file "stream-input" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "input" "ports" "sheets" "events" "encapsulate" "transforms" "utils")) + (:file "dead-keys" :depends-on ("stream-input")) (:file "text-selection" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "X11-colors" "medium" "output" "transforms" "sheets" "stream-output" "ports" "recording" "regions" @@ -259,8 +260,7 @@ :components ((:file "packages") (:file "utils" :depends-on ("packages")) (:file "colors" :depends-on ("packages")) - (:file "dead-keys" :depends-on ("utils")) - (:file "esa" :depends-on ("colors" "packages" "utils" "dead-keys")) + (:file "esa" :depends-on ("colors" "packages" "utils")) (:file "esa-buffer" :depends-on ("packages" "esa")) (:file "esa-io" :depends-on ("packages" "esa" "esa-buffer")) (:file "esa-command-parser" :depends-on ("packages" "esa")))))) --- /project/mcclim/cvsroot/mcclim/stream-input.lisp 2007/02/07 12:44:17 1.51 +++ /project/mcclim/cvsroot/mcclim/stream-input.lisp 2008/04/30 21:27:48 1.52 @@ -122,9 +122,77 @@ do (handle-event (event-sheet event) event)) nil) +(defvar *dead-key-table* (make-hash-table :test 'equal) + "A hash table mapping keyboard event names and characters to +either a similar hash table or characters.") + +(defclass dead-key-merging-mixin () + ((state :initform *dead-key-table*) + (last-deadie-gesture) ; For avoiding name clash with standard-extended-input-stream + (last-state)) + (:documentation "A mixin class for extended input streams that +takes care of handling dead keys. This is done by still passing +every gesture on, but accenting the final one as per the dead +keys read.")) + +(defmethod stream-read-gesture :around + ((stream dead-key-merging-mixin) + &key timeout peek-p + (input-wait-test *input-wait-test*) + (input-wait-handler *input-wait-handler*) + (pointer-button-press-handler + *pointer-button-press-handler*)) + (with-slots (state last-deadie-gesture last-state) stream + (handler-case + (loop with start-time = (get-internal-real-time) + with end-time = start-time + for gesture = (call-next-method stream + :timeout (when timeout + (- timeout (/ (- end-time start-time) + internal-time-units-per-second))) + :peek-p peek-p + :input-wait-test input-wait-test + :input-wait-handler input-wait-handler + :pointer-button-press-handler + pointer-button-press-handler) + do (setf end-time (get-internal-real-time) + last-deadie-gesture gesture + last-state state) + do (if (typep gesture '(or keyboard-event character)) + (let ((value (gethash (if (characterp gesture) + gesture + (keyboard-event-key-name gesture)) + state))) + (etypecase value + (null + (cond ((eq state *dead-key-table*) + (return gesture)) + ((or (and (typep gesture 'keyboard-event) + (keyboard-event-character gesture)) + (characterp gesture)) + (setf state *dead-key-table*)))) + (character + (setf state *dead-key-table*) + (return value)) + (hash-table + (return (setf state value))))) + (return gesture))) + ;; Policy decision: an abort cancels the current composition. + (abort-gesture (c) + (setf state *dead-key-table*) + (signal c))))) + +(defmethod stream-unread-gesture :around ((stream dead-key-merging-mixin) gesture) + (if (typep gesture '(or keyboard-event character)) + (with-slots (state last-deadie-gesture last-state) stream + (setf state last-state) + (call-next-method stream last-deadie-gesture)) + (call-next-method))) + (defclass standard-extended-input-stream (extended-input-stream ;; FIXME: is this still needed? - standard-sheet-input-mixin) + standard-sheet-input-mixin + dead-key-merging-mixin) ((pointer) (cursor :initarg :text-cursor) (last-gesture :accessor last-gesture :initform nil --- /project/mcclim/cvsroot/mcclim/dead-keys.lisp 2008/04/30 21:27:48 NONE +++ /project/mcclim/cvsroot/mcclim/dead-keys.lisp 2008/04/30 21:27:48 1.1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2008 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. ;;; Define various dead keys - perhaps this should be more ;;; backend-agnostic? Bah... (in-package :clim-internals) (defun set-dead-key-combination (character gestures table) "Set `gestures' to result in `character' in the hash table `table' (see `*dead-key-table*' for the format of the hash table)." (assert (not (null gestures))) (if (null (rest gestures)) ;; Just add it directly to this table. (setf (gethash (first gestures) table) character) ;; Ensure that the subtable exists. (let ((new-table (setf (gethash (first gestures) table) (gethash (first gestures) table (make-hash-table :test 'equal))))) (set-dead-key-combination character (rest gestures) new-table)))) (defmacro define-dead-key-combination (character (&rest gestures)) "Define a dead key combination that results in `character' when `gestures' (either characters or key names) is entered." (assert (>= (length gestures) 2)) `(set-dead-key-combination ,character ',gestures *dead-key-table*)) (define-dead-key-combination (code-char 193) (:dead-acute #\a)) (define-dead-key-combination (code-char 201) (:dead-acute #\e)) (define-dead-key-combination (code-char 205) (:dead-acute #\i)) (define-dead-key-combination (code-char 211) (:dead-acute #\o)) (define-dead-key-combination (code-char 218) (:dead-acute #\u)) (define-dead-key-combination (code-char 221) (:dead-acute #\y)) (define-dead-key-combination (code-char 225) (:dead-acute #\a)) (define-dead-key-combination (code-char 233) (:dead-acute #\e)) (define-dead-key-combination (code-char 237) (:dead-acute #\i)) (define-dead-key-combination (code-char 243) (:dead-acute #\o)) (define-dead-key-combination (code-char 250) (:dead-acute #\u)) (define-dead-key-combination (code-char 253) (:dead-acute #\y)) (define-dead-key-combination (code-char 199) (:dead-acute #\c)) (define-dead-key-combination (code-char 231) (:dead-acute #\c)) (define-dead-key-combination (code-char 215) (:dead-acute #\x)) (define-dead-key-combination (code-char 247) (:dead-acute #\-)) (define-dead-key-combination (code-char 222) (:dead-acute #\t)) (define-dead-key-combination (code-char 254) (:dead-acute #\t)) (define-dead-key-combination (code-char 223) (:dead-acute #\s)) (define-dead-key-combination (code-char 39) (:dead-acute #\space)) (define-dead-key-combination (code-char 197) (:dead-acute :dead-acute #\a)) (define-dead-key-combination (code-char 229) (:dead-acute :dead-acute #\a)) (define-dead-key-combination (code-char 192) (:dead-grave #\a)) (define-dead-key-combination (code-char 200) (:dead-grave #\e)) (define-dead-key-combination (code-char 204) (:dead-grave #\i)) (define-dead-key-combination (code-char 210) (:dead-grave #\o)) (define-dead-key-combination (code-char 217) (:dead-grave #\u)) (define-dead-key-combination (code-char 224) (:dead-grave #\a)) (define-dead-key-combination (code-char 232) (:dead-grave #\e)) (define-dead-key-combination (code-char 236) (:dead-grave #\i)) (define-dead-key-combination (code-char 242) (:dead-grave #\o)) (define-dead-key-combination (code-char 249) (:dead-grave #\u)) (define-dead-key-combination (code-char 96) (:dead-grave #\space)) (define-dead-key-combination (code-char 96) (:dead-grave :dead-grave)) (define-dead-key-combination (code-char 196) (:dead-diaeresis #\a)) (define-dead-key-combination (code-char 203) (:dead-diaeresis #\e)) (define-dead-key-combination (code-char 207) (:dead-diaeresis #\i)) (define-dead-key-combination (code-char 214) (:dead-diaeresis #\o)) (define-dead-key-combination (code-char 220) (:dead-diaeresis #\u)) (define-dead-key-combination (code-char 228) (:dead-diaeresis #\a)) (define-dead-key-combination (code-char 235) (:dead-diaeresis #\e)) (define-dead-key-combination (code-char 239) (:dead-diaeresis #\i)) (define-dead-key-combination (code-char 246) (:dead-diaeresis #\o)) (define-dead-key-combination (code-char 252) (:dead-diaeresis #\u)) (define-dead-key-combination (code-char 255) (:dead-diaeresis #\y)) (define-dead-key-combination (code-char 168) (:dead-diaeresis #\space)) (define-dead-key-combination (code-char 168) (:dead-diaeresis :dead-diaeresis)) (define-dead-key-combination (code-char 195) (:dead-tilde #\a)) (define-dead-key-combination (code-char 209) (:dead-tilde #\n)) (define-dead-key-combination (code-char 227) (:dead-tilde #\a)) (define-dead-key-combination (code-char 241) (:dead-tilde #\n)) (define-dead-key-combination (code-char 198) (:dead-tilde #\e)) (define-dead-key-combination (code-char 230) (:dead-tilde #\e)) (define-dead-key-combination (code-char 208) (:dead-tilde #\d)) (define-dead-key-combination (code-char 240) (:dead-tilde #\d)) (define-dead-key-combination (code-char 245) (:dead-tilde #\o)) (define-dead-key-combination (code-char 126) (:dead-tilde #\space)) (define-dead-key-combination (code-char 126) (:dead-tilde :dead-tilde)) (define-dead-key-combination (code-char 194) (:dead-circumflex #\a)) (define-dead-key-combination (code-char 202) (:dead-circumflex #\e)) (define-dead-key-combination (code-char 206) (:dead-circumflex #\i)) (define-dead-key-combination (code-char 212) (:dead-circumflex #\o)) (define-dead-key-combination (code-char 219) (:dead-circumflex #\u)) (define-dead-key-combination (code-char 226) (:dead-circumflex #\a)) (define-dead-key-combination (code-char 234) (:dead-circumflex #\e)) (define-dead-key-combination (code-char 238) (:dead-circumflex #\i)) (define-dead-key-combination (code-char 244) (:dead-circumflex #\o)) (define-dead-key-combination (code-char 251) (:dead-circumflex #\u)) (define-dead-key-combination (code-char 94) (:dead-circumflex #\space)) (define-dead-key-combination (code-char 94) (:dead-circumflex :dead-circumflex))