[mcclim-cvs] CVS mcclim/Backends/beagle/output
tmoore
tmoore at common-lisp.net
Thu Mar 23 15:27:24 UTC 2006
Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/output
In directory clnet:/tmp/cvs-serv22888/Backends/beagle/output
Modified Files:
fonts.lisp
Log Message:
Changes to get Beagle running with current sources. Various demos 'run' (tested address-book, clim-listener, functional-geometry) but many things aren't working (scroll bars).
--- /project/mcclim/cvsroot/mcclim/Backends/beagle/output/fonts.lisp 2005/05/18 20:21:57 1.2
+++ /project/mcclim/cvsroot/mcclim/Backends/beagle/output/fonts.lisp 2006/03/23 15:27:24 1.3
@@ -200,71 +200,104 @@
;;; All mediums and output sheets must implement a method for this generic function.
-(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)))
-
- ;; 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)))
+;;; Helper that doesn't handle newline
+;;; XXX text-size and text-bounding-rectangle* are both broken because the
+;;; Cocoa NSString function :size-with-attributes is quite buggy. Text
+;;; rendering should be rewritten to use glyphs or ATSUI (a pleasant task I'm
+;;; sure). -- moore
+
+(defun text-size-aux (medium string font start end)
+ ;; See if there's a better way to do this; is this stack allocation?
+ (let ((objc-str (%make-nsstring (subseq string start end))))
+ (slet ((bsize (send objc-str :size-with-attributes
+ (reuse-attribute-dictionary medium font))))
+ (let* ((descender (abs (send font 'descender)))
+ (fragment-width (pref bsize :<NSS>ize.width))
+ (fragment-height (pref bsize :<NSS>ize.height))
+ (fragment-baseline (- fragment-height descender)))
+ (send objc-str 'release)
+ (values fragment-width fragment-height descender fragment-baseline)))))
+
+(defmethod text-size ((medium beagle-medium) (s character)
+ &key (text-style (medium-text-style medium))
+ (start 0)
+ (end 1))
+ (text-size medium (string s) :text-style text-style :start start :end end))
+
+(defmethod text-size ((medium beagle-medium) (string string)
+ &key (text-style (medium-text-style medium))
+ (start 0)
+ ( end (length string)))
+ (declare (special *default-text-style*))
;; Check for 'empty string' case
- (if (>= start end)
- (values 0 0 0 0 0)
- (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))))))))))
+ (when (>= start end)
+ ;; XXX is 0 value for the baseline correct?
+ (return-from text-size (values 0 0 0 0 0)))
+ (let ((position-newline (position #\newline string :start start :end end))
+ (font (%text-style->beagle-font (or text-style *default-text-style*))))
+ (multiple-value-bind
+ (fragment-width fragment-height descender fragment-baseline)
+ (text-size-aux medium string font start (or position-newline end))
+ (declare (ignore descender))
+ (unless position-newline
+ (return-from text-size
+ (values fragment-width fragment-height fragment-width 0
+ fragment-baseline)))
+ (multiple-value-bind (w h x y b)
+ (text-size medium string :text-style text-style
+ :start (1+ 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 y)
+ ;; 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))))))
+
+(defmethod climi::text-bounding-rectangle*
+ ((medium beagle-medium) (s character)
+ &key (text-style (medium-text-style medium))
+ (start 0)
+ (end 1))
+ (climi::text-bounding-rectangle* medium (string s)
+ :text-style text-style :start start :end end))
+
+(defmethod climi::text-bounding-rectangle*
+ ((medium beagle-medium) (s string)
+ &key (text-style (medium-text-style medium))
+ (start 0)
+ (end 1))
+ (declare (special *default-text-style*))
+ ;; Check for 'empty string' case
+ (when (>= start end)
+ (return-from climi::text-bounding-rectangle* (values 0 0 0 0)))
+ (let ((font (%text-style->beagle-font (or text-style *default-text-style*)))
+ (height 0)
+ (width 0)
+ (baseline nil))
+ (loop
+ for line-start = start then (1+ line-end)
+ for line-end = (position #\newline s :start line-start :end end)
+ do (multiple-value-bind
+ (fragment-width fragment-height descender fragment-baseline)
+ (text-size-aux medium s font line-start (or line-end end))
+ (declare (ignore descender))
+ (incf height fragment-height)
+ (setq width (max width fragment-width))
+ (unless baseline
+ (setq baseline fragment-baseline)))
+ while line-end)
+ (values 0 (- baseline) width (- height baseline))))
+
;;; Note: we DO NOT want to draw the fonts in the medium-foreground colour - we want
More information about the Mcclim-cvs
mailing list