anchor.diff:  ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
   ;;; Boston, MA  02111-1307  USA.
   
  +;;;; TODO
  +
  +;;; Text Styles
  +
  +;; - *UNDEFINED-TEXT-STYLE* is missing
  +;; - Why is (EQ (MAKE-TEXT-STYLE NIL NIL 10) (MAKE-TEXT-STYLE NIL NIL 10.0005)) = T?
  +;;   Does it matter?
  +;; - Don't we want a weak hash-table for *TEXT-STYLE-HASH-TABLE*
  +;; - we need more macro hygiene in WITH-TEXT-STYLE
  +;;
  +;; --GB 2002-02-26
  +
  +;;; Media
  +
  +;; - MEDIUM-DRAW-POINTS*, MEDIUM-DRAW-LINES*, MEDIUM-DRAW-RECTANGLES*
  +;; - MEDIUM-DRAW-RECTANGLES*
  +;;
  +;; --GB 2002-02-26
  +
  +;;; Notes
  +
  +;; The text-style protocol is kind of useless for now. How is an
  +;; application programmer expected to implement new text-styles? I
  +;; think we would need something like:
  +;;
  +;;  TEXT-STYLE-CHARACTER-METRICS text-style character[1]
  +;;    -> width, ascent, descent, left-bearing, right-bearing
  +;;
  +;;  TEXT-STYLE-DRAW-TEXT text-style medium string x y
  +;;  Or even better:
  +;;  DESIGN-FROM-TEXT-STYLE-CHARACTER text-style character
  +;;
  +;;
  +;; And when you start to think about it, text-styles are not fonts. So
  +;; we need two protocols: A text style protocol and a font protocol. 
  +;;
  +;; A text style is then something, which maps a sequence of characters
  +;; into a couple of drawing commands, while probably using some font.
  +;;
  +;; While a font is something, which maps a _glyph index_ into a design.
  +;;
  +;; Example: Underlined with extra word spacing is a text style, while
  +;;          Adobe Times Roman 12pt is a font.
  +;;
  +;; And [it can't be said too often] unicode is not a glyph encoding
  +;; but more a kind of text formating.
  +;; 
  +;; [1] or even a code position
  +;; --GB
  +
   (in-package :CLIM-INTERNALS)
   
  +;; This must come early, because of implementation quirks:
  +
  +(define-protocol-class medium ()
  +  ())
  +
  +;;;;
  +;;;; 11 Text Styles
  +;;;;
  +
  +(eval-when (eval load compile)
  +
  +(define-protocol-class text-style ()
  +  ())
  +
  +(defgeneric text-style-components (text-style))
  +(defgeneric text-style-family (text-style))
  +(defgeneric text-style-face (text-style))
  +(defgeneric text-style-size (text-style))
  +(defgeneric merge-text-style (text-style-1 text-style-2))
  +(defgeneric text-style-ascent (text-style medium))
  +(defgeneric text-style-descent (text-style medium))
  +(defgeneric text-style-height (text-style medium))
  +(defgeneric text-style-width (text-style medium))
  +(defgeneric text-style-fixed-width-p (text-style medium))
  +
  +(defclass standard-text-style (text-style)
  +  ((family :initarg :text-family
  +	   :initform :fix
  +	   :reader text-style-family)
  +   (face   :initarg :text-face
  +	   :initform :roman
  +	   :reader text-style-face)
  +   (size   :initarg :text-size
  +	   :initform :normal
  +	   :reader text-style-size)))
  +
  +(defun family-key (family)
  +  (ecase family
  +    ((nil) 0)
  +    ((:fix :fixed) 1)
  +    ((:serif) 2)
  +    ((:sans-serif) 3)))
  +
  +(defun face-key (face)
  +  (if (equal face '(:bold :italic))
  +      4
  +      (ecase face
  +	((nil) 0)
  +	((:roman) 1)
  +	((:bold) 2)
  +	((:italic) 3))))
  +
  +(defun size-key (size)
  +  (if (numberp size)
  +      (+ 10 (round (* 256 size)))
  +      (ecase size
  +	((nil) 0)
  +	((:tiny) 1)
  +	((:very-small) 2)
  +	((:small) 3)
  +	((:normal) 4)
  +	((:large) 5)
  +	((:very-large) 6)
  +	((:huge) 7)
  +	((:smaller 8))
  +	((:larger 9)))))
  +
  +(defun text-style-key (family face size)
  +  (+ (* 256 (size-key size))
  +     (* 16 (face-key face))
  +     (family-key family)))
  +
  +(defvar *text-style-hash-table* (make-hash-table :test #'eql))
  +
  +(defun make-text-style (family face size)
  +  (let ((key (text-style-key family face size)))
  +    (declare (type fixnum key))
  +    (or (gethash key *text-style-hash-table*)
  +	(setf (gethash key *text-style-hash-table*)
  +	      (make-instance 'standard-text-style
  +			     :text-family family
  +			     :text-face face
  +			     :text-size size)))))
  +) ; end eval-when
  +
  +(defmethod print-object ((self text-style) stream)
  +  (print-unreadable-object (self stream :type t :identity nil)
  +    (format stream "~{~S~^ ~}" (multiple-value-list (text-style-components self)))))
  +
  +(defconstant *default-text-style* (make-text-style :fix :roman :normal))
  +
  +(defconstant *smaller-sizes* '(:huge :very-large :large :normal
  +			       :small :very-small :tiny :tiny))
  +
  +(defconstant *font-scaling-factor* 4/3)
  +(defconstant *font-min-size* 6)
  +(defconstant *font-max-size* 48)
  +
  +(defun find-smaller-size (size)
  +  (if (numberp size)
  +      (max (round (/ size *font-scaling-factor*)) *font-min-size*)
  +    (cadr (member size *smaller-sizes*))))
  +
  +(defconstant *larger-sizes* '(:tiny :very-small :small :normal
  +			      :large :very-large :huge :huge))
  +
  +(defun find-larger-size (size)
  +  (if (numberp size)
  +      (min (round (* size *font-scaling-factor*)) *font-max-size*)
  +    (cadr (member size *larger-sizes*))))
  +
  +(defmethod text-style-components ((text-style standard-text-style))
  +  (values (text-style-family text-style)
  +          (text-style-face text-style)
  +          (text-style-size text-style)))
  +
  +;;; Device-Font-Text-Style class
  +
  +(defclass device-font-text-style (text-style)
  +  ())
  +
  +(defun device-font-text-style-p (s)
  +  (typep s 'device-font-text-style))
  +
  +(defun make-device-font-text-style (display-device device-font-name)
  +  (port-make-font-text-style (port display-device) device-font-name))
  +
  +;;; Text-style utilities
  +
  +(defun merge-text-styles (s1 s2)
  +  (if (and (not (device-font-text-style-p s1))
  +	   (not (device-font-text-style-p s2)))
  +      (let ((new-style (make-text-style (or (text-style-family s1)
  +					    (text-style-family s2))
  +					(or (text-style-face s1)
  +					    (text-style-face s2))
  +					(or (text-style-size s1)
  +					    (text-style-size s2)))))
  +	(with-slots (size) new-style
  +	  (case size
  +	    (:smaller
  +	     (setq size (find-smaller-size (text-style-size s2))))
  +	    (:larger
  +	     (setq size (find-larger-size (text-style-size s2))))))
  +	new-style)
  +      s1))
  +
  +(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))))
  +
  +(defun parse-text-style (style)
  +  (if (text-style-p style)
  +      style
  +    (let ((family nil)
  +	  (face nil)
  +	  (size nil))
  +      (loop for item in style
  +	    do (cond
  +		((member item '(fix :serif :sans-serif))
  +		 (setq family item))
  +		((or (member item '(:roman :bold :italic))
  +		     (listp item))
  +		 (setq face item))
  +		((or (member item '(:tiny :very-small :small :normal
  +				    :large :very-large :huge))
  +		     (numberp item))
  +		 (setq size item))))
  +      (make-text-style family face size))))
  +
  +(defmacro with-text-style ((medium text-style) &body body)
  +  (declare (type symbol medium))
  +  (when (eq medium t)
  +    (setq medium '*standard-output*))
  +  `(flet ((continuation ()
  +	    ,@body))
  +     #-clisp (declare (dynamic-extent #'continuation))
  +     (invoke-with-text-style ,medium #'continuation (parse-text-style ,text-style))))
  +
  +(defmacro with-text-family ((medium family) &body body)
  +  (declare (type symbol medium))
  +  (when (eq medium t)
  +    (setq medium '*standard-output*))
  +  `(flet ((continuation ()
  +	    ,@body))
  +     #-clisp (declare (dynamic-extent #'continuation))
  +     (invoke-with-text-style ,medium #'continuation (make-text-style ,family nil nil))))
  +
  +(defmacro with-text-face ((medium face) &body body)
  +  (declare (type symbol medium))
  +  (when (eq medium t)
  +    (setq medium '*standard-output*))
  +  `(flet ((continuation ()
  +	    ,@body))
  +     #-clisp (declare (dynamic-extent #'continuation))
  +     (invoke-with-text-style ,medium
  +                             #'continuation (make-text-style nil ,face nil))))
  +
  +(defmacro with-text-size ((medium size) &body body)
  +  (declare (type symbol medium))
  +  (when (eq medium t)
  +    (setq medium '*standard-output*))
  +  `(flet ((continuation ()
  +	    ,@body))
  +     #-clisp (declare (dynamic-extent #'continuation))
  +     (invoke-with-text-style ,medium #'continuation (make-text-style nil nil ,size))))
  +
  ++
   ;;; MEDIUM class
  -
  -(defclass medium () ())
   
   (defclass basic-medium (medium)
     ((foreground :initarg :foreground
  
positive.code:   (: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))
  
negative.code:    ;; 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 *default-text-style*
                 :accessor medium-text-style)
     (default-text-style :initarg :default-text-style
       :initform *default-text-style*
       :accessor medium-default-text-style)
     (sheet :initarg :sheet
            :initform nil                 ; this means that medium is not linked to a sheet
  