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)