Index: recording.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/recording.lisp,v retrieving revision 1.118 diff -u -r1.118 recording.lisp --- recording.lisp 15 Feb 2005 11:28:11 -0000 1.118 +++ recording.lisp 12 Aug 2005 11:12:36 -0000 @@ -1644,7 +1644,7 @@ (def-grecording draw-text ((gs-text-style-mixin) string point-x point-y start end align-x align-y toward-x toward-y transform-glyphs) () ;; FIXME!!! Text direction. - ;; Multiple lines? + ;; FIXME: Multiple lines. (let* ((text-style (graphics-state-text-style graphic)) (width (if (characterp string) (stream-character-width stream string :text-style text-style) @@ -1654,27 +1654,26 @@ (ascent (text-style-ascent text-style (sheet-medium stream))) (descent (text-style-descent text-style (sheet-medium stream))) (height (+ ascent descent)) - (transform (medium-transformation medium)) - left top right bottom) + (transform (medium-transformation medium))) (setf (values point-x point-y) (transform-position transform point-x point-y)) - (ecase align-x - (:left (setq left point-x - right (+ point-x width))) - (:right (setq left (- point-x width) - right point-x)) - (:center (setq left (- point-x (round width 2)) - right (+ point-x (round width 2))))) - (ecase align-y - (:baseline (setq top (- point-y ascent) - bottom (+ point-y descent))) - (:top (setq top point-y - bottom (+ point-y height))) - (:bottom (setq top (- point-y height) - bottom point-y)) - (:center (setq top (- point-y (floor height 2)) - bottom (+ point-y (ceiling height 2))))) - (values left top right bottom))) + (multiple-value-bind (left top right bottom) + (text-bounding-rectangle* medium string + :start start :end end :text-style text-style) + (ecase align-x + (:left (incf left point-x) (incf right point-x)) + (:right (incf left (- point-x width)) (incf right (- point-x width))) + (:center (incf left (- point-x (round width 2))) + (incf right (- point-x (round width 2))))) + (ecase align-y + (:baseline (incf top point-y) (incf bottom point-y)) + (:top (incf top (+ point-y ascent)) + (incf bottom (+ point-y ascent))) + (:bottom (incf top (- point-y descent)) + (incf bottom (- point-y descent))) + (:center (incf top (- point-y (floor height 2))) ; pretty sure this is wrong + (incf bottom (- point-y (floor height 2))))) + (values left top right bottom)))) (defmethod* (setf output-record-position) :around (nx ny (record draw-text-output-record)) @@ -1736,6 +1735,15 @@ (baseline :initform 0) (width :initform 0) (max-height :initform 0) + ;; FIXME (or rework this comment): CLIM does not separate the + ;; notions of the text width and the bounding box; however, we need + ;; to, because some fonts will render outside the logical + ;; coordinates defined by the start position and the width. LEFT + ;; and RIGHT here (and below) deal with this in a manner completely + ;; hidden from the user. (should we export + ;; TEXT-BOUNDING-RECTANGLE*?) + (left :initarg :start-x) + (right :initarg :start-x) (start-x :initarg :start-x) (start-y :initarg :start-y) (end-x :initarg :start-x) @@ -1757,12 +1765,14 @@ ((record standard-text-displayed-output-record) (record2 standard-text-displayed-output-record)) (with-slots - (initial-x1 initial-y1 start-x start-y end-x end-y wrapped strings) + (initial-x1 initial-y1 start-x start-y left right end-x end-y wrapped strings) record2 (and (coordinate= (slot-value record 'initial-x1) initial-x1) (coordinate= (slot-value record 'initial-y1) initial-y1) (coordinate= (slot-value record 'start-x) start-x) (coordinate= (slot-value record 'start-y) start-y) + (coordinate= (slot-value record 'left) left) + (coordinate= (slot-value record 'right) right) (coordinate= (slot-value record 'end-x) end-x) (coordinate= (slot-value record 'end-y) end-y) (eq (slot-value record 'wrapped) wrapped) @@ -1835,20 +1845,21 @@ (defmethod tree-recompute-extent ((text-record standard-text-displayed-output-record)) - (with-standard-rectangle* (:x1 x1 :y1 y1) + (with-standard-rectangle* (:y1 y1) text-record - (with-slots (width max-height) + (with-slots (max-height left right) text-record (setf (rectangle-edges* text-record) - (values x1 y1 - (coordinate (+ x1 width)) - (coordinate (+ y1 max-height)))))) + (values (coordinate left) + y1 + (coordinate right) + (coordinate (+ y1 max-height)))))) text-record) (defmethod add-character-output-to-text-record ; XXX OAOO with ADD-STRING-... ((text-record standard-text-displayed-output-record) character text-style char-width height new-baseline) - (with-slots (strings baseline width max-height start-y end-x end-y medium) + (with-slots (strings baseline width max-height left right start-y end-x end-y medium) text-record (if (and strings (let ((string (last1 strings))) @@ -1868,11 +1879,18 @@ :element-type 'character :adjustable t :fill-pointer t))))) - (setq baseline (max baseline new-baseline) - end-x (+ end-x char-width) - max-height (max max-height height) - end-y (max end-y (+ start-y max-height)) - width (+ width char-width))) + (multiple-value-bind (minx miny maxx maxy) + (text-bounding-rectangle* medium character :text-style text-style) + (declare (ignore miny maxy)) + (setq baseline (max baseline new-baseline) + ;; KLUDGE: note END-X here is really START-X of the new + ;; string + left (min left (+ end-x minx)) + end-x (+ end-x char-width) + right (+ end-x (max 0 (- maxx char-width))) + max-height (max max-height height) + end-y (max end-y (+ start-y max-height)) + width (+ width char-width)))) (tree-recompute-extent text-record)) (defmethod add-string-output-to-text-record @@ -1886,7 +1904,7 @@ (aref string start) text-style string-width height new-baseline)) - (t (with-slots (strings baseline width max-height start-y end-x end-y + (t (with-slots (strings baseline width max-height left right start-y end-x end-y medium) text-record (let ((styled-string (make-instance @@ -1901,12 +1919,21 @@ (nconcf strings (list styled-string)) (replace (styled-string-string styled-string) string :start2 start :end2 end)) - (setq baseline (max baseline new-baseline) - end-x (+ end-x string-width) - max-height (max max-height height) - end-y (max end-y (+ start-y max-height)) - width (+ width string-width))) - (tree-recompute-extent text-record))))) + (multiple-value-bind (minx miny maxx maxy) + (text-bounding-rectangle* medium string + :text-style text-style + :start start :end end) + (declare (ignore miny maxy)) + (setq baseline (max baseline new-baseline) + ;; KLUDGE: note that END-X here really means + ;; START-X of the new string. + left (min left (+ end-x minx)) + end-x (+ end-x string-width) + right (+ end-x (max 0 (- maxx string-width))) + max-height (max max-height height) + end-y (max end-y (+ start-y max-height)) + width (+ width string-width)))) + (tree-recompute-extent text-record))))) (defmethod text-displayed-output-record-string ((record standard-text-displayed-output-record)) Index: stream-output.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/stream-output.lisp,v retrieving revision 1.55 diff -u -r1.55 stream-output.lisp --- stream-output.lisp 21 Apr 2005 02:43:19 -0000 1.55 +++ stream-output.lisp 12 Aug 2005 11:12:36 -0000 @@ -358,9 +358,7 @@ (unless (= start split) (stream-write-output stream string - (if (eql end split) - width - nil) + nil start split) (setq cx (+ cx width)) (with-slots (x y) (stream-text-cursor stream) Index: Backends/CLX/medium.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp,v retrieving revision 1.66 diff -u -r1.66 medium.lisp --- Backends/CLX/medium.lisp 17 Feb 2005 21:23:29 -0000 1.66 +++ Backends/CLX/medium.lisp 12 Aug 2005 11:12:36 -0000 @@ -826,6 +826,47 @@ font-ascent font-descent direction first-not-done)) (values width (+ ascent descent) width 0 ascent)) )))))) ) + +#-unicode +(defmethod climi::text-bounding-rectangle* + ((medium clx-medium) string &key text-style (start 0) end) + (when (characterp string) + (setf string (make-string 1 :initial-element string))) + (unless end (setf end (length string))) + (unless text-style (setf text-style (medium-text-style medium))) + (let ((xfont (text-style-to-X-font (port medium) text-style))) + (cond ((= start end) + (values 0 0 0 0)) + (t + (let ((position-newline (position #\newline string :start start))) + (cond ((not (null position-newline)) + (multiple-value-bind (width ascent descent left right + font-ascent font-descent direction + first-not-done) + (xlib:text-extents xfont string + :start start :end position-newline + :translate #'translate) + (declare (ignorable left right + font-ascent font-descent + direction first-not-done)) + (multiple-value-bind (minx miny maxx maxy) + (text-bounding-rectangle* + medium string :text-style text-style + :start (1+ position-newline) :end end) + (values (min minx left) (- ascent) + (max maxx right) (+ descent maxy))))) + (t + (multiple-value-bind (width ascent descent left right + font-ascent font-descent direction + first-not-done) + (xlib:text-extents xfont string + :start start :end end + :translate #'translate) + (declare (ignore width direction first-not-done)) + ;; FIXME: Potential style points: + ;; * (min 0 left), (max width right) + ;; * font-ascent / ascent + (values left (- font-ascent) right font-descent))))))))) #+unicode (defmethod text-size ((medium clx-medium) string &key text-style (start 0) end) Index: Experimental/freetype/freetype-fonts.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp,v retrieving revision 1.10 diff -u -r1.10 freetype-fonts.lisp --- Experimental/freetype/freetype-fonts.lisp 29 Jul 2005 06:50:20 -0000 1.10 +++ Experimental/freetype/freetype-fonts.lisp 12 Aug 2005 11:12:36 -0000 @@ -160,7 +160,8 @@ :y-origin top :x-advance dx :y-advance dy) - (list glyph-id dx dy)))) + (let ((right (+ left (array-dimension arr 1)))) + (list glyph-id dx dy left right top))))) ;;;;;;; mcclim interface @@ -182,22 +183,32 @@ (defmethod clim-clx::font-glyph-width ((font freetype-face) char) (with-slots (display font matrix) font (nth 1 (display-get-glyph display font matrix char)))) +(defmethod clim-clx::font-glyph-left ((font freetype-face) char) + (with-slots (display font matrix) font + (nth 3 (display-get-glyph display font matrix char)))) +(defmethod clim-clx::font-glyph-right ((font freetype-face) char) + (with-slots (display font matrix) font + (nth 4 (display-get-glyph display font matrix char)))) +;;; this is a hacky copy of XLIB:TEXT-EXTENTS (defmethod clim-clx::font-text-extents ((font freetype-face) string &key (start 0) (end (length string)) translate) ;; -> (width ascent descent left right ;; font-ascent font-descent direction ;; first-not-done) translate - (values - (loop for i from start below end - sum (clim-clx::font-glyph-width font (char-code (aref string i)))) - (clim-clx::font-ascent font) - (clim-clx::font-descent font) - 0 0 - (clim-clx::font-ascent font) - (clim-clx::font-descent font) - 0 end)) + (let ((width (loop for i from start below end + sum (clim-clx::font-glyph-width font (char-code (aref string i)))))) + (values + width + (clim-clx::font-ascent font) + (clim-clx::font-descent font) + (clim-clx::font-glyph-left font (char-code (char string start))) + (- width (- (clim-clx::font-glyph-width font (char-code (char string (1- end)))) + (clim-clx::font-glyph-right font (char-code (char string (1- end)))))) + (clim-clx::font-ascent font) + (clim-clx::font-descent font) + 0 end))) (defun drawable-picture (drawable) (or (getf (xlib:drawable-plist drawable) 'picture) @@ -373,6 +384,47 @@ font-ascent font-descent direction first-not-done)) (values width (+ ascent descent) width 0 ascent)) )))))) ) + +(defmethod climi::text-bounding-rectangle* + ((medium clx-medium) string &key text-style (start 0) end) + (when (characterp string) + (setf string (make-string 1 :initial-element string))) + (unless end (setf end (length string))) + (unless text-style (setf text-style (medium-text-style medium))) + (let ((xfont (text-style-to-X-font (port medium) text-style))) + (cond ((= start end) + (values 0 0 0 0)) + (t + (let ((position-newline (position #\newline string :start start))) + (cond ((not (null position-newline)) + (multiple-value-bind (width ascent descent left right + font-ascent font-descent direction + first-not-done) + (font-text-extents xfont string + :start start :end position-newline + :translate #'translate) + (declare (ignorable left right + font-ascent font-descent + direction first-not-done)) + (multiple-value-bind (minx miny maxx maxy) + (climi::text-bounding-rectangle* + medium string :text-style text-style + :start (1+ position-newline) :end end) + (values (min minx left) (- ascent) + (max maxx right) (+ descent maxy))))) + (t + (multiple-value-bind (width ascent descent left right + font-ascent font-descent direction + first-not-done) + (font-text-extents xfont string + :start start :end end + :translate #'translate) + (declare (ignore width direction first-not-done)) + ;; FIXME: Potential style points: + ;; * (min 0 left), (max width right) + ;; * font-ascent / ascent + (values left (- font-ascent) right font-descent))))))))) + (defmethod make-medium-gcontext* (medium foreground background line-style text-style (ink color) clipping-region) (let* ((drawable (sheet-mirror (medium-sheet medium)))