[bknr-cvs] r2413 - branches/bos/projects/bos/m2

[ksprotte at common-lisp.net]

Author: ksprotte
Date: Tue Jan 29 05:06:55 2008
New Revision: 2413

Modified:
   branches/bos/projects/bos/m2/geometry.lisp
Log:
added macro DORECT in geometry.lisp


Modified: branches/bos/projects/bos/m2/geometry.lisp
==============================================================================
--- branches/bos/projects/bos/m2/geometry.lisp	(original)
+++ branches/bos/projects/bos/m2/geometry.lisp	Tue Jan 29 05:06:55 2008
@@ -2,6 +2,7 @@
 
 ;; a point in this package is represented
 ;; as a list (x y)
+
 (defmacro with-point (point &body body)
   (let* ((*package* (symbol-package point))
 	 (x (intern (format nil "~A-X" (symbol-name point))))
@@ -21,6 +22,33 @@
     (sqrt (+ (expt (- point-a-x point-b-x) 2)
 	     (expt (- point-a-y point-b-y) 2)))))
 
+(defmacro dorect ((point (left top width height) &key test row-change) &body body)
+  "Iterate with POINT over all points in rect row per row. The list
+containing x and y is intended for only extracting those
+and not to be stored away (it will be modified).
+
+BODY is only executed, if TEST of the current point is true.
+
+For convenience, a null arg function ROW-CHANGE can be given
+that will be called between the rows."
+  (check-type point symbol)
+  (rebinding (left top)
+    `(iter
+       (with ,point = (list nil nil))
+       (for y from ,top to (1- (+ ,top ,height)))
+       ,(when row-change
+	      `(unless (first-time-p)
+		 (funcall ,row-change)))
+       (iter
+	 (for x from ,left to (1- (+ ,left ,width)))
+	 (setf (first ,point) x
+	       (second ,point) y)
+	 (when ,(if test
+		    `(funcall ,test point)
+		    t)
+	   , at body)))))
+
+
 ;; maybe change this function to take a
 ;; point as an argument?
 (defun point-in-polygon-p (x y polygon)
@@ -42,6 +70,14 @@
 (defun point-in-circle-p (point center radius)
   (<= (distance point center) radius))
 
+;;; for fun...
+(defun point-in-circle-p-test ()
+  (let ((center (list 4 4)))
+    (dorect (p (0 0 10 10) :row-change #'terpri)
+      (if (point-in-circle-p p center 3)
+	  (princ "x")
+	  (princ ".")))))
+
 ;;; directions
 
 ;; A direction can be represented either