diff --git a/ChangeLog.n b/ChangeLog.n index 054e37ed187687c1d329b12c9d742c6975dc88ac..75e74efe253cd8c180572bb5fe0766456b57d7af 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 b218f8dbd28af644c072fb9d0bd1b171ca3dc2c6..27c1f602d19fdd78dcfc768e6ea4e34a51753a9f 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)