1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
|
;;; -*- 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+))
;; Draw the new one, if there is one.
(when (gadget-value pane)
(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
: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)))
(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)))
(run-frame-top-level frame))))
(if new-process
(clim-sys:make-process #'run :name "Image viewer")
(run))))
|
