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))))