aboutsummaryrefslogtreecommitdiffhomepage
path: root/src/utils.lisp
blob: 4037b7a75e2e97ea79cd63f11703e8270e5b40a0 (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
125
126
127
128
129
130
131
132
133
134
135
136
137
;;;; utils.lisp

(in-package #:wheelwork)

(define-symbol-macro +pi-over-180+ 0.017453292519943295d0)

(defun radians (degrees)
  "Converse DEGREES to radians"
  (* degrees +pi-over-180+))

(defun safe-slot (object slot &optional default)
  (if-let (val (and (slot-exists-p object slot)
                    (slot-boundp object slot)
                    (slot-value object slot)))
    val
    default))

(defun counterclockwisep (a b c)
  "A B and C are vectors created by 3d-vectors:vec, each representing
a 2d point.  Returns T if the three are supplied in counterclockwise
order, nil if not."
  (> (* (- (vec:vx b) (vec:vx a))
        (- (vec:vy c) (vec:vy a)))
     (* (- (vec:vy b) (vec:vy a))
        (- (vec:vx c) (vec:vx a)))))


(defun segments-intersect-p (a b c d)
  "A B C and D are vectors of the sort created by 3d-vectors:vec,
each representing a 2d point.  Returns T if the line segment between A
and B intersects the linesegment between C and D, NIL otherwise."
  (or (vec:v= a c) (vec:v= a d) (vec:v= b c) (vec:v= b d)
      (and (not (eq (counterclockwisep a c d) (counterclockwisep b c d)))
           (not (eq (counterclockwisep a b c) (counterclockwisep a b d))))))

(defun paths-intersect-p (path-a path-b)
  "Paths are lists of vectors, each of which represents a 2d point."
  (loop for (a1 a2 . more-a) on path-a
        while a2
          thereis (loop for (b1 b2 . b-more) on path-b
                        while b2
                          thereis (segments-intersect-p a1 a2 b1 b2))))


(defun closed-path-p (path)
  (equalp (first path)
          (first (last path))))

(defun path-encloses-point-p (path pt)
  "Path is a list of vectors, pt is a single vector."
  (assert (closed-path-p path) () "Enclosing path must be a closed path.")
  (let* ((bounds
           (path-bounds path))
         (corner
           ;; creating a point guaranteed to be outside of the path
           (vec:vec (- (getf bounds :left) (getf bounds :width))
                    (- (getf bounds :bottom) (getf bounds :height))
                    0.0 1.0)))
    (loop for (p1 p2 . more) on path
          while p2
          when (segments-intersect-p p1 p2 pt corner)
            count 1 into intersection-count
          finally
             (return (oddp intersection-count)))))



(defun path-encloses-path-p (path-a path-b)
  "T if path-b is totally contained in path-a and does not intersect path-a"
  (assert (closed-path-p path-a) () "Enclosing path must be a closed path.")
  (and 
   (loop for (p1 p2 . more) on path-b
         while p2
         always (path-encloses-point-p path-a p1))
   (not (paths-intersect-p path-a path-b))))

(defun path-bounds (path)
  "Path is a list of vectors representing 2d points. Returns the
bounds and width and height as a plist of the form 

(:top N :left N :right N :bottom N :width N :height N)

This is the smallest UNROTATED RECTANGLE that contains the points in
the path."
  (loop
    with max-x = nil
    and max-y = nil
    and min-x = nil
    and min-y = nil
    for vec in path
    for x = (vec:vx vec)
    for y = (vec:vy vec)
    when (or (null max-x) (< max-x x))
      do (setf max-x x)
    when (or (null min-x) (< x min-x))
      do (setf min-x x)
    when (or (null max-y) (< max-y y))
      do (setf max-y y)
    when (or (null min-y) (< y min-y))
      do (setf min-y y)
    finally
       (return (list :top max-y :left min-x :right max-x :bottom min-y
                     :width (- max-x min-x)
                     :height (- max-y min-y)))))

(defmacro setf-many (&rest places-and-value)
  "e.g. (setf-many a b c 10) would set a b and c to 10"
  (let* ((value-form
           (first (last places-and-value)))
         (value
           (gensym))
         (clauses
           (loop for place in (butlast places-and-value)
                 append `(,place ,value))))
    `(let ((,value ,value-form))
       (setf ,@clauses))))


(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))))