From dlichteblau at common-lisp.net Sat Jul 7 13:41:31 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sat, 7 Jul 2007 09:41:31 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei/cl-automaton Message-ID: <20070707134131.109A42608B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/cl-automaton In directory clnet:/tmp/cvs-serv16032 Modified Files: automaton.lisp regexp.lisp state-and-transition.lisp Log Message: make Drei source code ASCII-clean (with apologies to Anders M?ller) --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton.lisp 2007/02/06 12:53:09 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton.lisp 2007/07/07 13:41:30 1.4 @@ -18,7 +18,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; -;;; Derived from dk.brics.automaton v1.8.1, (c) 2001-2005 by Anders M??ller +;;; Derived from dk.brics.automaton v1.8.1, (c) 2001-2005 by Anders M/oller ;;; - Functionality not used by the regular expression engine and not tested ;;; has been omitted from this initial release. ;;; - Some comments have been copied verbatim from the original code. --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/regexp.lisp 2007/02/06 12:53:09 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/regexp.lisp 2007/07/07 13:41:30 1.3 @@ -18,7 +18,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; Derived from dk.brics.automaton v1.8.1, (c) 2001-2005 by Anders M??ller +;;; Derived from dk.brics.automaton v1.8.1, (c) 2001-2005 by Anders M/oller ;;; - Some comments have been copied verbatim from the original code. ;;; Regular expressions are built from the following abstract syntax: --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/state-and-transition.lisp 2007/02/06 12:53:09 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/state-and-transition.lisp 2007/07/07 13:41:30 1.4 @@ -18,7 +18,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; Derived from dk.brics.automaton v1.8.1, (c) 2001-2005 by Anders M??ller +;;; Derived from dk.brics.automaton v1.8.1, (c) 2001-2005 by Anders M/oller (in-package :automaton) From crhodes at common-lisp.net Wed Jul 11 15:26:20 2007 From: crhodes at common-lisp.net (crhodes) Date: Wed, 11 Jul 2007 11:26:20 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070711152620.395F95D00B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv13045 Modified Files: bezier.lisp Log Message: Bezier designs which draw in the right place in all backends (I think). The implementation prior to this worked for the replay on an output-recording stream, and probably worked for the first draw using the pixmap (fall-through) rendering method. It did not work for the first draw on a backend with native bezier drawing routines, basically because the design was being passed through untransformed by the medium transformation. So: * define a method on medium-draw-bezier-design* specialized on transform-coordinates-mixin, to transform the region appropriately before passing down to backend-drawing functions. This method runs after the output-recording-stream method, so sadly we're now doing some transformations twice. * this implies deleting the translated-bezier-design class, as returning an object of a different class from transform-region meant that the idiom of doing (defmethod medium-draw-foo* :around ((medium t-c-mixin) foo) (let ((foo (transform-region (medium-transformation medium) foo))) (call-next-method medium foo))) would be in violation of the restriction that the set of applicable methods not change when using call next method. * deleting the translated-bezier-design class would mean losing the cacheing of pixmap renderings, so restore that by keeping track of the original design in all bezier-design subclasses, and use that in ensure-pixmap. * this on its own is still too slow, so for bezier-areas and bezier-unions additionally keep track of accumulated translation transformations, only performing the transformation of individual segments or areas when they are necessary. (A similar approach could be used for differences, but I ran out of energy; we have however recovered most of the speed loss from the introduction of this extra correctness.) * the Postscript and gtkairo backends, with their medium-draw-bezier* methods, needed some adjustment to perform the transformations themselves. Please test! --- /project/mcclim/cvsroot/mcclim/bezier.lisp 2006/12/26 16:44:45 1.1 +++ /project/mcclim/cvsroot/mcclim/bezier.lisp 2007/07/11 15:26:20 1.2 @@ -56,7 +56,8 @@ (- (* (realpart z) (point-y v)) (* (imagpart z) (point-x v)))) -(defclass bezier-design (design) ()) +(defclass bezier-design (design) + ((%or :accessor original-region :initform nil))) (defgeneric medium-draw-bezier-design* (stream design)) @@ -80,6 +81,12 @@ (when (stream-drawing-p stream) (medium-draw-bezier-design* medium design))))) +(defmethod medium-draw-bezier-design* :around + ((medium transform-coordinates-mixin) design) + (let* ((tr (medium-transformation medium)) + (design (transform-region tr design))) + (call-next-method medium design))) + (defmethod replay-output-record ((record bezier-design-output-record) stream &optional (region +everywhere+) (x-offset 0) (y-offset 0)) (declare (ignore x-offset y-offset region)) @@ -108,12 +115,12 @@ (values min-x min-y max-x max-y))) (defclass segments-mixin (bounding-rectangle-mixin) - ((%segments :initarg :segments :initform '() :reader segments))) + ((%segments :initarg :segments :initform '() :reader %segments))) -(defun compute-bounding-rectangle* (segments-mixin) +(defmethod compute-bounding-rectangle* ((segments-mixin segments-mixin)) (multiple-value-bind (final-min-x final-min-y final-max-x final-max-y) - (segment-bounding-rectangle (car (segments segments-mixin))) - (loop for segment in (cdr (segments segments-mixin)) + (segment-bounding-rectangle (car (%segments segments-mixin))) + (loop for segment in (cdr (%segments segments-mixin)) do (multiple-value-bind (min-x min-y max-x max-y) (segment-bounding-rectangle segment) (setf final-min-x (min final-min-x min-x) @@ -171,7 +178,7 @@ (make-instance 'bezier-curve :segments (mapcar (lambda (segment) (transform-segment transformation segment)) - (segments path)))) + (%segments path)))) (defmethod region-equal ((p1 point) (p2 point)) (let ((coordinate-epsilon (* #.(expt 2 10) double-float-epsilon))) @@ -179,49 +186,33 @@ (<= (abs (- (point-y p1) (point-y p2))) coordinate-epsilon)))) (defmethod region-union ((r1 bezier-curve) (r2 bezier-curve)) - (let ((p (slot-value (car (last (segments r1))) 'p3)) - (seg (car (segments r2)))) + (let ((p (slot-value (car (last (%segments r1))) 'p3)) + (seg (car (%segments r2)))) (if (region-equal p (slot-value seg 'p0)) (with-slots (p1 p2 p3) seg (make-instance 'bezier-curve - :segments (append (segments r1) + :segments (append (%segments r1) (cons (make-bezier-segment p p1 p2 p3) - (cdr (segments r2)))))) + (cdr (%segments r2)))))) (call-next-method)))) -;;; A region that translates a different region -(defclass translated-bezier-design (region bezier-design) - ((%translation :initarg :translation :reader translation) - (%region :initarg :region :reader original-region))) - -(defmethod bounding-rectangle* ((region translated-bezier-design)) - (let ((translation (translation region))) - (multiple-value-bind (min-x min-y max-x max-y) - (bounding-rectangle* (original-region region)) - (multiple-value-bind (final-min-x final-min-y) - (transform-position translation min-x min-y) - (multiple-value-bind (final-max-x final-max-y) - (transform-position translation max-x max-y) - (values final-min-x final-min-y final-max-x final-max-y)))))) - -(defgeneric really-transform-region (transformation region)) - ;;; an area defined as a closed path of Bezier curve segments -(defclass bezier-area (area bezier-design segments-mixin bounding-rectangle-mixin) ()) +(defclass bezier-area (area bezier-design segments-mixin bounding-rectangle-mixin) + ((%trans :initarg :transformation :reader transformation :initform +identity-transformation+))) (defgeneric close-path (path)) (defmethod close-path ((path bezier-curve)) - (let ((segments (segments path))) + (let ((segments (%segments path))) (assert (region-equal (slot-value (car segments) 'p0) (slot-value (car (last segments)) 'p3))) (make-instance 'bezier-area :segments segments))) (defun path-start (path) - (slot-value (car (segments path)) 'p0)) + (slot-value (car (%segments path)) 'p0)) (defun path-end (path) - (slot-value (car (last (segments path))) 'p3)) + (slot-value (car (last (%segments path))) 'p3)) (defun make-bezier-area (point-seq) (assert (region-equal (car point-seq) (car (last point-seq)))) @@ -232,18 +223,26 @@ (coordinate= (cadr coord-seq) (car (last coord-seq))))) (make-bezier-thing* 'bezier-area coord-seq)) -(defmethod really-transform-region (transformation (area bezier-area)) - (make-instance 'bezier-area - :segments (mapcar (lambda (segment) - (transform-segment transformation segment)) - (segments area)))) +(defmethod segments ((area bezier-area)) + (let ((tr (transformation area))) + (mapcar (lambda (s) (transform-segment tr s)) (%segments area)))) (defmethod transform-region (transformation (area bezier-area)) - (if (translation-transformation-p transformation) - (make-instance 'translated-bezier-design - :translation transformation - :region area) - (really-transform-region transformation area))) + (let* ((tr (transformation area)) + (result (if (translation-transformation-p transformation) + (make-instance 'bezier-area :segments (%segments area) + :transformation + (compose-transformations transformation tr)) + (make-instance 'bezier-area + :segments (mapcar (lambda (s) (transform-segment transformation s)) (segments area)))))) + (when (translation-transformation-p transformation) + (setf (original-region result) (or (original-region area) area))) + result)) + +(defmethod compute-bounding-rectangle* ((area bezier-area)) + (multiple-value-bind (lx ly ux uy) (call-next-method) + (let ((tr (transformation area))) + (transform-rectangle* tr lx ly ux uy)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -251,20 +250,20 @@ ;;; A union of bezier areas. This is not itself a bezier area. (defclass bezier-union (area bezier-design) - ((%areas :initarg :areas :initform '() :reader areas))) - -(defmethod really-transform-region (transformation (area bezier-union)) - (let ((areas (loop for area in (areas area) - collect (transform-region transformation area)))) - (make-instance 'bezier-union - :areas areas))) + ((%trans :initarg :transformation :reader transformation :initform +identity-transformation+) + (%areas :initarg :areas :initform '() :reader areas))) -(defmethod transform-region (transformation (area bezier-union)) - (if (translation-transformation-p transformation) - (make-instance 'translated-bezier-design - :translation transformation - :region area) - (really-transform-region transformation area))) +(defmethod transform-region (transformation (union bezier-union)) + (let* ((tr (transformation union)) + (new-tr (compose-transformations transformation tr)) + (result (if (translation-transformation-p transformation) + (make-instance 'bezier-union :areas (areas union) + :transformation new-tr) + (make-instance 'bezier-union + :areas (loop for area in (areas union) collect (transform-region new-tr area)))))) + (when (translation-transformation-p transformation) + (setf (original-region result) (or (original-region union) union))) + result)) (defun bounding-rectangle-of-areas (areas) (multiple-value-bind (final-min-x final-min-y final-max-x final-max-y) @@ -279,43 +278,57 @@ (values final-min-x final-min-y final-max-x final-max-y))) (defmethod bounding-rectangle* ((design bezier-union)) - (bounding-rectangle-of-areas (areas design))) + (multiple-value-bind (lx ly ux uy) + (bounding-rectangle-of-areas (areas design)) + (transform-rectangle* (transformation design) lx ly ux uy))) (defmethod region-union ((r1 bezier-area) (r2 bezier-area)) - (make-instance 'bezier-union - :areas (list r1 r2))) + (make-instance 'bezier-union :areas (list r1 r2))) (defmethod region-union ((r1 bezier-union) (r2 bezier-area)) - (make-instance 'bezier-union - :areas (cons r2 (areas r1)))) + (let ((tr (transformation r1))) + (make-instance 'bezier-union + :areas (cons (untransform-region tr r2) (areas r1)) + :transformation tr))) (defmethod region-union ((r1 bezier-area) (r2 bezier-union)) - (make-instance 'bezier-union - :areas (cons r1 (areas r2)))) + (let ((tr (transformation r2))) + (make-instance 'bezier-union + :areas (cons (untransform-region tr r1) (areas r2)) + :transformation tr))) (defmethod region-union ((r1 bezier-union) (r2 bezier-union)) - (make-instance 'bezier-union - :areas (append (areas r1) (areas r2)))) + (let ((tr1 (transformation r1)) + (tr2 (transformation r2))) + (if (transformation-equal tr1 tr2) + (make-instance 'bezier-union + :areas (append (areas r1) (areas r2)) + :transformation tr1) + (let ((len1 (length (areas r1))) + (len2 (length (areas r2)))) + (if (> len2 len1) + (make-instance 'bezier-union + :areas (append (mapcar (lambda (r) (untransform-region tr2 (transform-region tr1 r))) (areas r1)) (areas r2)) + :transformation tr2) + (make-instance 'bezier-union + :areas (append (mapcar (lambda (r) (untransform-region tr1 (transform-region tr2 r))) (areas r2)) (areas r1)) + :transformation tr1)))))) (defclass bezier-difference (area bezier-design) ((%positive-areas :initarg :positive-areas :initform '() :reader positive-areas) (%negative-areas :initarg :negative-areas :initform '() :reader negative-areas))) -(defmethod really-transform-region (transformation (area bezier-difference)) - (let ((pareas (loop for area in (positive-areas area) - collect (transform-region transformation area))) - (nareas (loop for area in (negative-areas area) - collect (transform-region transformation area)))) - (make-instance 'bezier-difference - :positive-areas pareas - :negative-areas nareas))) - (defmethod transform-region (transformation (area bezier-difference)) - (if (translation-transformation-p transformation) - (make-instance 'translated-bezier-design - :translation transformation - :region area) - (really-transform-region transformation area))) + (let* ((pareas (loop for area in (positive-areas area) + collect (transform-region transformation area))) + (nareas (loop for area in (negative-areas area) + collect (transform-region transformation area))) + (result (make-instance 'bezier-difference + :positive-areas pareas + :negative-areas nareas))) + (when (translation-transformation-p transformation) + (setf (original-region result) (or (original-region area) area))) + result)) (defmethod bounding-rectangle* ((design bezier-difference)) (bounding-rectangle-of-areas (positive-areas design))) @@ -326,19 +339,23 @@ :negative-areas (list r2))) (defmethod region-difference ((r1 bezier-area) (r2 bezier-union)) - (make-instance 'bezier-difference - :positive-areas (list r1) - :negative-areas (areas r2))) + (let ((tr (transformation r2))) + (make-instance 'bezier-difference + :positive-areas (list r1) + :negative-areas (mapcar (lambda (r) (transform-region tr r)) (areas r2))))) (defmethod region-difference ((r1 bezier-union) (r2 bezier-area)) - (make-instance 'bezier-difference - :positive-areas (areas r1) - :negative-areas (list r2))) + (let ((tr (transformation r1))) + (make-instance 'bezier-difference + :positive-areas (mapcar (lambda (r) (transform-region tr r)) (areas r1)) + :negative-areas (list r2)))) (defmethod region-difference ((r1 bezier-union) (r2 bezier-union)) - (make-instance 'bezier-difference - :positive-areas (areas r1) - :negative-areas (areas r2))) + (let ((tr1 (transformation r1)) + (tr2 (transformation r2))) + (make-instance 'bezier-difference + :positive-areas (mapcar (lambda (r) (transform-region tr1 r)) (areas r1)) + :negative-areas (mapcar (lambda (r) (transform-region tr2 r)) (areas r2))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -369,7 +386,7 @@ (%polygonalize p0 p1 p2 p3))) (defmethod polygonalize ((path bezier-curve)) - (let ((segments (segments path))) + (let ((segments (%segments path))) (make-polyline (cons (slot-value (car segments) 'p0) (mapcan #'polygonalize segments))))) @@ -390,11 +407,12 @@ (defmethod reverse-path ((path bezier-curve)) (make-instance 'bezier-curve - :segments (reverse (mapcar #'reverse-segment (segments path))))) + :segments (reverse (mapcar #'reverse-segment (%segments path))))) (defmethod reverse-path ((path bezier-area)) (make-instance 'bezier-area - :segments (reverse (mapcar #'reverse-segment (segments path))))) + :segments (reverse (mapcar #'reverse-segment (%segments path))) + :transformation (transformation path))) ;;; slanting transformation are used by Metafont (defun make-slanting-transformation (slant) @@ -574,7 +592,7 @@ (defmethod convolute-regions ((area bezier-area) (path bezier-curve)) (let ((polygon (polygonalize area))) (make-instance 'bezier-union - :areas (loop for segment in (segments path) + :areas (loop for segment in (%segments path) append (convolute-polygon-and-segment area polygon segment))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -670,9 +688,6 @@ (defmethod positive-negative-areas ((design bezier-difference)) (values (positive-areas design) (negative-areas design))) -(defmethod positive-negative-areas ((design translated-bezier-design)) - (positive-negative-areas (original-region design))) - (defun render-to-array (design) (multiple-value-bind (positive-areas negative-areas) (positive-negative-areas design) @@ -695,9 +710,6 @@ (render-polygon result polygon 1 min-x min-y))) result)))) -(defparameter *x* 0) -(defparameter *y* 0) - (defparameter *pixmaps* (make-hash-table :test #'equal)) (defun resolve-ink (medium) @@ -715,8 +727,9 @@ (defgeneric ensure-pixmap (medium design)) -(defmethod ensure-pixmap (medium design) - (let ((pixmap (gethash (list (medium-sheet medium) (resolve-ink medium) design) +(defmethod ensure-pixmap (medium rdesign) + (let* ((design (or (original-region rdesign) rdesign)) + (pixmap (gethash (list (medium-sheet medium) (resolve-ink medium) design) *pixmaps*))) (when (null pixmap) (let* ((picture (render-to-array design)) @@ -743,17 +756,21 @@ pixmap))) pixmap)) -(defmethod ensure-pixmap (medium (design translated-bezier-design)) - (ensure-pixmap medium (original-region design))) - (defun render-through-pixmap (design medium) (multiple-value-bind (min-x min-y) (bounding-rectangle* design) - (setf min-x (floor min-x) - min-y (floor min-y)) - (let ((pixmap (ensure-pixmap medium design))) - (copy-from-pixmap pixmap 0 0 (pixmap-width pixmap) (pixmap-height pixmap) - (medium-sheet medium) (+ *x* min-x) (+ *y* min-y))))) + ;; the design we've got has already been transformed by the + ;; medium/user transformation, and COPY-FROM-PIXMAP is in user + ;; coordinates. So we need to transform back (or set the medium's + ;; transformation to be +IDENTITY-TRANSFORMATION+ temporarily, but + ;; that's even uglier) + (multiple-value-bind (utmin-x utmin-y) + (untransform-position (medium-transformation medium) min-x min-y) + (setf min-x (floor utmin-x) + min-y (floor utmin-y)) + (let ((pixmap (ensure-pixmap medium design))) + (copy-from-pixmap pixmap 0 0 (pixmap-width pixmap) (pixmap-height pixmap) + (medium-sheet medium) min-x min-y))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -778,73 +795,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; Special cases on region-union and region-intersection - -(defmethod region-union ((r1 translated-bezier-design) (r2 bezier-curve)) - (region-union (really-transform-region (translation r1) (original-region r1)) r2)) - -(defmethod region-union ((r1 translated-bezier-design) (r2 bezier-area)) [64 lines skipped] From crhodes at common-lisp.net Wed Jul 11 15:26:20 2007 From: crhodes at common-lisp.net (crhodes) Date: Wed, 11 Jul 2007 11:26:20 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/PostScript Message-ID: <20070711152620.7FCE260035@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/PostScript In directory clnet:/tmp/cvs-serv13045/Backends/PostScript Modified Files: graphics.lisp Log Message: Bezier designs which draw in the right place in all backends (I think). The implementation prior to this worked for the replay on an output-recording stream, and probably worked for the first draw using the pixmap (fall-through) rendering method. It did not work for the first draw on a backend with native bezier drawing routines, basically because the design was being passed through untransformed by the medium transformation. So: * define a method on medium-draw-bezier-design* specialized on transform-coordinates-mixin, to transform the region appropriately before passing down to backend-drawing functions. This method runs after the output-recording-stream method, so sadly we're now doing some transformations twice. * this implies deleting the translated-bezier-design class, as returning an object of a different class from transform-region meant that the idiom of doing (defmethod medium-draw-foo* :around ((medium t-c-mixin) foo) (let ((foo (transform-region (medium-transformation medium) foo))) (call-next-method medium foo))) would be in violation of the restriction that the set of applicable methods not change when using call next method. * deleting the translated-bezier-design class would mean losing the cacheing of pixmap renderings, so restore that by keeping track of the original design in all bezier-design subclasses, and use that in ensure-pixmap. * this on its own is still too slow, so for bezier-areas and bezier-unions additionally keep track of accumulated translation transformations, only performing the transformation of individual segments or areas when they are necessary. (A similar approach could be used for differences, but I ran out of energy; we have however recovered most of the speed loss from the introduction of this extra correctness.) * the Postscript and gtkairo backends, with their medium-draw-bezier* methods, needed some adjustment to perform the transformations themselves. Please test! --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/graphics.lisp 2006/12/26 16:44:45 1.18 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/graphics.lisp 2007/07/11 15:26:20 1.19 @@ -547,36 +547,44 @@ ;;; Bezier support -(defmethod climi::medium-draw-bezier-design* - ((medium clim-postscript::postscript-medium) (design climi::bezier-area)) - (let ((stream (clim-postscript::postscript-medium-file-stream medium)) - (clim-postscript::*transformation* (sheet-native-transformation (medium-sheet medium)))) - (clim-postscript::postscript-actualize-graphics-state stream medium :color) - (format stream "newpath~%") - (let ((p0 (slot-value (car (climi::segments design)) 'climi::p0))) - (clim-postscript::write-coordinates stream (point-x p0) (point-y p0)) +(defun %draw-bezier-area (stream area) + (format stream "newpath~%") + (let ((segments (climi::segments area))) + (let ((p0 (slot-value (car segments) 'climi::p0))) + (write-coordinates stream (point-x p0) (point-y p0)) (format stream "moveto~%")) - (loop for segment in (climi::segments design) + (loop for segment in segments do (with-slots (climi::p1 climi::p2 climi::p3) segment - (clim-postscript::write-coordinates stream (point-x climi::p1) (point-y climi::p1)) - (clim-postscript::write-coordinates stream (point-x climi::p2) (point-y climi::p2)) - (clim-postscript::write-coordinates stream (point-x climi::p3) (point-y climi::p3)) + (write-coordinates stream (point-x climi::p1) (point-y climi::p1)) + (write-coordinates stream (point-x climi::p2) (point-y climi::p2)) + (write-coordinates stream (point-x climi::p3) (point-y climi::p3)) (format stream "curveto~%"))) (format stream "fill~%"))) (defmethod climi::medium-draw-bezier-design* - ((medium clim-postscript::postscript-medium) (design climi::bezier-union)) - (dolist (area (climi::areas design)) - (climi::medium-draw-bezier-design* medium area))) + ((medium postscript-medium) (design climi::bezier-area)) + (let ((stream (postscript-medium-file-stream medium)) + (*transformation* (sheet-native-transformation (medium-sheet medium)))) + (postscript-actualize-graphics-state stream medium :color) + (%draw-bezier-area stream design))) (defmethod climi::medium-draw-bezier-design* - ((medium clim-postscript::postscript-medium) (design climi::bezier-difference)) - (dolist (area (climi::positive-areas design)) - (climi::medium-draw-bezier-design* medium area)) - (with-drawing-options (medium :ink +background-ink+) - (dolist (area (climi::negative-areas design)) - (climi::medium-draw-bezier-design* medium area)))) + ((medium postscript-medium) (design climi::bezier-union)) + (let ((stream (postscript-medium-file-stream medium)) + (*transformation* (sheet-native-transformation (medium-sheet medium)))) + (postscript-actualize-graphics-state stream medium :color) + (let ((tr (climi::transformation design))) + (dolist (area (climi::areas design)) + (%draw-bezier-area stream (transform-region tr area)))))) (defmethod climi::medium-draw-bezier-design* - ((medium clim-postscript::postscript-medium) (design climi::translated-bezier-design)) - (climi::medium-draw-bezier-design* medium (climi::really-transform-region (climi::translation design) (climi::original-region design)))) + ((medium postscript-medium) (design climi::bezier-difference)) + (let ((stream (postscript-medium-file-stream medium)) + (*transformation* (sheet-native-transformation (medium-sheet medium)))) + (postscript-actualize-graphics-state stream medium :color) + (dolist (area (climi::positive-areas design)) + (%draw-bezier-area stream area)) + (with-drawing-options (medium :ink +background-ink+) + (postscript-actualize-graphics-state stream medium :color) + (dolist (area (climi::negative-areas design)) + (%draw-bezier-area stream area))))) From crhodes at common-lisp.net Wed Jul 11 15:26:21 2007 From: crhodes at common-lisp.net (crhodes) Date: Wed, 11 Jul 2007 11:26:21 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20070711152621.6BD5F65121@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv13045/Backends/gtkairo Modified Files: cairo.lisp Log Message: Bezier designs which draw in the right place in all backends (I think). The implementation prior to this worked for the replay on an output-recording stream, and probably worked for the first draw using the pixmap (fall-through) rendering method. It did not work for the first draw on a backend with native bezier drawing routines, basically because the design was being passed through untransformed by the medium transformation. So: * define a method on medium-draw-bezier-design* specialized on transform-coordinates-mixin, to transform the region appropriately before passing down to backend-drawing functions. This method runs after the output-recording-stream method, so sadly we're now doing some transformations twice. * this implies deleting the translated-bezier-design class, as returning an object of a different class from transform-region meant that the idiom of doing (defmethod medium-draw-foo* :around ((medium t-c-mixin) foo) (let ((foo (transform-region (medium-transformation medium) foo))) (call-next-method medium foo))) would be in violation of the restriction that the set of applicable methods not change when using call next method. * deleting the translated-bezier-design class would mean losing the cacheing of pixmap renderings, so restore that by keeping track of the original design in all bezier-design subclasses, and use that in ensure-pixmap. * this on its own is still too slow, so for bezier-areas and bezier-unions additionally keep track of accumulated translation transformations, only performing the transformation of individual segments or areas when they are necessary. (A similar approach could be used for differences, but I ran out of energy; we have however recovered most of the speed loss from the introduction of this extra correctness.) * the Postscript and gtkairo backends, with their medium-draw-bezier* methods, needed some adjustment to perform the transformations themselves. Please test! --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo.lisp 2006/12/26 17:29:49 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo.lisp 2007/07/11 15:26:20 1.4 @@ -707,6 +707,19 @@ ;;;; Bezier support +(defun %draw-bezier-area (medium area) + (with-slots (cr) medium + (let ((segments (climi::segments area))) + (let ((p0 (slot-value (car segments) 'climi::p0))) + (cairo_move_to cr (df (point-x p0)) (df (point-y p0)))) + (dolist (segment segments) + (with-slots (climi::p1 climi::p2 climi::p3) segment + (cairo_curve_to cr + (df (point-x climi::p1)) (df (point-y climi::p1)) + (df (point-x climi::p2)) (df (point-y climi::p2)) + (df (point-x climi::p3)) (df (point-y climi::p3))))) + (cairo_fill cr)))) + (defmethod climi::medium-draw-bezier-design* ((medium cairo-medium) (design climi::bezier-area)) (with-medium (medium) @@ -715,39 +728,36 @@ (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium)) - (with-slots (cr) medium - (let ((p0 (slot-value (car (climi::segments design)) 'climi::p0))) - (cairo_move_to cr (df (point-x p0)) (df (point-y p0)))) - (dolist (segment (climi::segments design)) - (with-slots (climi::p1 climi::p2 climi::p3) segment - (cairo_curve_to cr - (df (point-x climi::p1)) (df (point-y climi::p1)) - (df (point-x climi::p2)) (df (point-y climi::p2)) - (df (point-x climi::p3)) (df (point-y climi::p3))))) - (cairo_fill cr)))) + (%draw-bezier-area medium design))) (defmethod climi::medium-draw-bezier-design* ((medium cairo-medium) (design climi::bezier-union)) - (dolist (area (climi::areas design)) - (climi::medium-draw-bezier-design* medium area))) + (with-medium (medium) + (sync-sheet medium) + (sync-transformation medium) + (sync-ink medium (medium-ink medium)) + (sync-clipping-region medium (medium-clipping-region medium)) + (sync-line-style medium (medium-line-style medium)) + (let ((tr (climi::transformation design))) + (dolist (area (climi::areas design)) + (%draw-bezier-area medium (transform-region tr area)))))) (defmethod climi::medium-draw-bezier-design* ((medium cairo-medium) (design climi::bezier-difference)) - (dolist (area (climi::positive-areas design)) - (climi::medium-draw-bezier-design* medium area)) + (with-medium (medium) + (sync-sheet medium) + (sync-transformation medium) + (sync-ink medium (medium-ink medium)) + (sync-clipping-region medium (medium-clipping-region medium)) + (sync-line-style medium (medium-line-style medium)) + (dolist (area (climi::positive-areas design)) + (%draw-bezier-area medium area))) (with-drawing-options (medium :ink +background-ink+) - (dolist (area (climi::negative-areas design)) - (climi::medium-draw-bezier-design* medium area)))) - -(defmethod climi::medium-draw-bezier-design* - ((medium cairo-medium) (design climi::translated-bezier-design)) - (let ((tx (climi::translation design))) - (setf tx - ;; - ;; FIXME: needed for gsharp, doesn't make sense to me - ;; - (compose-transformations tx (medium-transformation medium))) - (climi::medium-draw-bezier-design* medium - (climi::really-transform-region - tx - (climi::original-region design))))) + (with-medium (medium) + (sync-sheet medium) + (sync-transformation medium) + (sync-ink medium (medium-ink medium)) + (sync-clipping-region medium (medium-clipping-region medium)) + (sync-line-style medium (medium-line-style medium)) + (dolist (area (climi::negative-areas design)) + (%draw-bezier-area medium area))))) From dlichteblau at common-lisp.net Sun Jul 15 12:00:17 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 15 Jul 2007 08:00:17 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20070715120017.A83916B366@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv28434 Modified Files: keys.lisp Log Message: german keyboard layout support (umlauts and eszett in particular) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/keys.lisp 2006/12/25 12:37:38 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/keys.lisp 2007/07/15 12:00:08 1.3 @@ -64,6 +64,7 @@ (DEFINE-KEY 91 (T :[ #\[)) (DEFINE-KEY 92 (T :|\\| #\\)) (DEFINE-KEY 93 (T :] #\])) +(DEFINE-KEY 94 (T :^ #\^)) (DEFINE-KEY 95 (T :_ #\_)) (DEFINE-KEY 96 (T :|`| #\`)) (DEFINE-KEY 97 (T :|a| #\a)) @@ -95,16 +96,27 @@ (DEFINE-KEY 123 (T :{ #\{)) (DEFINE-KEY 124 (T :|\|| #\|)) (DEFINE-KEY 125 (T :} #\})) +(DEFINE-KEY 167 (T :SECTION NIL)) +(DEFINE-KEY 176 (T :DEGREE NIL)) +(DEFINE-KEY 196 (T :A-DIAERESIS #.(code-char 196))) +(DEFINE-KEY 214 (T :O-DIAERESIS #.(code-char 214))) +(DEFINE-KEY 220 (T :U-DIAERESIS #.(code-char 220))) +(DEFINE-KEY 223 (T :SSHARP #.(code-char 223))) +(DEFINE-KEY 228 (T :|a-DIAERESIS| #.(code-char 228))) +(DEFINE-KEY 246 (T :|o-DIAERESIS| #.(code-char 246))) +(DEFINE-KEY 252 (T :|u-DIAERESIS| #.(code-char 252))) (DEFINE-KEY 65056 (T :ISO-LEFT-TAB NIL)) (DEFINE-KEY 65106 (T :DEAD-CIRCUMFLEX NIL)) (DEFINE-KEY 65107 (T :DEAD-TILDE NIL)) +(DEFINE-KEY 65237 ((12) :BACKSPACE #\Backspace) (T :TERMINATE-SERVER NIL)) (DEFINE-KEY 65273 (T :POINTER-ENABLE-KEYS NIL)) (DEFINE-KEY 65288 (T :BACKSPACE #\Backspace)) +(DEFINE-KEY 65288 ((4 8 0) :BACKSPACE #\Backspace) (T :TERMINATE-SERVER NIL)) (DEFINE-KEY 65289 (T :TAB #\Tab)) (DEFINE-KEY 65293 (T :RETURN #\Return)) (DEFINE-KEY 65299 ((9 1) :BREAK NIL) (T :PAUSE NIL)) (DEFINE-KEY 65300 (T :SCROLL-LOCK NIL)) -(DEFINE-KEY 65301 (T :SYS-REQ NIL)) +(DEFINE-KEY 65301 ((12 8) :PRINT NIL) (T :SYS-REQ NIL)) (DEFINE-KEY 65307 (T :ESCAPE NIL)) (DEFINE-KEY 65312 (T :MULTI-KEY NIL)) (DEFINE-KEY 65360 (T :HOME NIL)) @@ -116,9 +128,11 @@ (DEFINE-KEY 65366 (T :NEXT NIL)) (DEFINE-KEY 65367 (T :END NIL)) (DEFINE-KEY 65377 ((12 4 8 0) :PRINT NIL) (T :SYS-REQ NIL)) +(DEFINE-KEY 65377 ((4 0) :PRINT NIL) (T :SYS-REQ NIL)) (DEFINE-KEY 65379 (T :INSERT NIL)) (DEFINE-KEY 65383 (T :MENU NIL)) (DEFINE-KEY 65387 ((12 4) :PAUSE NIL) (T :BREAK NIL)) +(DEFINE-KEY 65406 (T :MODE-SWITCH NIL)) (DEFINE-KEY 65407 (T :NUM-LOCK NIL)) (DEFINE-KEY 65421 (T :KP-ENTER NIL)) (DEFINE-KEY 65429 (T :KP-HOME NIL)) @@ -137,6 +151,11 @@ (DEFINE-KEY 65453 (T :KP-SUBTRACT NIL)) (DEFINE-KEY 65454 (T :KP-DECIMAL NIL)) (DEFINE-KEY 65455 (T :KP-DIVIDE NIL)) +(DEFINE-KEY 65450 ((4 8 0) :KP-MULTIPLY NIL) (T NIL NIL)) +(DEFINE-KEY 65451 ((4 8 0) :KP-ADD NIL) (T NIL NIL)) +(DEFINE-KEY 65452 (T :KP-SEPARATOR NIL)) +(DEFINE-KEY 65453 ((4 8 0) :KP-SUBTRACT NIL) (T NIL NIL)) +(DEFINE-KEY 65455 ((4 8 0) :KP-DIVIDE NIL) (T NIL NIL)) (DEFINE-KEY 65456 (T :KP-0 NIL)) (DEFINE-KEY 65457 (T :KP-1 NIL)) (DEFINE-KEY 65458 (T :KP-2 NIL)) @@ -158,6 +177,18 @@ (DEFINE-KEY 65478 (T :F9 NIL)) (DEFINE-KEY 65479 (T :F10 NIL)) (DEFINE-KEY 65480 (T :F11 NIL)) +(DEFINE-KEY 65470 ((4 8 0) :F1 NIL) (T NIL NIL)) +(DEFINE-KEY 65471 ((4 8 0) :F2 NIL) (T NIL NIL)) +(DEFINE-KEY 65472 ((4 8 0) :F3 NIL) (T NIL NIL)) +(DEFINE-KEY 65473 ((4 8 0) :F4 NIL) (T NIL NIL)) +(DEFINE-KEY 65474 ((4 8 0) :F5 NIL) (T NIL NIL)) +(DEFINE-KEY 65475 ((4 8 0) :F6 NIL) (T NIL NIL)) +(DEFINE-KEY 65476 ((4 8 0) :F7 NIL) (T NIL NIL)) +(DEFINE-KEY 65477 ((4 8 0) :F8 NIL) (T NIL NIL)) +(DEFINE-KEY 65478 ((4 8 0) :F9 NIL) (T NIL NIL)) +(DEFINE-KEY 65479 ((4 8 0) :F10 NIL) (T NIL NIL)) +(DEFINE-KEY 65480 ((4 8 0) :F11 NIL) (T NIL NIL)) +(DEFINE-KEY 65481 ((4 8 0) :F12 NIL) (T NIL NIL)) (DEFINE-KEY 65505 (T :SHIFT-LEFT NIL)) (DEFINE-KEY 65506 (T :SHIFT-RIGHT NIL)) (DEFINE-KEY 65507 (T :CONTROL-LEFT NIL)) @@ -165,7 +196,25 @@ (DEFINE-KEY 65509 (T :CAPS-LOCK NIL)) (DEFINE-KEY 65511 (T :META-LEFT NIL)) (DEFINE-KEY 65512 (T :META-RIGHT NIL)) +(DEFINE-KEY 65513 (T :ALT-LEFT NIL)) +(DEFINE-KEY 65515 (T :SUPER-LEFT NIL)) (DEFINE-KEY 65535 (T :DELETE #\Rubout)) (DEFINE-KEY 268828535 (T :SUN-AUDIO-LOWER-VOLUME NIL)) (DEFINE-KEY 268828536 (T :SUN-AUDIO-MUTE NIL)) -(DEFINE-KEY 268828537 (T :SUN-AUDIO-RAISE-VOLUME NIL)) \ No newline at end of file +(DEFINE-KEY 268828537 (T :SUN-AUDIO-RAISE-VOLUME NIL)) +(DEFINE-KEY 269024769 ((12) :F1 NIL) (T NIL NIL)) +(DEFINE-KEY 269024770 ((12) :F2 NIL) (T NIL NIL)) +(DEFINE-KEY 269024771 ((12) :F3 NIL) (T NIL NIL)) +(DEFINE-KEY 269024772 ((12) :F4 NIL) (T NIL NIL)) +(DEFINE-KEY 269024773 ((12) :F5 NIL) (T NIL NIL)) +(DEFINE-KEY 269024774 ((12) :F6 NIL) (T NIL NIL)) +(DEFINE-KEY 269024775 ((12) :F7 NIL) (T NIL NIL)) +(DEFINE-KEY 269024776 ((12) :F8 NIL) (T NIL NIL)) +(DEFINE-KEY 269024777 ((12) :F9 NIL) (T NIL NIL)) +(DEFINE-KEY 269024778 ((12) :F10 NIL) (T NIL NIL)) +(DEFINE-KEY 269024779 ((12) :F11 NIL) (T NIL NIL)) +(DEFINE-KEY 269024780 ((12) :F12 NIL) (T NIL NIL)) +(DEFINE-KEY 269024800 ((12) :KP-DIVIDE NIL) (T NIL NIL)) +(DEFINE-KEY 269024801 ((12) :KP-MULTIPLY NIL) (T NIL NIL)) +(DEFINE-KEY 269024802 ((12) :KP-ADD NIL) (T NIL NIL)) +(DEFINE-KEY 269024803 ((12) :KP-SUBTRACT NIL) (T NIL NIL)) From dlichteblau at common-lisp.net Sun Jul 15 12:38:38 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 15 Jul 2007 08:38:38 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070715123838.07F3B1900B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv10361 Modified Files: recording.lisp Log Message: Fixed bug reported by Fred Gilham, [mcclim-devel] Tooltip stuff * recording.lisp (erase-output-record): Lock the bounding rectangle to the pixel grid and add extra safety at the borders to avoid leaving fragments on the border. --- /project/mcclim/cvsroot/mcclim/recording.lisp 2007/06/03 18:47:03 1.132 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2007/07/15 12:38:37 1.133 @@ -2048,10 +2048,20 @@ when (eq parent nil) do (return nil) when (eq parent ancestor) do (return t))) +(defun rounded-bounding-rectangle (region) + ;; return a bounding rectangle whose coordinates have been rounded to + ;; lock into the pixel grid. Includes some extra safety to make + ;; sure antialiasing around the theoretical limits are included, too. + (with-bounding-rectangle* (x1 y1 x2 y2) region + (make-rectangle* (floor (- x1 0.5)) + (floor (- y1 0.5)) + (ceiling (+ x2 0.5)) + (ceiling (+ y2 0.5))))) + (defmethod erase-output-record (record (stream standard-output-recording-stream) &optional (errorp t)) (letf (((stream-recording-p stream) nil)) - (let ((region (bounding-rectangle record))) + (let ((region (rounded-bounding-rectangle record))) (with-bounding-rectangle* (x1 y1 x2 y2) region (if (output-record-ancestor-p (stream-output-history stream) record) (progn From crhodes at common-lisp.net Tue Jul 17 06:36:02 2007 From: crhodes at common-lisp.net (crhodes) Date: Tue, 17 Jul 2007 02:36:02 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070717063602.82F8513017@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv20781 Modified Files: bezier.lisp Log Message: In bezier area/curve convolution, don't put the area (pen) down quite so often: reduces redundant areas in unions from draw-path in gsharp. (Also rename convlute -> convolve) --- /project/mcclim/cvsroot/mcclim/bezier.lisp 2007/07/11 15:26:20 1.2 +++ /project/mcclim/cvsroot/mcclim/bezier.lisp 2007/07/17 06:36:01 1.3 @@ -568,7 +568,13 @@ (add-points p1 left) (add-points p0 left)) (make-line-segment (add-points p0 left) (add-points p0 right))))))) -(defun convolute-polygon-and-segment (area polygon segment) +(defun area-at-point (area point) + (let ((transformation + (make-translation-transformation (point-x point) (point-y point)))) + (transform-region transformation area))) + +(defun convolve-polygon-and-segment (area polygon segment first) + (declare (optimize debug)) (let* ((points (polygon-points polygon)) (sides (loop for (p0 p1) on (append (last points) points) until (null p1) @@ -576,24 +582,20 @@ (split-points (find-split-points sides segment)) (segments (split-segment segment split-points))) (loop for segment in segments - append (list (let* ((p (slot-value segment 'p0)) - (transformation (make-translation-transformation - (point-x p) (point-y p)))) - (transform-region transformation area)) - (convert-primitive-segment-to-bezier-area (polygon-points polygon) - segment) - (let* ((p (slot-value segment 'p3)) - (transformation (make-translation-transformation - (point-x p) (point-y p)))) - (transform-region transformation area)))))) + if first collect (area-at-point area (slot-value segment 'p0)) + collect (convert-primitive-segment-to-bezier-area + (polygon-points polygon) segment) + collect (area-at-point area (slot-value segment 'p3))))) -(defgeneric convolute-regions (area path)) +(defgeneric convolve-regions (area path)) -(defmethod convolute-regions ((area bezier-area) (path bezier-curve)) +(defmethod convolve-regions ((area bezier-area) (path bezier-curve)) (let ((polygon (polygonalize area))) - (make-instance 'bezier-union - :areas (loop for segment in (%segments path) - append (convolute-polygon-and-segment area polygon segment))))) + (make-instance + 'bezier-union :areas + (loop for segment in (%segments path) + for first = t then nil + append (convolve-polygon-and-segment area polygon segment first))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -793,6 +795,7 @@ (defmethod medium-draw-bezier-design* (medium design) (render-through-pixmap design medium)) +#| ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Test cases @@ -806,3 +809,4 @@ (defparameter *r4* (make-bezier-curve* '(100 100 120 150 160 160 170 160))) (defparameter *r5* (convolute-regions *r2* *r4*)) +|# From rstrandh at common-lisp.net Tue Jul 17 15:58:47 2007 From: rstrandh at common-lisp.net (rstrandh) Date: Tue, 17 Jul 2007 11:58:47 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/Null Message-ID: <20070717155847.4E0FC44064@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/Null In directory clnet:/tmp/cvs-serv24460 Modified Files: graft.lisp medium.lisp port.lisp Log Message: Added IGNORE declarations to avoid compiler warnings. --- /project/mcclim/cvsroot/mcclim/Backends/Null/graft.lisp 2006/03/24 11:45:03 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/Null/graft.lisp 2007/07/17 15:58:47 1.2 @@ -23,7 +23,9 @@ ()) (defmethod graft-width ((graft null-graft) &key (units :device)) - ()) + (declare (ignore units)) + nil) (defmethod graft-height ((graft null-graft) &key (units :device)) - ()) + (declare (ignore units)) + nil) --- /project/mcclim/cvsroot/mcclim/Backends/Null/medium.lisp 2006/03/24 12:03:31 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/Null/medium.lisp 2007/07/17 15:58:47 1.3 @@ -23,18 +23,22 @@ ((buffering-output-p :accessor medium-buffering-output-p))) (defmethod (setf medium-text-style) :before (text-style (medium null-medium)) - ()) + (declare (ignore text-style)) + nil) (defmethod (setf medium-line-style) :before (line-style (medium null-medium)) - ()) + (declare (ignore line-style)) + nil) (defmethod (setf medium-clipping-region) :after (region (medium null-medium)) - ()) + (declare (ignore region)) + nil) (defmethod medium-copy-area ((from-drawable null-medium) from-x from-y width height (to-drawable null-medium) to-x to-y) + (declare (ignore from-x from-y width height to-x to-y)) nil) #+nil ; FIXME: PIXMAP class @@ -43,26 +47,34 @@ from-x from-y width height (to-drawable pixmap) to-x to-y) + (declare (ignore from-x from-y width height to-x to-y)) nil) + (defmethod medium-copy-area ((from-drawable pixmap) from-x from-y width height (to-drawable null-medium) to-x to-y) - ()) + (declare (ignore from-x from-y width height to-x to-y)) + nil) + (defmethod medium-copy-area ((from-drawable pixmap) from-x from-y width height (to-drawable pixmap) to-x to-y) - ())) + (declare (ignore from-x from-y width height to-x to-y)) + nil)) (defmethod medium-draw-point* ((medium null-medium) x y) - ()) + (declare (ignore x y)) + nil) (defmethod medium-draw-points* ((medium null-medium) coord-seq) - ()) + (declare (ignore coord-seq)) + nil) (defmethod medium-draw-line* ((medium null-medium) x1 y1 x2 y2) - ()) + (declare (ignore x1 y1 x2 y2)) + nil) ;; FIXME: Invert the transformation and apply it here, as the :around ;; methods on transform-coordinates-mixin will cause it to be applied @@ -74,33 +86,50 @@ nil)) (defmethod medium-draw-polygon* ((medium null-medium) coord-seq closed filled) - ()) + (declare (ignore coord-seq closed filled)) + nil) (defmethod medium-draw-rectangle* ((medium null-medium) left top right bottom filled) - ()) + (declare (ignore left top right bottom filled)) + nil) + (defmethod medium-draw-rectangles* ((medium null-medium) position-seq filled) - ()) + (declare (ignore position-seq filled)) + nil) (defmethod medium-draw-ellipse* ((medium null-medium) center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle filled) - ()) + (declare (ignore center-x center-y + radius-1-dx radius-1-dy + radius-2-dx radius-2-dy + start-angle end-angle filled)) + nil) (defmethod medium-draw-circle* ((medium null-medium) center-x center-y radius start-angle end-angle filled) - ()) + (declare (ignore center-x center-y radius + start-angle end-angle filled)) + nil) (defmethod text-style-ascent (text-style (medium null-medium)) + (declare (ignore text-style)) 1) + (defmethod text-style-descent (text-style (medium null-medium)) + (declare (ignore text-style)) 1) + (defmethod text-style-height (text-style (medium null-medium)) (+ (text-style-ascent text-style medium) (text-style-descent text-style medium))) + (defmethod text-style-character-width (text-style (medium null-medium) char) + (declare (ignore text-style char)) 1) + ;;; FIXME: this one is nominally backend-independent (defmethod text-style-width (text-style (medium null-medium)) (text-style-character-width text-style medium #\m)) @@ -134,11 +163,16 @@ start end align-x align-y toward-x toward-y transform-glyphs) - ()) + (declare (ignore string x y + start end + align-x align-y + toward-x toward-y transform-glyphs)) + nil) #+nil (defmethod medium-buffering-output-p ((medium null-medium)) t) + #+nil (defmethod (setf medium-buffering-output-p) (buffer-p (medium null-medium)) buffer-p) @@ -146,18 +180,23 @@ (defmethod medium-draw-glyph ((medium null-medium) element x y align-x align-y toward-x toward-y transform-glyphs) - ()) + (declare (ignore element x y + align-x align-y toward-x toward-y + transform-glyphs)) + nil) (defmethod medium-finish-output ((medium null-medium)) - ()) + nil) + (defmethod medium-force-output ((medium null-medium)) - ()) + nil) (defmethod medium-clear-area ((medium null-medium) left top right bottom) - ()) + (declare (ignore left top right bottom)) + nil) (defmethod medium-beep ((medium null-medium)) - ()) + nil) (defmethod invoke-with-special-choices (continuation (medium null-medium)) (let ((sheet (medium-sheet medium))) --- /project/mcclim/cvsroot/mcclim/Backends/Null/port.lisp 2007/02/07 12:44:19 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/Null/port.lisp 2007/07/17 15:58:47 1.4 @@ -80,19 +80,20 @@ (defmethod port-set-sheet-region ((port null-port) (sheet mirrored-sheet-mixin) region) - ()) + (declare (ignore region)) + nil) (defmethod port-enable-sheet ((port null-port) (mirror mirrored-sheet-mixin)) - ()) + nil) (defmethod port-disable-sheet ((port null-port) (mirror mirrored-sheet-mixin)) - ()) + nil) (defmethod destroy-port :before ((port null-port)) - ()) + nil) (defmethod port-motion-hints ((port null-port) (mirror mirrored-sheet-mixin)) - ()) + nil) (defmethod (setf port-motion-hints) (value (port null-port) (sheet mirrored-sheet-mixin)) @@ -100,7 +101,8 @@ (defmethod get-next-event ((port null-port) &key wait-function (timeout nil)) - ()) + (declare (ignore wait-function timeout)) + nil) (defmethod make-graft ((port null-port) &key (orientation :default) (units :device)) @@ -113,30 +115,37 @@ (defmethod text-style-mapping ((port null-port) text-style &optional character-set) - ()) + (declare (ignore text-style character-set)) + nil) (defmethod (setf text-style-mapping) (font-name (port null-port) - (text-style text-style) &optional character-set) - ()) + (text-style text-style) &optional character-set) + (declare (ignore font-name text-style character-set)) + nil) (defmethod port-character-width ((port null-port) text-style char) - ()) + (declare (ignore text-style char)) + nil) (defmethod port-string-width ((port null-port) text-style string &key (start 0) end) - ()) + (declare (ignore text-style string start end)) + nil) (defmethod port-mirror-width ((port null-port) sheet) - ()) + (declare (ignore sheet)) + nil) (defmethod port-mirror-height ((port null-port) sheet) - ()) + (declare (ignore sheet)) + nil) (defmethod graft ((port null-port)) (first (climi::port-grafts port))) (defmethod port-allocate-pixmap ((port null-port) sheet width height) - ()) + (declare (ignore sheet width height)) + nil) (defmethod port-deallocate-pixmap ((port null-port) pixmap) #+nil @@ -147,16 +156,17 @@ (values (slot-value pointer 'x) (slot-value pointer 'y))) (defmethod pointer-button-state ((pointer null-pointer)) - ()) + nil) (defmethod port-modifier-state ((port null-port)) - ()) + nil) (defmethod synthesize-pointer-motion-event ((pointer null-pointer)) - ()) + nil) (defmethod port-frame-keyboard-input-focus ((port null-port) frame) (frame-properties frame 'focus)) + (defmethod (setf port-frame-keyboard-input-focus) (focus (port null-port) frame) (setf (frame-properties frame 'focus) focus)) @@ -165,35 +175,44 @@ focus) (defmethod port-keyboard-input-focus ((port null-port)) - ()) + nil) (defmethod port-force-output ((port null-port)) - ()) + nil) ;; FIXME: What happens when CLIM code calls tracking-pointer recursively? (defmethod port-grab-pointer ((port null-port) pointer sheet) - ()) + (declare (ignore pointer sheet)) + nil) (defmethod port-ungrab-pointer ((port null-port) pointer sheet) - ()) + (declare (ignore pointer sheet)) + nil) (defmethod distribute-event :around ((port null-port) event) - ()) + (declare (ignore event)) + nil) (defmethod set-sheet-pointer-cursor ((port null-port) sheet cursor) - ()) + (declare (ignore sheet cursor)) + nil) (defmethod bind-selection ((port null-port) window &optional time) - ()) + (declare (ignore window time)) + nil) (defmethod release-selection ((port null-port) &optional time) - ()) + (declare (ignore time)) + nil) (defmethod request-selection ((port null-port) requestor time) - ()) + (declare (ignore requestor time)) + nil) (defmethod get-selection-from-event ((port null-port) event) - ()) + (declare (ignore event)) + nil) (defmethod send-selection ((port null-port) event string) + (declare (ignore event string)) nil) From rstrandh at common-lisp.net Wed Jul 18 16:31:27 2007 From: rstrandh at common-lisp.net (rstrandh) Date: Wed, 18 Jul 2007 12:31:27 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070718163127.01B4E37011@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv4744 Modified Files: recording.lisp Log Message: Added IGNORE declarations to avoid warnings about unused variables. --- /project/mcclim/cvsroot/mcclim/recording.lisp 2007/07/15 12:38:37 1.133 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2007/07/18 16:31:27 1.134 @@ -1083,6 +1083,7 @@ (defmethod replay-output-record :around ((record gs-ink-mixin) stream &optional region x-offset y-offset) + (declare (ignore region x-offset y-offset)) (with-drawing-options (stream :ink (graphics-state-ink record)) (call-next-method))) @@ -1111,6 +1112,7 @@ (defmethod replay-output-record :around ((record gs-clip-mixin) stream &optional region x-offset y-offset) + (declare (ignore region x-offset y-offset)) (with-drawing-options (stream :clipping-region (graphics-state-clip record)) (call-next-method))) @@ -1140,6 +1142,7 @@ (defmethod replay-output-record :around ((record gs-line-style-mixin) stream &optional region x-offset y-offset) + (declare (ignore region x-offset y-offset)) (with-drawing-options (stream :line-style (graphics-state-line-style record)) (call-next-method))) @@ -1166,6 +1169,7 @@ (defmethod replay-output-record :around ((record gs-text-style-mixin) stream &optional region x-offset y-offset) + (declare (ignore region x-offset y-offset)) (with-drawing-options (stream :text-style (graphics-state-text-style record)) (call-next-method))) @@ -1688,7 +1692,6 @@ :text-style text-style)) ) (ascent (text-style-ascent text-style (sheet-medium stream))) (descent (text-style-descent text-style (sheet-medium stream))) - (height (+ ascent descent)) (transform (medium-transformation medium))) (setf (values point-x point-y) (transform-position transform point-x point-y)) From rstrandh at common-lisp.net Wed Jul 18 16:57:14 2007 From: rstrandh at common-lisp.net (rstrandh) Date: Wed, 18 Jul 2007 12:57:14 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070718165714.7A29113017@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv8060 Modified Files: events.lisp Log Message: Avoid compiler warnings about implicit creation of generic functions. --- /project/mcclim/cvsroot/mcclim/events.lisp 2006/03/29 10:43:36 1.29 +++ /project/mcclim/cvsroot/mcclim/events.lisp 2007/07/18 16:57:14 1.30 @@ -158,13 +158,19 @@ (defmethod pointer-event-y ((event pointer-event)) (get-pointer-position ((event-sheet event) event) y)) +(defgeneric pointer-event-position* (pointer-event)) + (defmethod pointer-event-position* ((event pointer-event)) (get-pointer-position ((event-sheet event) event) (values x y))) +(defgeneric device-event-x (device-event)) + (defmethod device-event-x ((event device-event)) (get-pointer-position ((event-sheet event) event) x)) +(defgeneric device-event-y (device-event)) + (defmethod device-event-y ((event device-event)) (get-pointer-position ((event-sheet event) event) y)) @@ -237,9 +243,13 @@ (declare (ignorable x y)) , at body)) +(defgeneric window-configuration-event-x (window-configuration-event)) + (defmethod window-configuration-event-x ((event window-configuration-event)) (get-window-position ((event-sheet event) event) x)) +(defgeneric window-configuration-event-y (window-configuration-event)) + (defmethod window-configuration-event-y ((event window-configuration-event)) (get-window-position ((event-sheet event) event) y)) From rstrandh at common-lisp.net Thu Jul 19 06:17:32 2007 From: rstrandh at common-lisp.net (rstrandh) Date: Thu, 19 Jul 2007 02:17:32 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/PostScript Message-ID: <20070719061732.F071413025@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/PostScript In directory clnet:/tmp/cvs-serv29801/Backends/PostScript Modified Files: font.lisp Log Message: Removed an unused local variable and added some IGNORE declarations to remove a few compiler warnings. --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/font.lisp 2006/03/29 10:43:38 1.10 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/font.lisp 2007/07/19 06:17:32 1.11 @@ -94,7 +94,6 @@ (unless end (setq end (length string))) (let* ((font-info (or (gethash font-name *font-metrics*) (error "Unknown font ~S." font-name))) - (char-names (font-info-char-names font-info)) (char-metrics (font-info-char-infos font-info)) (scale (/ size 1000)) (width 0) (upper-width 0) @@ -237,10 +236,12 @@ direction first-not-done) (psfont-text-extents metrics-key string :start start :end position-newline) + (declare (ignore width 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) + (declare (ignore miny)) (values (* scale (min minx left)) (* scale (- ascent)) (* scale (max maxx right)) @@ -251,6 +252,7 @@ direction first-not-done) (psfont-text-extents metrics-key string :start start :end end) + (declare (ignore width font-ascent font-descent direction first-not-done)) (values (* scale left) (* scale (- ascent)) (* scale right) From ahefner at common-lisp.net Thu Jul 19 06:35:43 2007 From: ahefner at common-lisp.net (ahefner) Date: Thu, 19 Jul 2007 02:35:43 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20070719063543.CDBBE66008@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv1203 Modified Files: medium.lisp Log Message: Fix medium-copy-area between pixmaps - we need a graphics context, but none of the medium-gcontext methods apply to pixmaps, so create one using the medium of sheet associated with the destination pixmap. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2007/04/01 17:23:22 1.80 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2007/07/19 06:35:42 1.81 @@ -638,9 +638,10 @@ (defmethod medium-copy-area ((from-drawable pixmap) from-x from-y width height (to-drawable pixmap) to-x to-y) (xlib:copy-area (pixmap-mirror from-drawable) - (medium-gcontext from-drawable +background-ink+) + (medium-gcontext (sheet-medium (slot-value to-drawable 'sheet)) + +background-ink+) (round-coordinate from-x) (round-coordinate from-y) - (round width) (round height) + (round width) (round height) (pixmap-mirror to-drawable) (round-coordinate to-x) (round-coordinate to-y))) From ahefner at common-lisp.net Thu Jul 19 06:49:57 2007 From: ahefner at common-lisp.net (ahefner) Date: Thu, 19 Jul 2007 02:49:57 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20070719064957.D8E4513025@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv4687 Modified Files: misc-tests.lisp Log Message: Define tests in a nicer fashion. Add tests for scaled/rotated arrows, gadget output records, and transparent ink. --- /project/mcclim/cvsroot/mcclim/Examples/misc-tests.lisp 2007/02/05 03:26:10 1.1 +++ /project/mcclim/cvsroot/mcclim/Examples/misc-tests.lisp 2007/07/19 06:49:57 1.2 @@ -24,7 +24,18 @@ (in-package :clim-demo) -(defstruct misc-test-item name drawer description) + +(defvar *misc-tests* (make-hash-table :test 'equal)) + +(defstruct misc-test name description drawer) + +(defmacro define-misc-test (name arglist description &body body) + (check-type name string) + (check-type description string) + `(setf (gethash ,name *misc-tests*) + (make-misc-test :name ,name + :description ,description + :drawer (lambda ,arglist , at body)))) (define-application-frame misc-tests () () @@ -33,23 +44,9 @@ (description :application-pane) (selector :list-pane :mode :exclusive - :name-key #'misc-test-item-name - :items (list - (make-misc-test-item :name "Empty Records 1" - :drawer 'misc-empty-records-1 - :description "Tests the effect of empty output records on their parent's bounding rectangle. If successful, you will see a circle enclosed in a square. The square should tightly fit the circle. If the rectangle extends all the way to the top/left edges of the pane, McCLIM is not handling this correctly. This specifically exercises addition of empty children in recompute-extent-for-new-child.") - (make-misc-test-item :name "Empty Records 2" - :drawer 'misc-empty-records-2 - :description "Tests the effect of empty output records on their parent's bounding rectangle. If successful, you will see a circle enclosed in a square. The square should tightly fit the circle. If the rectangle extends all the way to the top/left edges of the pane, McCLIM is not handling this correctly. This specifically tests addition and deletion of an empty child, and failure may point to recompute-extent-for-new-child or recompute-extent-for-changed-child.") - (make-misc-test-item :name "Empty Records 3" - :drawer 'misc-empty-records-3 - :description "Tests the effect of empty output records on their parent's bounding rectangle. If successful, you will see a circle enclosed in a square. The square should tightly fit the circle. If the rectangle extends all the way to the top/left edges of the pane, McCLIM is not handling this correctly. This test creates a new output record, fills it with content, then clears the record contents.") - (make-misc-test-item :name "Empty Borders" - :drawer 'misc-empty-bordering - :description "Tests handling of empty output records by surrounding-output-with-border. If successful, you will see twelve small circles arranged themselves in a larger circle. A likely failure mode will exhibit the circles piled on each other in the upper-left corner of the pane.") - (make-misc-test-item :name "Underlining" - :drawer 'misc-underlining-test - :description "Tests the underlining border style. You should see five lines of text, equally spaced, with the second and third lines having the phrase 'all live' underlined, first by a thick black line then by a thin dashed red line. If the lines are broken or the spacing is irregular, the :move-cursor nil key of surrounding-output-with-border may not have behaved as expected. ")) + :name-key #'misc-test-name + :items (sort (loop for x being the hash-values of *misc-tests* + collect x) #'string< :key #'misc-test-name) :value-changed-callback (lambda (pane item) (declare (ignore pane)) @@ -58,8 +55,8 @@ (window-clear output) (window-clear description) (with-text-style (description (make-text-style :sans-serif :roman :normal)) - (write-string (misc-test-item-description item) description)) - (funcall (misc-test-item-drawer item) output))))) + (write-string (misc-test-description item) description)) + (funcall (misc-test-drawer item) output))))) (:layouts (default (spacing (:thickness 3) @@ -73,25 +70,30 @@ (clim-extensions:lowering () (scrolling (:scroll-bar :vertical :height 200) description))))))))) -(defun misc-empty-records-1 (stream) +(define-misc-test "Empty Records 1" (stream) + "Tests the effect of empty output records on their parent's bounding rectangle. If successful, you will see a circle enclosed in a square. The square should tightly fit the circle. If the rectangle extends all the way to the top/left edges of the pane, McCLIM is not handling this correctly. This specifically exercises addition of empty children in recompute-extent-for-new-child." (surrounding-output-with-border (stream :shape :rectangle) (draw-circle* stream 200 200 40) (with-new-output-record (stream)))) -(defun misc-empty-records-2 (stream) + +(define-misc-test "Empty Records 2" (stream) + "Tests the effect of empty output records on their parent's bounding rectangle. If successful, you will see a circle enclosed in a square. The square should fit the circle within a few pixels distance. If the rectangle extends all the way to the top/left edges of the pane, McCLIM is not handling this correctly. This specifically tests addition and deletion of an empty child, and failure may point to recompute-extent-for-new-child or recompute-extent-for-changed-child." (surrounding-output-with-border (stream :shape :rectangle) (draw-circle* stream 200 200 40) (let ((record (with-new-output-record (stream)))) (delete-output-record record (output-record-parent record))))) -(defun misc-empty-records-3 (stream) +(define-misc-test "Empty Records 3" (stream) + "Tests the effect of empty output records on their parent's bounding rectangle. If successful, you will see a circle enclosed in a square. The square should fit the circle within a few pixels distance. If the rectangle extends all the way to the top/left edges of the pane, McCLIM is not handling this correctly. This test creates a new output record, fills it with content, then clears the record contents." (surrounding-output-with-border (stream :shape :rectangle) (draw-circle* stream 200 200 40) (let ((record (with-new-output-record (stream) (draw-circle* stream 50 50 10)))) (clear-output-record record)))) - -(defun misc-empty-bordering (stream) + +(define-misc-test "Empty Borders" (stream) + "Tests handling of empty output records by surrounding-output-with-border. If successful, you will see twelve small circles arranged themselves in a larger circle. A likely failure mode will exhibit the circles piled on each other in the upper-left corner of the pane." (with-room-for-graphics (stream :first-quadrant nil) (with-text-style (stream (make-text-style :sans-serif :roman :small)) (loop with outer-radius = 180 @@ -113,7 +115,8 @@ ;(multiple-value-call #'draw-point* stream (stream-cursor-position stream)) #+NIL (print i stream)))))) -(defun misc-underlining-test (stream) +(define-misc-test "Underlining" (stream) + "Tests the underlining border style. You should see five lines of text, equally spaced, with the second and third lines having the phrase 'all live' underlined, first by a thick black line then by a thin dashed red line. If the lines are broken or the spacing is irregular, the :move-cursor nil key of surrounding-output-with-border may not have behaved as expected. " (with-text-family (stream :sans-serif) (format stream "~&We all live in a yellow subroutine.~%") (format stream "~&We ") @@ -132,3 +135,95 @@ (format stream "~&We all live in a yellow subroutine.~%") (format stream "~&We all live in a yellow subroutine.~%"))) +(define-misc-test "Transparent Ink Test" (stream) + "Drawing with transparent ink can be useful as a way of reserving space as padding around the visible part of a drawing. This test checks that the medium supports drawing in transparent ink, and that it is recorded with the expected bounding rectangle. It will draw two tables, which should format identically except for one square, which will be transparent in the first table and blue in the second. If the in absence of the blue square its row and column collapse to a small size, the bounding rectangle for the transparent squares is probably wrong. Light gray circles will be drawn in the backgroud, and should show through the empty row/column of the table." + (let ((table '((1 1 1 0 1) + (1 1 1 0 1) + (1 1 1 0 1) + (0 0 0 2 0) + (1 1 1 0 1))) + (inks (list +transparent-ink+ +red+ +blue+)) + (records nil)) + ;; Draw some junk to make sure the transparent ink is really transparent, + ;; and not just matching the background: + (dotimes (i 400) + (draw-circle* stream (- (random 600) 100) (- (random 600) 100) (1+ (* 40 (random 1.0) (random 1.0))) :ink +gray90+)) + ;; Draw two tables: + (format-items '(0 2) :stream stream :printer + (lambda (foo stream) + ;; Why isn't there an :equalize-row-heights ? + (surrounding-output-with-border (stream) + (formatting-table (stream :equalize-column-widths nil) + (dolist (row table) + (formatting-row (stream) + (dolist (cell row) + (formatting-cell (stream) + (push + (with-new-output-record (stream) + (draw-rectangle* stream 0 0 32 32 + :ink (elt inks (if (eql cell 2) + foo + cell)))) + records))))))))) + ;; Make sure the bounding rectangles are the same: + (unless (reduce + (lambda (a b) + (and a + (> 1 (abs (- (bounding-rectangle-width a) + (bounding-rectangle-width b)))) + (> 1 (abs (- (bounding-rectangle-height a) + (bounding-rectangle-height b)))) + b)) + records) + (format stream "~&The bounding rectangles don't look right..~%")))) + +(define-misc-test "Arrows" (stream) + "Tests scaling and rotation of arrow heads, and the handling of the case where the heads become sufficiently large that they would overlap and should join in the middle. The line thickness and arrowhead width is increased from thin to thick, counterclockwise. The tips of the arrows should always fall on the green and red points." + (let ((scale 1.2) + (from-head t) + (to-head t)) + (with-room-for-graphics (stream :first-quadrant nil) + (with-scaling (stream scale scale) + (loop for theta from 0.0 below (* 2 pi) by (/ (* 2 pi) 17) do + (progn (let* ((x2 (* 250 (sin theta))) + (y2 (* 250 (cos theta))) + (x1 (* 0.2 x2)) + (y1 (* 0.2 y2))) + (draw-arrow* stream x1 y1 x2 y2 + :line-thickness (1+ (* 8 theta)) + :head-width (* 5 (1+ theta)) + :to-head to-head + :from-head from-head + :head-length (* 10 (1+ theta)) ) + (draw-point* stream x1 y1 :ink +red+ :line-thickness 5) + (draw-point* stream x2 y2 :ink +green+ :line-thickness 5)))))))) + +(define-misc-test "Gadget Output Records" (stream) + "This tests integration of gadget output records. They should have correct bounding rectangles, and moving the output record should move the gadget. Adding/removing the output record from the history should add/remove the gadget as expected. If these things are true, gadget outputs records should work in almost any situation normal CLIM drawing would (excluding inside incremental redisplay, at present (?)), including graph layout and table formatting. This test uses format-graph-from-roots to create graph whose nodes are push-buttons." + (let ((tree #+NIL '(peter peter (pumpkin eater)) + #+NIL '(one (two (three (four and there he kept her very well) + ) + had a wife but "couldn't" keep her) + peter peter pumpkin eater) + '((peter peter pumpkin eater) + (had (a wife) (but (couldnt (keep (her))))) + (he (put her (in (a pumpkin shell)))) + (and there he (kept her (very well)))))) + (format-graph-from-roots tree + (lambda (obj stream) + (let ((obj (typecase obj (list (first obj)) (t obj)))) + (let ((fm (frame-manager *application-frame*))) + (with-look-and-feel-realization (fm *application-frame*) + (with-output-as-gadget (stream) + (make-pane 'push-button + :activate-callback + (lambda (&rest args) + (declare (ignore args)) + (notify-user *application-frame* "You clicked a button.")) + :label (string-downcase + (princ-to-string obj)))))))) + (lambda (obj) + (if (listp obj) (rest obj) nil)) + :stream stream))) + + From ahefner at common-lisp.net Thu Jul 19 06:52:51 2007 From: ahefner at common-lisp.net (ahefner) Date: Thu, 19 Jul 2007 02:52:51 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070719065251.97CEB2E1CB@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv5509 Modified Files: graphics.lisp Log Message: Fix draw-arrow* when applied directly to a medium (it assumed a sheet). --- /project/mcclim/cvsroot/mcclim/graphics.lisp 2007/02/05 02:58:46 1.57 +++ /project/mcclim/cvsroot/mcclim/graphics.lisp 2007/07/19 06:52:51 1.58 @@ -572,14 +572,13 @@ (p end) (q start) - (medium (sheet-medium sheet)) - (line-style (medium-line-style medium)) + (line-style (medium-line-style sheet)) ;; FIXME: I believe this thickness is in "line-style-units", ;; which are only coincidentally the same as pixel coorindates ;; on screen backends, using :normal units. There is no function ;; documented for converting the units to stream coordinates. (thickness (multiple-value-bind (dx dy) - (transform-distance (invert-transformation (medium-transformation medium)) + (transform-distance (invert-transformation (medium-transformation sheet)) (line-style-thickness line-style) 0) (sqrt (+ (* dx dx) (* dy dy))))) From ahefner at common-lisp.net Thu Jul 19 06:55:40 2007 From: ahefner at common-lisp.net (ahefner) Date: Thu, 19 Jul 2007 02:55:40 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20070719065540.05034481A4@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv6318 Modified Files: medium.lisp Log Message: Fix +transparent-ink+ on the CLX backend in a questionable manner. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2007/07/19 06:35:42 1.81 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2007/07/19 06:55:39 1.82 @@ -173,6 +173,11 @@ (setf (xlib:gcontext-clip-mask gc :unsorted) rect-seq))))) gc))) +(defmethod medium-gcontext ((medium clx-medium) (ink (eql +transparent-ink+))) + (let ((drawable (port-lookup-mirror (port medium) (medium-sheet medium)))) + (with-slots (gc) medium + (or gc (setf gc (xlib:create-gcontext :drawable drawable)))))) + (defmethod medium-gcontext ((medium clx-medium) (ink (eql +foreground-ink+))) (medium-gcontext medium (medium-foreground medium))) @@ -589,8 +594,9 @@ (ink (medium-ink ,medium)) (gc (medium-gcontext ,medium ink))) line-style ink - (unwind-protect - (progn , at body) + (unwind-protect + (unless (eql ink +transparent-ink+) + (progn , at body)) #+ignore(xlib:free-gcontext gc)))))) From ahefner at common-lisp.net Thu Jul 19 06:58:30 2007 From: ahefner at common-lisp.net (ahefner) Date: Thu, 19 Jul 2007 02:58:30 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20070719065830.1BD55481A5@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv7920 Modified Files: misc-tests.lisp Log Message: Tidying up. --- /project/mcclim/cvsroot/mcclim/Examples/misc-tests.lisp 2007/07/19 06:49:57 1.2 +++ /project/mcclim/cvsroot/mcclim/Examples/misc-tests.lisp 2007/07/19 06:58:30 1.3 @@ -111,9 +111,7 @@ :filled t :line-thickness 1 :background +gray50+ - :outline-ink +gray40+) - ;(multiple-value-call #'draw-point* stream (stream-cursor-position stream)) - #+NIL (print i stream)))))) + :outline-ink +gray40+)))))) (define-misc-test "Underlining" (stream) "Tests the underlining border style. You should see five lines of text, equally spaced, with the second and third lines having the phrase 'all live' underlined, first by a thick black line then by a thin dashed red line. If the lines are broken or the spacing is irregular, the :move-cursor nil key of surrounding-output-with-border may not have behaved as expected. " @@ -200,12 +198,7 @@ (define-misc-test "Gadget Output Records" (stream) "This tests integration of gadget output records. They should have correct bounding rectangles, and moving the output record should move the gadget. Adding/removing the output record from the history should add/remove the gadget as expected. If these things are true, gadget outputs records should work in almost any situation normal CLIM drawing would (excluding inside incremental redisplay, at present (?)), including graph layout and table formatting. This test uses format-graph-from-roots to create graph whose nodes are push-buttons." - (let ((tree #+NIL '(peter peter (pumpkin eater)) - #+NIL '(one (two (three (four and there he kept her very well) - ) - had a wife but "couldn't" keep her) - peter peter pumpkin eater) - '((peter peter pumpkin eater) + (let ((tree '((peter peter pumpkin eater) (had (a wife) (but (couldnt (keep (her))))) (he (put her (in (a pumpkin shell)))) (and there he (kept her (very well)))))) From rstrandh at common-lisp.net Thu Jul 19 10:41:57 2007 From: rstrandh at common-lisp.net (rstrandh) Date: Thu, 19 Jul 2007 06:41:57 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Goatee Message-ID: <20070719104157.6D9647209A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Goatee In directory clnet:/tmp/cvs-serv4089/Goatee Modified Files: clim-area.lisp Log Message: Removed IGNORE declaration of undefined variables. --- /project/mcclim/cvsroot/mcclim/Goatee/clim-area.lisp 2006/05/09 14:01:09 1.34 +++ /project/mcclim/cvsroot/mcclim/Goatee/clim-area.lisp 2007/07/19 10:41:56 1.35 @@ -299,7 +299,6 @@ (defmethod climi::map-over-output-records-1 (function (record simple-screen-area) function-args) - (declare (ignore x-offset y-offset)) (if function-args (loop for line = (area-first-line record) then (next line) while line From rstrandh at common-lisp.net Sat Jul 21 12:27:46 2007 From: rstrandh at common-lisp.net (rstrandh) Date: Sat, 21 Jul 2007 08:27:46 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070721122746.D981E830AA@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv12394 Modified Files: pointer-tracking.lisp Log Message: Declared some more arguments IGNORE or IGNORABLE to remove some more compiler warnings. --- /project/mcclim/cvsroot/mcclim/pointer-tracking.lisp 2006/12/21 10:36:40 1.18 +++ /project/mcclim/cvsroot/mcclim/pointer-tracking.lisp 2007/07/21 12:27:45 1.19 @@ -81,7 +81,7 @@ &key pointer multiple-window transformp context-type (highlight nil highlight-p)) &body body) - (declare (ignorable pointer transformp context-type highlight)) + (declare (ignorable multiple-window pointer transformp context-type highlight)) (setq sheet (stream-designator-symbol sheet '*standard-output*)) (loop for (event-name handler-args . handler-body) in body @@ -123,7 +123,7 @@ (defmethod tracking-pointer-loop ((state tracking-pointer-state) frame sheet &rest args &key pointer multiple-window transformp context-type highlight) - (declare (ignore pointer context-type highlight frame)) + (declare (ignore args pointer context-type highlight frame)) (with-sheet-medium (medium sheet) (flet ((do-tracking () (loop From rstrandh at common-lisp.net Sat Jul 21 13:06:45 2007 From: rstrandh at common-lisp.net (rstrandh) Date: Sat, 21 Jul 2007 09:06:45 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070721130645.694E46012F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv20327 Modified Files: dialog.lisp Log Message: Added more IGNORE declarations. --- /project/mcclim/cvsroot/mcclim/dialog.lisp 2007/06/06 05:03:12 1.27 +++ /project/mcclim/cvsroot/mcclim/dialog.lisp 2007/07/21 13:06:45 1.28 @@ -278,7 +278,9 @@ additional-activation-gestures delimiter-gestures additional-delimiter-gestures) - (declare (ignore activation-gestures additional-activation-gestures + (declare (ignore default-type provide-default insert-default replace-input + history active-p prompt-mode display-default + activation-gestures additional-activation-gestures delimiter-gestures additional-delimiter-gestures)) (let ((query (find query-identifier (queries stream) :key #'query-identifier :test #'equal)) From rstrandh at common-lisp.net Sat Jul 21 13:18:59 2007 From: rstrandh at common-lisp.net (rstrandh) Date: Sat, 21 Jul 2007 09:18:59 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070721131859.ECA271600F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv22562 Modified Files: panes.lisp Log Message: more IGNORE declarations --- /project/mcclim/cvsroot/mcclim/panes.lisp 2007/03/20 01:43:55 1.182 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2007/07/21 13:18:59 1.183 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.182 2007/03/20 01:43:55 ahefner Exp $ +;;; $Id: panes.lisp,v 1.183 2007/07/21 13:18:59 rstrandh Exp $ (in-package :clim-internals) @@ -904,6 +904,7 @@ (defmethod change-space-requirements ((pane top-level-sheet-pane) &rest space-req-keys &key resize-frame &allow-other-keys) + (declare (ignore space-req-keys)) (cond (*changing-space-requirements* ;; just record what we have (unless (find pane *changed-space-requirements* :key #'second) @@ -999,6 +1000,7 @@ ;; application-frame. I am not sure if this is totally right. ;; ;; --GB 2003-03-16 + (declare (ignore space-req-keys resize-frame)) (let ((w (space-requirement-width (compose-space pane))) (h (space-requirement-height (compose-space pane)))) (resize-sheet pane w h) From rstrandh at common-lisp.net Sat Jul 21 14:17:15 2007 From: rstrandh at common-lisp.net (rstrandh) Date: Sat, 21 Jul 2007 10:17:15 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070721141715.5A925830A3@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv4727 Modified Files: table-formatting.lisp Log Message: Added IGNORABLE declaration. --- /project/mcclim/cvsroot/mcclim/table-formatting.lisp 2006/03/10 21:58:13 1.39 +++ /project/mcclim/cvsroot/mcclim/table-formatting.lisp 2007/07/21 14:17:15 1.40 @@ -132,6 +132,7 @@ (min-width 0) (min-height 0) (record-type ''standard-cell-output-record)) &body body) + (declare (ignorable align-x align-y)) (setq stream (stream-designator-symbol stream '*standard-output*)) (with-keywords-removed (more (:record-type :min-width :min-height)) (with-gensyms (record) From rstrandh at common-lisp.net Sun Jul 22 06:30:41 2007 From: rstrandh at common-lisp.net (rstrandh) Date: Sun, 22 Jul 2007 02:30:41 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20070722063041.BA0BD1603F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv24361/Backends/CLX Modified Files: port.lisp Log Message: Added more IGNORE declarations to avoid compiler warnings. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2007/02/07 12:44:18 1.127 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2007/07/22 06:30:41 1.128 @@ -137,6 +137,7 @@ (let ((entry (fontset-point point fontset))) (if entry (destructuring-bind ((range-start . range-stop) font translator) entry + (declare (ignore range-start range-stop)) (xlib:char-width font (funcall translator point))) 0))) @@ -350,6 +351,10 @@ :structure-notify :pointer-motion :button-motion))) + ;; I am declaring BORDER-WIDTH ignore to get a cleaner build, but I + ;; don't really understand why the use of it is commented out in favor + ;; of the constant 0. -- RS 2007-07-22 + (declare (ignore border-width)) (when (null (port-lookup-mirror port sheet)) (update-mirror-geometry sheet) (let* ((desired-color (typecase sheet @@ -665,6 +670,7 @@ target property requestor selection request first-keycode count &allow-other-keys) + (declare (ignore display request first-keycode count)) (declare (special *clx-port*)) (let ((sheet (and window (port-lookup-sheet *clx-port* window)))) (when sheet