Index: medium.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/medium.lisp,v retrieving revision 1.57 diff -u -r1.57 medium.lisp --- medium.lisp 22 Jan 2006 21:17:07 -0000 1.57 +++ medium.lisp 8 Mar 2006 17:44:26 -0000 @@ -87,6 +87,7 @@ (defgeneric text-style-fixed-width-p (text-style medium)) (defgeneric text-style-equalp (style1 style2)) +(defmethod text-style-equalp ((style1 text-style) (style2 text-style)) nil) (defclass standard-text-style (text-style) ((family :initarg :text-family @@ -155,7 +156,7 @@ ) ; end eval-when -(defmethod print-object ((self text-style) stream) +(defmethod print-object ((self standard-text-style) stream) (print-unreadable-object (self stream :type t :identity nil) (format stream "~{~S~^ ~}" (multiple-value-list (text-style-components self))))) @@ -196,15 +197,25 @@ ;;; Device-Font-Text-Style class (defclass device-font-text-style (text-style) - ()) + ((display-device :initarg :display-device :accessor display-device) + (device-font-name :initarg :device-font-name :accessor device-font-name))) + +(defmethod print-object ((self device-font-text-style) stream) + (print-unreadable-object (self stream :type t :identity nil) + (format stream "~S on ~S" (device-font-name self) (display-device self)))) (defun device-font-text-style-p (s) (typep s 'device-font-text-style)) +(defmethod text-style-equalp ((style1 device-font-text-style) (style2 device-font-text-style)) + (eq style1 style2)) + (defmethod text-style-mapping ((port basic-port) text-style &optional character-set) (declare (ignore character-set)) - (gethash (parse-text-style text-style) (port-text-style-mappings port))) + (if (keywordp text-style) + (gethash (parse-text-style text-style) (port-text-style-mappings port)) + (gethash text-style (port-text-style-mappings port)))) (defmethod (setf text-style-mapping) (mapping (port basic-port) text-style @@ -221,11 +232,12 @@ (setf (gethash text-style (port-text-style-mappings port)) mapping)) -(defun make-device-font-text-style (port font-name) +(defgeneric make-device-font-text-style (port font-name)) + +(defmethod make-device-font-text-style (port font-name) (let ((text-style (make-instance 'device-font-text-style - :text-family font-name - :text-face nil - :text-size nil))) + :display-device port + :device-font-name font-name))) (setf (text-style-mapping port text-style) font-name) text-style)) Index: Backends/PostScript/font.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Backends/PostScript/font.lisp,v retrieving revision 1.8 diff -u -r1.8 font.lisp --- Backends/PostScript/font.lisp 13 Aug 2005 14:28:23 -0000 1.8 +++ Backends/PostScript/font.lisp 8 Mar 2006 17:44:26 -0000 @@ -42,16 +42,40 @@ (xmin :initarg :xmin :reader char-xmin) (xmax :initarg :xmax :reader char-xmax))) -;;; (defvar *font-metrics* (make-hash-table :test 'equal)) -(defun define-font-metrics (name ascent descent angle char-infos) +(defstruct postscript-device-font-name + (font-file (error "missing argument")) + (metrics-file (error "missing argument")) + (size (error "missing argument"))) + +(defun %font-name-size (font-name) + (etypecase font-name + (postscript-device-font-name (postscript-device-font-name-size font-name)) + (cons (cdr font-name)))) +(defun %font-name-metrics-key (font-name) + (etypecase font-name + (postscript-device-font-name font-name) + (cons (car font-name)))) +(defun %font-name-postscript-name (font-name) + (etypecase font-name + (postscript-device-font-name + (let ((font-info (gethash font-name *font-metrics*))) + (unless font-info + (error "Unknown font: ~S" font-info)) + (font-info-name font-info))) + (cons (concatenate 'string (car font-name) "-iso")))) + + + + +(defun define-font-metrics (name ascent descent angle char-infos &optional (font-name nil)) (let ((font-info (make-instance 'font-info :name name :ascent ascent :descent descent :italic-angle angle))) - (setf (gethash name *font-metrics*) font-info) + (setf (gethash (or font-name name) *font-metrics*) font-info) (loop for (code name width ascent descent xmin xmax) in char-infos do (when (>= code 0) (setf (aref (font-info-char-names font-info) code) @@ -137,30 +161,44 @@ (mapping (port postscript-port) (text-style text-style) &optional character-set) (declare (ignore character-set)) - (unless (and (consp mapping) - (stringp (car mapping)) - (numberp (cdr mapping))) - (error "Mapping a text style to a style specification is not~ - implemented.")) - (when (not (gethash (car mapping) *font-metrics*)) - (cerror "Ignore." "Mapping text style ~S to an unknown font ~S." - text-style (car mapping))) - (setf (gethash text-style (port-text-style-mappings port)) - mapping)) + (cond + ((and (consp mapping) + (stringp (car mapping)) + (numberp (cdr mapping))) + (when (not (gethash (car mapping) *font-metrics*)) + (cerror "Ignore." "Mapping text style ~S to an unknown font ~S." + text-style (car mapping))) + (setf (gethash text-style (port-text-style-mappings port)) + mapping)) + (t + (when (not (gethash mapping *font-metrics*)) + (cerror "Ignore." "Mapping text style ~S to an unknown font ~S." + text-style mapping)) + (setf (gethash text-style (port-text-style-mappings port)) + mapping)))) ;; The following four functions should be rewritten: AFM contains all ;; needed information (defmethod text-style-ascent (text-style (medium postscript-medium)) - (multiple-value-bind (width height final-x final-y baseline) - (text-size medium "I" :text-style text-style) - (declare (ignore width height final-x final-y)) - baseline)) + (let* ((font-name (text-style-mapping (port medium) + (merge-text-styles text-style + (medium-merged-text-style medium)))) + (font-info (or (gethash (%font-name-metrics-key font-name) + *font-metrics*) + (error "Unknown font ~S." font-name))) + (size (%font-name-size font-name))) + (* (/ size 1000) (font-info-ascent font-info)))) + (defmethod text-style-descent (text-style (medium postscript-medium)) - (multiple-value-bind (width height final-x final-y baseline) - (text-size medium "q" :text-style text-style) - (declare (ignore width final-x final-y)) - (- height baseline))) + (let* ((font-name (text-style-mapping (port medium) + (merge-text-styles text-style + (medium-merged-text-style medium)))) + (font-info (or (gethash (%font-name-metrics-key font-name) + *font-metrics*) + (error "Unknown font ~S." font-name))) + (size (%font-name-size font-name))) + (* (/ size 1000) (font-info-descent font-info)))) (defmethod text-style-height (text-style (medium postscript-medium)) (multiple-value-bind (width height final-x final-y baseline) @@ -181,10 +219,13 @@ (setf string (make-string 1 :initial-element string))) (unless end (setf end (length string))) (unless text-style (setf text-style (medium-text-style medium))) - (destructuring-bind (psfont . size) - (text-style-mapping (port medium) - (merge-text-styles text-style - (medium-merged-text-style medium))) + (let* ((font-name + (text-style-mapping (port medium) + (merge-text-styles + text-style + (medium-merged-text-style medium)))) + (metrics-key (%font-name-metrics-key font-name)) + (size (%font-name-size font-name))) (let ((scale (/ size 1000))) (cond ((= start end) (values 0 0 0 0)) @@ -194,7 +235,7 @@ (multiple-value-bind (width ascent descent left right font-ascent font-descent direction first-not-done) - (psfont-text-extents psfont string + (psfont-text-extents metrics-key string :start start :end position-newline) (multiple-value-bind (minx miny maxx maxy) (climi::text-bounding-rectangle* @@ -208,24 +249,30 @@ (multiple-value-bind (width ascent descent left right font-ascent font-descent direction first-not-done) - (psfont-text-extents psfont string + (psfont-text-extents metrics-key string :start start :end end) (values (* scale left) - (* scale (- font-ascent)) + (* scale (- ascent)) (* scale right) - (* scale font-descent))))))))))) + (* scale descent))))))))))) -(defun psfont-text-extents (font string &key (start 0) (end (length string))) - (let* ((font-info (or (gethash font *font-metrics*) - (error "Unknown font ~S." font))) +(defun psfont-text-extents (metrics-key string &key (start 0) (end (length string))) + (let* ((font-info (or (gethash metrics-key *font-metrics*) + (error "Unknown font ~S." metrics-key))) (char-metrics (font-info-char-infos font-info)) (width (loop for i from start below end sum (char-width (gethash (aref *iso-latin-1-symbolic-names* (char-code (char string i))) - char-metrics))))) + char-metrics)))) + (ascent (loop for i from start below end + maximize (char-ascent (gethash (aref *iso-latin-1-symbolic-names* (char-code (char string i))) + char-metrics)))) + (descent (loop for i from start below end + maximize (char-descent (gethash (aref *iso-latin-1-symbolic-names* (char-code (char string i))) + char-metrics))))) (values width - (font-info-ascent font-info) - (font-info-descent font-info) + ascent + descent (char-xmin (gethash (aref *iso-latin-1-symbolic-names* (char-code (char string start))) char-metrics)) (- width (- (char-width (gethash (aref *iso-latin-1-symbolic-names* (char-code (char string (1- end)))) @@ -243,9 +290,41 @@ &key text-style (start 0) end) (when (characterp string) (setq string (string string))) (unless end (setq end (length string))) - (destructuring-bind (font . size) - (text-style-mapping (port medium) - (merge-text-styles text-style - (medium-merged-text-style medium))) - (text-size-in-font font size + (let* ((font-name (text-style-mapping (port medium) + (merge-text-styles text-style + (medium-merged-text-style medium)))) + (size (%font-name-size font-name)) + (metrics-key (%font-name-metrics-key font-name))) + (text-size-in-font metrics-key size string start (or end (length string))))) + +(defmethod invoke-with-text-style :around + ((medium postscript-medium) + continuation + (text-style clim-internals::device-font-text-style)) + (unless (member text-style (device-fonts medium)) + (push text-style (device-fonts medium))) + (call-next-method)) + +(defun write-font-to-postscript-stream (stream text-style) + (with-open-file (font-stream + (postscript-device-font-name-font-file (clim-internals::device-font-name text-style)) + :direction :input + :external-format :latin-1) + (let ((font (make-string (file-length font-stream)))) + (read-sequence font font-stream) + (write-string font (postscript-medium-file-stream stream))))) + +(defmethod make-device-font-text-style ((port postscript-port) font-name) + (check-type font-name postscript-device-font-name) + (let ((text-style (make-instance 'clim-internals::device-font-text-style + :display-device port + :device-font-name font-name))) + (multiple-value-bind (dict-name ascent descent angle char-infos) + (with-open-file (stream (postscript-device-font-name-metrics-file font-name) + :direction :input + :external-format :latin-1) + (clim-postscript::read-afm-stream stream)) + (clim-postscript::define-font-metrics dict-name ascent descent angle char-infos font-name)) + (setf (text-style-mapping port text-style) font-name) + text-style)) Index: Backends/PostScript/graphics.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Backends/PostScript/graphics.lisp,v retrieving revision 1.15 diff -u -r1.15 graphics.lisp --- Backends/PostScript/graphics.lisp 30 Dec 2005 18:02:39 -0000 1.15 +++ Backends/PostScript/graphics.lisp 8 Mar 2006 17:44:26 -0000 @@ -462,11 +462,14 @@ (defmethod postscript-set-graphics-state (stream medium (kind (eql :text-style))) - (destructuring-bind (font . size) - (medium-font medium) + (let* ((font-name (medium-font medium)) + (font (%font-name-postscript-name font-name)) + (size (%font-name-size font-name))) (pushnew font (slot-value (medium-sheet medium) 'document-fonts) :test #'string=) - (format stream "/~A-iso findfont ~D scalefont setfont~%" font size))) ;### evil hack. + (format stream "/~A findfont ~D scalefont setfont~%" + font + size))) ;### evil hack. (defun postscript-escape-char (char) (case char @@ -522,7 +525,9 @@ (format-postscript-number ty)))) (multiple-value-bind (total-width total-height final-x final-y baseline) - (destructuring-bind (font . size) (medium-font medium) + (let* ((font-name (medium-font medium)) + (font (%font-name-metrics-key font-name)) + (size (%font-name-size font-name))) (text-size-in-font font size string 0 nil)) (declare (ignore final-x final-y)) ;; Only one line? Index: Experimental/freetype/freetype-fonts.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp,v retrieving revision 1.11 diff -u -r1.11 freetype-fonts.lisp --- Experimental/freetype/freetype-fonts.lisp 13 Aug 2005 14:28:33 -0000 1.11 +++ Experimental/freetype/freetype-fonts.lisp 8 Mar 2006 17:44:26 -0000 @@ -301,9 +301,32 @@ (fmakunbound 'clim-clx::text-style-to-x-font) +(defstruct freetype-device-font-name + (font-file (error "missing argument")) + (size (error "missing argument"))) + +(defmethod clim-clx::text-style-to-X-font :around + ((port clim-clx::clx-port) (text-style climi::device-font-text-style)) + (let ((display (slot-value port 'clim-clx::display)) + (font-name (climi::device-font-name text-style))) + (make-free-type-face display + (freetype-device-font-name-font-file font-name) + (freetype-device-font-name-size font-name)))) + +(defmethod text-style-mapping :around + ((port clim-clx::clx-port) (text-style climi::device-font-text-style) + &optional character-set) + (values (gethash text-style (clim-clx::port-text-style-mappings port)))) +(defmethod (setf text-style-mapping) :around + (value + (port clim-clx::clx-port) + (text-style climi::device-font-text-style) + &optional character-set) + (setf (gethash text-style (clim-clx::port-text-style-mappings port)) value)) + (defparameter *free-type-face-hash* (make-hash-table :test #'equal)) -(defmethod clim-clx::text-style-to-X-font :around ((port clim-clx::clx-port) text-style) +(defmethod clim-clx::text-style-to-X-font :around ((port clim-clx::clx-port) (text-style standard-text-style)) (multiple-value-bind (family face size) (clim:text-style-components text-style) (let ((display (clim-clx::clx-port-display port)))