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)))
