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

Diff of /mcclim/medium.lisp

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

revision 1.35 by adejneka, Tue Jun 4 07:45:46 2002 UTC revision 1.36 by adejneka, Thu Jun 13 05:02:08 2002 UTC
# Line 195  Line 195 
195    (typep s 'device-font-text-style))    (typep s 'device-font-text-style))
196    
197  (defun make-device-font-text-style (display-device device-font-name)  (defun make-device-font-text-style (display-device device-font-name)
198      ;; FIXME!!! Non-standard GF.
199    (port-make-font-text-style (port display-device) device-font-name))    (port-make-font-text-style (port display-device) device-font-name))
200    
201  ;;; Text-style utilities  ;;; Text-style utilities
# Line 204  Line 205 
205    (setq s2 (parse-text-style s2))    (setq s2 (parse-text-style s2))
206    (if (and (not (device-font-text-style-p s1))    (if (and (not (device-font-text-style-p s1))
207             (not (device-font-text-style-p s2)))             (not (device-font-text-style-p s2)))
208        (let ((new-style (make-text-style (or (text-style-family s1)        (let* ((family (or (text-style-family s1) (text-style-family s2)))
209                                              (text-style-family s2))               (face (or (text-style-face s1) (text-style-face s2)))
210                                          (or (text-style-face s1)               (size1 (text-style-size s1))
211                                              (text-style-face s2))               (size2 (text-style-size s2))
212                                          (or (text-style-size s1)               (size (case size1
213                                              (text-style-size s2)))))                       ((nil) size2)
214          (with-slots (size) new-style                       (:smaller (find-smaller-size size2))
215            (case (text-style-size s1)                       (:larger (find-larger-size size2))
216              (:smaller                       (t size1))))
217               (setq size (find-smaller-size (text-style-size s2))))          (make-text-style family face size))
             (:larger  
              (setq size (find-larger-size (text-style-size s2))))))  
         new-style)  
218        s1))        s1))
219    
 (defmethod invoke-with-text-style ((sheet sheet) continuation text-style)  
   (invoke-with-text-style (sheet-medium sheet) continuation text-style))  
   
 (defmethod invoke-with-text-style ((medium medium) continuation text-style)  
   (let ((old-style (medium-text-style medium)))  
     (setf (medium-text-style medium)  
       (merge-text-styles text-style (medium-merged-text-style medium)))  
     (unwind-protect  
         (funcall continuation)  
       (setf (medium-text-style medium) old-style))))  
   
220  (defun parse-text-style (style)  (defun parse-text-style (style)
221    (if (text-style-p style)    (if (text-style-p style)
222        style        style
# Line 238  Line 225 
225            (size nil))            (size nil))
226        (loop for item in style        (loop for item in style
227              do (cond              do (cond
228                  ((member item '(fix :serif :sans-serif))                  ((member item '(:fix :serif :sans-serif))
229                   (setq family item))                   (setq family item))
230                  ((or (member item '(:roman :bold :italic))                  ((or (member item '(:roman :bold :italic))
231                       (listp item))                       (consp item))
232                   (setq face item))                   (setq face item))
233                  ((or (member item '(:tiny :very-small :small :normal                  ((or (member item '(:tiny :very-small :small :normal
234                                      :large :very-large :huge))                                      :large :very-large :huge))
# Line 250  Line 237 
237        (make-text-style family face size))))        (make-text-style family face size))))
238    
239  (defmacro with-text-style ((medium text-style) &body body)  (defmacro with-text-style ((medium text-style) &body body)
   (declare (type symbol medium))  
240    (when (eq medium t)    (when (eq medium t)
241      (setq medium '*standard-output*))      (setq medium '*standard-output*))
242    `(flet ((continuation ()    (check-type medium symbol)
243      `(flet ((continuation (,medium)
244                (declare (ignorable ,medium))
245              ,@body))              ,@body))
246       #-clisp (declare (dynamic-extent #'continuation))       (declare (dynamic-extent #'continuation))
247       (invoke-with-text-style ,medium #'continuation (parse-text-style ,text-style))))       (invoke-with-text-style ,medium #'continuation
248                                 (parse-text-style ,text-style))))
249    
250    (defmethod invoke-with-text-style ((sheet sheet) continuation text-style)
251      (let ((medium (sheet-medium sheet))) ; FIXME: WITH-SHEET-MEDIUM
252        (with-text-style (medium text-style)
253          (funcall continuation sheet))))
254    
255    (defmethod invoke-with-text-style ((medium medium) continuation text-style)
256      (letf (((medium-text-style medium)
257              (merge-text-styles text-style (medium-merged-text-style medium))))
258        (funcall continuation medium)))
259    
260  (defmacro with-text-family ((medium family) &body body)  (defmacro with-text-family ((medium family) &body body)
261    (declare (type symbol medium))    (declare (type symbol medium))
262    (when (eq medium t)    (when (eq medium t)
263      (setq medium '*standard-output*))      (setq medium '*standard-output*))
264    `(flet ((continuation ()    `(flet ((continuation (,medium)
265              ,@body))              ,@body))
266       #-clisp (declare (dynamic-extent #'continuation))       (declare (dynamic-extent #'continuation))
267       (invoke-with-text-style ,medium #'continuation (make-text-style ,family nil nil))))       (invoke-with-text-style ,medium #'continuation
268                                 (make-text-style ,family nil nil))))
269    
270  (defmacro with-text-face ((medium face) &body body)  (defmacro with-text-face ((medium face) &body body)
271    (declare (type symbol medium))    (declare (type symbol medium))
272    (when (eq medium t)    (when (eq medium t)
273      (setq medium '*standard-output*))      (setq medium '*standard-output*))
274    `(flet ((continuation ()    `(flet ((continuation (,medium)
275              ,@body))              ,@body))
276       #-clisp (declare (dynamic-extent #'continuation))       (declare (dynamic-extent #'continuation))
277       (invoke-with-text-style ,medium       (invoke-with-text-style ,medium #'continuation
278                               #'continuation (make-text-style nil ,face nil))))                               (make-text-style nil ,face nil))))
279    
280  (defmacro with-text-size ((medium size) &body body)  (defmacro with-text-size ((medium size) &body body)
281    (declare (type symbol medium))    (declare (type symbol medium))
282    (when (eq medium t)    (when (eq medium t) (setq medium '*standard-output*))
283      (setq medium '*standard-output*))    `(flet ((continuation (,medium)
   `(flet ((continuation ()  
284              ,@body))              ,@body))
285       #-clisp (declare (dynamic-extent #'continuation))       (declare (dynamic-extent #'continuation))
286       (invoke-with-text-style ,medium #'continuation (make-text-style nil nil ,size))))       (invoke-with-text-style ,medium #'continuation
287                                 (make-text-style nil nil ,size))))
288    
289    
290  ;;; MEDIUM class  ;;; MEDIUM class
# Line 496  Line 496 
496  (defmethod medium-draw-point* :around ((medium basic-medium) x y)  (defmethod medium-draw-point* :around ((medium basic-medium) x y)
497    (let ((tr (medium-transformation medium)))    (let ((tr (medium-transformation medium)))
498      (with-transformed-position (tr x y)      (with-transformed-position (tr x y)
499                                 (call-next-method medium x y))))        (call-next-method medium x y))))
500    
501  (defmethod medium-draw-points* :around ((medium basic-medium) coord-seq)  (defmethod medium-draw-points* :around ((medium basic-medium) coord-seq)
502    (let ((tr (medium-transformation medium)))    (let ((tr (medium-transformation medium)))
503      (with-transformed-positions (tr coord-seq)      (with-transformed-positions (tr coord-seq)
504                                  (call-next-method medium coord-seq))))        (call-next-method medium coord-seq))))
505    
506  (defmethod medium-draw-line* :around ((medium basic-medium) x1 y1 x2 y2)  (defmethod medium-draw-line* :around ((medium basic-medium) x1 y1 x2 y2)
507    (let ((tr (medium-transformation medium)))    (let ((tr (medium-transformation medium)))
508      (with-transformed-position (tr x1 y1)      (with-transformed-position (tr x1 y1)
509                                 (with-transformed-position (tr x2 y2)        (with-transformed-position (tr x2 y2)
510                                                            (call-next-method medium x1 y1 x2 y2)))))          (call-next-method medium x1 y1 x2 y2)))))
511    
512  (defmethod medium-draw-lines* :around ((medium basic-medium) coord-seq)  (defmethod medium-draw-lines* :around ((medium basic-medium) coord-seq)
513    (let ((tr (medium-transformation medium)))    (let ((tr (medium-transformation medium)))
514      (with-transformed-positions (tr coord-seq)      (with-transformed-positions (tr coord-seq)
515                                  (call-next-method medium coord-seq))))        (call-next-method medium coord-seq))))
516    
517  (defmethod medium-draw-polygon* :around ((medium basic-medium) coord-seq closed filled)  (defmethod medium-draw-polygon* :around ((medium basic-medium) coord-seq closed filled)
518    (let ((tr (medium-transformation medium)))    (let ((tr (medium-transformation medium)))
519      (with-transformed-positions (tr coord-seq)      (with-transformed-positions (tr coord-seq)
520                                  (call-next-method medium coord-seq closed filled))))        (call-next-method medium coord-seq closed filled))))
521    
522  (defmethod medium-draw-rectangle* :around ((medium basic-medium) left top right bottom filled)  (defmethod medium-draw-rectangle* :around ((medium basic-medium) left top right bottom filled)
523    (let ((tr (medium-transformation medium)))    (let ((tr (medium-transformation medium)))

Legend:
Removed from v.1.35  
changed lines
  Added in v.1.36

  ViewVC Help
Powered by ViewVC 1.1.5