home *** CD-ROM | disk | FTP | other *** search
/ vis-ftp.cs.umass.edu / vis-ftp.cs.umass.edu.tar / vis-ftp.cs.umass.edu / pub / Software / ASCENDER / ascendMar8.tar / UMass / ISR / isr2geometry.lisp < prev    next >
Lisp/Scheme  |  1995-04-11  |  7KB  |  165 lines
  1. ;;; -*- Mode:Common-Lisp; Package:ISR2; Base:10 -*-
  2. ;;;
  3. ;;; GEOMETRY.LISP - some basic geometric routines
  4.  
  5. (in-package "ISR2")
  6.  
  7. ;;;=====================
  8. ;;; Definition of points:
  9. ;;;   (point x y) - make a point
  10. ;;;   (x-coord point) - return x-coordinate
  11. ;;;   (y-coord point) - return y-coordinate
  12.  
  13. (defmacro make-point (x-coord y-coord) `(list ,x-coord ,y-coord))
  14. (defmacro x-coord (point) `(car ,point))
  15. (defmacro y-coord (point) `(cadr ,point))
  16.  
  17. (defmacro delta-x (point1 point2) 
  18.   `(- (x-coord ,point2) (x-coord ,point1))) 
  19. (defmacro delta-y (point1 point2) 
  20.   `(- (y-coord ,point2) (y-coord ,point1)))
  21.  
  22. (defmacro translate-point (point xinc yinc)
  23.   (let ((lp (gensym)))
  24.     `(let ((,lp ,point))
  25.         (make-point (+ (x-coord ,lp) ,xinc)
  26.          (+ (y-coord ,lp) ,yinc)))))
  27.  
  28. (defmacro point-distance (point1 point2)
  29.   (let ((lp1 (gensym)) (lp2 (gensym)))
  30.     `(let* ((,lp1 ,point1)
  31.             (,lp2 ,point2)
  32.             (dx (delta-x ,lp1 ,lp2))
  33.        (dy (delta-y ,lp1 ,lp2)))
  34.        (sqrt (+ (* dx dx) (* dy dy))))))
  35.  
  36. ;;;=====================
  37. ;;; A point list is a list of points.
  38. ;;; A vertex list is a point list where the last point is implicitly
  39. ;;;   connected with the first point.
  40.  
  41. (defun find-extrema (point-list)
  42.   "  return as multiple values the minimum x value, minimum y value,
  43.    maximum x value, and maximum y value. (four values in all)."
  44.   (let ((x (car (first point-list)))
  45.     (y (cadr (first point-list))))
  46.     (if (null (cdr point-list))
  47.     (values x y x y)
  48.     (multiple-value-bind (lowx lowy highx highy) (find-extrema (cdr point-list))
  49.       (values (min x lowx) (min y lowy) (max x highx) (max y highy))))))
  50.  
  51. (defun clockwise-p (vertex-list)
  52.   "Returns T if the vertex-list specifies a clockwise walk, NIL otherwise."
  53.   (not (counterclockwise-p vertex-list)))
  54.  
  55. (defun counterclockwise-p (vertex-list)
  56.   "Returns T if the vertex-list specifies a counterclockwise walk, NIL otherwise."
  57.   (let ((lowx (find-extrema vertex-list))  ;;leftmost X coordinate
  58.     (len (length vertex-list)))
  59.     (multiple-value-bind (current position)
  60.       (#-:EXPLORER lispm::find #+:EXPLORER find lowx vertex-list :test #'= :key #'car)
  61.       (let ((previous (elt vertex-list (mod (1- position) len)))
  62.         (next (elt vertex-list (mod (1+ position) len))))
  63.     ;;test if walk from previous to current to next is a counterclockwise cycle
  64.     (ccw-cycle-p (car previous) (cadr previous)
  65.              (car current) (cadr current)
  66.              (car next) (cadr next))))))
  67.  
  68. (defun ccw-cycle-p (x1 y1 x2 y2 x3 y3)
  69.   "  Returns T iff (x1,y1)-(x2,y2)-(x3,y3)-(x1,y1) is a counterclockwise walk, NIL otherwise."
  70. ;;;;Note: computed by taking the determinant of the matrix
  71. ;;;;   x1 y1 1 
  72. ;;;;   x2 y2 1 
  73. ;;;;   x3 y3 1 
  74. ;;;;the determinant is positive iff p1-p2-p3 form a CCW cycle
  75.   (plusp (+ (* x1 (- y2 y3)) 
  76.         (* y1 (- x3 x2)) 
  77.         (- (* x2 y3) (* y2 x3)))))
  78.  
  79. ;;;=====================
  80.  
  81. (defmacro for-each-edge ((vertex-list x1 y1 x2 y2) &body body)
  82.   "  Perform the body once for each edge specified by the vertex list.  Inside the
  83.   body, the variables given as X1, Y1, X2 and Y2 are bound to the endpoints of the edge.
  84.   The vertex list '((10 10)(20 10)(15 15)) specifies 3 edges:
  85.     10,10 to 20,10 ;  20,10 to 15,15 ; and 15,15 to 10,10.
  86.   Special cases:
  87.     The vertex list '((10 10)(10 20)) has only one edge, 
  88.     The list '((10 10)) has no edges.
  89.   VERTEX-LIST is evaluated only once.  Its value is returned from this macro."
  90.   (let ((vertices (gensym))
  91.     (vlist (gensym))
  92.     (v1 (gensym))
  93.     (v2 (gensym)))
  94.     `(let ((,vertices ,vertex-list))
  95.        (do ((,v1 (when (> (length ,vertices) 1) (car ,vertices)) (car ,vlist))
  96.         (,v2 (cadr ,vertices) (or (cadr ,vlist) (car ,vertices)))
  97.         (,vlist (when (> (length ,vertices) 2) (cdr ,vertices)) (cdr ,vlist)))
  98.        ((null ,v1) ,vertices)
  99.      (let ((,x1 (car ,v1))
  100.            (,y1 (cadr ,v1))
  101.            (,x2 (car ,v2))
  102.            (,y2 (cadr ,v2)))
  103.        ,@body)))))
  104.  
  105. (defun point-inside-polygon-p (x y vertex-list)
  106.   "  Determines whether the point (X,Y) is inside the simple polygon (no self intersections)
  107.   specified by VERTEX-LIST.  A vertex list is a list of x,y points describing a walk around 
  108.   the edges of the polygon.
  109.     Example: (point-inside-polygon-p 15 15 '((10 10)(20 10)(20 20)(10 20)))  -->  T.
  110.   Results are unpredictable if the point is actually on an edge."
  111.   (let ((count 0))
  112.     (for-each-edge (vertex-list x1 y1 x2 y2)
  113.       (when (and (> (max y1 y2) y) (<= (min y1 y2) y))
  114.     (cond
  115.       ((>= (min x1 x2) x) nil)
  116.       ((<= (max x1 x2) x) (incf count))
  117.       ((< (+ x1 (/ (* (- y y1) (- x2 x1)) (- y2 y1))) x) (incf count))
  118.       (t nil))))
  119.     (oddp count)))
  120.  
  121. ;;;=====================
  122. ;;; some special purpose code for rectangles
  123.  
  124. (defun bounding-rect-no-extend (end1 end2 radius &key (length nil))
  125.   "Returns a rectangle bounding the line defined by end1 and end2.
  126.    The rectangle has the same length as the line, and has width 2*radius.
  127.    The rectangle is returned as (p1 p2 p3 p4), where p1-p2-p3-p4-p1 is
  128.    a counterclockwise walk around the rectangle.  If end1 is the leftmost
  129.    lowest point of the line then p1 will be the leftmost lowest point 
  130.    of the rectangle."
  131.   (let* ((length (or length (point-distance end1 end2)))
  132.      (xinc (* radius (/ (delta-y end1 end2) length)))
  133.      (yinc (* radius (/ (delta-x end1 end2) length))))
  134.     (if (> (delta-x end1 end2) 0)
  135.     (list (translate-point end1 xinc (- yinc))
  136.           (translate-point end2 xinc (- yinc))
  137.           (translate-point end2 (- xinc) yinc)
  138.           (translate-point end1 (- xinc) yinc))
  139.     (list (translate-point end1 (- xinc) yinc)
  140.           (translate-point end1 xinc (- yinc))
  141.           (translate-point end2 xinc (- yinc))
  142.           (translate-point end2 (- xinc) yinc)))))
  143.  
  144. (defun inside-rect-p (point rect-vertices)
  145.   "Returns t iff point lies inside or on a rectangle having the
  146.    given vertices.  The vertices must specify a counterclockwise
  147.    walk around the rectangle.  This test may run faster when the
  148.    distance from the first vertex to the second vertex is greater
  149.    than the distance from the second to the third."
  150.   (let* ((p1 (first rect-vertices))
  151.      (p2 (second rect-vertices))
  152.      (p4 (fourth rect-vertices))
  153.      (dx (delta-x p1 p2))
  154.      (dy (delta-y p1 p2))
  155.      (high1 (- (* dx (y-coord p4)) (* dy (x-coord p4))))
  156.      (low1 (- (* dx (y-coord p1)) (* dy (x-coord p1))))
  157.      (high2 (+ (* dy (y-coord p2)) (* dx (x-coord p2))))
  158.      (low2 (+ (* dy (y-coord p1)) (* dx (x-coord p1)))))
  159.     (and (<= low1
  160.          (- (* dx (y-coord point)) (* dy (x-coord point)))
  161.          high1)
  162.      (<= low2
  163.          (+ (* dy (y-coord point)) (* dx (x-coord point)))
  164.          high2))))
  165.