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

Diff of /mcclim/medium.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.27 by gilbert, Sat Feb 16 02:27:54 2002 UTC revision 1.28 by gilbert, Tue Feb 26 16:12:08 2002 UTC
# Line 17  Line 17 
17  ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,  ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
18  ;;; Boston, MA  02111-1307  USA.  ;;; Boston, MA  02111-1307  USA.
19    
20  (in-package :CLIM-INTERNALS)  ;;;; TODO
   
 ;;; MEDIUM class  
   
 (defclass medium () ())  
   
 (defclass basic-medium (medium)  
   ((foreground :initarg :foreground  
                :initform +black+  
                :accessor medium-foreground)  
    (background :initarg :background  
                :initform +white+  
                :accessor medium-background)  
    (ink :initarg :ink  
         :initform +foreground-ink+  
         :accessor medium-ink)  
    (transformation :type transformation  
                    :initarg :transformation  
                    :initform +identity-transformation+  
                    :accessor medium-transformation)  
    (clipping-region :type region  
                     :initarg :clipping-region  
                     :initform +everywhere+  
                     :documentation "Clipping region in the SHEET coordinates.")  
    ;; always use this slot through its accessor, since there may  
    ;; be secondary methods on it -RS 2001-08-23  
    (line-style :initarg :line-style  
                :initform (make-line-style)  
                :accessor medium-line-style)  
    ;; always use this slot through its accessor, since there may  
    ;; be secondary methods on it -RS 2001-08-23  
    (text-style :initarg :text-style  
                :initform (make-text-style :fix :roman :normal)  
                :accessor medium-text-style)  
    (default-text-style :initarg :default-text-style  
      :initform (make-text-style :fix :roman :normal)  
      :accessor medium-default-text-style)  
    (sheet :initarg :sheet  
           :initform nil                 ; this means that medium is not linked to a sheet  
           :reader medium-sheet  
           :writer (setf %medium-sheet) ))  
   (:documentation "The basic class, on which all CLIM mediums are built.") )  
   
 (defclass ungrafted-medium (basic-medium) ())  
   
 (defmethod mediump ((x medium))  
   t)  
   
 (defmethod mediump ((x medium))  
   nil)  
   
 (defmethod initialize-instance :after ((medium medium) &rest args)  
   (declare (ignore args))  
   ;; Initial CLIPPING-REGION is in coordinates, given by initial  
   ;; TRANSFORMATION, but we store it in SHEET's coords.  
   (with-slots (clipping-region) medium  
     (setf clipping-region (transform-region (medium-transformation medium)  
                                             clipping-region))))  
   
 (defmethod medium-clipping-region ((medium medium))  
   (untransform-region (medium-transformation medium)  
                     (slot-value medium 'clipping-region)))  
   
 (defmethod (setf medium-clipping-region) (region (medium medium))  
   (setf (slot-value medium 'clipping-region)  
         (transform-region (medium-transformation medium)  
                             region)))  
   
 (defmethod (setf medium-clipping-region) :after (region (medium medium))  
   (declare (ignore region))  
   (let ((sheet (medium-sheet medium)))  
     (when sheet  
       (invalidate-cached-regions sheet))))  
   
 (defmethod (setf medium-transformation) :after (transformation (medium medium))  
   (declare (ignore transformation))  
   (let ((sheet (medium-sheet medium)))  
     (when sheet  
       (invalidate-cached-transformations sheet))))  
   
 (defmethod medium-merged-text-style ((medium medium))  
   (merge-text-styles (medium-text-style medium) (medium-default-text-style medium)))  
21    
22  ;; with-sheet-medium moved to output.lisp. --GB  ;;; Text Styles
 ;; with-sheet-medium-bound moved to output.lisp. --GB  
23    
24  (defmacro with-pixmap-medium ((medium pixmap) &body body)  ;; - *UNDEFINED-TEXT-STYLE* is missing
25    (let ((old-medium (gensym))  ;; - Why is (EQ (MAKE-TEXT-STYLE NIL NIL 10) (MAKE-TEXT-STYLE NIL NIL 10.0005)) = T?
26          (old-pixmap (gensym)))  ;;   Does it matter?
27      `(let* ((,old-medium (pixmap-medium ,pixmap))  ;; - Don't we want a weak hash-table for *TEXT-STYLE-HASH-TABLE*
28              (,medium (or ,old-medium (make-medium (port ,pixmap) ,pixmap)))  ;; - we need more macro hygiene in WITH-TEXT-STYLE
29              (,old-pixmap (medium-sheet ,medium)))  ;;
30         (setf (pixmap-medium ,pixmap) ,medium)  ;; --GB 2002-02-26
31         (setf (%medium-sheet ,medium) ,pixmap) ;is medium a basic medium? --GB  
32         (unwind-protect  ;;; Media
33             (progn  
34               ,@body)  ;; - MEDIUM-DRAW-POINTS*, MEDIUM-DRAW-LINES*, MEDIUM-DRAW-RECTANGLES*
35           (setf (pixmap-medium ,pixmap) ,old-medium)  ;; - MEDIUM-DRAW-RECTANGLES*
36           (setf (medium-sheet ,medium) ,old-pixmap)))))  ;;
37    ;; --GB 2002-02-26
38    
39    ;;; Notes
40    
41    ;; The text-style protocol is kind of useless for now. How is an
42    ;; application programmer expected to implement new text-styles? I
43    ;; think we would need something like:
44    ;;
45    ;;  TEXT-STYLE-CHARACTER-METRICS text-style character[1]
46    ;;    -> width, ascent, descent, left-bearing, right-bearing
47    ;;
48    ;;  TEXT-STYLE-DRAW-TEXT text-style medium string x y
49    ;;  Or even better:
50    ;;  DESIGN-FROM-TEXT-STYLE-CHARACTER text-style character
51    ;;
52    ;;
53    ;; And when you start to think about it, text-styles are not fonts. So
54    ;; we need two protocols: A text style protocol and a font protocol.
55    ;;
56    ;; A text style is then something, which maps a sequence of characters
57    ;; into a couple of drawing commands, while probably using some font.
58    ;;
59    ;; While a font is something, which maps a _glyph index_ into a design.
60    ;;
61    ;; Example: Underlined with extra word spacing is a text style, while
62    ;;          Adobe Times Roman 12pt is a font.
63    ;;
64    ;; And [it can't be said too often] unicode is not a glyph encoding
65    ;; but more a kind of text formating.
66    ;;
67    ;; [1] or even a code position
68    ;; --GB
69    
70  ;;; Medium Device functions  (in-package :CLIM-INTERNALS)
71    
72  (defmethod medium-device-transformation ((medium medium))  ;; This must come early, because of implementation quirks:
   (sheet-device-transformation (medium-sheet medium)))  
73    
74  (defmethod medium-device-region ((medium medium))  (define-protocol-class medium ()
75    (sheet-device-region (medium-sheet medium)))    ())
76    
77    ;;;;
78  ;;; Text-Style class  ;;;; 11 Text Styles
79    ;;;;
80    
81  (eval-when (eval load compile)  (eval-when (eval load compile)
82    
83  (defclass text-style ()  (define-protocol-class text-style ()
84    ())    ())
85    
86  (defmethod text-style-p ((x text-style))  (defgeneric text-style-components (text-style))
87    (declare (ignorable x))  (defgeneric text-style-family (text-style))
88    t)  (defgeneric text-style-face (text-style))
89    (defgeneric text-style-size (text-style))
90  (defmethod text-style-p ((x t))  (defgeneric merge-text-style (text-style-1 text-style-2))
91    (declare (ignorable x))  (defgeneric text-style-ascent (text-style medium))
92    nil)  (defgeneric text-style-descent (text-style medium))
93    (defgeneric text-style-height (text-style medium))
94    (defgeneric text-style-width (text-style medium))
95    (defgeneric text-style-fixed-width-p (text-style medium))
96    
97  (defclass standard-text-style (text-style)  (defclass standard-text-style (text-style)
98    ((family :initarg :text-family    ((family :initarg :text-family
99             :initform :fix             :initform :fix
100             :reader text-style-family)             :reader text-style-family)
101     (face :initarg :text-face     (face   :initarg :text-face
102           :initform :roman             :initform :roman
103           :reader text-style-face)             :reader text-style-face)
104     (size :initarg :text-size     (size   :initarg :text-size
105           :initform :normal             :initform :normal
106           :reader text-style-size)))             :reader text-style-size)))
107    
108  (defun family-key (family)  (defun family-key (family)
109    (ecase family    (ecase family
# Line 331  Line 284 
284       (invoke-with-text-style ,medium #'continuation (make-text-style nil nil ,size))))       (invoke-with-text-style ,medium #'continuation (make-text-style nil nil ,size))))
285    
286    
287    ;;; MEDIUM class
288    
289    (defclass basic-medium (medium)
290      ((foreground :initarg :foreground
291                   :initform +black+
292                   :accessor medium-foreground)
293       (background :initarg :background
294                   :initform +white+
295                   :accessor medium-background)
296       (ink :initarg :ink
297            :initform +foreground-ink+
298            :accessor medium-ink)
299       (transformation :type transformation
300                       :initarg :transformation
301                       :initform +identity-transformation+
302                       :accessor medium-transformation)
303       (clipping-region :type region
304                        :initarg :clipping-region
305                        :initform +everywhere+
306                        :documentation "Clipping region in the SHEET coordinates.")
307       ;; always use this slot through its accessor, since there may
308       ;; be secondary methods on it -RS 2001-08-23
309       (line-style :initarg :line-style
310                   :initform (make-line-style)
311                   :accessor medium-line-style)
312       ;; always use this slot through its accessor, since there may
313       ;; be secondary methods on it -RS 2001-08-23
314       (text-style :initarg :text-style
315                   :initform *default-text-style*
316                   :accessor medium-text-style)
317       (default-text-style :initarg :default-text-style
318         :initform *default-text-style*
319         :accessor medium-default-text-style)
320       (sheet :initarg :sheet
321              :initform nil                 ; this means that medium is not linked to a sheet
322              :reader medium-sheet
323              :writer (setf %medium-sheet) ))
324      (:documentation "The basic class, on which all CLIM mediums are built.") )
325    
326    (defclass ungrafted-medium (basic-medium) ())
327    
328    (defmethod initialize-instance :after ((medium medium) &rest args)
329      (declare (ignore args))
330      ;; Initial CLIPPING-REGION is in coordinates, given by initial
331      ;; TRANSFORMATION, but we store it in SHEET's coords.
332      (with-slots (clipping-region) medium
333        (setf clipping-region (transform-region (medium-transformation medium)
334                                                clipping-region))))
335    
336    (defmethod medium-clipping-region ((medium medium))
337      (untransform-region (medium-transformation medium)
338                        (slot-value medium 'clipping-region)))
339    
340    (defmethod (setf medium-clipping-region) (region (medium medium))
341      (setf (slot-value medium 'clipping-region)
342            (transform-region (medium-transformation medium)
343                                region)))
344    
345    (defmethod (setf medium-clipping-region) :after (region (medium medium))
346      (declare (ignore region))
347      (let ((sheet (medium-sheet medium)))
348        (when sheet
349          (invalidate-cached-regions sheet))))
350    
351    (defmethod (setf medium-transformation) :after (transformation (medium medium))
352      (declare (ignore transformation))
353      (let ((sheet (medium-sheet medium)))
354        (when sheet
355          (invalidate-cached-transformations sheet))))
356    
357    (defmethod medium-merged-text-style ((medium medium))
358      (merge-text-styles (medium-text-style medium) (medium-default-text-style medium)))
359    
360    ;; with-sheet-medium moved to output.lisp. --GB
361    ;; with-sheet-medium-bound moved to output.lisp. --GB
362    
363    (defmacro with-pixmap-medium ((medium pixmap) &body body)
364      (let ((old-medium (gensym))
365            (old-pixmap (gensym)))
366        `(let* ((,old-medium (pixmap-medium ,pixmap))
367                (,medium (or ,old-medium (make-medium (port ,pixmap) ,pixmap)))
368                (,old-pixmap (medium-sheet ,medium)))
369           (setf (pixmap-medium ,pixmap) ,medium)
370           (setf (%medium-sheet ,medium) ,pixmap) ;is medium a basic medium? --GB
371           (unwind-protect
372               (progn
373                 ,@body)
374             (setf (pixmap-medium ,pixmap) ,old-medium)
375             (setf (%medium-sheet ,medium) ,old-pixmap)))))
376    
377    ;;; Medium Device functions
378    
379    (defmethod medium-device-transformation ((medium medium))
380      (sheet-device-transformation (medium-sheet medium)))
381    
382    (defmethod medium-device-region ((medium medium))
383      (sheet-device-region (medium-sheet medium)))
384    
385    
386  ;;; Line-Style class  ;;; Line-Style class
387    
388  (defclass line-style ()  (defclass line-style ()
# Line 472  Line 524 
524                              t filled))))                              t filled))))
525    
526  (defmethod medium-draw-rectangles* :around ((medium basic-medium) position-seq filled)  (defmethod medium-draw-rectangles* :around ((medium basic-medium) position-seq filled)
527      ;; point-seq can be a vector! --GB
528    (let ((tr (medium-transformation medium)))    (let ((tr (medium-transformation medium)))
529      (if (rectilinear-transformation-p tr)      (if (rectilinear-transformation-p tr)
530          (loop for (left top right bottom) on position-seq by #'cddddr          (loop for (left top right bottom) on position-seq by #'cddddr

Legend:
Removed from v.1.27  
changed lines
  Added in v.1.28

  ViewVC Help
Powered by ViewVC 1.1.5