backends: further cleanup of text-bounding-rectangle* api

5 files changed, 48 insertions, 91 deletions

diff --git a/Backends/PostScript/font/font.lisp b/Backends/PostScript/font/font.lisp
index 95526b91..fdb90872 100644
--- a/Backends/PostScript/font/font.lisp
+++ b/Backends/PostScript/font/font.lisp
@@ -14,9 +14,8 @@
 
 (in-package #:clim-postscript-font)
 
-(defclass postscript-font-medium (basic-medium climb:approx-bbox-medium-mixin)
-  ((device-fonts :initform nil
-                 :accessor device-fonts)))
+(defclass postscript-font-medium (basic-medium)
+  ((device-fonts :initform nil :accessor device-fonts)))
 
 (defclass postscript-font-port (basic-port) ())
 
@@ -178,9 +177,9 @@
 
 (defmethod climb:text-bounding-rectangle*
     ((medium postscript-font-medium) string
-     &key text-style (start 0) end align-x align-y direction
+     &key text-style (start 0) end (align-x :left) (align-y :baseline) direction
      &aux (string (string string)))
-  (declare (ignore align-x align-y direction))
+  (declare (ignore direction))
   (climi::orf end (length string))
   (when (>= start end)
     (return-from climb:text-bounding-rectangle*
@@ -194,23 +193,16 @@
          (metrics-key (font-name-metrics-key font-name))
          (size (font-name-size font-name))
          (scale (float (/ size 1000))))
-    (flet ((text-extents (start end)
-             (multiple-value-bind (width ascent descent left right
-                                   font-ascent font-descent
-                                   direction first-not-done)
-                 (psfont-text-extents metrics-key string
-                                      :start start :end end)
-               (declare (ignore width font-ascent font-descent direction
-                                first-not-done))
-               (if (< descent ascent)
-                   (values left descent right ascent)
-                   (values left ascent  right descent)))))
-      (multiple-value-bind (minx miny maxx maxy)
-          (text-extents start end)
-        (values (* scale minx)
-                (* scale miny)
-                (* scale maxx)
-                (* scale maxy))))))
+    (multiple-value-bind (width ymin ymax xmin xmax
+                          font-ascent font-descent
+                          direction first-not-done)
+        (psfont-text-extents metrics-key string :start start :end end)
+      (declare (ignore width font-ascent font-descent direction first-not-done))
+      (climb:align-bounding-rectangle (* scale xmin)
+                                      (* scale ymin)
+                                      (* scale xmax)
+                                      (* scale ymax)
+                                      align-x align-y))))
 
 (defun psfont-text-extents (metrics-key string &key (start 0) (end (length string)))
   (let* ((font-info (or (gethash metrics-key *font-metrics*)
diff --git a/Backends/common/medium.lisp b/Backends/common/medium.lisp
index 9692045c..ffce4e7d 100644
--- a/Backends/common/medium.lisp
+++ b/Backends/common/medium.lisp
@@ -17,43 +17,30 @@
       (compose-transformations (medium-device-transformation medium)
                                (draw-text-rotation* x y toward-x toward-y))))
 
-;; For multiline text alignment may change the bbox. For instance longest line
-;; may start with a character with left-bearing=0 and shorter line starts with a
-;; character which has left-bearing=-10. If text is left-aligned then bbox
-;; starts from coordinate x=-10, but if text is right-aligned it is x=0. This
-;; mixin provides decent adjustment for alignment for simpler algorithms. Method
-;; is not pixel-perfect hence it should be used sparingly for early prototypes.
-(defclass approx-bbox-medium-mixin () ()
-  (:documentation "Adjusts bounding rectangle to alignment with a decent heuristic."))
-
-(defmethod text-bounding-rectangle* :around
-    ((medium approx-bbox-medium-mixin) string &key text-style start end
-                                                (align-x :left)
-                                                (align-y :baseline)
-                                                (direction :ltr))
-  (declare (ignore start end direction))
-  (multiple-value-bind (left top right bottom) (call-next-method)
-    (let ((width (- right left)))
-      (ecase align-x
-        (:left)
-        (:right
-         (decf left width)
-         (decf right width))
-        (:center
-         (decf left (/ width 2.0s0))
-         (decf right (/ width 2.0s0)))))
-    (let ((ascent (text-style-ascent text-style medium))
-          (descent (text-style-descent text-style medium))
-          (height (- bottom top)))
-      (ecase align-y
-        (:baseline)
-        (:top
-         (setf top (- ascent (abs top))
-               bottom (+ top height)))
-        (:bottom
-         (decf top bottom)
-         (decf bottom bottom))
-        (:center
-         (setf top (- (/ height 2.0s0)))
-         (setf bottom (/ height 2.0s0)))))
-    (values left top right bottom)))
+;;; The baseline is assumed to be at y=0.
+(defun align-bounding-rectangle (xmin ymin xmax ymax align-x align-y)
+  (ecase align-x
+    (:left)
+    (:center
+     (let ((hcenter (/ (- xmax xmin) 2)))
+       (setf xmin (- hcenter))
+       (setf xmax (+ hcenter))))
+    (:right
+     (let ((hsize (- xmax xmin)))
+       (setf xmin (- hsize))
+       (setf xmax 0))))
+  (ecase align-y
+    (:top
+     (let ((vsize (- ymax ymin)))
+       (setf ymin 0)
+       (setf ymax vsize)))
+    (:center
+     (let ((vcenter (/ (- ymax ymin) 2)))
+       (setf ymin (- vcenter))
+       (setf ymax (+ vcenter))))
+    (:baseline)
+    (:bottom
+     (let ((vsize (- ymax ymin)))
+       (setf ymin (- vsize))
+       (setf ymax 0))))
+  (values xmin ymin xmax ymax))
diff --git a/Core/system/packages.lisp b/Core/system/packages.lisp
index 10f33bbf..52334eb1 100644
--- a/Core/system/packages.lisp
+++ b/Core/system/packages.lisp
@@ -2094,10 +2094,11 @@
    #:text-bounding-rectangle*
    #:normalize-font-size
    #:parse-text-style*
-   ;; Mixins available for backends
-   #:multiline-text-medium-mixin
-   #:approx-bbox-medium-mixin
+   ;; Mixins and helpers available for backends
    #:transform-coordinates-mixin
+   #:draw-text-rotation*
+   #:medium-text-transformation*
+   #:align-bounding-rectangle
    ;; From CLIM (mentioned in the spec)
    #:adopt-frame
    #:allocate-space
diff --git a/Extensions/fonts/mcclim-native-ttf.lisp b/Extensions/fonts/mcclim-native-ttf.lisp
index aa438497..d5fd9b09 100644
--- a/Extensions/fonts/mcclim-native-ttf.lisp
+++ b/Extensions/fonts/mcclim-native-ttf.lisp
@@ -360,30 +360,8 @@ but argument must constitute exactly one character."
              (incf origin-x (font-glyph-dx font code))
              (incf origin-y (font-glyph-dy font code))))
       (map-over-string-glyph-codes #'process-code string start end)
-      (ecase align-x
-        (:left)
-        (:center
-         (let ((hcenter (/ (- xmax xmin) 2)))
-           (setf xmin (- hcenter))
-           (setf xmax (+ hcenter))))
-        (:right
-         (let ((hsize (- xmax xmin)))
-           (setf xmin (- hsize))
-           (setf xmax 0))))
-      (ecase align-y
-        (:top
-         (let ((vsize (- ymax ymin)))
-           (setf ymin 0)
-           (setf ymax vsize)))
-        (:center
-         (let ((vcenter (/ (- ymax ymin) 2)))
-           (setf ymin (- vcenter))
-           (setf ymax (+ vcenter))))
-        (:baseline)
-        (:bottom
-         (let ((vsize (- ymax ymin)))
-           (setf ymin (- vsize))
-           (setf ymax 0))))
+      (multiple-value-setq (xmin ymin xmax ymax)
+        (climb:align-bounding-rectangle xmin ymin xmax ymax align-x align-y))
       (values xmin ymin xmax ymax origin-x origin-y))))
 
 (defun font-text-extents (font string &key start end align-x align-y direction)
diff --git a/Extensions/render/package.lisp b/Extensions/render/package.lisp
index da1f0e8b..32276918 100644
--- a/Extensions/render/package.lisp
+++ b/Extensions/render/package.lisp
@@ -49,5 +49,4 @@
                 #:medium-native-transformation
                 #:medium-device-transformation
                 #:medium-native-region
-                #:medium-device-region
-                #:multiline-text-medium-mixin))
+                #:medium-device-region))