[mcclim-cvs] CVS update: mcclim/Experimental/freetype/freetype-fonts.lisp
Christophe Rhodes
crhodes at common-lisp.net
Sat Aug 13 14:28:59 UTC 2005
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)))
More information about the Mcclim-cvs
mailing list