aboutsummaryrefslogtreecommitdiffhomepage
path: root/src/grid-geometry.lisp
blob: 5fdfdd8b53faa2444b06197ce81be1b8e3142d99 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
;;; grid-geometry.lisp

(in-package :wheelwork )

(defmacro with-grid-line
    ((x y) (start-x start-y) (end-x end-y) &body body)
  "Execute BODY for X and Y assigned to integer values in a line
connecting the integer point START-X , START-Y and END-X, END-Y. "
  (with-gensyms (sx sy ex ey distance step progress xdiff ydiff)
    `(loop
       with ,sx = ,start-x
       with ,sy = ,start-y
       with ,ex = ,end-x
       with ,ey = ,end-y
       with ,xdiff = (- ,ex ,sx)
       with ,ydiff = (- ,ey, sy)
       with ,distance = (max (abs ,xdiff) (abs ,ydiff))
       for ,step from 0 to ,distance
       for ,progress = (if (zerop ,distance) 0.0 (/ ,step ,distance))
       for ,x = (round (+ ,start-x (* ,progress ,xdiff)))
       for ,y = (round (+ ,start-y (* ,progress ,ydiff)))
       do (progn ,@body))))

(defun grid-bbox-for (poly)
  "POLY is a list of pairs of xy coordinates. Return a pair of
pairs, ((min-x min-y) (max-x max-y)), representing the bottom left and
top right corners of the bounding box for POLY "
  (loop for (x y) in poly
        minimizing x into x-min
        maximizing x into x-max
        minimizing y into y-min
        maximizing y into y-max
        finally (return (list (list x-min y-min)
                              (list x-max y-max)))))

(defun grid-counterclockwisep (a b c)
  (> (* (- (first b) (first a))
        (- (second c) (second a)))
     (* (- (second b) (second a))
        (- (first c) (first a)))))

(defun grid-segments-intersect-p (a b c d)
  (or (equalp a c) (equalp a d) (equalp b c) (equalp b d)
      (and (not (eq (grid-counterclockwisep a c d) (grid-counterclockwisep b c d)))
           (not (eq (grid-counterclockwisep a b c) (grid-counterclockwisep a b d))))))

(defun grid-poly-contains-p (poly x y)
  (let ((pt
          (list x y))
        (corner
          (list -1 x))) 
    (loop for (p1 p2 . more) on poly
          while p2
          when (grid-segments-intersect-p p1 p2 pt corner)
            count 1 into intersection-count
          finally
             (progn
               (when (grid-segments-intersect-p p1 (first poly) pt corner)
                 (incf intersection-count))
               (return (oddp intersection-count))))))

(defmacro with-grid-path
    ((x y) (path &key autoclosep interiorp) &body body)
  "Interiorp assumes autoclosep."
  (with-gensyms (points x1 y1 x2 y2 more)
    (let* ((autoclose-clause
             (when (or interiorp autoclosep)
               `(destructuring-bind (,x2 ,y2) (first ,points)
                  (with-grid-line (,x ,y) (,x2 ,y2) (,x1 ,y1)
                    ,@body))))
           (interior-clause
             (when interiorp
               `(destructuring-bind ((,x1 ,y1) (,x2 ,y2)) (grid-bbox-for ,points)
                  (loop for ,x from ,x1 to ,x2 do
                    (loop for ,y from ,y1 to ,y2
                          when (grid-poly-contains-p ,points ,x ,y)
                            do ,@body)))))) 
      `(let ((,points ,path))
         (loop
           for ((,x1 ,y1) (,x2 ,y2) . ,more) on ,points
           while ,x2 do
             (with-grid-line (,x ,y) (,x1 ,y1) (,x2 ,y2)
               ,@body)
           finally (progn
                     ,autoclose-clause
                     ,interior-clause))))))

(defmacro with-grid-rect ((x y) (left bottom right top) &body body)
  `(loop for ,x from ,left to ,right do
    (loop for ,y from ,bottom to ,top do ,@body )))

(defmacro with-grid-circle
    ((x y) (cx cy radius &key interiorp) &body body)
  (with-gensyms (rad sx sy)
    (let ((comparator
            (if interiorp '>= '=))) 
      `(let ((,sx ,cx) (,sy ,cy) (,rad ,radius)) 
         (loop for ,x from (- ,sx ,rad) to (+ ,sx ,rad) do
           (loop for ,y from (- ,sy ,rad)  to (+ ,sy ,rad) do
             (when (,comparator ,rad (round (euclidean-dist ,x ,y ,sx ,sy)))
               ,@body)))))))


(defmacro with-grid-bezier
    ((x y) (control-pts &key (count 1000)) &body body)
  "CONTROL-POINTS is an expression that evalueates to a list of (X Y)
pairs, these are the control points for the curve.. COUNT is the
number of points on the bezier curve that will be calclated. The first
point is always the first control point and the last point is always
the last control point.  Use high counts for smooth curves, as needed.

Evaluates the BODY with X Y bound to a point on the bezier curve.
"
  (with-gensyms (fn points a step)
    `(let* ((,step
              (/ 1.0 ,count))
            (,points
              ,control-pts)
            (,fn
              (apply #'bezier-lambda ,points)))
       (loop for ,a from 0.0 to 1.0 by ,step
             for (,x ,y) = (mapcar #'round (funcall ,fn ,a))
             do ,@body))))