/[mcclim]/mcclim/grafts.lisp
ViewVC logotype

Contents of /mcclim/grafts.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Fri Mar 21 21:36:59 2003 UTC (11 years ago) by mikemac
Branch: MAIN
CVS Tags: McCLIM-0-9, mcclim-0-9-4, McCLIM-0-9-5, McCLIM-0-9-4, McCLIM-0-9-6, McCLIM-0-9-1, McCLIM-0-9-3, McCLIM-0-9-2, HEAD
Changes since 1.7: +1 -1 lines
make all of the package names passed to in-package be lowercase keywords for ACL's java mode
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
4
5 ;;; This library is free software; you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Library General Public
7 ;;; License as published by the Free Software Foundation; either
8 ;;; version 2 of the License, or (at your option) any later version.
9 ;;;
10 ;;; This library is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;; Library General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU Library General Public
16 ;;; License along with this library; if not, write to the
17 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
18 ;;; Boston, MA 02111-1307 USA.
19
20 (in-package :clim-internals)
21
22 (defclass graft (sheet-multiple-child-mixin mirrored-sheet-mixin basic-sheet)
23 ((orientation :initform :default
24 :initarg :orientation
25 :reader graft-orientation)
26 (units :initform :device
27 :initarg :units
28 :reader graft-units)
29 (mirror :initarg :mirror)
30 )
31 )
32
33 (defmethod initialize-instance :after ((graft graft) &rest args)
34 (declare (ignore args))
35 (port-register-mirror (port graft) graft (slot-value graft 'mirror)))
36 ; (setf (graft graft) graft))
37
38 (defun graftp (x)
39 (typep x 'graft))
40
41 (defmethod graft ((graft graft))
42 graft)
43
44 (defmethod sheet-grafted-p ((sheet basic-sheet))
45 (if (sheet-parent sheet)
46 (sheet-grafted-p (sheet-parent sheet))
47 nil))
48
49 (defmethod sheet-grafted-p ((graft graft))
50 t)
51
52 (defmethod sheet-viewable-p ((graft graft))
53 (sheet-enabled-p graft))
54
55 (defun find-graft (&key (port nil)
56 (server-path *default-server-path*)
57 (orientation :default)
58 (units :device))
59 (if (null port)
60 (setq port (find-port :server-path server-path)))
61 (block find-graft
62 (map-over-grafts #'(lambda (graft)
63 (if (and (eq orientation (graft-orientation graft))
64 (eq units (graft-units graft)))
65 (return-from find-graft graft)))
66 port)
67 (return-from find-graft (make-graft port :orientation orientation :units units))))
68
69 (defun map-over-grafts (function port)
70 (mapc function (port-grafts port)))
71
72 (defmacro with-graft-locked (graft &body body)
73 `(let ((graft ,graft))
74 ,@body))
75
76 #-(and)
77 (defmethod graft-width ((graft graft) &key (units :device))
78 (if (eq units :device)
79 1000
80 1))
81
82 #-(and)
83 (defmethod graft-height ((graft graft) &key (units :device))
84 (if (eq units :device)
85 1000
86 1))
87
88 (defun graft-pixels-per-millimeter (graft)
89 ;; We assume square pixels here --GB
90 (/ (graft-width graft :units :device)
91 (graft-width graft :units :millimeters)))
92
93 (defun graft-pixels-per-inch (graft)
94 ;; We assume square pixels here --GB
95 (/ (graft-width graft :units :device)
96 (graft-width graft :units :inches)))
97
98 (defmethod sheet-native-transformation ((sheet graft))
99 +identity-transformation+)
100
101 (defmethod sheet-native-region ((sheet graft))
102 +everywhere+)

  ViewVC Help
Powered by ViewVC 1.1.5