April 2006 - mcclim-cvs@common-lisp.net - mailman3.common-lisp.net

[mcclim-cvs] CVS mcclim
by afuchs 22 Apr '06

22 Apr '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv32675 Modified Files: incremental-redisplay.lisp Log Message: Back out the spatial-trees change to compute-difference-set. --- /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 23:25:23 1.59 +++ /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/22 15:31:27 1.60 @@ -754,12 +754,12 @@ ;; (declare (values erases moves draws erase-overlapping move-overlapping)) (let (was is + stay come (everywhere (or +everywhere+ (pane-viewport-region (updating-output-stream record)))) (was-table (make-hash-table :test #'equalp)) - (is-table (make-hash-table :test #'equalp)) - (stay-tree (%make-tree-output-record-tree))) + (is-table (make-hash-table :test #'equalp))) (labels ((collect-1-was (record) (push record was) @@ -771,14 +771,12 @@ ;; stay = is ^ was (cond ((updating-output-record-p record) (if (eq :clean (output-record-dirty record)) - (spatial-trees:insert - (make-tree-output-record-entry record 0) stay-tree) + (push record stay) (push record come))) (t (let ((q (gethash (output-record-hash record) was-table))) (if (some #'(lambda (x) (output-record-equal record x)) q) - (spatial-trees:insert - (make-tree-output-record-entry record 0) stay-tree) + (push record stay) (push record come))))))) ;; Collect what was there (labels ((gather-was (record) @@ -829,15 +827,15 @@ (when check-overlapping (setf (values gone gone-overlap) (loop for k in gone - if (spatial-trees:search (%record-to-spatial-tree-rectangle k) - stay-tree) + if (some (lambda (x) (region-intersects-region-p k x)) + stay) collect (list k k) into gone-overlap* else collect (list k k) into gone* finally (return (values gone* gone-overlap*)))) (setf (values come come-overlap) (loop for k in come - if (spatial-trees:search (%record-to-spatial-tree-rectangle k) - stay-tree) + if (some (lambda (x) (region-intersects-region-p k x)) + stay) collect (list k k) into come-overlap* else collect (list k k) into come* finally (return (values come* come-overlap*)))))

1 0

[mcclim-cvs] CVS mcclim
by crhodes 21 Apr '06

21 Apr '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv30320 Modified Files: commands.lisp Log Message: the command-table-error subclasses must handle :format-control and :format-arguments. Make it so, and test for it (and also test that not passing them doesn't lead to an unprintable condition. New test file input-editing, for an invariant I spotted while browsing. --- /project/mcclim/cvsroot/mcclim/commands.lisp 2006/03/23 17:03:38 1.61 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2006/04/21 12:03:23 1.62 @@ -95,8 +95,9 @@ (defparameter *command-tables* (make-hash-table :test #'eq)) -(define-condition command-table-error (error) - ()) +(define-condition command-table-error (simple-error) + () + (:default-initargs :format-control "" :format-arguments nil)) (define-condition command-table-not-found (command-table-error) ())

1 0

[mcclim-cvs] CVS mcclim/Tests
by crhodes 21 Apr '06

21 Apr '06

Update of /project/mcclim/cvsroot/mcclim/Tests In directory clnet:/tmp/cvs-serv30320/Tests Modified Files: commands.lisp Added Files: input-editing.lisp Log Message: the command-table-error subclasses must handle :format-control and :format-arguments. Make it so, and test for it (and also test that not passing them doesn't lead to an unprintable condition. New test file input-editing, for an invariant I spotted while browsing. --- /project/mcclim/cvsroot/mcclim/Tests/commands.lisp 2006/03/23 17:03:40 1.3 +++ /project/mcclim/cvsroot/mcclim/Tests/commands.lisp 2006/04/21 12:03:23 1.4 @@ -50,3 +50,23 @@ 'removal-test-table) (command-not-present () t) (:no-error (x) (declare (ignore x)) nil))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; command table errors (see 27.2) +(assert (subtypep 'command-table-error 'error)) +(assert (subtypep 'command-table-not-found 'command-table-error)) +(assert (subtypep 'command-table-already-exists 'command-table-error)) +(assert (subtypep 'command-not-present 'command-table-error)) +(assert (subtypep 'command-not-accessible 'command-table-error)) +(assert (subtypep 'command-already-present 'command-table-error)) + +(let ((condition (make-condition 'command-table-error + :format-control "~A" + :format-arguments '(!)))) + (assert (find #\! (format nil "~A" condition)))) +;;; not actually required to DTRT here, but we use this form (without +;;; control and arguments) internally, so make sure that we don't +;;; error out recursively when in the debugger with one of these. +(let ((condition (make-condition 'command-not-present))) + (format nil "~A" condition)) --- /project/mcclim/cvsroot/mcclim/Tests/input-editing.lisp 2006/04/21 12:03:23 NONE +++ /project/mcclim/cvsroot/mcclim/Tests/input-editing.lisp 2006/04/21 12:03:23 1.1 (defpackage :clim-tests (:use :clim-lisp :clim)) (in-package :clim-tests) (assert (null *activation-gestures*))

1 0

[mcclim-cvs] CVS mcclim
by afuchs 20 Apr '06

20 Apr '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv26160 Modified Files: incremental-redisplay.lisp Log Message: Remove the STAY list for good from c-d-set. Agh. Save your buffers before committing. Sorry for the commits spam. --- /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 23:21:35 1.58 +++ /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 23:25:23 1.59 @@ -754,7 +754,6 @@ ;; (declare (values erases moves draws erase-overlapping move-overlapping)) (let (was is - stay come (everywhere (or +everywhere+ (pane-viewport-region (updating-output-stream record)))) @@ -772,7 +771,8 @@ ;; stay = is ^ was (cond ((updating-output-record-p record) (if (eq :clean (output-record-dirty record)) - (push record stay) + (spatial-trees:insert + (make-tree-output-record-entry record 0) stay-tree) (push record come))) (t (let ((q (gethash (output-record-hash record) was-table)))

1 0

[mcclim-cvs] CVS mcclim
by afuchs 20 Apr '06

20 Apr '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv25992 Modified Files: incremental-redisplay.lisp Log Message: Big O changes, this time. Some more constant factors, too. * Use a spatial tree for the "stay" records and query it. Note that I said "changes", not improvements. It's 1:30 in the morning, so I'll leave the benchmarking to others. (: * Also, build the list of gone-overlap, come-overlap, come and gone records "right" the first time around, so we can just return it unmodified, without having to mapcar (list x x) over them first. --- /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 22:53:15 1.57 +++ /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 23:21:35 1.58 @@ -759,7 +759,8 @@ (everywhere (or +everywhere+ (pane-viewport-region (updating-output-stream record)))) (was-table (make-hash-table :test #'equalp)) - (is-table (make-hash-table :test #'equalp))) + (is-table (make-hash-table :test #'equalp)) + (stay-tree (%make-tree-output-record-tree))) (labels ((collect-1-was (record) (push record was) @@ -776,7 +777,8 @@ (t (let ((q (gethash (output-record-hash record) was-table))) (if (some #'(lambda (x) (output-record-equal record x)) q) - (push record stay) + (spatial-trees:insert + (make-tree-output-record-entry record 0) stay-tree) (push record come))))))) ;; Collect what was there (labels ((gather-was (record) @@ -827,29 +829,28 @@ (when check-overlapping (setf (values gone gone-overlap) (loop for k in gone - if (some (lambda (x) (region-intersects-region-p k x)) - stay) - collect k into gone-overlap* - else collect k into gone* + if (spatial-trees:search (%record-to-spatial-tree-rectangle k) + stay-tree) + collect (list k k) into gone-overlap* + else collect (list k k) into gone* finally (return (values gone* gone-overlap*)))) (setf (values come come-overlap) (loop for k in come - if (some (lambda (x) (region-intersects-region-p k x)) - stay) - collect k into come-overlap* - else collect k into come* + if (spatial-trees:search (%record-to-spatial-tree-rectangle k) + stay-tree) + collect (list k k) into come-overlap* + else collect (list k k) into come* finally (return (values come* come-overlap*))))) ;; Hmm, we somehow miss come-overlap ... (values ;; erases - (loop for k in gone collect (list k k)) + gone ;; moves nil ;; draws - (loop for k in come collect (list k k)) + come ;; erase overlapping - (append (loop for k in gone-overlap collect (list k k)) - (loop for k in come-overlap collect (list k k))) + (append gone-overlap come-overlap) ;; move overlapping nil)))))

1 0

[mcclim-cvs] CVS mcclim
by afuchs 20 Apr '06

20 Apr '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv20802 Modified Files: incremental-redisplay.lisp Log Message: argh. revert the last constant-factors fold. gather-was and gather-is are fundamentally different. file under lessons learned. --- /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 22:43:47 1.56 +++ /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 22:53:15 1.57 @@ -778,24 +778,38 @@ (if (some #'(lambda (x) (output-record-equal record x)) q) (push record stay) (push record come))))))) - ;; Collect what was there and what's still there - (labels ((gather-was-and-is (record) + ;; Collect what was there + (labels ((gather-was (record) (cond ((displayed-output-record-p record) (collect-1-was record)) ((updating-output-record-p record) (cond ((eq :clean (output-record-dirty record)) - (collect-1-was record) + (collect-1-was record)) + ((eq :moved (output-record-dirty record)) + (collect-1-was (slot-value record 'old-bounds))) + (t + (map-over-output-records-overlapping-region #'gather-was + (old-children record) + everywhere)))) + (t + (map-over-output-records-overlapping-region #'gather-was record everywhere))))) + (gather-was record)) + ;; Collect what still is there + (labels ((gather-is (record) + (cond ((displayed-output-record-p record) + (collect-1-is record)) + ((updating-output-record-p record) + (cond ((eq :clean (output-record-dirty record)) (collect-1-is record)) ((eq :moved (output-record-dirty record)) - (collect-1-was (slot-value record 'old-bounds)) (collect-1-is record)) (t - (map-over-output-records-overlapping-region #'gather-was-and-is - (old-children record) + (map-over-output-records-overlapping-region #'gather-is + (sub-record record) everywhere)))) (t - (map-over-output-records-overlapping-region #'gather-was-and-is record everywhere))))) - (gather-was-and-is record))) + (map-over-output-records-overlapping-region #'gather-is record everywhere) )))) + (gather-is record))) ;; (let (gone) ;; gone = was \ is

1 0

[mcclim-cvs] CVS mcclim
by afuchs 20 Apr '06

20 Apr '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv19230 Modified Files: incremental-redisplay.lisp Log Message: Improve constant factors on compute-difference-set further * gather-was and gather-is do the same, too. merge them. --- /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 22:40:48 1.55 +++ /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 22:43:47 1.56 @@ -778,38 +778,24 @@ (if (some #'(lambda (x) (output-record-equal record x)) q) (push record stay) (push record come))))))) - ;; Collect what was there - (labels ((gather-was (record) + ;; Collect what was there and what's still there + (labels ((gather-was-and-is (record) (cond ((displayed-output-record-p record) (collect-1-was record)) ((updating-output-record-p record) (cond ((eq :clean (output-record-dirty record)) - (collect-1-was record)) - ((eq :moved (output-record-dirty record)) - (collect-1-was (slot-value record 'old-bounds))) - (t - (map-over-output-records-overlapping-region #'gather-was - (old-children record) - everywhere)))) - (t - (map-over-output-records-overlapping-region #'gather-was record everywhere))))) - (gather-was record)) - ;; Collect what still is there - (labels ((gather-is (record) - (cond ((displayed-output-record-p record) - (collect-1-is record)) - ((updating-output-record-p record) - (cond ((eq :clean (output-record-dirty record)) + (collect-1-was record) (collect-1-is record)) ((eq :moved (output-record-dirty record)) + (collect-1-was (slot-value record 'old-bounds)) (collect-1-is record)) (t - (map-over-output-records-overlapping-region #'gather-is - (sub-record record) + (map-over-output-records-overlapping-region #'gather-was-and-is + (old-children record) everywhere)))) (t - (map-over-output-records-overlapping-region #'gather-is record everywhere) )))) - (gather-is record))) + (map-over-output-records-overlapping-region #'gather-was-and-is record everywhere))))) + (gather-was-and-is record))) ;; (let (gone) ;; gone = was \ is

1 0

[mcclim-cvs] CVS mcclim
by afuchs 20 Apr '06

20 Apr '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv19078 Modified Files: incremental-redisplay.lisp Log Message: Improve constant factors on compute-difference-set. * now does more things in only one iteration over: * is, is-table, come, stay * was, was-table. * big-O improvements left as an exercise to the reader or evaluator. --- /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/03/10 21:58:13 1.54 +++ /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 22:40:48 1.55 @@ -748,75 +748,79 @@ (defmethod compute-difference-set ((record standard-updating-output-record) &optional (check-overlapping t) - offset-x offset-y - old-offset-x old-offset-y) + offset-x offset-y + old-offset-x old-offset-y) (declare (ignore offset-x offset-y old-offset-x old-offset-y)) ;; (declare (values erases moves draws erase-overlapping move-overlapping)) (let (was is + stay + come (everywhere (or +everywhere+ - (pane-viewport-region (updating-output-stream record))))) - ;; Collect what was there - (labels ((gather-was (record) - (cond ((displayed-output-record-p record) - (push record was)) - ((updating-output-record-p record) - (cond ((eq :clean (output-record-dirty record)) - (push record was)) - ((eq :moved (output-record-dirty record)) - (push (slot-value record 'old-bounds) was)) - (t - (map-over-output-records-overlapping-region #'gather-was - (old-children record) - everywhere)))) + (pane-viewport-region (updating-output-stream record)))) + (was-table (make-hash-table :test #'equalp)) + (is-table (make-hash-table :test #'equalp))) + + (labels ((collect-1-was (record) + (push record was) + (push record (gethash (output-record-hash record) was-table))) + (collect-1-is (record) + (push record is) + (push record (gethash (output-record-hash record) is-table)) + ;; come = is \ was + ;; stay = is ^ was + (cond ((updating-output-record-p record) + (if (eq :clean (output-record-dirty record)) + (push record stay) + (push record come))) (t - (map-over-output-records-overlapping-region #'gather-was record everywhere)) ))) - (gather-was record)) - ;; Collect what still is there - (labels ((gather-is (record) - (cond ((displayed-output-record-p record) - (push record is)) - ((updating-output-record-p record) - (cond ((eq :clean (output-record-dirty record)) - (push record is)) - ((eq :moved (output-record-dirty record)) - (push record is)) - (t - (map-over-output-records-overlapping-region #'gather-is - (sub-record record) - everywhere)))) - (t - (map-over-output-records-overlapping-region #'gather-is record everywhere) )))) - (gather-is record)) + (let ((q (gethash (output-record-hash record) was-table))) + (if (some #'(lambda (x) (output-record-equal record x)) q) + (push record stay) + (push record come))))))) + ;; Collect what was there + (labels ((gather-was (record) + (cond ((displayed-output-record-p record) + (collect-1-was record)) + ((updating-output-record-p record) + (cond ((eq :clean (output-record-dirty record)) + (collect-1-was record)) + ((eq :moved (output-record-dirty record)) + (collect-1-was (slot-value record 'old-bounds))) + (t + (map-over-output-records-overlapping-region #'gather-was + (old-children record) + everywhere)))) + (t + (map-over-output-records-overlapping-region #'gather-was record everywhere))))) + (gather-was record)) + ;; Collect what still is there + (labels ((gather-is (record) + (cond ((displayed-output-record-p record) + (collect-1-is record)) + ((updating-output-record-p record) + (cond ((eq :clean (output-record-dirty record)) + (collect-1-is record)) + ((eq :moved (output-record-dirty record)) + (collect-1-is record)) + (t + (map-over-output-records-overlapping-region #'gather-is + (sub-record record) + everywhere)))) + (t + (map-over-output-records-overlapping-region #'gather-is record everywhere) )))) + (gather-is record))) ;; - (let ((was-table (make-hash-table :test #'equalp)) - (is-table (make-hash-table :test #'equalp)) - gone - stay - come) - (loop for w in was do (push w (gethash (output-record-hash w) was-table))) - (loop for i in is do (push i (gethash (output-record-hash i) is-table))) + (let (gone) ;; gone = was \ is (loop for w in was do - (cond ((updating-output-record-p w) - (unless (eq :clean (output-record-dirty w)) - (push (old-children w) gone))) - (t - (let ((q (gethash (output-record-hash w) is-table))) - (unless (some #'(lambda (x) (output-record-equal w x)) q) - (push w gone)))))) - ;; come = is \ was - ;; stay = is ^ was - (loop for i in is do - (cond ((updating-output-record-p i) - (if (eq :clean (output-record-dirty i)) - (push i stay) - (push i come))) - (t - (let ((q (gethash (output-record-hash i) was-table))) - (if (some #'(lambda (x) (output-record-equal i x)) q) - (push i stay) - (push i come)))))) + (cond ((updating-output-record-p w) + (unless (eq :clean (output-record-dirty w)) + (push (old-children w) gone))) + (t + (let ((q (gethash (output-record-hash w) is-table))) + (unless (some #'(lambda (x) (output-record-equal w x)) q) + (push w gone)))))) ;; Now we essentially want 'gone', 'stay', 'come' (let ((gone-overlap nil) (come-overlap nil)) @@ -825,14 +829,14 @@ (loop for k in gone if (some (lambda (x) (region-intersects-region-p k x)) stay) - collect k into gone-overlap* + collect k into gone-overlap* else collect k into gone* finally (return (values gone* gone-overlap*)))) (setf (values come come-overlap) (loop for k in come if (some (lambda (x) (region-intersects-region-p k x)) stay) - collect k into come-overlap* + collect k into come-overlap* else collect k into come* finally (return (values come* come-overlap*))))) ;; Hmm, we somehow miss come-overlap ...

1 0

[mcclim-cvs] CVS mcclim/Examples
by crhodes 19 Apr '06

19 Apr '06

Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv28012/Examples Modified Files: text-size-test.lisp Log Message: Add text-bounding-rectangle* mode to text-size-test --- /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp 2006/04/17 17:54:58 1.1 +++ /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp 2006/04/19 11:43:31 1.2 @@ -37,6 +37,11 @@ (with-radio-box (:type :some-of) (make-pane 'toggle-button :label "Bold" :id :bold) (make-pane 'toggle-button :label "Italic" :id :italic))) + (rectangle + (with-radio-box () + (radio-box-current-selection + (make-pane 'toggle-button :label "Text-Size" :id :text-size)) + (make-pane 'toggle-button :label "Text-Bounding-Rectangle" :id :text-bounding-rectangle))) (size (make-pane 'slider :orientation :horizontal @@ -49,7 +54,8 @@ (labelling (:label "Text") text) (horizontally () (labelling (:label "Family") family) - (labelling (:label "Face") face)) + (labelling (:label "Face") face) + (labelling (:label "Rectangle") rectangle)) (labelling (:label "Size") size) canvas)))) @@ -62,6 +68,7 @@ (family (gadget-id (gadget-value (find-pane-named frame 'family)))) (faces (mapcar #'gadget-id (gadget-value (find-pane-named frame 'face)))) + (rectangle (gadget-id (gadget-value (find-pane-named frame 'rectangle)))) (face (if (cdr faces) '(:bold :italic) (car faces))) (style (make-text-style family face size))) (multiple-value-bind (width height final-x final-y baseline) @@ -78,16 +85,26 @@ ;;; (setf (stream-cursor-position stream) (values x1 y1)) ;;; (with-text-style (stream style) ;;; (write-string str stream)) - (draw-rectangle* stream - x1 y1 - (+ x1 width) (+ y1 height) - :ink +red+ - :filled nil) - (draw-rectangle* stream - x1 y1 - (+ x1 final-x) (+ y1 final-y) - :ink +blue+ - :filled nil))))) + (ecase rectangle + ((:text-size) + (draw-rectangle* stream + x1 y1 + (+ x1 width) (+ y1 height) + :ink +red+ + :filled nil) + (draw-rectangle* stream + x1 y1 + (+ x1 final-x) (+ y1 final-y) + :ink +blue+ + :filled nil)) + ((:text-bounding-rectangle) + (multiple-value-bind (left top right bottom) + (climi::text-bounding-rectangle* (sheet-medium stream) str :text-style style) + (draw-rectangle* stream + (+ x1 left) (+ y1 baseline top) + (+ x1 right) (+ y1 baseline bottom) + :ink +purple+ + :filled nil)))))))) (define-text-size-test-command (com-quit-text-size-test :menu "Quit") () (frame-exit *application-frame*))

1 0

[mcclim-cvs] CVS mcclim/Backends/gtkairo
by dlichteblau 17 Apr '06

17 Apr '06

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv16648 Modified Files: medium.lisp Log Message: * Backends/gtkairo/medium.lisp (TEXT-STYLE-WIDTH): return max_x_advance instead of computing 1 em. Fixes the cursor position problem in Climacs. (TEXT-SIZE): changed return values almost completely. See comments there. (CLIMI::TEXT-BOUNDING-RECTANGLE*): Reimplemented to look more like what CLIM-CLX does. No real insight, but cannot be worse than it was. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/04/17 18:40:27 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/04/17 18:48:52 1.2 @@ -590,6 +590,18 @@ ;;; TEXT-STYLE-ASCENT +;; FIXME: Cairo documentation states that these numbers, AIUI, are not +;; exact measurements but rather values tweaked by the font designer for +;; better visual effect. +;; +;; What this seems to mean in practise is that, say, ASCENT is nearly +;; identical to text_extent.height in the tests I tried. +;; +;; So which one does CLIM want? What are these function actually being +;; used for? +;; +;; --DFL + (let ((hash (make-hash-table))) (defmethod text-style-ascent :around (text-style (medium gtkairo-medium)) (or (gethash text-style hash) @@ -653,6 +665,11 @@ (cairo_font_extents cr res) ;; ### let's hope that cairo respects ;; height = ascent + descent. + ;; + ;; No, it expressly doesn't. Cairo documentation states that + ;; height includes additional space that is meant to give more + ;; aesthetic line spacing than ascent+descent would. Is that a + ;; problem for us? --DFL (slot res 'cairo_font_extents 'height)))))) @@ -673,9 +690,13 @@ (sync-sheet medium) (cairo_identity_matrix cr) (sync-text-style medium text-style t) - (cffi:with-foreign-object (res 'cairo_text_extents) - (cairo_text_extents cr "m" res) - (slot res 'cairo_text_extents 'width)))))) + ;; This didn't work well for Climacs. --DFL +;;; (cffi:with-foreign-object (res 'cairo_text_extents) +;;; (cairo_text_extents cr "m" res) +;;; (slot res 'cairo_text_extents 'width)) + (cffi:with-foreign-object (res 'cairo_font_extents) + (cairo_font_extents cr res) + (slot res 'cairo_font_extents 'max_x_advance)))))) ;;; TEXT-STYLE-FIXED-WIDTH-P @@ -717,6 +738,27 @@ :start start :end (or end (length string))))) +(defmethod climi::text-bounding-rectangle* + ((medium gtkairo-medium) string &key text-style (start 0) end) + (with-gtk () + (when (characterp string) (setf string (string string))) + (setf text-style (or text-style (medium-text-style medium))) + (setf text-style + (merge-text-styles text-style (medium-default-text-style medium))) + (climi::text-bounding-rectangle* (metrik-medium (port medium)) + string + :text-style text-style + :start start + :end (or end (length string))))) + +;; FIXME: TEXT-SIZE [and presumably TEXT-BOUNDING-RECTANGLE*, too] are +;; supposed to take newlines into account. The CLX backend code was +;; written to support that but does not -- T-B-R errors out and T-S +;; doesn't return what WRITE-STRING on the sheet actually does. So +;; let's not steal code from CLIM-CLX when it's broken. Doesn't +;; actually look like anyone has been depending on this after all. +;; -- DFL + (defmethod text-size ((medium metrik-medium) string &key text-style (start 0) end) (with-cairo-medium (medium) @@ -733,17 +775,46 @@ (subseq string start (or end (length string))) res) (cffi:with-foreign-slots - ((width height x_advance y_advance) res cairo_text_extents) - (values (ceiling width) - (ceiling height) - (ceiling x_advance) - (ceiling y_advance) - ;; baseline? - (ceiling (text-style-ascent text-style medium)))))))) + ((x_advance height y_bearing) res cairo_text_extents) + (values + ;; use x_advance instead of width, since CLIM wants to trailing + ;; spaces to be taken into account. + (ceiling x_advance) + (ceiling height) + ;; Sames values again here: The CLIM spec states that these + ;; values differ only for multi-line text. And y_advance is 0 + ;; for european text, which is not what we want. --DFL + (ceiling x_advance) + (ceiling height) + ;; This used to be TEXT-STYLE-ASCENT, but see comment there. + (abs (ceiling y_bearing)))))))) (defmethod climi::text-bounding-rectangle* - ((medium gtkairo-medium) string &key text-style (start 0) end) - (text-size medium string :text-style text-style :start start :end end)) + ((medium metrik-medium) string &key text-style (start 0) end) + (with-cairo-medium (medium) + ;; -> left ascent right descent + (when (characterp string) (setf string (string string))) + (setf text-style (or text-style (make-text-style nil nil nil))) + (setf text-style + (merge-text-styles text-style (medium-default-text-style medium))) + (with-slots (cr) medium + (cairo_identity_matrix cr) + (sync-text-style medium text-style t) + (cffi:with-foreign-object (res 'cairo_text_extents) + (cairo_text_extents cr + (subseq string start (or end (length string))) + res) + ;; This used to be a straight call to TEXT-SIZE. Looking at + ;; what CLIM-CLX does, this looks better to me, but I'm not sure + ;; whether it's 100% right: + ;; --DFL + (cffi:with-foreign-slots + ((height x_advance y_advance x_bearing y_bearing) + res cairo_text_extents) + (values (ceiling x_bearing) + (ceiling y_bearing) + (ceiling x_advance) + (ceiling (+ height y_bearing)))))))) ;;;; ------------------------------------------------------------------------ ;;;; General Designs

1 0