[bknr-cvs] r2402 - branches/bos/projects/bos/m2
ksprotte at common-lisp.net
ksprotte at common-lisp.net
Thu Jan 24 16:36:57 UTC 2008
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)
More information about the Bknr-cvs
mailing list