Author: ksprotte Date: Thu Jan 24 11:36:56 2008 New Revision: 2402 Modified: branches/bos/projects/bos/m2/geometry.lisp branches/bos/projects/bos/m2/m2.lisp branches/bos/projects/bos/m2/packages.lisp Log: working on geometry... (backup commit) 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 11:36:56 2008 @@ -1,19 +1,177 @@ (in-package :geometry) +;; a point in this package is represented +;; as a list (x y) + +;; maybe change this function to take a +;; point as an argument? (defun point-in-polygon-p (x y polygon) (let (result (py y)) (loop with (pjx . pjy) = (aref polygon (1- (length polygon))) - for (pix . piy) across polygon - when (and (or (and (<= piy py) (< py pjy)) - (and (<= pjy py) (< py piy))) - (< x - (+ (/ (* (- pjx pix) (- py piy)) - (- pjy piy)) - pix))) - do (setf result (not result)) - do (setf pjx pix - pjy piy)) + for (pix . piy) across polygon + when (and (or (and (<= piy py) (< py pjy)) + (and (<= pjy py) (< py piy))) + (< x + (+ (/ (* (- pjx pix) (- py piy)) + (- pjy piy)) + pix))) + do (setf result (not result)) + do (setf pjx pix + pjy piy)) result)) +;;; directions + +;; A direction can be represented either +;; as one of the symbols: +;; :down, :left, :right, :up +;; +;; or as a list of dx and dy +;; which can be used to move from one +;; point to another in that direction +;; +;; the mapping is as follows: +;; +;; dx dy symbol +;; -- -- ----- +;; 0 1 :down +;; -1 0 :left +;; 1 0 :right +;; 0 -1 :up +;; + +(defmethod turn-right ((direction symbol)) + (case direction + (:down :left) + (:left :up) + (:up :right) + (:right :down))) + +(defmethod turn-right ((direction list)) + (direction-as-list (turn-right (direction-as-symbol direction)))) + +(defmethod turn-left ((direction symbol)) + (case direction + (:down :right) + (:right :up) + (:up :left) + (:left :down))) + +(defmethod turn-left ((direction list)) + (direction-as-list (turn-left (direction-as-symbol direction)))) + +(defmethod direction-as-symbol ((direction symbol)) + direction) + +(defmethod direction-as-symbol ((direction list)) + (arnesi:switch (direction :test #'equal) + (((0 1)) :down) + (((-1 0)) :left) + (((1 0)) :right) + (((0 -1)) :up))) + +(defmethod direction-as-list ((direction list)) + direction) + +(defmethod direction-as-list ((direction symbol)) + (case direction + (:down '(0 1)) + (:left '(-1 0)) + (:right '(1 0)) + (:up '(0 -1)))) + +(defmethod move ((point list) direction) + (destructuring-bind (x y) + point + (destructuring-bind (dx dy) + (direction-as-list direction) + (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))))) + +(defun find-boundary-point (point in-region-p &optional (direction :up)) + (let* ((direction (direction-as-list direction)) + (next (move point direction))) + (if (funcall in-region-p next) + (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. +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)) + (labels ((neighbour (point direction) + "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)))) + (choose-next (point direction) + (acond + ((neighbour point (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) + (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) + (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))) + (destructuring-bind (&optional next-point next-direction) + (choose-next boundary-point (direction-as-list :left)) + (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 (direction-as-list :up) 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 11:36:56 2008 @@ -105,6 +105,14 @@ (find-if #'(lambda (allocation-area) (point-in-polygon-p (m2-x m2) (m2-y m2) (allocation-area-vertices allocation-area))) (class-instances 'allocation-area))) +(defun m2s-polygon (m2s) + (let* ((m2 (first m2s)) + (contract (m2-contract m2))) + (region-to-polygon (list (m2-x m2) (m2-y m2)) + (lambda (p) + (let ((m2 (apply #'get-m2 p))) + (and m2 (eql contract (m2-contract m2)))))))) + ;;;; SPONSOR ;;; Exportierte Funktionen: @@ -483,4 +491,48 @@ (random-elt (cons (1+ (random 300)) '(1 1 1 1 1 5 5 10 10 10 10 10 10 10 10 10 10 10 10 10 30 30 30))) - :paidp t)))) \ No newline at end of file + :paidp t)))) + + +;;; for quick visualization +#+ltk +(defun show-m2s-polygon (m2s &aux (points (m2s-polygon m2s))) + (labels ((compute-bounding-box (m2s) + (let* ((left (m2-x (elt m2s 0))) + (top (m2-y (elt m2s 0))) + (right left) + (bottom top)) + (loop for i from 1 below (length m2s) do + (let* ((v (elt m2s i)) + (x (m2-x v)) + (y (m2-y v))) + (setf left (min left x) + right (max right x) + top (min top y) + bottom (max bottom y)))) + (values left top (- right left) (- bottom top))))) + (multiple-value-bind (LEFT TOP WIDTH HEIGHT) + (compute-bounding-box m2s) + (finish-output) + (flet ((transform-x (x) + (+ 30 (* 30 (- x left)))) + (transform-y (y) + (+ 30 (* 30 (- y top))))) + (ltk:with-ltk () + (let ((canvas (make-instance 'ltk:canvas :width 700 :height 700))) + ;; draw m2s + (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")) + ;; draw polygon + (loop for a in points + for b in (cdr points) + while (and a b) + do (ltk:create-line* canvas + (transform-x (first a)) (transform-y (second a)) + (transform-x (first b)) (transform-y (second b)))) + (let ((a (first points))) + (ltk:create-text canvas (transform-x (first a)) (transform-y (second a)) "o")) + (ltk:pack canvas))))))) + Modified: branches/bos/projects/bos/m2/packages.lisp ============================================================================== --- branches/bos/projects/bos/m2/packages.lisp (original) +++ branches/bos/projects/bos/m2/packages.lisp Thu Jan 24 11:36:56 2008 @@ -1,8 +1,10 @@ (in-package :cl-user) (defpackage :geometry - (:use :cl) - (:export #:point-in-polygon-p)) + (:use :cl :iterate :arnesi) + (:export #:point-in-polygon-p + #:find-boundary-point + #:region-to-polygon)) (defpackage :geo-utm (:use :cl)