Changeset 2834

Show
Ignore:
Timestamp:
03/31/08 14:06:10 (9 months ago)
Author:
ksprotte
Message:

new function rectangle-intersects-p

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

  • trunk/projects/bos/m2/geometry.lisp

    r2644 r2834  
    33;; a point in this package is represented 
    44;; as a list (x y) 
     5 
     6;; a rectangle is represented 
     7;; as a list (left top width height) 
    58 
    69(defmacro with-point (point &body body) 
    …… 
    1821           ,@body)))) 
    1922 
     23(defmacro with-rectangle (rectangle &body body) 
     24  (destructuring-bind (rectangle &key suffix) (ensure-list rectangle) 
     25    (flet ((add-suffix (symbol) 
     26             (if suffix 
     27                 (intern (format nil "~a-~a" (symbol-name symbol) (string-upcase suffix)) 
     28                         (symbol-package symbol)) 
     29                 symbol))) 
     30      `(destructuring-bind (,(add-suffix 'left) 
     31                            ,(add-suffix 'top) 
     32                             ,(add-suffix 'width) 
     33                             ,(add-suffix 'height)) 
     34           ,rectangle 
     35         ,@body)))) 
     36 
    2037(defun distance (point-a point-b) 
    2138  (with-points (point-a point-b) 
    …… 
    2340             (expt (- point-a-y point-b-y) 2))))) 
    2441 
    25 (defmacro dorect ((point (left top width height) &key test row-change) &body body) 
    26   "Iterate with POINT over all points in rect row per row. The list 
    27 containing x and y is intended for only extracting those 
    28 and not to be stored away (it will be modified). 
    29  
    30 BODY is only executed, if TEST of the current point is true. 
    31  
    32 For convenience, a null arg function ROW-CHANGE can be given 
    33 that will be called between the rows." 
    34   (check-type point symbol) 
    35   (rebinding (left top) 
    36     `(iter 
    37        (with ,point = (list nil nil)) 
    38        (for y from ,top to (1- (+ ,top ,height))) 
    39        ,(when row-change 
    40               `(unless (first-time-p) 
    41                  (funcall ,row-change))) 
    42        (iter 
    43          (for x from ,left to (1- (+ ,left ,width))) 
    44          (setf (first ,point) x 
    45                (second ,point) y) 
    46          (when ,(if test 
    47                     `(funcall ,test ,point) 
    48                     t) 
    49            ,@body))))) 
    50  
    51 (defun rect-center (left top width height &key roundp) 
    52   (let ((x (+ left (/ width 2))) 
    53         (y (+ top (/ height 2)))) 
    54     (if roundp 
    55         (list (round x) (round y)) 
    56         (list x y)))) 
     42;; (defmacro dorect ((point rectangle &key test row-change) &body body) 
     43;;   "Iterate with POINT over all points in rect row per row. The list 
     44;; containing x and y is intended for only extracting those 
     45;; and not to be stored away (it will be modified). 
     46 
     47;; BODY is only executed, if TEST of the current point is true. 
     48 
     49;; For convenience, a null arg function ROW-CHANGE can be given 
     50;; that will be called between the rows." 
     51;;   (check-type point symbol) 
     52;;   (with-rectangle rectangle 
     53;;     (rebinding (left top) 
     54;;       `(iter 
     55;;          (with ,point = (list nil nil)) 
     56;;          (for y from ,top to (1- (+ ,top ,height))) 
     57;;          ,(when row-change 
     58;;                 `(unless (first-time-p) 
     59;;                    (funcall ,row-change))) 
     60;;          (iter 
     61;;            (for x from ,left to (1- (+ ,left ,width))) 
     62;;            (setf (first ,point) x 
     63;;                  (second ,point) y) 
     64;;            (when ,(if test 
     65;;                       `(funcall ,test ,point) 
     66;;                       t) 
     67;;              ,@body)))))) 
     68 
     69(defun rectangle-center (rectangle &key roundp) 
     70  (with-rectangle rectangle 
     71    (let ((x (+ left (/ width 2))) 
     72          (y (+ top (/ height 2)))) 
     73      (if roundp 
     74          (list (round x) (round y)) 
     75          (list x y))))) 
     76 
     77(defun rectangle-intersects-p (a b) 
     78  (with-rectangle (a :suffix a) 
     79    (with-rectangle (b :suffix b) 
     80      (let* ((right-a (+ left-a width-a)) 
     81             (bottom-a (+ top-a height-a)) 
     82             (right-b (+ left-b width-b)) 
     83             (bottom-b (+ top-b height-b)) 
     84             (left (max left-a left-b)) 
     85             (top (max top-a top-b)) 
     86             (right (min right-a right-b)) 
     87             (bottom (min bottom-a bottom-b))) 
     88        (and (> right left) (> bottom top)))))) 
    5789 
    5890;; maybe change this function to take a 
    …… 
    77109  (<= (distance point center) radius)) 
    78110 
    79 (defun point-in-rect-p (point left top width height) 
     111(defun point-in-rect-p (point rectangle) 
    80112  (with-point point 
    81     (and (<= left point-x (1- (+ left width))) 
    82          (<= top point-y (1- (+ top height)))))) 
     113    (with-rectangle rectangle 
     114      (and (<= left point-x (1- (+ left width))) 
     115           (<= top point-y (1- (+ top height))))))) 
    83116 
    84117;;; for fun... 
    85 (defun point-in-circle-p-test () 
    86   (let ((center (list 4 4))) 
    87     (dorect (p (0 0 10 10) :row-change #'terpri) 
    88       (if (point-in-circle-p p center 3) 
    89         (princ "x") 
    90         (princ "."))))) 
     118;; (defun point-in-circle-p-test () 
     119;;   (let ((center (list 4 4))) 
     120;;     (dorect (p (0 0 10 10) :row-change #'terpri) 
     121;;       (if (point-in-circle-p p center 3) 
     122;;      (princ "x") 
     123;;      (princ "."))))) 
    91124 
    92125(defun bounding-box (objects &key (key #'identity)) 

  • trunk/projects/bos/m2/m2.lisp

    r2725 r2834  
    354354  (destructuring-bind (left top width height) 
    355355      (contract-bounding-box contract) 
    356     (let ((center (rect-center left top width height :roundp t)) 
     356    (let ((center (rectangle-center (list left top width height) :roundp t)) 
    357357          (diameter (* 2 radius)) 
    358358          (contracts (make-hash-table :test #'eq))) 
    …… 
    369369  (destructuring-bind (left top width height) 
    370370      (contract-bounding-box contract) 
    371     (rect-center left top width height :roundp t))) 
     371    (rectangle-center (list left top width height) :roundp t))) 
    372372 
    373373(defun contract-center-lon-lat (contract) 

  • trunk/projects/bos/m2/packages.lisp

    r2775 r2834  
    66           #:distance 
    77           #:dorect 
    8            #:rect-center 
     8           #:rectangle-center 
     9           #:rectangle-intersects-p 
    910           #:point-in-polygon-p 
    1011           #:point-in-circle-p