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

[ksprotte at common-lisp.net]

Author: ksprotte
Date: Thu Jan 24 17:59:58 2008
New Revision: 2406

Modified:
   branches/bos/projects/bos/m2/geometry.lisp
   branches/bos/projects/bos/m2/m2.lisp
Log:
just another backup for geometry in progress -- sorry

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 17:59:58 2008
@@ -90,15 +90,8 @@
       (list (+ x dx)
 	    (+ y dy)))))
 
-;;; polygon-from-m2s
-;; (defun find-m2-by-min-x-y (m2s)
-;;   (iter
-;;     (for m2 in m2s)
-;;     (for x = (m2-x m2))
-;;     (for y = (m2-y m2))
-;;     (minimizing x into min-x)
-;;     (minimizing y into min-y)
-;;     (finally (return (get-m2 min-x min-y)))))
+
+;;; TODO eql for directions
 
 (defun find-boundary-point (point in-region-p &optional (direction :up))
   (let* ((direction (direction-as-list direction))
@@ -107,7 +100,6 @@
 	(find-boundary-point next in-region-p)
 	point)))
 
-
 ;;; region-to-polygon
 (defun region-to-polygon (point in-region-p)
   "Will return a closed path of points in mathematical order.
@@ -118,9 +110,15 @@
 	       "Validate the NEIGHBOUR of POINT in DIRECTION,
               if it is part of the region, returns (NEIGHBOUR DIRECTION),
               otherwise return NIL."
-	       (let ((neighbour (move point direction)))
-		 (when (funcall in-region-p neighbour)
-		   (list neighbour direction))))
+	       (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)
 	       (acond
 		((neighbour point (turn-right direction)) it)
@@ -135,32 +133,37 @@
 	       (member (direction-as-symbol direction) '(:left :down)))
 	     (category-change-p (direction new-direction)
 	       (arnesi:xor (left-down-p direction)
-			   (left-down-p new-direction)))
+			   (left-down-p new-direction)))	     
 	     (traverse (point direction end-point)
 	       (unless (terminate point 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)))
+		 (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 (direction-as-list :left))
+	    (choose-next boundary-point initial-direction)
 	  (declare (ignore next-direction))
 	  (cond
 	    ((null next-point)
@@ -172,6 +175,6 @@
 		     (list (1+ x) (1+ y))
 		     (list (1+ x)     y)
 		     (list     x      y))))
-	    (t (traverse boundary-point (direction-as-list :up) next-point)
+	    (t (traverse boundary-point initial-direction next-point)
 	       (nreverse polygon))))))))
 

Modified: branches/bos/projects/bos/m2/m2.lisp
==============================================================================
--- branches/bos/projects/bos/m2/m2.lisp	(original)
+++ branches/bos/projects/bos/m2/m2.lisp	Thu Jan 24 17:59:58 2008
@@ -511,8 +511,9 @@
 			    top (min top y)
 			    bottom (max bottom y))))
 	       (values left top (- right left) (- bottom top)))))	      
-    (multiple-value-bind (LEFT TOP WIDTH HEIGHT)
+    (multiple-value-bind (left top width height)
 	(compute-bounding-box m2s)
+      (declare (ignore width height))
       (finish-output)
       (flet ((transform-x (x)
 	       (+ 30 (* 30 (- x left))))
@@ -524,7 +525,7 @@
 	    (loop for m2 in m2s
 	       for x = (transform-x (m2-x m2))
 	       for y = (transform-y (m2-y m2))
-	       do (ltk:create-text canvas (+ 10 x) (+ 10 y) "X"))
+	       do (ltk:create-text canvas (+ 10 x) (+ 10 y) "x"))
 	    ;; draw polygon
 	    (loop for a in points
 	       for b in (cdr points)