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

[ksprotte at common-lisp.net]

Author: ksprotte
Date: Thu Jan 24 19:05:22 2008
New Revision: 2407

Modified:
   branches/bos/projects/bos/m2/geometry.lisp
Log:
point-to-polygon now much clearer and ... works

Modified: branches/bos/projects/bos/m2/geometry.lisp
==============================================================================
--- branches/bos/projects/bos/m2/geometry.lisp	(original)
+++ branches/bos/projects/bos/m2/geometry.lisp	Thu Jan 24 19:05:22 2008
@@ -90,8 +90,7 @@
       (list (+ x dx)
 	    (+ y dy)))))
 
-
-;;; TODO eql for directions
+;;; TODO add eql for directions ?
 
 (defun find-boundary-point (point in-region-p &optional (direction :up))
   (let* ((direction (direction-as-list direction))
@@ -105,76 +104,51 @@
   "Will return a closed path of points in mathematical order.
 IN-REGION-P is a predicate that takes a point as an argument.
 It defines the region whose bounding polygon is to be found."
-  (let (polygon (count 0))
+  (let ((polygon)
+	(count 0)
+	(boundary-point (find-boundary-point point in-region-p :up))
+	(initial-direction :left))
     (labels ((neighbour (point direction)
 	       "Validate the NEIGHBOUR of POINT in DIRECTION,
               if it is part of the region, returns (NEIGHBOUR DIRECTION),
-              otherwise return NIL."
+              otherwise returns NIL."
 	       (when point
 		 (let ((neighbour (move point direction)))
 		   (when (funcall in-region-p neighbour)
 		     (list neighbour direction)))))
-	     (diagonal-neighbour (point direction)
-	       (case (direction-as-symbol direction)
-		 (:left (neighbour (first (neighbour point direction)) :up))
-		 (:right (neighbour (first (neighbour point direction)) :down))
-		 (t nil)))
 	     (choose-next (point direction)
+	       "Returns a place to move to next as a list (NEXT-POINT NEXT-DIRECTION).
+                NEXT-POINT can be the same POINT (but then with a different direction."
 	       (acond
 		((neighbour point (turn-right direction)) it)
+		((neighbour (first (neighbour point direction))
+			    (turn-right direction))
+		 it)
 		((neighbour point direction) it)
-		((neighbour point (turn-left direction)) it)
-		((neighbour point (turn-left (turn-left direction))) it)))
-	     (terminate (point end-point)
-	       (when (equal point end-point)
+		(t (list point (turn-left direction)))))
+	     (terminate (point direction)
+	       "Are we done?"
+	       (when (and (eql direction initial-direction)
+			  (equal point boundary-point))
 		 (incf count)
-		 (= 2 count)))
-	     (left-down-p (direction)
-	       (member (direction-as-symbol direction) '(:left :down)))
-	     (category-change-p (direction new-direction)
-	       (arnesi:xor (left-down-p direction)
-			   (left-down-p new-direction)))	     
-	     (traverse (point direction end-point)
-	       (unless (terminate point end-point)
-		 (aif (diagonal-neighbour point direction)
-		      ;; diagonal swap
-		      (destructuring-bind (point direction)
-			  it
-			(traverse point direction end-point))
-		      (destructuring-bind (x y) point
-			(destructuring-bind (next-point next-direction)
-			    (choose-next point direction)
-			  ;; push
-			  (if (left-down-p direction)
-			      (push point polygon)
-			      (push (list (1+ x) (1+ y)) polygon))
-			  (when (and (category-change-p direction next-direction)
-				     (left-down-p direction))
-			    (push (list x (1+ y)) polygon)
-			    (push (list (1+ x) (1+ y)) polygon))
-			  (when (and (category-change-p direction next-direction)
-				     (not (left-down-p direction)))
-			    (push (list (1+ x) y) polygon)
-			    (push (list x y) polygon))
-			  ;; print
-			  (print (list point (direction-as-symbol direction)))		   
-			  ;; traverse
-			  (traverse next-point next-direction end-point)))))))
-      (let ((boundary-point (find-boundary-point point in-region-p :up))
-	    (initial-direction (direction-as-list :left)))
-	(destructuring-bind (&optional next-point next-direction)
-	    (choose-next boundary-point initial-direction)
-	  (declare (ignore next-direction))
-	  (cond
-	    ((null next-point)
-	     ;; single m2 case
-	     (destructuring-bind (x y)
-		 point
-	       (list (list     x      y)
-		     (list     x  (1+ y))
-		     (list (1+ x) (1+ y))
-		     (list (1+ x)     y)
-		     (list     x      y))))
-	    (t (traverse boundary-point initial-direction next-point)
-	       (nreverse polygon))))))))
+		 (= 2 count))) 
+	     (push-point (point direction)
+	       "Add a point to POLYGON. The actual point
+                depends on the DIRECTION."
+	       (push
+		(case direction
+		  (:left point)
+		  (:down (move point :down))
+		  (:right (move (move point :down) :right))
+		  (:up (move point :right)))
+		polygon))
+	     (traverse (point direction)
+	       "Go to next POINT by DIRECTION."
+	       (push-point point direction)
+	       (unless (terminate point direction)		 
+		 (destructuring-bind (next-point next-direction)
+		     (choose-next point direction)
+		   (traverse next-point next-direction)))))
+      (traverse boundary-point initial-direction)
+      (nreverse polygon))))