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 11 Aug 2005 14:07:26 -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)) @@ -1837,8 +1836,11 @@ ((text-record standard-text-displayed-output-record)) (with-standard-rectangle* (:x1 x1 :y1 y1) text-record - (with-slots (width max-height) + (with-slots (width max-height start-x) text-record + (when (< start-x x1) + (setq width (+ width (- x1 start-x)))) + (setq x1 start-x) (setf (rectangle-edges* text-record) (values x1 y1 (coordinate (+ x1 width)) @@ -1848,7 +1850,7 @@ (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 start-x start-y end-x end-y medium) text-record (if (and strings (let ((string (last1 strings))) @@ -1869,6 +1871,8 @@ :adjustable t :fill-pointer t))))) (setq baseline (max baseline new-baseline) + start-x (min start-x (+ end-x (text-bounding-rectangle* + medium character :text-style text-style))) end-x (+ end-x char-width) max-height (max max-height height) end-y (max end-y (+ start-y max-height)) @@ -1886,7 +1890,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 start-x start-y end-x end-y medium) text-record (let ((styled-string (make-instance @@ -1902,6 +1906,7 @@ (replace (styled-string-string styled-string) string :start2 start :end2 end)) (setq baseline (max baseline new-baseline) + start-x (min start-x (+ end-x (text-bounding-rectangle* medium string :text-style text-style :start start :end end))) end-x (+ end-x string-width) max-height (max max-height height) end-y (max end-y (+ start-y max-height)) 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 11 Aug 2005 14:07:26 -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 11 Aug 2005 14:07:26 -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 11 Aug 2005 14:07:26 -0000 @@ -160,7 +160,8 @@ :y-origin top :x-advance dx :y-advance dy) - (list glyph-id dx dy)))) + (let ((right (- dy 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)))