mcclim-cvs January 2008

mcclim-cvs@common-lisp.net

7 participants
255 discussions

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 12 Jan '08

12 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv6351/Drei Modified Files: lisp-syntax.lisp Log Message: Changed the semantics for expression movement (now not identical to Emacs). --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/12 10:52:24 1.65 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/12 11:37:21 1.66 @@ -2038,9 +2038,8 @@ (not (= (offset mark) (end-offset potential-form)))) (typecase potential-form (reader-conditional-form - (setf (offset mark) (end-offset - (or (first-form (children potential-form)) - potential-form)))) + (setf (offset mark) (or (start-offset (first-form (children potential-form))) + (end-offset potential-form)))) (t (setf (offset mark) (end-offset potential-form))))))) (defmethod forward-delete-expression (mark (syntax lisp-syntax) &optional (count 1)

1 0

[mcclim-cvs] CVS mcclim/Drei/Tests
by thenriksen 12 Jan '08

12 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv6351/Drei/Tests Modified Files: lisp-syntax-tests.lisp Log Message: Changed the semantics for expression movement (now not identical to Emacs). --- /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2008/01/10 11:03:39 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2008/01/12 11:37:20 1.13 @@ -825,9 +825,9 @@ (51 0 (11 28 7) "(defun list (&rest elements) (append elements nil))") - (nil nil (5 18 9) + (nil nil (5 18 2) "#+nil (list 1 2 3)") - (nil nil (0 5 nil) + (nil nil (0 2 nil) "#+nil (list 1 2 3)")) (motion-fun-one-test (list lisp-syntax)

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 12 Jan '08

12 Jan '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv334 Modified Files: package.lisp views.lisp Log Message: Added stub classes and constants for gadget views. Programs using these will at least compile now, though they may not work. Hopefully, this batch of stub views will be like a sad puppy in the corner, sooner or later guilting someone into finishing the implementation. --- /project/mcclim/cvsroot/mcclim/package.lisp 2007/11/19 20:28:44 1.63 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2008/01/12 11:04:05 1.64 @@ -873,6 +873,8 @@ #:line-style-unit ;generic function #:linep ;predicate #:list-pane ;class + #:list-pane-view ;class + #:+list-pane-view+ ;constant #:lookup-keystroke-command-item ;function #:lookup-keystroke-item ;function #:make-3-point-transformation ;function @@ -1039,6 +1041,8 @@ #:open-stream-p ;generic function #:open-window-stream ;function #:option-pane ;class + #:option-pane-view ;class + #:+option-pane-view+ ;constant #:or ;presentation type #:oriented-gadget-mixin ;class #:outlined-pane ;pane @@ -1167,6 +1171,8 @@ #:propagate-output-record-changes-p ;generic function #:push-button ;class #:push-button-pane ;class + #:push-button-view ;class + #:+push-button-view+ ;constant #:push-button-show-as-default ;generic function #:queue-event ;generic function #:queue-repaint ;generic function @@ -1175,6 +1181,8 @@ #:radio-box-current-selection ;generic function #:radio-box-pane ;class #:radio-box-selections ;generic function + #:radio-box-view ;class + #:+radio-box-view+ ;class #:raise-frame ;generic function #:raise-mirror ;generic function #:raise-sheet ;generic function @@ -1313,6 +1321,8 @@ #:slider ;class #:slider-drag-callback ;generic function #:slider-pane ;class + #:slider-view ;slider-view + #:+slider-view+ ;constant #:space-requirement ;class #:space-requirement+ ;function #:space-requirement+* ;function @@ -1464,6 +1474,8 @@ #:text-displayed-output-record-string ;generic function #:text-editor ;class #:text-editor-pane ;class + #:text-editor-view ;class + #:+text-editor-view+ ;constant #:text-field ;class #:text-field-pane ;class #:text-field-view ;class (Franz User's Guide) @@ -1489,6 +1501,8 @@ #:toggle-button ;class #:toggle-button-indicator-type ;generic function #:toggle-button-pane ;class + #:toggle-button-view ;class + #:+toggle-button-view+ ;constant #:token-or-type ;presentation type abbrev #:tracking-pointer ;macro #:transform-distance ;generic function --- /project/mcclim/cvsroot/mcclim/views.lisp 2006/03/10 21:58:13 1.7 +++ /project/mcclim/cvsroot/mcclim/views.lisp 2008/01/12 11:04:05 1.8 @@ -42,11 +42,35 @@ (defclass pointer-documentation-view (textual-view) ()) -;;; Views described in the Franz User manual... +;;; Views described in the Franz User manual (CLIM 2.2)... + +(defclass toggle-button-view (gadget-view) + ()) + +(defclass push-button-view (gadget-view) + ()) + +(defclass radio-box-view (gadget-view) + ()) + +(defclass check-box-view (gadget-view) + ()) + +(defclass slider-view (gadget-view) + ()) (defclass text-field-view (gadget-dialog-view) ((width :accessor width :initarg :width :initform nil))) +(defclass text-editor-view (gadget-view) + ()) + +(defclass list-pane-view (gadget-view) + ()) + +(defclass option-pane-view (gadget-view) + ()) + (defparameter +textual-view+ (make-instance 'textual-view)) (defparameter +textual-menu-view+ (make-instance 'textual-menu-view)) @@ -59,11 +83,24 @@ (defparameter +gadget-dialog-view+ (make-instance 'gadget-dialog-view)) -(defparameter +pointer-documentation-view+ - (make-instance 'pointer-documentation-view)) +(defparameter +pointer-documentation-view+ (make-instance 'pointer-documentation-view)) + +(defparameter +toggle-button-view+ (make-instance 'toggle-button-view)) + +(defparameter +push-button-view+ (make-instance 'push-button-view)) + +(defparameter +radio-box-view+ (make-instance 'radio-box-view)) + +(defparameter +slider-view+ (make-instance 'slider-view)) (defparameter +text-field-view+ (make-instance 'text-field-view)) +(defparameter +text-editor-view+ (make-instance 'text-editor-view)) + +(defparameter +list-pane-view+ (make-instance 'list-pane-view)) + +(defparameter +option-pane-view+ (make-instance 'option-pane-view)) + (defmethod stream-default-view (stream) (declare (ignore stream)) +textual-view+)

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 12 Jan '08

12 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv29151/Drei Modified Files: lisp-syntax.lisp Log Message: Make Drei forward-expression handle #+foo whatever properly through the magic of special cases. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/11 07:52:03 1.64 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/12 10:52:24 1.65 @@ -2036,7 +2036,12 @@ (form-around syntax (offset mark))))) (when (and (not (null potential-form)) (not (= (offset mark) (end-offset potential-form)))) - (setf (offset mark) (end-offset potential-form))))) + (typecase potential-form + (reader-conditional-form + (setf (offset mark) (end-offset + (or (first-form (children potential-form)) + potential-form)))) + (t (setf (offset mark) (end-offset potential-form))))))) (defmethod forward-delete-expression (mark (syntax lisp-syntax) &optional (count 1) (limit-action #'error-limit-action))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 11 Jan '08

11 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv22161/Drei Modified Files: lisp-syntax-swine.lisp lisp-syntax.lisp Log Message: Never, ever, try to do lazy parsing in Lisp syntax, the potential for disaster is just too great. Changed all calls to update-parse to make sure the entire parse tree is up to date. Later specializations can be considered optimisation. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/01/10 11:17:00 1.13 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/01/11 07:52:03 1.14 @@ -566,7 +566,7 @@ provided are, in order: the form, the forms operator, the indices to the operand at `offset', or the indices to an operand entered at that position if none is there, and the operands in the form." - (update-parse syntax 0 offset) + (update-parse syntax) (let* ((form ;; Find a form with a valid (fboundp) operator. (let ((immediate-form --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/10 11:17:00 1.63 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/11 07:52:03 1.64 @@ -1161,7 +1161,7 @@ package can be found at all, or the otherwise found packages are invalid, return the value of `*package*'." (as-offsets ((offset mark-or-offset)) - (update-parse syntax 0 offset) + (update-parse syntax) (let* ((designator (rest (find offset (package-list syntax) :key #'first :test #'>=)))) @@ -1183,7 +1183,7 @@ form can be found, return the package specified in the attribute list. If no such package is specified, return \"CLIM-USER\"." (as-offsets ((offset mark-or-offset)) - (update-parse syntax 0 offset) + (update-parse syntax) (flet ((normalise (designator) (typecase designator (symbol @@ -1421,7 +1421,7 @@ "Return the list form that `mark-or-offset' is inside, or NIL if no such form exists." (as-offsets ((offset mark-or-offset)) - (update-parse syntax 0 offset) + (update-parse syntax) (let ((form-around (form-around syntax offset))) (when form-around (if (and (form-list-p form-around) @@ -1559,7 +1559,7 @@ (defun in-type-p (syntax mark-or-offset type) (as-offsets ((offset mark-or-offset)) - (update-parse syntax 0 offset) + (update-parse syntax) (with-slots (stack-top) syntax (if (or (null (start-offset stack-top)) (> offset (end-offset stack-top)) @@ -1626,7 +1626,7 @@ (:method ((syntax lisp-syntax) (form form) (offset integer)) nil) (:method :before ((syntax lisp-syntax) (form form) (offset integer)) - (update-parse syntax 0 offset))) + (update-parse syntax))) (defgeneric at-end-of-form-p (syntax form offset) (:documentation "Return true if `offset' is at the end of the @@ -1634,7 +1634,7 @@ (:method ((syntax lisp-syntax) (form form) (offset integer)) nil) (:method :before ((syntax lisp-syntax) (form form) (offset integer)) - (update-parse syntax 0 offset))) + (update-parse syntax))) (defmethod at-beginning-of-form-p ((syntax lisp-syntax) (form list-form) (offset integer)) @@ -1666,7 +1666,7 @@ is defined by what type of form is at `mark-or-offset', but for a list form, it would be right after the opening parenthesis." (as-offsets ((offset mark-or-offset)) - (update-parse syntax 0 offset) + (update-parse syntax) (let ((form-around (form-around syntax offset))) (when form-around (labels ((recurse (form) @@ -1681,7 +1681,7 @@ is defined by what type of form is at `mark-or-offset', but for a list form, it would be right before the closing parenthesis." (as-offsets ((offset mark-or-offset)) - (update-parse syntax 0 offset) + (update-parse syntax) (let ((form-around (form-around syntax offset))) (when form-around (labels ((recurse (form) @@ -1696,7 +1696,7 @@ defined as the earliest point the contents could be entered, for example right after the opening parenthesis for a list." (as-offsets ((offset mark-or-offset)) - (update-parse syntax 0 offset) + (update-parse syntax) (let ((form-around (form-around syntax offset))) (when (form-list-p form-around) (at-beginning-of-form-p syntax form-around offset))))) @@ -1707,7 +1707,7 @@ latest point the contents could be entered, for example right before the closing parenthesis for a list." (as-offsets ((offset mark-or-offset)) - (update-parse syntax 0 offset) + (update-parse syntax) (let ((form-around (form-around syntax offset))) (when (form-list-p form-around) (at-end-of-form-p syntax (form-around syntax offset) offset))))) @@ -1717,7 +1717,7 @@ beginning of a string form, false otherwise. \"Beginning\" is right after the opening double-quote." (as-offsets ((offset mark-or-offset)) - (update-parse syntax 0 offset) + (update-parse syntax) (let ((form-around (form-around syntax offset))) (when (form-string-p form-around) (at-beginning-of-form-p syntax form-around offset))))) @@ -1727,7 +1727,7 @@ a list-like form, false otherwise. \"End\" is right before the ending double-quote." (as-offsets ((offset mark-or-offset)) - (update-parse syntax 0 offset) + (update-parse syntax) (let ((form-around (form-around syntax offset))) (when (form-string-p form-around) (at-end-of-form-p syntax form-around offset))))) @@ -1882,7 +1882,7 @@ ;;; exploit the parse (defun form-before-in-children (syntax children offset) - (update-parse syntax 0 offset) + (update-parse syntax) (loop for (first . rest) on children if (formp first) do @@ -1910,7 +1910,7 @@ "Offset past buffer end") (assert (>= offset 0) nil "Offset before buffer start") - (update-parse syntax 0 offset) + (update-parse syntax) (or (gethash offset (form-before-cache syntax)) (setf (gethash offset (form-before-cache syntax)) (with-slots (stack-top) syntax @@ -1920,7 +1920,7 @@ (form-before-in-children syntax (children stack-top) offset)))))) (defun form-after-in-children (syntax children offset) - (update-parse syntax 0 offset) + (update-parse syntax) (loop for child in children if (formp child) do (cond ((< (start-offset child) offset (end-offset child)) @@ -1943,7 +1943,7 @@ "Offset past buffer end") (assert (>= offset 0) nil "Offset before buffer start") - (update-parse syntax 0 offset) + (update-parse syntax) (or (gethash offset (form-after-cache syntax)) (setf (gethash offset (form-after-cache syntax)) (with-slots (stack-top) syntax @@ -1953,7 +1953,7 @@ (form-after-in-children syntax (children stack-top) offset)))))) (defun form-around-in-children (syntax children offset) - (update-parse syntax 0 offset) + (update-parse syntax) (loop for child in children if (formp child) do (cond ((or (<= (start-offset child) offset (end-offset child)) @@ -1972,7 +1972,7 @@ "Offset past buffer end") (assert (>= offset 0) nil "Offset before buffer start") - (update-parse syntax 0 offset) + (update-parse syntax) (or (gethash offset (form-around-cache syntax)) (setf (gethash offset (form-around-cache syntax)) (with-slots (stack-top) syntax

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 11 Jan '08

11 Jan '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv4196 Modified Files: NEWS Log Message: Added mention of MCCLIM-IMAGES to NEWS. --- /project/mcclim/cvsroot/mcclim/NEWS 2007/11/21 22:33:50 1.27 +++ /project/mcclim/cvsroot/mcclim/NEWS 2008/01/11 06:01:38 1.28 @@ -4,6 +4,8 @@ ** 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. * Changes in mcclim-0.9.5 relative to 0.9.4: ** Installation: the systems clim-listener, clim-examples,

1 0

[mcclim-cvs] CVS mcclim/Extensions/Images
by thenriksen 11 Jan '08

11 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Extensions/Images In directory clnet:/tmp/cvs-serv2033/Extensions/Images Modified Files: gif.lisp image-viewer.lisp images.lisp jpeg.lisp package.lisp xpm.lisp Log Message: Changed MCCLIM-IMAGES:LOAD-IMAGE to create an instance of an image class containing size information. Fixex JPEG reading. --- /project/mcclim/cvsroot/mcclim/Extensions/Images/gif.lisp 2008/01/09 10:20:23 1.3 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/gif.lisp 2008/01/11 06:00:06 1.4 @@ -23,10 +23,11 @@ (define-image-reader "gif" (image-pathname &key) (let* ((data-stream (skippy:load-data-stream image-pathname)) (first-image (aref (skippy:images data-stream) 0)) - (pattern-array (make-array (list (skippy:height first-image) - (skippy:width first-image)))) + (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) + 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+ @@ -35,7 +36,8 @@ (skippy:color-rgb (skippy:color-table-entry color-table i)) (make-rgb-color (/ r 255) (/ g 255) (/ b 255)))) 'vector))) - (dotimes (y (array-dimension pattern-array 0)) - (dotimes (x (array-dimension pattern-array 1)) + (dotimes (y image-height) + (dotimes (x image-width) (setf (aref pattern-array y x) (skippy:pixel-ref first-image x y)))) - (make-pattern pattern-array designs))) + (make-image (make-pattern pattern-array designs) + image-height image-width))) --- /project/mcclim/cvsroot/mcclim/Extensions/Images/image-viewer.lisp 2008/01/09 19:27:39 1.1 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/image-viewer.lisp 2008/01/11 06:00:06 1.2 @@ -45,6 +45,10 @@ ;; 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) - (draw-design pane (gadget-value pane)))) + ;; Try to ensure there is room for the new image. + (change-space-requirements pane + :height (image-height (gadget-value pane)) + :width (image-width (gadget-value pane))) + ;; Draw the new one, if there is one. + (draw-image pane (gadget-value pane)))) --- /project/mcclim/cvsroot/mcclim/Extensions/Images/images.lisp 2008/01/06 08:36:57 1.1 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/images.lisp 2008/01/11 06:00:06 1.2 @@ -27,7 +27,7 @@ file to be read, and any keyword arguments provided by the user.") -(defun image-format-supported (format) +(defun image-format-supported-p (format) "Return true if `format' is supported by `load-image'." (not (null (gethash format *image-readers*)))) @@ -49,18 +49,42 @@ image format `format'." (error 'unsupported-image-format :image-format format)) +(defclass image () + ((%image-design :reader image-design + :initarg :image-design + :initform (error "A design must be provided for the image")) + (%width :reader image-width + :initarg :image-width + :initform (error "A width must be provided for the image")) + (%height :reader image-height + :initarg :image-height + :initform (error "A width must be provided for the image")))) + +(defun make-image (design height width) + "Make and return an instance of `image' with the specified +`design', `width' and `height'." + (make-instance 'image :image-design design + :image-height height + :image-width width)) + +(defun draw-image (stream image) + "Draw `image' to `stream'. `Stream' must be a sufficiently +powerful output stream (probably an `extended-output-stream')." + (draw-design stream (image-design image))) + (defun load-image (image-pathname &rest args &key) "Load an image from `image-pathname', with the format of the -image being the pathname-type of `image-pathname'. `Args' can be -any keyword-arguments, they will be passed on to the image reader -function for the relevant image format. If the image format is -not recognised, an error of type `unsupprted-image-format' will -be signalled." +image being the pathname-type of `image-pathname'. Returns an +instance of class `image'. `Args' can be any keyword-arguments, +they will be passed on to the image reader function for the +relevant image format. If the image format is not recognised, an +error of type `unsupprted-image-format' will be signalled." (apply #'load-image-of-format (pathname-type image-pathname) image-pathname args)) (defun load-image-of-format (format image-pathname &rest args &key) - "Load an image of format `format' from `image-pathname'. `Args' + "Load an image of format `format' from +`image-pathname'. Returns an instance of class `image'. `Args' can be any keyword-arguments, they will be passed on to the image reader function for `format'. If the image format is not recognised, an error of type `unsupprted-image-format' will be --- /project/mcclim/cvsroot/mcclim/Extensions/Images/jpeg.lisp 2008/01/07 12:54:02 1.2 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/jpeg.lisp 2008/01/11 06:00:06 1.3 @@ -31,15 +31,18 @@ (rgb-image (make-instance 'clim-internals::rgb-image :width width :height height :alphap nil :data rgb-image-data))) - (loop for y from (1- height) downto 0 do - (loop for x from (1- width) downto 0 do - (let ((grey (svref rgb (+ x (* y width))))) - (setf (aref rgb-image-data y x) - (dpb grey (byte 8 0) - (dpb grey (byte 8 8) - (dpb grey (byte 8 16) - (dpb (- 255 0) (byte 8 24) 0)))))))) - (clim-internals::make-rgb-image-design rgb-image))))) + (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 rgb-image-data y x) + (dpb red (byte 8 0) + (dpb green (byte 8 8) + (dpb blue (byte 8 16) + (dpb (- 255 0) (byte 8 24) 0)))))))) + (make-image (clim-internals::make-rgb-image-design rgb-image) + height width))))) (define-image-reader "jpg" (pathname) (load-image-of-format "jpeg" pathname)) --- /project/mcclim/cvsroot/mcclim/Extensions/Images/package.lisp 2008/01/09 19:27:39 1.2 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/package.lisp 2008/01/11 06:00:06 1.3 @@ -22,7 +22,9 @@ (defpackage :mcclim-images (:use :clim-lisp :clim) - (:export :export #:image-format-supported + (:export #:image-format-supported-p + #:image #:image-width #:image-height + #:draw-image #:load-image #:load-image-of-format #:unsupported-image-format #:image-format #:image-viewer #:image-viewer-pane)) --- /project/mcclim/cvsroot/mcclim/Extensions/Images/xpm.lisp 2008/01/06 08:36:57 1.1 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/xpm.lisp 2008/01/11 06:00:06 1.2 @@ -442,7 +442,10 @@ (define-image-reader "xpm" (pathname &key) (with-open-file (input pathname :element-type '(unsigned-byte 8)) - (xpm-parse-stream input))) + (let ((pattern (xpm-parse-stream input))) + (make-image pattern + (pattern-height pattern) + (pattern-width pattern))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

[mcclim-cvs] CVS mcclim/Apps/Listener
by thenriksen 11 Jan '08

11 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv2033/Apps/Listener Modified Files: dev-commands.lisp Log Message: Changed MCCLIM-IMAGES:LOAD-IMAGE to create an instance of an image class containing size information. Fixex JPEG reading. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/01/09 17:19:47 1.44 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/01/11 06:00:04 1.45 @@ -1424,7 +1424,7 @@ (if (probe-file image-pathname) (handler-case (with-room-for-graphics () - (draw-design *standard-output* (mcclim-images:load-image image-pathname))) + (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)))) (format t "No such file: ~A" image-pathname)))

1 0

[mcclim-cvs] CVS mcclim/Backends/CLX
by thenriksen 11 Jan '08

11 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv871/Backends/CLX Modified Files: medium.lisp Log Message: Draw images from the upper-left corner in the CLX backend. Strange sense of deja-vu. Didn't I fix this already? --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2008/01/06 01:37:06 1.83 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2008/01/11 05:55:52 1.84 @@ -1200,10 +1200,10 @@ :clip-x x :clip-y (- y height)) (xlib:copy-area pixmap gcontext 0 0 width height - da x (- y height)))) + da x y))) (t (xlib:copy-area pixmap gcontext 0 0 width height - da x (- y height))))))))) + da x y)))))))) (defmethod climi::medium-free-image-design ((medium clx-medium) (design climi::rgb-image-design))

1 0

[mcclim-cvs] CVS mcclim/ESA
by thenriksen 11 Jan '08

11 Jan '08

Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv24404/ESA Modified Files: packages.lisp utils.lisp Log Message: Changed the Drei/ESA modes-idea to work through metaclasses, enabling default modes. --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/07 22:01:59 1.10 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/11 02:44:14 1.11 @@ -23,7 +23,7 @@ ;;; Package definitions for ESA. (defpackage :esa-utils - (:use :clim-lisp) + (:use :clim-lisp :clim-mop) (:export #:with-gensyms #:once-only #:unlisted @@ -50,7 +50,7 @@ #:observer-notified #:notify-observers #:name-mixin #:name #:subscriptable-name-mixin #:subscripted-name #:subscript #:subscript-generator - #:mode #:modual-mixin + #:mode #:modual-class #:available-modes #:mode-directly-applicable-p #:mode-applicable-p #:mode-enabled-p @@ -58,7 +58,8 @@ #:nonapplicable-mode #:change-class-for-enabled-mode #:change-class-for-disabled-mode - #:enable-mode #:disable-mode)) + #:enable-mode #:disable-mode + #:add-default-modes #:remove-default-modes)) (defpackage :esa (:use :clim-lisp :clim :esa-utils) --- /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2008/01/09 18:21:44 1.8 +++ /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2008/01/11 02:44:14 1.9 @@ -364,23 +364,61 @@ () (:documentation "A superclass for all modes.")) -(defclass modual-mixin () - ((%original-class-name :accessor original-class-name - :documentation "The original name of the -class the `modual-mixin' is part of, the actual name will change -as modes are added and removed.")) - (:documentation "A mixin for objects supporting modes.")) +(defconstant +default-modes-plist-symbol+ 'modual-class-default-modes + "The symbol that is pushed onto the property list of the name +of a class to contain the list of default modes for the class.") + +(defun default-modes (modual-class) + "Return the list of default modes for `modual-class', which +must be a symbol and the name of a modual class. The modes are +returned as a list of conses, with the car of each cons being the +name of the mode as a symbol, and the cdr of each cons being a +list of initargs" + (getf (symbol-plist modual-class) +default-modes-plist-symbol+)) + +(defun (setf default-modes) (new-default-modes modual-class) + "Set the list of default modes for `modual-class', which must +be a symbol and the name of a modual class. The modes should be +given as a list of conses, with the car of each cons being the +name of the mode as a symbol, and the cdr of each cons being a +list of initargs" + (setf (getf (symbol-plist modual-class) +default-modes-plist-symbol+) + new-default-modes)) -(defmethod initialize-instance :after ((object modual-mixin) &rest initargs) +(defclass modual-class (standard-class) + () + (:documentation "A metaclass for defining classes supporting +changing of modes.")) + +(defmethod validate-superclass ((c1 modual-class) (c2 standard-class)) + t) + +(defmethod compute-slots ((c modual-class)) + (append (call-next-method) + (list (make-instance 'standard-effective-slot-definition + :name '%original-class-name + :allocation :instance + :documentation "The original name of the class +the `modual-mixin' is part of, the actual name will change as +modes are added and removed.")))) + +(defmethod make-instance ((class modual-class) &rest initargs) (declare (ignore initargs)) - (setf (original-class-name object) (class-name (class-of object)))) + (let ((instance (call-next-method))) + (setf (slot-value instance '%original-class-name) + (class-name class)) + (dolist (class (reverse (class-precedence-list class)) instance) + (when (symbolp (class-name class)) + (dolist (mode-and-initargs (default-modes (class-name class))) + (apply #'enable-mode instance (first mode-and-initargs) + (rest mode-and-initargs))))))) (defgeneric available-modes (modual) (:documentation "Return all available modes for `modual'. Not all of the modes may be applicable, use the `applicable-modes' function if you're only interested in these.") (:method-combination append) - (:method append ((modual modual-mixin)) + (:method append ((modual t)) '())) (defgeneric mode-directly-applicable-p (modual mode-name) @@ -391,7 +429,7 @@ \"opt-out\" where a mode can forcefully prevent another specific mode from being enabled. ") (:method-combination or) - (:method or ((modual modual-mixin) mode-name) + (:method or ((modual t) mode-name) nil)) (defgeneric mode-applicable-p (modual mode-name) @@ -402,21 +440,21 @@ a sort of \"opt-out\" where a mode can forcefully prevent another specific mode from being enabled. ") (:method-combination or) - (:method or ((modual modual-mixin) mode-name) + (:method or ((modual t) mode-name) (mode-directly-applicable-p modual mode-name))) (defgeneric enabled-modes (modual) (:documentation "Return a list of the names of the modes directly enabled for `modual'.") (:method-combination append) - (:method append ((modual modual-mixin)) + (:method append ((modual t)) '())) (defgeneric mode-enabled-p (modual mode-name) (:documentation "Return true if `mode-name' is enabled for `modual' or any modual \"sub-objects\"." ) (:method-combination or) - (:method or ((modual modual-mixin) mode-name) + (:method or ((modual t) mode-name) (member mode-name (enabled-modes modual) :test #'equal))) (define-condition nonapplicable-mode (error) @@ -445,7 +483,7 @@ `modual', using `initargs' as options for the mode. If the mode is already enabled, do nothing. If the mode is not applicable to `modual', signal an `nonapplicable-mode' error.") - (:method :around ((modual modual-mixin) mode-name &rest initargs) + (:method :around ((modual t) mode-name &rest initargs) (declare (ignore initargs)) (unless (mode-enabled-p modual mode-name) (call-next-method)))) @@ -454,7 +492,7 @@ (:documentation "Disable the mode of the name `mode-name' for `modual'. If a mode of the provided name is not enabled, do nothing.") - (:method :around ((modual modual-mixin) mode-name) + (:method :around ((modual t) mode-name) (when (mode-enabled-p modual mode-name) (call-next-method)))) @@ -478,7 +516,8 @@ ;; Avert thine eyes, thy of gentle spirit. (if (null modes) (find-class modual) - (eval `(defclass ,(gensym) (,modual ,@modes) ())))) + (eval `(defclass ,(gensym) (,modual ,@modes) () + (:metaclass modual-class))))) (defun find-class-implementing-modes (modual modes) "Find, possibly create, the class implementing `modual' (a @@ -498,7 +537,7 @@ "Change the class of `modual' so that it has a mode of name `mode-name', created with the provided `initargs'." (apply #'change-class modual (find-class-implementing-modes - (original-class-name modual) + (slot-value modual '%original-class-name) (cons mode-name (enabled-modes modual))) initargs)) @@ -506,15 +545,44 @@ "Change the class of `modual' so that it does not have a mode of name `mode-name'." (change-class modual (find-class-implementing-modes - (original-class-name modual) + (slot-value modual '%original-class-name) (remove mode-name (enabled-modes modual) :test #'equal)))) -(defmethod enable-mode ((modual modual-mixin) mode-name &rest initargs) +(defmethod enable-mode ((modual t) mode-name &rest initargs) (if (mode-directly-applicable-p modual mode-name) (apply #'change-class-for-enabled-mode modual mode-name initargs) (nonapplicable-mode modual mode-name))) -(defmethod disable-mode ((modual modual-mixin) mode-name) +(defmethod disable-mode ((modual t) mode-name) (when (mode-directly-applicable-p modual mode-name) (change-class-for-disabled-mode modual mode-name))) + +(defmacro add-default-modes (modual-class &body modes) + "Add `modes' to the list of default modes for +`modual-class'. Will not replace any already existing modes. The +elements in `modes' can either be a single symbol, the name of a +mode, or a cons of the name of a mode and a list of initargs for +the mode. In the former case, no initargs will be given. Please +do not use default modes as a programming tool, they should be +reserved for user-oriented functionality." + (dolist (mode modes) + (let ((mode-name (unlisted mode))) + (check-type mode-name symbol) + ;; Take care not to add the same mode twice, this is risky enough + ;; as it is. + (setf (default-modes modual-class) + (cons (listed mode) + (delete mode-name (default-modes modual-class) :key #'first)))))) + +(defmacro remove-default-modes (modual-class &body modes) + "Remove `modes' from the list of default modes for +`modual-class'. `Modes' must be a list of names of modes in the +form of symbols. If a provided mode is not set as a default mode, +nothing will be done." + (dolist (mode modes) + (check-type mode symbol) + ;; Take care not to add the same mode twice, this is risky enough + ;; as it is. + (setf (default-modes modual-class) + (delete mode (default-modes modual-class) :key #'first))))

1 0

← Newer
1
...
14
15
16
17
18
19
20
...
26
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 January 2008