September 2005 - mcclim-cvs@common-lisp.net

[mcclim-cvs] CVS update: mcclim/Tests/commands.lisp
by crhodes＠common-lisp.net 30 Sep '05

30 Sep '05

Update of /project/mcclim/cvsroot/mcclim/Tests In directory common-lisp.net:/tmp/cvs-serv25896/Tests Modified Files: commands.lisp Log Message: Whoops. Fix obvious thinko Date: Fri Sep 30 18:02:40 2005 Author: crhodes Index: mcclim/Tests/commands.lisp diff -u mcclim/Tests/commands.lisp:1.1 mcclim/Tests/commands.lisp:1.2 --- mcclim/Tests/commands.lisp:1.1 Fri Sep 30 18:01:32 2005 +++ mcclim/Tests/commands.lisp Fri Sep 30 18:02:33 2005 @@ -35,7 +35,7 @@ (lambda (menu-name gesture item) (incf count) (assert - (and (equal menu-name nil) + (and (equal menu-name "Test") (equal gesture '(:keyboard #\u 0)) (equal (command-menu-item-value item) (lookup-keystroke-command-item gesture 'menu-test-table)))))

1 0

[mcclim-cvs] CVS update: mcclim/Tests/commands.lisp
by crhodes＠common-lisp.net 30 Sep '05

30 Sep '05

Update of /project/mcclim/cvsroot/mcclim/Tests In directory common-lisp.net:/tmp/cvs-serv24976/Tests Added Files: commands.lisp Log Message: Commit untested patch from JQS for command-table-keystroke mapping. Add untested tests for the problem. People with non-mutant mcclim trees and a certain amount of free time would be well advised to run the tests. Date: Fri Sep 30 18:01:32 2005 Author: crhodes

1 0

[mcclim-cvs] CVS update: mcclim/commands.lisp
by crhodes＠common-lisp.net 30 Sep '05

30 Sep '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv24976 Modified Files: commands.lisp Log Message: Commit untested patch from JQS for command-table-keystroke mapping. Add untested tests for the problem. People with non-mutant mcclim trees and a certain amount of free time would be well advised to run the tests. Date: Fri Sep 30 18:01:31 2005 Author: crhodes Index: mcclim/commands.lisp diff -u mcclim/commands.lisp:1.54 mcclim/commands.lisp:1.55 --- mcclim/commands.lisp:1.54 Thu Aug 18 06:30:09 2005 +++ mcclim/commands.lisp Fri Sep 30 18:01:30 2005 @@ -471,7 +471,8 @@ (loop for gesture in keystroke-accelerators for item in keystroke-items do (funcall function - (command-menu-item-name item) + (and (slot-boundp item 'menu-name) + (command-menu-item-name item)) gesture item)))))

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Listener/package.lisp
by rschlatte＠common-lisp.net 22 Sep '05

22 Sep '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory common-lisp.net:/tmp/cvs-serv10205/Apps/Listener Modified Files: package.lisp Log Message: Remove clim-listener:run-listener-process, since it's not used anymore. Also update comment in fix-sbcl Date: Thu Sep 22 13:40:31 2005 Author: rschlatte Index: mcclim/Apps/Listener/package.lisp diff -u mcclim/Apps/Listener/package.lisp:1.1 mcclim/Apps/Listener/package.lisp:1.2 --- mcclim/Apps/Listener/package.lisp:1.1 Sun Jan 2 06:08:46 2005 +++ mcclim/Apps/Listener/package.lisp Thu Sep 22 13:40:31 2005 @@ -3,7 +3,7 @@ (defpackage "CLIM-LISTENER" (:use "CLIM" "CLIM-LISP") - (:export #:run-listener #:run-listener-process #:dev-commands)) + (:export #:run-listener #:dev-commands)) (in-package :clim-listener)

1 0

[mcclim-cvs] CVS update: mcclim/Lisp-Dep/fix-sbcl.lisp
by rschlatte＠common-lisp.net 22 Sep '05

22 Sep '05

Update of /project/mcclim/cvsroot/mcclim/Lisp-Dep In directory common-lisp.net:/tmp/cvs-serv10205/Lisp-Dep Modified Files: fix-sbcl.lisp Log Message: Remove clim-listener:run-listener-process, since it's not used anymore. Also update comment in fix-sbcl Date: Thu Sep 22 13:40:29 2005 Author: rschlatte Index: mcclim/Lisp-Dep/fix-sbcl.lisp diff -u mcclim/Lisp-Dep/fix-sbcl.lisp:1.9 mcclim/Lisp-Dep/fix-sbcl.lisp:1.10 --- mcclim/Lisp-Dep/fix-sbcl.lisp:1.9 Fri Aug 19 23:34:43 2005 +++ mcclim/Lisp-Dep/fix-sbcl.lisp Thu Sep 22 13:40:29 2005 @@ -19,10 +19,9 @@ (export sym :clim-mop)))) -;;; In SBCL the Common Lisp versions of CLASS-OF and FIND-CLASS return -;;; wrappers which the MOP can't grok, so use the PCL versions -;;; instead. - +;;; In SBCL the Common Lisp versions of CLASS-OF and FIND-CLASS used +;;; to return wrappers which the MOP couldn't grok. This has been fixed +;;; for some time, certainly in sbcl 0.9.4. #+nil (eval-when (:compile-toplevel :load-toplevel :execute) (flet ((reexport (symbols)

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/README.txt
by rschlatte＠common-lisp.net 22 Sep '05

22 Sep '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle In directory common-lisp.net:/tmp/cvs-serv10205/Backends/beagle Modified Files: README.txt Log Message: Remove clim-listener:run-listener-process, since it's not used anymore. Also update comment in fix-sbcl Date: Thu Sep 22 13:40:30 2005 Author: rschlatte Index: mcclim/Backends/beagle/README.txt diff -u mcclim/Backends/beagle/README.txt:1.18 mcclim/Backends/beagle/README.txt:1.19 --- mcclim/Backends/beagle/README.txt:1.18 Sun Jun 12 18:53:25 2005 +++ mcclim/Backends/beagle/README.txt Thu Sep 22 13:40:30 2005 @@ -118,13 +118,12 @@ 7. -> (setf climi:*default-server-path* :clx) 8. -> (clim-listener:run-listener) 9. CL-USER> (setf climi:*default-server-path* :beagle) -10. CL-USER> (clim-listener:run-listener-process) +10. CL-USER> (clim-listener:run-listener :new-process t) I can get both a CLX and a Beagle Listener running simultaneously. -You can also do a (clim-listener:run-listener-process) in (8) and -then run the other listener from the OpenMCL Listener. -Other variations probably work too, but I haven't experimented too -much. +You can also do a (clim-listener:run-listener :new-process t) in (8) +and then run the other listener from the OpenMCL Listener. Other +variations probably work too, but I haven't experimented too much. (7) isn't actually necessary, since the CLX port appears in the server- path search order before the Beagle port does.

1 0

[mcclim-cvs] CVS update: mcclim/Tests/transformations.lisp
by rstrandh＠common-lisp.net 21 Sep '05

21 Sep '05

Update of /project/mcclim/cvsroot/mcclim/Tests In directory common-lisp.net:/tmp/cvs-serv12191 Modified Files: transformations.lisp Log Message: more tests on transformations. Date: Wed Sep 21 22:18:09 2005 Author: rstrandh Index: mcclim/Tests/transformations.lisp diff -u mcclim/Tests/transformations.lisp:1.1 mcclim/Tests/transformations.lisp:1.2 --- mcclim/Tests/transformations.lisp:1.1 Mon Sep 19 00:12:04 2005 +++ mcclim/Tests/transformations.lisp Wed Sep 21 22:18:06 2005 @@ -54,3 +54,71 @@ (assert (typep (make-3-point-transformation p1 p2 p3 p4 p5 p6) 'transformation)) (assert (typep (make-3-point-transformation* x1 y1 x2 y2 x3 y3 x4 y4 x5 y5 x6 y6) 'transformation)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; transformation protocol + +(let* ((t1 (make-rotation-transformation 0)) + (t2 (make-scaling-transformation 1 1))) + (assert (identity-transformation-p t1)) + (assert (identity-transformation-p t2)) + (assert (transformation-equal t1 t2)) + (assert (invertible-transformation-p t1)) + (assert (invertible-transformation-p t2)) + (assert (translation-transformation-p t1)) + (assert (translation-transformation-p t2)) +;;; tests fail +;;; (assert (reflection-transformation-p t1)) +;;; (assert (reflection-transformation-p t2)) + (assert (rigid-transformation-p t1)) + (assert (rigid-transformation-p t2)) + (assert (even-scaling-transformation-p t1)) + (assert (even-scaling-transformation-p t2)) + (assert (scaling-transformation-p t1)) + (assert (scaling-transformation-p t2)) + (assert (rectilinear-transformation-p t1)) + (assert (rectilinear-transformation-p t2)) + (assert (transformation-equal t1 (compose-transformations t1 t2))) + (assert (transformation-equal t1 (invert-transformation t1))) + (assert (transformation-equal t1 (compose-translation-with-transformation t1 0 0))) + (assert (transformation-equal t1 (compose-rotation-with-transformation t1 0))) + (assert (transformation-equal t1 (compose-scaling-with-transformation t1 1 1))) +;;; tests fail +;;; (assert (transformation-equal t1 (compose-transformation-with-translation t1 0 0))) + (assert (transformation-equal t1 (compose-transformation-with-rotation t1 0))) + (assert (transformation-equal t1 (compose-transformation-with-scaling t1 1 1)))) + + +(let ((tr (make-rotation-transformation 0)) + (r (make-rectangle* 10 20 30 40)) + (x 10) (y 20)) + (assert (region-equal r (transform-region tr r))) + (assert (region-equal r (untransform-region tr r))) + (multiple-value-bind (xx yy) (transform-position tr x y) + (assert (= (coordinate x) xx)) + (assert (= (coordinate y) yy))) + (multiple-value-bind (xx yy) (untransform-position tr x y) + (assert (= (coordinate x) xx)) + (assert (= (coordinate y) yy))) + (multiple-value-bind (xx yy) (transform-distance tr x y) + (assert (= (coordinate x) xx)) + (assert (= (coordinate y) yy))) + (multiple-value-bind (xx yy) (untransform-distance tr x y) + (assert (= (coordinate x) xx)) + (assert (= (coordinate y) yy))) + (let ((x2 55) (y2 -20)) + (multiple-value-bind (xx1 yy1 xx2 yy2) (transform-rectangle* tr x y x2 y2) + (assert (= xx1 (min (coordinate x) (coordinate x2)))) + (assert (= yy1 (min (coordinate y) (coordinate y2)))) + (assert (= xx2 (max (coordinate x) (coordinate x2)))) + (assert (= yy2 (max (coordinate y) (coordinate y2))))) + (multiple-value-bind (xx1 yy1 xx2 yy2) (untransform-rectangle* tr x y x2 y2) + (assert (= xx1 (min (coordinate x) (coordinate x2)))) + (assert (= yy1 (min (coordinate y) (coordinate y2)))) + (assert (= xx2 (max (coordinate x) (coordinate x2)))) + (assert (= yy2 (max (coordinate y) (coordinate y2))))))) + + + +

1 0

[mcclim-cvs] CVS update: mcclim/medium.lisp
by rgoldman＠common-lisp.net 20 Sep '05

20 Sep '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv9719 Modified Files: medium.lisp Log Message: Fixed missing check for dashes part of line-style in LINE-STYLE-EQUALP. Date: Tue Sep 20 22:35:59 2005 Author: rgoldman Index: mcclim/medium.lisp diff -u mcclim/medium.lisp:1.54 mcclim/medium.lisp:1.55 --- mcclim/medium.lisp:1.54 Tue Jan 25 00:03:41 2005 +++ mcclim/medium.lisp Tue Sep 20 22:35:59 2005 @@ -585,7 +585,7 @@ (eql (line-style-thickness style1) (line-style-thickness style2)) (eql (line-style-joint-shape style1) (line-style-joint-shape style2)) (eql (line-style-cap-shape style1) (line-style-cap-shape style2)) - (eql (line-style-thickness style1) (line-style-thickness style2)))) + (eql (line-style-dashes style1) (line-style-dashes style2)))) ;;; Misc ops

1 0

[mcclim-cvs] CVS update: mcclim/Tests/transformations.lisp
by rstrandh＠common-lisp.net 18 Sep '05

18 Sep '05

Update of /project/mcclim/cvsroot/mcclim/Tests In directory common-lisp.net:/tmp/cvs-serv6875 Added Files: transformations.lisp Log Message: First part of the tests for affine transformations. Date: Mon Sep 19 00:12:04 2005 Author: rstrandh

1 0

[mcclim-cvs] CVS update: mcclim/Tests/bounding-rectangles.lisp
by rstrandh＠common-lisp.net 13 Sep '05

13 Sep '05

Update of /project/mcclim/cvsroot/mcclim/Tests In directory common-lisp.net:/tmp/cvs-serv19677 Added Files: bounding-rectangles.lisp Log Message: new file with tests related to bounding rectangles Date: Wed Sep 14 00:06:09 2005 Author: rstrandh

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp
by varkesteijn＠common-lisp.net 13 Sep '05

13 Sep '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv4106 Modified Files: inspector.lisp Log Message: Bug fix: printed iso 8601 time stamp claims to be in UTC (as indicated by the trailing Z), but was in local time. Date: Tue Sep 13 13:07:41 2005 Author: varkesteijn Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.32 mcclim/Apps/Inspector/inspector.lisp:1.33 --- mcclim/Apps/Inspector/inspector.lisp:1.32 Tue Apr 26 23:35:24 2005 +++ mcclim/Apps/Inspector/inspector.lisp Tue Sep 13 13:07:40 2005 @@ -599,7 +599,7 @@ "Return the given universal time in ISO 8601 format. This will raise an error if the given time is not a decodable universal time." (multiple-value-bind (sec min hour date month year) - (decode-universal-time time) + (decode-universal-time time 0) (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0DZ" year month date hour min sec)))

1 0

[mcclim-cvs] CVS update: mcclim/Tests/regions.lisp
by rstrandh＠common-lisp.net 12 Sep '05

12 Sep '05

Update of /project/mcclim/cvsroot/mcclim/Tests In directory common-lisp.net:/tmp/cvs-serv9556 Modified Files: regions.lisp Log Message: Tests for ellipses and elliptical arcs. This addition means that regions are mostly covered. Date: Mon Sep 12 23:23:57 2005 Author: rstrandh Index: mcclim/Tests/regions.lisp diff -u mcclim/Tests/regions.lisp:1.3 mcclim/Tests/regions.lisp:1.4 --- mcclim/Tests/regions.lisp:1.3 Sun Sep 11 23:44:42 2005 +++ mcclim/Tests/regions.lisp Mon Sep 12 23:23:56 2005 @@ -227,4 +227,67 @@ (assert (region-equal (make-point x1 y2) (rectangle-min-point r1))) (assert (region-equal (make-point x2 y1) (rectangle-max-point r1)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; ellipse +(assert (subtypep 'ellipse 'area)) +(assert (subtypep 'standard-ellipse 'ellipse)) + +(let* ((xc 234) (yc 345) (xdr1 -858) (ydr1 44) (xdr2 -55) (ydr2 5) + (sa 10) (ea 270) + (pc (make-point xc yc)) + (e1 (make-ellipse* xc yc xdr1 ydr1 xdr2 ydr2 :start-angle sa :end-angle ea)) + (e2 (make-ellipse pc xdr1 ydr1 xdr2 ydr2 :start-angle sa :end-angle ea)) + (e3 (make-ellipse pc xdr1 ydr1 xdr2 ydr2))) + (assert (typep e1 'standard-ellipse)) + (assert (ellipsep e1)) +;;; this test fails +;;; (assert (region-equal e1 e2)) + (multiple-value-bind (x y) (ellipse-center-point* e1) + (assert (= (coordinate xc) x)) + (assert (= (coordinate yc) y)) + (assert (region-equal (make-point x y) (ellipse-center-point e2)))) + (multiple-value-bind (xr11 yr11 xr12 yr12) (ellipse-radii e1) + (multiple-value-bind (xr21 yr21 xr22 yr22) (ellipse-radii e2) + (assert (= xr11 xr21)) + (assert (= yr11 yr21)) + (assert (= xr12 xr22)) + (assert (= yr12 yr22)))) + (assert (= (coordinate sa) (coordinate (ellipse-start-angle e1)))) + (assert (= (coordinate ea) (coordinate (ellipse-end-angle e1)))) + (assert (null (ellipse-start-angle e3))) + (assert (null (ellipse-end-angle e3)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; elliptical arc + +(assert (subtypep 'elliptical-arc 'path)) +(assert (subtypep 'standard-elliptical-arc 'elliptical-arc)) + +(let* ((xc 234) (yc 345) (xdr1 -858) (ydr1 44) (xdr2 -55) (ydr2 5) + (sa 10) (ea 270) + (pc (make-point xc yc)) + (ea1 (make-elliptical-arc* xc yc xdr1 ydr1 xdr2 ydr2 :start-angle sa :end-angle ea)) + (ea2 (make-elliptical-arc pc xdr1 ydr1 xdr2 ydr2 :start-angle sa :end-angle ea)) + (ea3 (make-elliptical-arc pc xdr1 ydr1 xdr2 ydr2))) + (assert (typep ea1 'standard-elliptical-arc)) + (assert (elliptical-arc-p ea1)) +;;; this test fails +;;; (assert (region-equal ea1 ea2)) + (multiple-value-bind (x y) (ellipse-center-point* ea1) + (assert (= (coordinate xc) x)) + (assert (= (coordinate yc) y)) + (assert (region-equal (make-point x y) (ellipse-center-point ea2)))) + (multiple-value-bind (xr11 yr11 xr12 yr12) (ellipse-radii ea1) + (multiple-value-bind (xr21 yr21 xr22 yr22) (ellipse-radii ea2) + (assert (= xr11 xr21)) + (assert (= yr11 yr21)) + (assert (= xr12 xr22)) + (assert (= yr12 yr22)))) + (assert (= (coordinate sa) (coordinate (ellipse-start-angle ea1)))) + (assert (= (coordinate ea) (coordinate (ellipse-end-angle ea1)))) + (assert (null (ellipse-start-angle ea3))) + (assert (null (ellipse-end-angle ea3))))

1 0

[mcclim-cvs] CVS update: mcclim/Tests/regions.lisp
by rstrandh＠common-lisp.net 11 Sep '05

11 Sep '05

Update of /project/mcclim/cvsroot/mcclim/Tests In directory common-lisp.net:/tmp/cvs-serv5189 Modified Files: regions.lisp Log Message: tests for lines and rectangles Date: Sun Sep 11 23:44:42 2005 Author: rstrandh Index: mcclim/Tests/regions.lisp diff -u mcclim/Tests/regions.lisp:1.2 mcclim/Tests/regions.lisp:1.3 --- mcclim/Tests/regions.lisp:1.2 Thu Sep 8 23:43:22 2005 +++ mcclim/Tests/regions.lisp Sun Sep 11 23:44:42 2005 @@ -143,7 +143,9 @@ (push (make-point x y) points)) pl1) (assert (null (set-difference (list p1 p2 p3) points :test #'region-equal))) - (assert (null (set-difference points (list p1 p2 p3) :test #'region-equal)))) + (assert (null (set-difference points (list p1 p2 p3) :test #'region-equal))) + (assert (polyline-closed pl3)) + (assert (not (polyline-closed pl2)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -172,3 +174,57 @@ pg1) (assert (null (set-difference (list p1 p2 p3) points :test #'region-equal))) (assert (null (set-difference points (list p1 p2 p3) :test #'region-equal)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; line + +(assert (subtypep 'line 'polyline)) +(assert (subtypep 'standard-line 'line)) + +(let* ((x1 234) (y1 876) (x2 345) (y2 -55) + (p1 (make-point x1 y1)) (p2 (make-point x2 y2)) + (l1 (make-line p1 p2)) (l2 (make-line* x1 y1 x2 y2))) + (assert (typep l1 'standard-line)) + (assert (linep l1)) + (assert (region-equal l1 l2)) + (multiple-value-bind (xx1 yy1) (line-start-point* l1) + (assert (= (coordinate x1) xx1)) + (assert (= (coordinate y1) yy1))) + (multiple-value-bind (xx2 yy2) (line-end-point* l1) + (assert (= (coordinate x2) xx2)) + (assert (= (coordinate y2)yy2))) + (assert (region-equal p1 (line-start-point l1))) + (assert (region-equal p2 (line-end-point l1)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; rectangle + +(assert (subtypep 'rectangle 'polygon)) +(assert (subtypep 'standard-rectangle 'rectangle)) + +(let* ((x1 234) (y1 876) (x2 345) (y2 -55) + (p1 (make-point x1 y1)) (p2 (make-point x2 y2)) + (r1 (make-rectangle p1 p2)) (r2 (make-rectangle* x1 y1 x2 y2))) + (assert (typep r1 'standard-rectangle)) + (assert (rectanglep r1)) + (assert (region-equal r1 r2)) + (multiple-value-bind (min-x min-y max-x max-y) (rectangle-edges* r1) + (assert (= (rectangle-min-x r1) min-x)) + (assert (= (rectangle-min-y r1) min-y)) + (assert (= (rectangle-max-x r1) max-x)) + (assert (= (rectangle-max-y r1) max-y)) + (assert (= (coordinate x1) min-x)) + (assert (= (coordinate y1) max-y)) + (assert (= (coordinate x2) max-x)) + (assert (= (coordinate y2) min-y)) + (multiple-value-bind (width height) (rectangle-size r1) + (assert (= width (rectangle-width r1))) + (assert (= height (rectangle-height r1))) + (assert (= width (- max-x min-x))) + (assert (= height (- max-y min-y))))) + (assert (region-equal (make-point x1 y2) (rectangle-min-point r1))) + (assert (region-equal (make-point x2 y1) (rectangle-max-point r1)))) + +

1 0

[mcclim-cvs] CVS update: mcclim/graphics.lisp
by rschlatte＠common-lisp.net 10 Sep '05

10 Sep '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv26755 Modified Files: graphics.lisp Log Message: Implement with-output-to-pixmap with incomplete / missing size arguments Date: Sat Sep 10 13:53:15 2005 Author: rschlatte Index: mcclim/graphics.lisp diff -u mcclim/graphics.lisp:1.50 mcclim/graphics.lisp:1.51 --- mcclim/graphics.lisp:1.50 Wed Feb 2 12:33:58 2005 +++ mcclim/graphics.lisp Sat Sep 10 13:53:15 2005 @@ -705,15 +705,28 @@ ;;; mess. I think we need a pixmap output recording stream in order to do this ;;; right. -- moore (defmacro with-output-to-pixmap ((medium-var sheet &key width height) &body body) - `(let* ((pixmap (allocate-pixmap ,sheet ,width ,height)) ; XXX size might be unspecified -- APD - (,medium-var (make-medium (port ,sheet) pixmap)) - (old-medium (sheet-medium ,sheet))) - (setf (slot-value pixmap 'medium) ,medium-var) ; hmm, [seems to work] -- BTS - (setf (%sheet-medium ,sheet) ,medium-var) ;is sheet a sheet-with-medium-mixin? --GB - (unwind-protect - (progn ,@body) - (setf (%sheet-medium ,sheet) old-medium));is sheet a sheet-with-medium-mixin? --GB - pixmap)) + (if (and width height) + `(let* ((pixmap (allocate-pixmap ,sheet ,width ,height)) + (,medium-var (make-medium (port ,sheet) pixmap)) + (old-medium (sheet-medium ,sheet))) + (setf (slot-value pixmap 'medium) ,medium-var) ; hmm, [seems to work] -- BTS + (setf (%sheet-medium ,sheet) ,medium-var) ;is sheet a sheet-with-medium-mixin? --GB + (unwind-protect + (progn ,@body) + (setf (%sheet-medium ,sheet) old-medium)) ;is sheet a sheet-with-medium-mixin? --GB + pixmap) + (let ((record (gensym "OUTPUT-RECORD-"))) + ;; rudi (2005-09-05) What to do when only width or height are + ;; given? And what's the meaning of medium-var? + `(let* ((,medium-var ,sheet) + (,record (with-output-to-output-record (,medium-var) + ,@body))) + (with-output-to-pixmap + (,medium-var + ,sheet + :width ,(or width `(bounding-rectangle-width ,record)) + :height ,(or height `(bounding-rectangle-height ,record))) + (replay-output-record ,record ,sheet)))))) ;;; XXX This seems to be incorrect. ;;; This presumes that your drawing will completely fill the bounding rectangle

1 0

[mcclim-cvs] CVS update: mcclim/Tests/regions.lisp
by rstrandh＠common-lisp.net 08 Sep '05

08 Sep '05

Update of /project/mcclim/cvsroot/mcclim/Tests In directory common-lisp.net:/tmp/cvs-serv28792 Modified Files: regions.lisp Log Message: More tests for regions. Lines and rectangles are not done yet. Date: Thu Sep 8 23:43:23 2005 Author: rstrandh Index: mcclim/Tests/regions.lisp diff -u mcclim/Tests/regions.lisp:1.1 mcclim/Tests/regions.lisp:1.2 --- mcclim/Tests/regions.lisp:1.1 Fri Aug 26 21:58:37 2005 +++ mcclim/Tests/regions.lisp Thu Sep 8 23:43:22 2005 @@ -16,8 +16,6 @@ (assert (subtypep 'path 'region)) (assert (subtypep 'path 'bounding-rectangle)) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; area @@ -27,7 +25,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; coordiante +;;; coordinate (assert (or (and (subtypep 'coordinate t) (subtypep t 'coordinate)) @@ -100,4 +98,77 @@ (assert (or (typep d 'standard-region-difference) (pointp d))) (assert (member (length regions) '(1 2))) - (assert (member p1 regions :test #'region-equal))) + (assert (member p1 regions :test #'region-equal)) + (let* ((regions2 '())) + (map-over-region-set-regions + (lambda (region) (push region regions2)) + d) + (assert (null (set-difference regions regions2 :test #'region-equal))) + (assert (null (set-difference regions2 regions :test #'region-equal))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; polyline + +(assert (subtypep 'polyline 'path)) +(assert (subtypep 'standard-polyline 'polyline)) + +(let* ((x1 10) (y1 22) (x2 30) (y2 30) (x3 50) (y3 5) + (p1 (make-point x1 y1)) (p2 (make-point x2 y2)) (p3 (make-point x3 y3)) + (pl1 (make-polyline (list p1 p2 p3))) + (pl2 (make-polyline* (list x1 y1 x2 y2 x3 y3))) + (pl3 (make-polyline (list p1 p2 p3) :closed t)) + (pl4 (make-polyline* (list x1 y1 x2 y2 x3 y3) :closed t)) + (points '())) + (assert (typep pl1 'standard-polyline)) + (assert (polylinep pl1)) + (assert (typep pl2 'standard-polyline)) + (assert (polylinep pl2)) + (assert (region-equal pl1 pl2)) + (assert (typep pl3 'standard-polyline)) + (assert (polylinep pl3)) + (assert (typep pl4 'standard-polyline)) + (assert (polylinep pl4)) + (assert (region-equal pl3 pl4)) + (assert (null (set-difference (polygon-points pl1) (list p1 p2 p3) :test #'region-equal))) + (assert (null (set-difference (list p1 p2 p3) (polygon-points pl1) :test #'region-equal))) + (assert (null (set-difference (polygon-points pl2) (list p1 p2 p3) :test #'region-equal))) + (assert (null (set-difference (list p1 p2 p3) (polygon-points pl2) :test #'region-equal))) + (assert (null (set-difference (polygon-points pl3) (list p1 p2 p3) :test #'region-equal))) + (assert (null (set-difference (list p1 p2 p3) (polygon-points pl3) :test #'region-equal))) + (assert (null (set-difference (polygon-points pl4) (list p1 p2 p3) :test #'region-equal))) + (assert (null (set-difference (list p1 p2 p3) (polygon-points pl4) :test #'region-equal))) + (map-over-polygon-coordinates + (lambda (x y) + (push (make-point x y) points)) + pl1) + (assert (null (set-difference (list p1 p2 p3) points :test #'region-equal))) + (assert (null (set-difference points (list p1 p2 p3) :test #'region-equal)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; polygon + +(assert (subtypep 'polygon 'area)) +(assert (subtypep 'standard-polygon 'polygon)) + +(let* ((x1 10) (y1 22) (x2 30) (y2 30) (x3 50) (y3 5) + (p1 (make-point x1 y1)) (p2 (make-point x2 y2)) (p3 (make-point x3 y3)) + (pg1 (make-polygon (list p1 p2 p3))) + (pg2 (make-polygon* (list x1 y1 x2 y2 x3 y3))) + (points '())) + (assert (typep pg1 'standard-polygon)) + (assert (polygonp pg1)) + (assert (typep pg2 'standard-polygon)) + (assert (polygonp pg2)) + (assert (region-equal pg1 pg2)) + (assert (null (set-difference (polygon-points pg1) (list p1 p2 p3) :test #'region-equal))) + (assert (null (set-difference (list p1 p2 p3) (polygon-points pg1) :test #'region-equal))) + (assert (null (set-difference (polygon-points pg2) (list p1 p2 p3) :test #'region-equal))) + (assert (null (set-difference (list p1 p2 p3) (polygon-points pg2) :test #'region-equal))) + (map-over-polygon-coordinates + (lambda (x y) + (push (make-point x y) points)) + pg1) + (assert (null (set-difference (list p1 p2 p3) points :test #'region-equal))) + (assert (null (set-difference points (list p1 p2 p3) :test #'region-equal))))

1 0

[mcclim-cvs] CVS update: mcclim/presentation-defs.lisp
by mretzlaff＠common-lisp.net 02 Sep '05

02 Sep '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv19729 Modified Files: presentation-defs.lisp Log Message: In response to: http://article.gmane.org/gmane.lisp.mcclim.devel/724 We reSIGNAL the condition now before the call to ABORT, to give outer handlers a chance to say "I know how to handle this" (as Christophe Rhodes has put it). Date: Fri Sep 2 13:36:48 2005 Author: mretzlaff Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.47 mcclim/presentation-defs.lisp:1.48 --- mcclim/presentation-defs.lisp:1.47 Thu Sep 1 04:59:11 2005 +++ mcclim/presentation-defs.lisp Fri Sep 2 13:36:48 2005 @@ -664,7 +664,9 @@ display-default query-identifier activation-gestures additional-activation-gestures delimiter-gestures additional-delimiter-gestures)) - (handler-bind ((abort-gesture #'abort)) + (handler-bind ((abort-gesture (lambda (condition) + (signal condition) ;; to give outer handlers a chance to say "I know how to handle this" + (abort condition)))) (let* ((real-type (expand-presentation-type-abbreviation type)) (real-default-type (cond (default-type-p (expand-presentation-type-abbreviation

1 0

[mcclim-cvs] CVS update: mcclim/presentation-defs.lisp mcclim/presentations.lisp
by mretzlaff＠common-lisp.net 01 Sep '05

01 Sep '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv10674 Modified Files: presentation-defs.lisp presentations.lisp Log Message: Section 23.7.1 "Defining Presentation Translators" of the clim spec says in the subsection on DEFINE-PRESENTATION-ACTION: Note that the tester for presentation actions is always assumed to be definitive. This hasn't been the case until now for McCLIM. In addition to this the lambda-list of DEFINE-DRAG-AND-DROP-TRANSLATOR has been revised a bit. (Note that I couldn't find a sentence in the spec that specifies the default value for the parameter MENU, but the other three define-translator macros have all t as the default. Nevertheless, most of the parameters are ignored right now.) Date: Thu Sep 1 04:59:12 2005 Author: mretzlaff Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.46 mcclim/presentation-defs.lisp:1.47 --- mcclim/presentation-defs.lisp:1.46 Thu Aug 25 22:24:10 2005 +++ mcclim/presentation-defs.lisp Thu Sep 1 04:59:11 2005 @@ -2020,17 +2020,20 @@ (presentation-subtypep subtype-over over)))))) (defmacro define-drag-and-drop-translator - (name - (from-type to-type destination-type command-table - &rest args - &key (gesture :select) tester documentation - pointer-documentation menu priority - (feedback 'frame-drag-and-drop-feedback) - (highlighting 'frame-drag-and-drop-highlighting)) + (name (from-type to-type destination-type command-table + &rest args &key + (gesture :select) + (tester 'default-translator-tester) + documentation + (pointer-documentation nil pointer-documentation-p) + (menu t) + (priority 0) + (feedback 'frame-drag-and-drop-feedback) + (highlighting 'frame-drag-and-drop-highlighting)) arglist &body body) - (declare (ignore tester documentation pointer-documentation menu - priority)) + (declare (ignore tester documentation pointer-documentation pointer-documentation-p + menu priority)) (let* ((real-from-type (expand-presentation-type-abbreviation from-type)) (real-dest-type (expand-presentation-type-abbreviation destination-type)) Index: mcclim/presentations.lisp diff -u mcclim/presentations.lisp:1.70 mcclim/presentations.lisp:1.71 --- mcclim/presentations.lisp:1.70 Fri Jan 14 13:43:23 2005 +++ mcclim/presentations.lisp Thu Sep 1 04:59:11 2005 @@ -1357,6 +1357,7 @@ `',tester `#',(make-translator-fun (car tester) (cdr tester))) + :tester-definitive t :documentation #',(make-documentation-fun documentation) ,@(when pointer-documentation-p `(:pointer-documentation

1 0