Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory common-lisp.net:/tmp/cvs-serv4334/Experimental/freetype
Modified Files: freetype-fonts.lisp Log Message: Commit working version of text-bounding-rectangle* stuff, as trailed on mcclim-devel 2005-08-12. Basically, this is needed because the drawn area for left-to-right text need not lie between (x,y-ascent) and (x+width,y+descent). (No doubt other text drawing directions suffer from the same problem, but they're not yet implemented in McCLIM).
New per-medium function TEXT-BOUNDING-RECTANGLE* which actually returns the bounding-rectangle* of what is drawn (cf. TEXT-WIDTH, which doesn't do anything of the sort). Use it in DEF-GRECORDING DRAW-TEXT, and in add-{string,character}-to-output-record, to properly adjust the output record coordinates. While we're at it, fix the bounding box for :y-align :center DRAW-TEXT.
Implement this per-medium function for the CLX backend, for the experimental freetype text handling, and for postscript (tested using Climacs, Tabcode and clim-demo::postscript-text). This patch was mostly motivated by the observation that incremental redisplay in climacs windows using the freetype backend caused graphical artifacts to appear over time, thanks to glyphs drawing outside the output record bounding rectangles.
Breaks: * CLX backend with #+unicode (clisp?) * Beagle backend * OpenGL backend (please fix!)
Date: Sat Aug 13 16:28:34 2005 Author: crhodes
Index: mcclim/Experimental/freetype/freetype-fonts.lisp diff -u mcclim/Experimental/freetype/freetype-fonts.lisp:1.10 mcclim/Experimental/freetype/freetype-fonts.lisp:1.11 --- mcclim/Experimental/freetype/freetype-fonts.lisp:1.10 Fri Jul 29 08:50:20 2005 +++ mcclim/Experimental/freetype/freetype-fonts.lisp Sat Aug 13 16:28:33 2005 @@ -160,7 +160,8 @@ :y-origin top :x-advance dx :y-advance dy) - (list glyph-id dx dy)))) + (let ((right (+ 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)))