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)))