mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

[mcclim-cvs] CVS mcclim/Apps/Listener
by ahefner 07 Jun '09

07 Jun '09

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory cl-net:/tmp/cvs-serv32228 Modified Files: dev-commands.lisp listener.lisp package.lisp Added Files: asdf.lisp Log Message: ASDF commands for the listener. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2009/04/14 07:36:42 1.66 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2009/06/07 08:47:39 1.67 @@ -24,7 +24,9 @@ (define-command-table application-commands) (define-command-table lisp-dev-commands :inherit-from nil) ;; Translators live here -(define-command-table lisp-commands :inherit-from (lisp-dev-commands)) +(define-command-table lisp-commands + :inherit-from (lisp-dev-commands) + :menu (("ASDF" :menu asdf-commands))) (define-command-table show-commands :inherit-from (lisp-dev-commands)) @@ -34,7 +36,6 @@ (define-command-table directory-stack-commands) - ;;; Presentation types (define-presentation-type specializer () :inherit-from 'expression) @@ -1241,11 +1242,6 @@ "Load" (format nil "Load ~A" pathname))) -(defmethod mime-type-to-command ((mime-type text/x-lisp-system) pathname) - (values `(com-load-file ,pathname) - "Load System" - (format nil "Load System ~A" pathname))) - ;; I've taken to doing translator documentation exactly opposite of how the CLIM ;; spec seems to intend. The spec says that the pointer-documentation should be ;; short and quickly computed, and the documentation should be longer and more --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2008/12/07 20:24:44 1.44 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2009/06/07 08:47:40 1.45 @@ -96,11 +96,15 @@ :display-time :command-loop :end-of-line-action :allow))) (:top-level (default-frame-top-level :prompt 'print-listener-prompt)) (:command-table (listener - :inherit-from (application-commands lisp-commands filesystem-commands show-commands) - :menu (("Application" :menu application-commands) - ("Lisp" :menu lisp-commands) - ("Filesystem" :menu filesystem-commands) - ("Show" :menu show-commands)))) + :inherit-from (application-commands + lisp-commands + asdf-commands + filesystem-commands + show-commands) + :menu (("Listener" :menu application-commands) + ("Lisp" :menu lisp-commands) + ("Filesystem" :menu filesystem-commands) + ("Show" :menu show-commands)))) (:disabled-commands com-pop-directory com-drop-directory com-swap-directory) (:menu-bar t) (:layouts (default --- /project/mcclim/cvsroot/mcclim/Apps/Listener/package.lisp 2008/04/26 21:19:59 1.4 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/package.lisp 2009/06/07 08:47:40 1.5 @@ -8,7 +8,7 @@ (in-package :clim-listener) (eval-when (:load-toplevel) -; (format t "~&~%!@#%^!@#!@ ... ~A~%~%" *load-truename*) - (defparameter *icon-path* (merge-pathnames - #P"icons/" - (load-time-value (or #.*compile-file-pathname* *load-pathname*))))) + (defparameter *icon-path* + (merge-pathnames + #P"icons/" + (load-time-value (or #.*compile-file-pathname* *load-pathname*))))) --- /project/mcclim/cvsroot/mcclim/Apps/Listener/asdf.lisp 2009/06/07 08:47:43 NONE +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/asdf.lisp 2009/06/07 08:47:43 1.1 ;;; This is a lisp listener. ;;; (C) Copyright 2009 by Andy Hefner (ahefner(a)gmail.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-listener) ;;;; CLIM defintions for interacting with ASDF (define-command-table asdf-commands :inherit-from nil) (define-presentation-type asdf-system ()) (define-presentation-type asdf-system-definition () :inherit-from 'pathname) (defclass asdf-attribute-view (textual-view) ((ignorable-attributes :reader ignorable-attributes :initform nil :initarg :ignore) (note-unloaded :reader note-unloaded :initform nil :initarg :note-unloaded) (default-label :reader default-attr-label :initform "" :initarg :default))) (defmethod ignorable-attributes (view) nil) (defmethod note-unloaded (view) nil) (defmethod default-attr-label (view) "") (defun asdf-loaded-systems () "Retrieve a list of loaded systems from ASDF" (let (systems) (maphash (lambda (name foo.system) (declare (ignore name)) (push (cdr foo.system) systems)) asdf::*defined-systems*) systems)) (defun asdf-get-central-registry () asdf::*central-registry*) (defun asdf-registry-system-files () "Retrieve the list of unique pathnames contained within the ASDF registry folders" (remove-duplicates (remove-if-not #'pathname-name (apply #'concatenate 'list (mapcar (lambda (form) (list-directory (merge-pathnames (eval form) #p"*.asd"))) (asdf-get-central-registry)))) :test #'equal)) (defun asdf-system-name (system) (slot-value system 'asdf::name)) (defun asdf-operation-pretty-name (op) (case op (asdf:compile-op "compiled") (asdf:load-op "loaded") (:unloaded "unloaded") (otherwise (prin1-to-string op)))) (defun asdf-system-history (system) (let (history) (maphash (lambda (operation time) (declare (ignore time)) (push operation history)) (slot-value system 'asdf::operation-times)) (nreverse history))) (define-presentation-method presentation-typep (object (type asdf-system)) (typep object 'asdf:system)) (define-presentation-method present (object (type asdf-system) stream (view textual-view) &key acceptably) (if acceptably (princ (asdf-system-name object) stream ) (let* ((history (asdf-system-history object)) (loaded-p (find 'asdf:load-op history)) (eff-history (set-difference history (ignorable-attributes view)))) (when (and (note-unloaded view) (not loaded-p)) (push :unloaded eff-history)) (format stream "~A~A" (asdf-system-name object) (if (null eff-history) (default-attr-label view) (format nil " (~{~a~^, ~})" (mapcar 'asdf-operation-pretty-name eff-history))))))) (define-presentation-method accept ((type asdf-system) stream (view textual-view) &key) (multiple-value-bind (object success) (completing-from-suggestions (stream) (dolist (system (asdf-loaded-systems)) (suggest (asdf-system-name system) system))) (if success object (simple-parse-error "Unknown system")))) (define-command (com-list-systems :name "List Systems" :command-table asdf-commands :menu t) () (format-items (asdf-loaded-systems) :printer (lambda (item stream) (present item 'asdf-system :stream stream :view (make-instance 'asdf-attribute-view :note-unloaded t :ignore '(asdf:compile-op asdf:load-op)))) :presentation-type 'asdf-system)) (define-command (com-show-available-systems :name "Show System Files" :command-table asdf-commands :menu t) () (format-items (asdf-registry-system-files) :presentation-type 'asdf-system-definition)) (define-command (com-operate-on-system :name "Operate On System" :command-table asdf-commands :menu t) ((system '(type-or-string asdf-system) :prompt "system") (operation '(member asdf::compile-op asdf::load-op) :default 'asdf::load-op :prompt "operation")) (asdf:oos operation system)) (define-command (com-load-system :name "Load System" :command-table asdf-commands :menu t) ((system '(type-or-string asdf-system) :prompt "system")) (asdf:oos 'asdf:compile-op system) (asdf:oos 'asdf:load-op system)) (defmethod mime-type-to-command ((mime-type text/x-lisp-system) pathname) (values `(com-load-system ,pathname) "Load System" (format nil "Load System ~A" pathname)))

1 0

[mcclim-cvs] CVS mcclim/Extensions/Bitmap-formats
by rstrandh 07 Jun '09

07 Jun '09

Update of /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats In directory cl-net:/tmp/cvs-serv2246 Modified Files: jpeg.lisp Log Message: Patch from Cyrus Harmon to make it possible to read grayscale jpeg files. --- /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats/jpeg.lisp 2008/04/14 16:46:30 1.1 +++ /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats/jpeg.lisp 2009/06/07 06:56:49 1.2 @@ -23,22 +23,32 @@ (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)))) + (multiple-value-bind (rgb height width ncomp) + (jpeg:decode-image pathname) + (let* ((array (make-array (list height width) + :element-type '(unsigned-byte 32)))) + (case ncomp + (3 + (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))))))))) + (1 + (dotimes (x width) + (dotimes (y height) + (let ((gray (aref rgb (+ x (* y width))))) + (setf (aref array y x) + (dpb gray (byte 8 0) + (dpb gray (byte 8 8) + (dpb gray (byte 8 16) + (dpb (- 255 0) (byte 8 24) 0)))))))))) + array))) (define-bitmap-file-reader :jpg (pathname) (read-bitmap-file pathname :format :jpeg))

1 0

[mcclim-cvs] CVS mcclim
by ahefner 03 Jun '09

03 Jun '09

Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv24386 Modified Files: medium.lisp Log Message: Change *default-text-style* to a sans-serif face. --- /project/mcclim/cvsroot/mcclim/medium.lisp 2008/01/21 01:26:42 1.64 +++ /project/mcclim/cvsroot/mcclim/medium.lisp 2009/06/03 20:38:15 1.65 @@ -158,7 +158,7 @@ (equal (text-style-face style1) (text-style-face style2)) (eql (text-style-size style1) (text-style-size style2)))) -(defconstant *default-text-style* (make-text-style :fix :roman :normal)) +(defconstant *default-text-style* (make-text-style :sans-serif :roman :normal)) (defconstant *undefined-text-style* *default-text-style*) (defconstant *smaller-sizes* '(:huge :very-large :large :normal

1 0

[mcclim-cvs] CVS mcclim
by ahefner 03 Jun '09

03 Jun '09

Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv19226 Modified Files: panes.lisp regions.lisp text-selection.lisp Log Message: Handle selection-notify-events in the text gadget and input editor. For communicating with the input editor, signal and handle a selection-notify condition from the lower level event handler (I can't think of a better approach to communicating across the layers). Disable the old default of pasting by synthesizing keypress events, but make it available via paste-as-keypress-mixin. --- /project/mcclim/cvsroot/mcclim/panes.lisp 2008/12/19 08:58:14 1.194 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2009/06/03 20:33:16 1.195 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.194 2008/12/19 08:58:14 ahefner Exp $ +;;; $Id: panes.lisp,v 1.195 2009/06/03 20:33:16 ahefner Exp $ (in-package :clim-internals) @@ -2597,7 +2597,7 @@ (setf (cursor-position cursor) (values 0 0)))) (scroll-extent pane 0 0) (change-space-requirements pane :width 0 :height 0)) - + (defmethod window-refresh ((pane clim-stream-pane)) (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane) @@ -2684,9 +2684,9 @@ ;;; INTERACTOR PANES -(defclass interactor-pane (clim-stream-pane - cut-and-paste-mixin - mouse-wheel-scroll-mixin) +(defclass interactor-pane (cut-and-paste-mixin + mouse-wheel-scroll-mixin + clim-stream-pane) () (:default-initargs :display-time nil :end-of-line-action :scroll @@ -2714,9 +2714,9 @@ ;;; APPLICATION PANES -(defclass application-pane (clim-stream-pane - cut-and-paste-mixin - mouse-wheel-scroll-mixin) +(defclass application-pane (cut-and-paste-mixin + mouse-wheel-scroll-mixin + clim-stream-pane) () (:default-initargs :display-time :command-loop :scroll-bars t)) @@ -2838,9 +2838,9 @@ ;;; 29.4.5 Creating a Standalone CLIM Window -(defclass window-stream (clim-stream-pane - cut-and-paste-mixin - mouse-wheel-scroll-mixin) +(defclass window-stream (cut-and-paste-mixin + mouse-wheel-scroll-mixin + clim-stream-pane) ()) (defmethod close ((stream window-stream) --- /project/mcclim/cvsroot/mcclim/regions.lisp 2008/01/23 22:37:08 1.38 +++ /project/mcclim/cvsroot/mcclim/regions.lisp 2009/06/03 20:33:16 1.39 @@ -4,7 +4,7 @@ ;;; Created: 1998-12-02 19:26 ;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> ;;; License: LGPL (See file COPYING for details). -;;; $Id: regions.lisp,v 1.38 2008/01/23 22:37:08 thenriksen Exp $ +;;; $Id: regions.lisp,v 1.39 2009/06/03 20:33:16 ahefner Exp $ ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 1998,1999,2001 by Gilbert Baumann ;;; (c) copyright 2001 by Arnaud Rouanet (rouanet(a)emi.u-bordeaux.fr) @@ -89,6 +89,9 @@ (defvar +everywhere+ (make-instance 'everywhere-region)) (defvar +nowhere+ (make-instance 'nowhere-region)) +(defmethod bounding-rectangle* ((x nowhere-region)) + (values 0 0 0 0)) + ;; 2.5.1.1 Region Predicates in CLIM (defgeneric region-equal (region1 region2)) --- /project/mcclim/cvsroot/mcclim/text-selection.lisp 2005/11/28 13:04:55 1.7 +++ /project/mcclim/cvsroot/mcclim/text-selection.lisp 2009/06/03 20:33:16 1.8 @@ -60,7 +60,7 @@ "Background ink to use for marked stuff.") -;;;; Text Selection "Protocol" +;;;; Text Selection Protocol (defgeneric release-selection (port &optional time) (:documentation "Relinquish ownership of the selection.")) @@ -153,7 +153,12 @@ (point-1-y :initform nil) (point-2-x :initform nil) (point-2-y :initform nil) - (dragging-p :initform nil) )) + (dragging-p :initform nil))) + +(defclass paste-as-keypress-mixin () + () + (:documentation "Implements the old McCLIM behavior of pasting via a + sequence of key press events. You couldn't possibly want this.")) (defmethod handle-repaint :around ((pane cut-and-paste-mixin) region) (with-slots (markings) pane @@ -174,29 +179,23 @@ ((medium-background medium) *marked-background*)) (call-next-method pane R)))))))))) - -(defmethod bounding-rectangle* ((x (eql +nowhere+))) - (values 0 0 0 0)) - - -(defmethod dispatch-event :around ((pane cut-and-paste-mixin #|extended-output-stream|#) +(defmethod dispatch-event :around ((pane cut-and-paste-mixin) (event pointer-button-press-event)) (if (eql (event-modifier-state event) +shift-key+) (eos/shift-click pane event) (call-next-method))) -(defmethod dispatch-event :around ((pane cut-and-paste-mixin #|extended-output-stream|#) +(defmethod dispatch-event :around ((pane cut-and-paste-mixin) (event pointer-button-release-event)) (if (eql (event-modifier-state event) +shift-key+) (eos/shift-release pane event) (call-next-method))) -(defmethod dispatch-event :around ((pane cut-and-paste-mixin #|extended-output-stream|#) +(defmethod dispatch-event :around ((pane cut-and-paste-mixin) (event pointer-motion-event)) (with-slots (point-1-x dragging-p) pane (if (and (eql (event-modifier-state event) +shift-key+)) - (when dragging-p - (eos/shift-drag pane event)) + (when dragging-p (eos/shift-drag pane event)) (call-next-method)))) @@ -283,7 +282,7 @@ (rotatef bx1 bx2)) (let ((*lines* nil) (*all-lines* nil)) - (map-over-text record ;(stream-output-history stream) + (map-over-text record (lambda (x y string ts record full-record) (let ((q (assoc y *lines*))) (unless q @@ -311,7 +310,6 @@ (let ((start-i 0) (start-record (fifth (cadar *lines*))) (end-i 0) - ; end-record (end-record (fifth (cadar (last *lines*))))) (loop for chunk in (cdr (first *lines*)) do @@ -323,8 +321,10 @@ (setf start-i i start-record record))))) - ;; Finally in the last line find the index farthest to the left which still is greater than bx2. - ;; Or put differently: Search from the left and while we are still in bounds maintain end-i and end-record. + ;; Finally in the last line find the index farthest to the left + ;; which still is greater than bx2. Or put differently: Search + ;; from the left and while we are still in bounds maintain end-i + ;; and end-record. (loop for chunk in (cdr (car (last *lines*))) do (destructuring-bind (x y string ts record full-record) chunk (declare (ignorable x y string ts record full-record)) @@ -375,21 +375,24 @@ ;;;; Selections Events -(defmethod dispatch-event :around ((pane cut-and-paste-mixin #|extended-output-stream|#) +(defmethod dispatch-event :around ((pane cut-and-paste-mixin) (event selection-clear-event)) (pane-clear-markings pane (event-timestamp event))) -(defmethod dispatch-event :around ((pane cut-and-paste-mixin #|extended-output-stream|#) +(defmethod dispatch-event :around ((pane cut-and-paste-mixin) (event selection-request-event)) (send-selection (port pane) event (fetch-selection pane))) +(define-condition selection-notify () + ((event :reader event-of :initarg :event))) +(defmethod handle-event ((pane cut-and-paste-mixin) + (event selection-notify-event)) + (signal 'selection-notify :event event)) -(defmethod dispatch-event :around ((pane cut-and-paste-mixin #|extended-output-stream|#) +(defmethod dispatch-event :around ((pane paste-as-keypress-mixin) (event selection-notify-event)) (let ((matter (get-selection-from-event (port pane) event))) - #+NIL - (format *trace-output* "Got ~S.~%" matter) (loop for c across matter do (dispatch-event pane (make-instance 'key-press-event

1 0

[mcclim-cvs] CVS mcclim/Drei
by ahefner 03 Jun '09

03 Jun '09

Update of /project/mcclim/cvsroot/mcclim/Drei In directory cl-net:/tmp/cvs-serv19226/Drei Modified Files: drei-clim.lisp input-editor.lisp Log Message: Handle selection-notify-events in the text gadget and input editor. For communicating with the input editor, signal and handle a selection-notify condition from the lower level event handler (I can't think of a better approach to communicating across the layers). Disable the old default of pasting by synthesizing keypress events, but make it available via paste-as-keypress-mixin. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/10/23 20:47:57 1.46 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2009/06/03 20:33:16 1.47 @@ -292,6 +292,15 @@ gesture is, for example, one that is not simply a click on a modifier key.")) +(defun propagate-changed-value (drei) + (when (modified-p (view drei)) + (when (gadget-value-changed-callback drei) + (value-changed-callback drei + (gadget-client drei) + (gadget-id drei) + (gadget-value drei))) + (setf (modified-p (view drei)) nil))) + (defmethod handle-gesture ((drei drei-gadget-pane) gesture) (let ((*command-processor* drei) (*abort-gestures* *esa-abort-gestures*) @@ -303,13 +312,7 @@ (abort-gesture () (display-message "Aborted"))) (display-drei drei :redisplay-minibuffer t) - (when (modified-p (view drei)) - (when (gadget-value-changed-callback drei) - (value-changed-callback drei - (gadget-client drei) - (gadget-id drei) - (gadget-value drei))) - (setf (modified-p (view drei)) nil))))) + (propagate-changed-value drei)))) ;;; This is the method that functions as the entry point for all Drei ;;; gadget logic. @@ -321,6 +324,16 @@ (with-bound-drei-special-variables (gadget :prompt (format nil "~A " (gesture-name gesture))) (handle-gesture gadget gesture))))))) +(defmethod handle-event ((gadget drei-gadget-pane) + (event clim-backend:selection-notify-event)) + ;; Cargo-culted from above: + (unless (and (currently-processing-p gadget) (directly-processing-p gadget)) + (letf (((currently-processing-p gadget) t)) + (insert-sequence (point (view gadget)) + (clim-backend:get-selection-from-event (port gadget) event)) + (display-drei gadget :redisplay-minibuffer t) + (propagate-changed-value gadget)))) + (defmethod handle-event :before ((gadget drei-gadget-pane) (event pointer-button-press-event)) (let ((previous (stream-set-input-focus gadget))) --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/06/29 23:36:27 1.49 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2009/06/03 20:33:16 1.50 @@ -586,6 +586,13 @@ finally (return 0)) t t) (handler-case (process-gestures-or-command drei) + (climi::selection-notify (c) + (let* ((event (climi::event-of c)) + (sheet (event-sheet event)) + (port (port sheet))) + (when (eq *standard-input* sheet) + (insert-sequence (point (view drei)) + (clim-backend:get-selection-from-event port event))))) (unbound-gesture-sequence (c) (display-message "~A is unbound" (gesture-name (gestures c)))) (abort-gesture (c)

1 0

[mcclim-cvs] CVS mcclim
by ahefner 03 Jun '09

03 Jun '09

Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv4027 Modified Files: pixmap.lisp Log Message: Define sheet-direct-mirror on pixmaps (patch from Evgeny M. Zubok) --- /project/mcclim/cvsroot/mcclim/pixmap.lisp 2003/03/21 21:36:59 1.7 +++ /project/mcclim/cvsroot/mcclim/pixmap.lisp 2009/06/03 04:07:48 1.8 @@ -88,3 +88,6 @@ (transform-region (sheet-device-transformation pixmap) (medium-clipping-region (pixmap-medium pixmap))))) + +(defmethod sheet-direct-mirror ((pixmap mirrored-pixmap)) + (port-lookup-mirror (port pixmap) pixmap))

1 0

[mcclim-cvs] CVS mcclim/Drei
by rstrandh 31 May '09

31 May '09

Update of /project/mcclim/cvsroot/mcclim/Drei In directory cl-net:/tmp/cvs-serv28006 Modified Files: views.lisp Log Message: I added a new kind of undo record named CHANGE-RECORD, created by (setf buffer-object). This fixes a problem that was reported by Nikodemus Siivola where fill-paragraph did not record any undo information, because it was using (setf buffer-object) as opposed to insert or delete. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/05/15 13:51:40 1.46 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2009/05/31 07:28:18 1.47 @@ -187,6 +187,16 @@ `delete-record' containing a mark is created and added to the undo tree.")) +(defclass change-record (simple-undo-record) + ((objects :initarg :objects + :documentation "The sequence of objects that are to +replace the records that are currently in the buffer at the +offset whenever flip-undo-record is called on an instance of +change-record")) + (:documentation "Whenever objects are modified, a +`change-record' containing a mark is created and added to the +undo tree.")) + (defclass compound-record (drei-undo-record) ((records :initform '() :initarg :records @@ -201,7 +211,11 @@ (defmethod print-object ((object insert-record) stream) (with-slots (offset objects) object - (format stream "[offset: ~a objects: ~a]" offset objects))) + (format stream "[offset: ~a inserted objects: ~a]" offset objects))) + +(defmethod print-object ((object change-record) stream) + (with-slots (offset objects) object + (format stream "[offset: ~a changed objects: ~a]" offset objects))) (defmethod print-object ((object compound-record) stream) (with-slots (records) object @@ -227,6 +241,14 @@ :objects (buffer-sequence buffer offset (+ offset n))) (undo-accumulate buffer)))) +(defmethod (setf buffer-object) :before (new-object (buffer undo-mixin) offset) + (unless (performing-undo buffer) + (push (make-instance 'change-record + :buffer buffer + :offset offset + :objects (buffer-sequence buffer offset (1+ offset))) + (undo-accumulate buffer)))) + (defmacro with-undo ((get-buffers-exp) &body body) "This macro executes the forms of `body', registering changes made to the list of buffers retrieved by evaluating @@ -273,6 +295,11 @@ :objects (buffer-sequence buffer offset (+ offset length))) (delete-buffer-range buffer offset length))) +(defmethod flip-undo-record ((record change-record)) + (with-slots (buffer offset objects) record + (loop for i from 0 below (length objects) + do (rotatef (aref objects i) (buffer-object buffer (+ i offset)))))) + (defmethod flip-undo-record ((record compound-record)) (with-slots (records) record (mapc #'flip-undo-record records)

1 0

[mcclim-cvs] CVS mcclim/Backends/CLX
by crhodes 20 Apr '09

20 Apr '09

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory cl-net:/tmp/cvs-serv14292/Backends/CLX Modified Files: medium.lisp port.lisp Log Message: Try to use iso-10646 fonts where appropriate; don't leave the choice of encoding to the server. Patch from Juliusz Chroboczek. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2008/11/09 19:55:38 1.89 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2009/04/20 10:21:00 1.90 @@ -945,8 +945,8 @@ ;;; is by no means a proper solution to the problem of ;;; internationalization, because fonts tend not to have a complete ;;; coverage of the entirety of the Unicode space, even assuming that -;;; the underlying lisp supports it (as of 2006-02-06, only the case -;;; for SBCL and CLISP); instead, the translation function is meant to +;;; the underlying lisp supports it (this is the case at least for SBCL, +;;; CLISP and CCL); instead, the translation function is meant to ;;; handle font sets by requesting the X server change fonts in the ;;; middle of rendering strings. However, the below stands a chance ;;; of working when using ISO-8859-1-encoded fonts, and will tend to --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2009/04/20 10:14:27 1.139 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2009/04/20 10:21:00 1.140 @@ -980,8 +980,6 @@ :italic-bold "bold-i")) )) (defun open-font (display font-name) - - (let ((fonts (xlib:list-font-names display font-name :max-fonts 1))) (if fonts (xlib:open-font display (first fonts)) @@ -1013,13 +1011,20 @@ (size-number (if (numberp size) (round size) (or (getf *clx-text-sizes* size) - (getf *clx-text-sizes* :normal)))) - (font-name (format nil "-~A-~A-*-*-~D-*-*-*-*-*-*-*" - family-name face-name size-number))) - (setf (gethash text-style table) - (cons font-name - (open-font (clx-port-display port) font-name))) - font-name)))))) + (getf *clx-text-sizes* :normal))))) + (flet ((try (encoding) + (let* ((fn (format nil "-~A-~A-*-*-~D-*-*-*-*-*-~A" + family-name face-name size-number + encoding)) + (font (open-font (clx-port-display port) fn))) + (and font (cons fn font))))) + (let ((fn-font + (or + (and (> char-code-limit #x100) (try "iso10646-1")) + (try "iso8859-1") + (try "*-*")))) + (setf (gethash text-style table) fn-font) + (car fn-font))))))))) (defmethod (setf text-style-mapping) (font-name (port clx-port) (text-style text-style)

1 0

[mcclim-cvs] CVS mcclim/Backends/CLX
by crhodes 20 Apr '09

20 Apr '09

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory cl-net:/tmp/cvs-serv13113/Backends/CLX Modified Files: port.lisp Log Message: Cooperate better with X11 window managers. Patch from Juliusz Chroboczek. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2009/04/20 09:56:45 1.138 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2009/04/20 10:14:27 1.139 @@ -458,7 +458,14 @@ (setf (xlib:wm-hints window) (xlib:make-wm-hints :input :on)) (setf (xlib:wm-name window) (frame-pretty-name frame)) (setf (xlib:wm-icon-name window) (frame-pretty-name frame)) - (setf (xlib:wm-protocols window) `(:wm_delete_window))))) + (xlib:set-wm-class + window + (string-downcase (frame-name frame)) + (string-capitalize (string-downcase (frame-name frame)))) + (setf (xlib:wm-protocols window) `(:wm_delete_window)) + (xlib:change-property window + :WM_CLIENT_LEADER (list (xlib:window-id window)) + :WINDOW 32)))) (defmethod realize-mirror ((port clx-port) (sheet unmanaged-top-level-sheet-pane)) (realize-mirror-aux port sheet

1 0

[mcclim-cvs] CVS mcclim/Backends/CLX
by crhodes 20 Apr '09

20 Apr '09

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory cl-net:/tmp/cvs-serv10178/Backends/CLX Modified Files: port.lisp Log Message: Minimize redraws in the CLX backend. Patch from Juliusz Chroboczek. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2009/02/18 17:34:44 1.137 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2009/04/20 09:56:45 1.138 @@ -363,6 +363,7 @@ (override-redirect :off) (map t) (backing-store :not-useful) + (save-under :off) (event-mask `(:exposure :key-press :key-release :button-press :button-release @@ -412,6 +413,7 @@ :border border :override-redirect override-redirect :backing-store backing-store + :save-under save-under :gravity :north-west ;; Evil Hack -- but helps enormously (Has anybody ;; a good idea how to sneak the concept of @@ -461,6 +463,7 @@ (defmethod realize-mirror ((port clx-port) (sheet unmanaged-top-level-sheet-pane)) (realize-mirror-aux port sheet :override-redirect :on + :save-under :on :map nil :event-mask '(:structure-notify)))

1 0

← Newer
1
2
3
4
5
6
7
...
170
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs