From 5a283f401c98eee3ffbc6efd6936b698738a49cc Mon Sep 17 00:00:00 2001 From: Andreas Fuchs <asf@boinkor.net> Date: Mon, 7 Sep 2009 16:56:09 +0200 Subject: [PATCH] spr36362: Fix :align-x,-y in the face of text rotation. The text alignment offset is relative to the text baseline, which may be rotated. Change text drawing and bounding box calculation to shift the text after we compute the direction of the baseline. --- ChangeLog.n | 6 ++ tk-silica/xt-graphics.lisp | 210 +++++++++++++++++++------------------ 2 files changed, 114 insertions(+), 102 deletions(-) diff --git a/ChangeLog.n b/ChangeLog.n index 054e37ed..75e74efe 100644 --- a/ChangeLog.n +++ b/ChangeLog.n @@ -3,6 +3,12 @@ don't forget to change the version in utils/packages.lisp if you do anything user visible. ******************************************************************************* +2009-09-07 Andreas Fuchs <afuchs@franz.com> + + * tk-silica/xt-graphics: Make sure that drawing rotated text plays nice with + :align-x and :align-y. These are relative to the text baseline, which may be + rotated, so compute bounding box and text offset after the rotation. + 2009-08-12 Andreas Fuchs <afuchs@franz.com> * clim/tracking-pointer.lisp: Record position info in tracking-pointer-1 diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index b218f8db..27c1f602 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -1496,6 +1496,18 @@ (- end-angle start-angle) filled)))))))) +(defun compute-text-alignment-delta (width height baseline align-x align-y) + (values (ecase align-x + (:right width) + (:center (floor width 2)) + (:left 0)) + (ecase align-y + (:bottom (- height baseline)) + (:center (- (floor height 2) + baseline)) + (:baseline 0) + (:top baseline)))) + (defmethod medium-draw-text* ((medium xt-medium) string-or-char x y start end align-x align-y @@ -1517,113 +1529,107 @@ (unless (zerop last-y) (error "Attempting to draw multi-line using ~S" 'medium-draw-text*)) - (ecase align-x - (:right - (let ((dx width)) - (when towards-x (decf towards-x dx)) - (decf x dx))) - (:center - (let ((dx (floor width 2))) - (when towards-x (decf towards-x dx)) - (decf x dx))) - (:left nil)) - - (ecase align-y - (:bottom - (let ((dy (- height baseline))) - (decf y dy) - (when towards-y (decf towards-y dy)))) - (:center - (let ((dy (- (floor height 2) - baseline))) - (decf y dy) - (when towards-y (decf towards-y dy)))) - (:baseline nil) - (:top - (when towards-y (incf towards-y baseline)) - (incf y baseline))) - - (let ((y-factor 0) - (x-factor 1)) - (when (and towards-x towards-y) - (let ((xxx (- towards-x x)) - (yyy (- towards-y y))) - (cond ((zerop yyy) - (setq y-factor 0) - (setq x-factor (if (minusp xxx) -1 1))) - ((zerop xxx) - (setq x-factor 0) - (setq y-factor (if (minusp yyy) -1 1))) - (t - ;; this branch is rather expensive. - ;; avoid these calls if the calculation is trivial. jpm. - (let ((alpha (atan yyy xxx))) - (setq y-factor (sin alpha)) - (setq x-factor (cos alpha))))))) - (let ((drawable (medium-drawable medium)) - (font (excl:ics-target-case - (:-ics (text-style-mapping port text-style - *all-character-sets*)) - (:+ics (text-style-font-set port text-style))))) - (when drawable - (fix-coordinates x y) - (discard-illegal-coordinates medium-draw-text* x y) - (let ((gc (adjust-ink - (decode-ink (medium-ink medium) medium) - medium - x - (- y height)))) - (if (and towards-x towards-y) - (excl:ics-target-case - (:+ics - (port-draw-rotated-multibyte-text port drawable gc x y string start end - font - towards-x towards-y transform-glyphs)) - (:-ics - (setf (tk::gcontext-font gc) (text-style-mapping port text-style nil)) - (port-draw-rotated-text port drawable gc x y string start end - font towards-x towards-y transform-glyphs))) - (excl:ics-target-case - (:+ics - (tk::draw-multibyte-string drawable font - gc x y string start end)) - (:-ics - (setf (tk::gcontext-font gc) (text-style-mapping port text-style nil)) - (tk::draw-string drawable gc x y string start end)))))) - (let ((dx (* width x-factor)) - (dy (* width y-factor))) - (incf x dx) - (incf y dy) - (when towards-x (incf towards-x dx)) - (when towards-y (incf towards-y dy)))))))) + ;; These two are used to correct the alignment after text has + ;; been rotated: + (multiple-value-bind (left up) + (compute-text-alignment-delta width height baseline align-x align-y) + (let ((y-factor 0) + (x-factor 1)) + (if (and towards-x towards-y) + (let ((xxx (- towards-x x)) + (yyy (- towards-y y))) + (cond ((zerop yyy) ; horizontal (UNTESTED) + (setq y-factor 0) + (setq x-factor (if (minusp xxx) -1 1)) + (setf x (- x (* x-factor left)) + towards-x (- towards-x (* x-factor left)) + y (+ y (* x-factor up)) + towards-y (+ towards-y (* x-factor up)))) + ((zerop xxx) ; vertical + (setq x-factor 0) + (setq y-factor (if (minusp yyy) -1 1)) + (setf y (- y (* y-factor left)) + towards-y (- towards-y (* y-factor left)) + x (- x (* y-factor up)) + towards-x (- towards-x (* y-factor up)))) + (t + ;; this branch is rather expensive. + ;; avoid these calls if the calculation is trivial. jpm. + (let ((alpha (atan yyy xxx))) + (setq y-factor (sin alpha)) + (setq x-factor (cos alpha)))))) + (setf x (- x left) + y (+ y up))) + (let ((drawable (medium-drawable medium)) + (font (excl:ics-target-case + (:-ics (text-style-mapping port text-style + *all-character-sets*)) + (:+ics (text-style-font-set port text-style))))) + (when drawable + (fix-coordinates x y) + (discard-illegal-coordinates medium-draw-text* x y) + (let ((gc (adjust-ink + (decode-ink (medium-ink medium) medium) + medium + x + (- y height)))) + (if (and towards-x towards-y) + (excl:ics-target-case + (:+ics + (port-draw-rotated-multibyte-text port drawable gc x y string start end + font + towards-x towards-y transform-glyphs)) + (:-ics + (setf (tk::gcontext-font gc) (text-style-mapping port text-style nil)) + (port-draw-rotated-text port drawable gc x y string start end + font towards-x towards-y transform-glyphs))) + (excl:ics-target-case + (:+ics + (tk::draw-multibyte-string drawable font + gc x y string start end)) + (:-ics + (setf (tk::gcontext-font gc) (text-style-mapping port text-style nil)) + (tk::draw-string drawable gc x y string start end)))))) + (let ((dx (* width x-factor)) + (dy (* width y-factor))) + (incf x dx) + (incf y dy) + (when towards-x (incf towards-x dx)) + (when towards-y (incf towards-y dy))))))))) (defmethod medium-text-bounding-box ((medium xt-medium) - string x y start end align-x - align-y text-style - towards-x towards-y - transform-glyphs transformation) - (declare (ignore string start end towards-x towards-y align-x align-y - transform-glyphs transformation text-style x y)) + string x y start end align-x + align-y text-style + towards-x towards-y + transform-glyphs transformation) + (declare (ignore towards-x towards-y transform-glyphs transformation x y)) (multiple-value-bind (left top right bottom cx cy towards-x towards-y) (call-next-method) (if (and towards-y towards-x) - (flet ((compute-rotation (cx cy towards-x towards-y) - (decf towards-x cx) - (decf towards-y cy) - (mod (round (atan towards-y towards-x) (/ pi 2.0)) 4))) - (let ((transformation - (make-rotation-transformation - (* (compute-rotation cx cy towards-x - towards-y) - (/ pi 2.0)) - (make-point cx cy)))) - (multiple-value-setq (left top) - (transform-position transformation left top)) - (multiple-value-setq (right bottom) - (transform-position transformation right bottom)) - (values (min left right) (min top bottom) - (max left right) (max top bottom)))) - (values left top right bottom)))) + (flet ((compute-rotation (cx cy towards-x towards-y) + (decf towards-x cx) + (decf towards-y cy) + (mod (round (atan towards-y towards-x) (/ pi 2.0)) 4))) + (let ((transformation + (make-rotation-transformation + (* (compute-rotation cx cy towards-x + towards-y) + (/ pi 2.0)) + (make-point cx cy)))) + (multiple-value-bind (width height last-x last-y baseline) + (text-size medium string :text-style text-style :start start :end end) + (declare (ignore last-x last-y)) + (multiple-value-bind (adjust-left adjust-up) + (compute-text-alignment-delta width height baseline align-x align-y) + (multiple-value-setq (left top) + (transform-position transformation + (- left adjust-left) (+ top adjust-up))) + (multiple-value-setq (right bottom) + (transform-position transformation + (- right adjust-left) (+ bottom adjust-up))))) + (values (min left right) (min top bottom) + (max left right) (max top bottom)))) + (values left top right bottom)))) (defun compute-rotation (x y towards-x towards-y) (decf towards-x x) -- GitLab