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