Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/output In directory common-lisp.net:/tmp/cvs-serv24418/beagle/output
Modified Files: fonts.lisp medium.lisp Log Message: Rewrote font metrics code; bounding rectangles around text now look much better. Unfortunately there doesn't seem to be a way not to include Cocoa's own 'leading' in the font metrics, which means the linegap is larger than it needs to be. This can be resolved with a move to 10.4 (new constants in NSStringAdditions to control this). Rejigged the drawing methods somewhat so the 'thinnest visible line' gets displayed which makes bounding rects look better. Artefacts less obvious (but still present )-:) now.
Date: Wed May 18 22:21:57 2005 Author: drose
Index: mcclim/Backends/beagle/output/fonts.lisp diff -u mcclim/Backends/beagle/output/fonts.lisp:1.1 mcclim/Backends/beagle/output/fonts.lisp:1.2 --- mcclim/Backends/beagle/output/fonts.lisp:1.1 Tue May 17 00:13:19 2005 +++ mcclim/Backends/beagle/output/fonts.lisp Wed May 18 22:21:57 2005 @@ -122,26 +122,43 @@ ;;; performance. It's possible that the caching can be improved. Caching doesn't adversly ;;; affect performance though so it's staying in.
+#|| +origin 0.0 + 0.0+------------------------+ + | ^ ^ | + | |height |ascent | + | | | width | + |<|-------|------------->| + | | v | + 12.0 +-|----------------------+ + | | ^descent | + | v v | + 15.0 +------------------------+ + +Baseline = 12.0 +Height = 15.0 == height +Ascent = 12.0 == (height - (height - baseline)) == baseline +Descent = 3.0 == (height - ascent) == (height - baseline) +Width = width +||# + (defun beagle-font-metrics (metric text-style medium &optional (char nil)) "Metric is one of :ascent :descent :width :height" - (declare (ignore medium)) ; for now... - (when char - (setf char (format nil "~a" char))) - (let* ((key (if char (cons text-style char) text-style)) + (declare (special *beagle-font-metrics*)) + (let* ((string (if char + (string char) + "m")) + (key (cons text-style string)) ; possible to avoid consing? (metrics (gethash key *beagle-font-metrics*))) (when (null metrics) - ;; No metrics found in the hashtable; lookup the font and representative character, - ;; and populate the hashtable. - (let ((nsfont (%text-style->beagle-font (or text-style *default-text-style*))) - (representative (if char (%make-nsstring char) #@"m"))) - ;; populate metrics, and the hashtable, accordingly with width, - ;; height, ascent, descent of text-style. - ;; Should the height actually be ascent + descent? Probably want to (abs) the descender too... - (setf metrics (list `(:ascent . ,(send nsfont 'ascender)) - `(:descent . ,(abs (send nsfont 'descender))) - `(:width . ,(send nsfont :width-of-string representative)) - `(:height . ,(send nsfont 'default-line-height-for-font)))) - (setf (gethash key *beagle-font-metrics*) metrics))) + (multiple-value-bind (width height x y baseline) + (text-size medium string :text-style text-style) + (declare (ignore x y)) + (setf metrics (list `(:ascent . ,baseline) + `(:descent . ,(- height baseline)) + `(:width . ,width) + `(:height . ,height)))) + (setf (gethash key *beagle-font-metrics*) metrics)) (cdr (assoc metric metrics))))
@@ -183,45 +200,76 @@
;;; All mediums and output sheets must implement a method for this generic function.
-;;; This is the primary method McCLIM uses to lay out text, so we have to get it right... -;;; Spec says for STREAMS (and the text WILL be output in a "stream") the origin is in the TOP LEFT -;;; corner (graft :default orientation). Cocoa assumes everything uses an orign in the BOTTOM LEFT -;;; corner (graft :graphics orientation). We calculate the size the way CLIM wants it calculated, -;;; and hope this means CLIM can lay everything out properly. - -;;; TODO: what is the meaning of START and END? Not the boundaries of a -;;; substring whose size is to be determined; the logic below -;;; ignores such possibilities - (defmethod text-size ((medium beagle-medium) string &key text-style (start 0) end) + (declare (special *default-text-style*)) + + ;; Method can be passed either a string or a char; make sure for the latter + ;; that we see only strings. (when (characterp string) (setf string (string string))) - (unless end (setf end (length string))) - (unless text-style (setf text-style (medium-text-style medium))) - (if (= start end) + + ;; Make sure there's an 'end' specified + (unless end + (setf end (length string))) + + ;; Make sure there's a text-style + (unless text-style + (setf text-style (medium-text-style medium))) + + ;; Check for 'empty string' case + (if (>= start end) (values 0 0 0 0 0) - (let (;(position-newline (position #\newline string :start start)) - (objc-string (%make-nsstring (subseq string start end))) - (beagle-font (%text-style->beagle-font (or text-style *default-text-style*)))) - ;; Now we actually need to take the font into account! - (slet ((bsize (send objc-string :size-with-attributes (reuse-attribute-dictionary medium beagle-font)))) - (values (pref bsize :<NSS>ize.width) ; width - (pref bsize :<NSS>ize.height) ; height - (pref bsize :<NSS>ize.width) ; new x - ;; new y - (- (pref bsize :<NSS>ize.height) (send beagle-font 'default-line-height-for-font)) - ;; baseline - assume linegap is equal above + below the font... - ;; baseline is at (- height (1/2 linegap) descender) - (- (pref bsize :<NSS>ize.height) (/ (- (send beagle-font 'default-line-height-for-font) - (send beagle-font 'ascender) - (abs (send beagle-font 'descender))) - 2) - (abs (send beagle-font 'descender)))))))) - - -;;; Note: we DO NOT want to draw the fonts in the medium-foreground colour - we want to draw them in a specific -;;; colour (unless McCLIM sets the medium foreground colour in order to achieve drawing elements in specific -;;; colours). + (let ((position-newline (position #\newline string :start start)) + ;; See if there's a better way to do this; is this stack + ;; allocation? + (objc-str (%make-nsstring (subseq string start end))) + (font (%text-style->beagle-font (or text-style + *default-text-style*)))) + (slet ((bsize (send objc-str :size-with-attributes + (reuse-attribute-dictionary medium font)))) + ;; Don't use 'text-style-descent' in the following, since that + ;; method is defined in terms of this one :-) + (let* ((descender (abs (send font 'descender))) + (fragment-width (pref bsize :<NSS>ize.width)) + (fragment-height (pref bsize :<NSS>ize.height)) + (fragment-x (pref bsize :<NSS>ize.width)) + ;; subtract line height from this later... + (fragment-y (pref bsize :<NSS>ize.height)) + ;; baseline = height - descender + (fragment-baseline (- fragment-height descender))) + (send objc-str 'release) + (if (null position-newline) + (values fragment-width + fragment-height + fragment-x + (- fragment-y fragment-height) + fragment-baseline) + (progn + (multiple-value-bind (w h x y b) + (text-size medium string :text-style text-style + :start position-newline + :end end) + ;; Current width, or width of sub-fragment, whichever + ;; is larger + (let ((largest-width (max fragment-width w)) + ;; current height + height of sub-fragment + (current+fragment-height (+ fragment-height h)) + ;; new y position; one line height smaller than the + ;; total height + (y-position (- (+ fragment-y y) fragment-height)) + ;; baseline of string; total height - baseline size, where + ;; baseline 'size' is (line-height - baseline). + (baseline (- (+ fragment-height h) (- h b)))) + (values largest-width + current+fragment-height + x ; always use last x calculated... + y-position + baseline)))))))))) + + +;;; Note: we DO NOT want to draw the fonts in the medium-foreground colour - we want +;;; to draw them in a specific colour (unless McCLIM sets the medium foreground colour +;;; in order to achieve drawing elements in specific colours).
(let ((reusable-dict nil)) ;; create a mutable dictionary on-demand and reuse it
Index: mcclim/Backends/beagle/output/medium.lisp diff -u mcclim/Backends/beagle/output/medium.lisp:1.1 mcclim/Backends/beagle/output/medium.lisp:1.2 --- mcclim/Backends/beagle/output/medium.lisp:1.1 Tue May 17 00:13:19 2005 +++ mcclim/Backends/beagle/output/medium.lisp Wed May 18 22:21:57 2005 @@ -577,12 +577,44 @@ (do-sequence ((left top right bottom) coord-seq) (when (< right left) (rotatef left right)) (when (< top bottom) (rotatef top bottom)) - (let ((rect (ccl::make-ns-rect left bottom (- right left) (- top bottom)))) + (let ((rect (ccl::make-ns-rect (pixel-center left) + (pixel-center bottom) + (pixel-count (- right left)) + (pixel-count (- top bottom))))) (send path :append-bezier-path-with-rect rect))) (if filled (send mirror :fill-path path :in-colour colour) (send mirror :stroke-path path :in-colour colour))))))
+;; ::FIXME:: Move these from here! +(defun pixel-center (pt) +"Ensure any ordinate provided sits on the center of a pixel. This +prevents Cocoa from 'antialiasing' lines, making them thicker and +a shade of grey. Ensures the return value is a short-float, as +required by the Cocoa methods." +;; Interesting... I thought 'center of pixel' was 0.5, 1.5, ... n.5 +;; but this works much better with 0.0, 1.0, 2.0... +;; (coerce (+ (round-coordinate pt) 0.5) 'short-float)) + (coerce (round-coordinate pt) 'short-float)) + +(defun pixel-count (sz) +"Ensures any value provided is rounded to the nearest unit, and +returned as a short-float as required by the Cocoa methods." + (coerce (round-coordinate sz) 'short-float)) + +;;; Nabbed from CLX backend medium.lisp +(declaim (inline round-coordinate)) +(defun round-coordinate (x) + "Function used for rounding coordinates: + +We use "mercantile rounding", instead of the CL round to nearest +even number, when in doubt. + +Reason: As the CLIM drawing model is specified, you quite often +want to operate with coordinates, which are multiples of 1/2. +Using CL:ROUND gives "random" results. Using "mercantile +rounding" gives consistent results." + (floor (+ x .5)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -620,8 +652,10 @@ (origin-y (- center-y radius-dy)) (width (* 2 radius-dx)) (height (* 2 radius-dy))) - (send path :append-bezier-path-with-oval-in-rect (ccl::make-ns-rect origin-x origin-y - width height)) + (send path :append-bezier-path-with-oval-in-rect (ccl::make-ns-rect (pixel-center origin-x) + (pixel-center origin-y) + (pixel-count width) + (pixel-count height))) (if filled (send mirror :fill-path path :in-colour colour) (send mirror :stroke-path path :in-colour colour)))))) @@ -632,10 +666,10 @@ (let ((tr (sheet-native-transformation (medium-sheet medium)))) (with-beagle-graphics (medium) (with-transformed-position (tr center-x center-y) - (slet ((point (ns-make-point (coerce center-x 'short-float) - (coerce center-y 'short-float)))) + (slet ((point (ns-make-point (pixel-center center-x) + (pixel-center center-y)))) (send path :append-bezier-path-with-arc-with-center point - :radius (coerce radius 'short-float) + :radius (pixel-count radius) :start-angle (coerce (/ start-angle (/ pi 180)) 'short-float) :end-angle (coerce (/ end-angle (/ pi 180)) 'short-float) :clockwise NIL))) @@ -683,10 +717,10 @@ (with-beagle-graphics (medium) (with-transformed-position (tr x1 y1) (with-transformed-position (tr x2 y2) - (slet ((p1 (ns-make-point (+ (coerce x1 'short-float) 0.5) - (+ (coerce y1 'short-float) 0.5))) - (p2 (ns-make-point (+ (coerce x2 'short-float) 0.5) - (+ (coerce y2 'short-float) 0.5)))) + (slet ((p1 (ns-make-point (pixel-center x1) + (pixel-center y1))) + (p2 (ns-make-point (pixel-center x2) + (pixel-center y2)))) (send path :move-to-point p1) (send path :line-to-point p2) (send mirror :stroke-path path :in-colour colour))))))) @@ -706,10 +740,10 @@ (with-transformed-positions ((sheet-native-transformation (medium-sheet medium)) coord-seq) (with-beagle-graphics (medium) (do-sequence ((x1 y1 x2 y2) coord-seq) - (slet ((p1 (ns-make-point (+ (coerce x1 'short-float) 0.5) - (+ (coerce y1 'short-float) 0.5))) - (p2 (ns-make-point (+ (coerce x2 'short-float) 0.5) - (+ (coerce y2 'short-float) 0.5)))) + (slet ((p1 (ns-make-point (pixel-center x1) + (pixel-center y1))) + (p2 (ns-make-point (pixel-center x2) + (pixel-center y2)))) (send path :move-to-point p1) (send path :line-to-point p2))) (send mirror :stroke-path path :in-colour colour)))) @@ -731,13 +765,13 @@ (when (< top bottom) (rotatef top bottom)) (when (and filled (or (typep ink 'climi::transformed-design) (typep ink 'climi::indexed-pattern))) - (send mirror :draw-image colour :at-point (ns-make-point (coerce left 'short-float) - (coerce top 'short-float))) + (send mirror :draw-image colour :at-point (ns-make-point (pixel-center left) + (pixel-center top))) (return-from medium-draw-rectangle* (values))) - (send path :append-bezier-path-with-rect (ccl::make-ns-rect (coerce left 'short-float) - (coerce bottom 'short-float) - (coerce (- right left) 'short-float) - (coerce (- top bottom) 'short-float))) + (send path :append-bezier-path-with-rect (ccl::make-ns-rect (pixel-center left) + (pixel-center bottom) + (pixel-count (- right left)) + (pixel-count (- top bottom)))) (if filled (send mirror :fill-path path :in-colour colour) (send mirror :stroke-path path :in-colour colour))))))) @@ -757,12 +791,12 @@ (assert (evenp (length coord-seq))) (with-transformed-positions ((sheet-native-transformation (medium-sheet medium)) coord-seq) (with-beagle-graphics (medium) - (send path :move-to-point (ns-make-point (coerce (elt coord-seq 0) 'short-float) - (coerce (elt coord-seq 1) 'short-float))) + (send path :move-to-point (ns-make-point (pixel-center (elt coord-seq 0)) + (pixel-center (elt coord-seq 1)))) (do ((count 2 (+ count 2))) ((> count (1- (length coord-seq)))) - (slet ((pt (ns-make-point (coerce (elt coord-seq count) 'short-float) - (coerce (elt coord-seq (1+ count)) 'short-float)))) + (slet ((pt (ns-make-point (pixel-center (elt coord-seq count)) + (pixel-center (elt coord-seq (1+ count)))))) (send path :line-to-point pt))) ;; ensure polyline joins up if appropriate. This needs to be done after ;; all points have been set in the bezier path. @@ -799,18 +833,22 @@ (multiple-value-bind (text-width text-height x-cursor y-cursor baseline) (text-size medium string :start start :end end) (declare (ignore x-cursor y-cursor)) - (setf x (+ (- x (ecase align-x - (:left 0) - (:center (round text-width 2)) - (:right text-width)) 0.5))) - (setf y (+ (ecase align-y - (:top (- y text-height)) - (:center (- y (floor text-height 2))) - (:baseline (- y baseline)) - (:bottom y)) 0.5)) + (setf x (- x (ecase align-x + (:left 0) + (:center (round text-width 2)) + (:right text-width)))) + (setf y (ecase align-y +;;; (:top (- y text-height)) + (:top y) + (:center (- y (floor text-height 2))) + (:baseline (- y baseline)) +;;; (:bottom y))) + (:bottom (- y text-height)))) (slet ((point (ns-make-point (coerce x 'short-float) (coerce y 'short-float)))) (let ((objc-string (%make-nsstring (subseq string start end)))) + ;; NB: draw-string-at-point uses upper-left as origin in a flipped + ;; view. (send mirror :draw-string objc-string :at-point point :with-attributes (reuse-attribute-dictionary medium font :colour colour)