0. ;this is geometric_functions.rkt
1.  
2. ;(require "structs.rkt")
3.  
4. (provide in-between?
5.          point-in-rect?
6.          biggest
7.          smallest
8.          reasonable-equal?
9.          intersect?
10.          arc-intersect?
11.          line-intersect?)
12.  
13. ;; geometric functions
14. (define (point-in-rect? x y xs ys xb yb)
15.   (and (> x xs) (< x xb) (> y ys) (< y yb)))
16.  
17. ;; auxilliary functions
18. (define (best fn lst)
19.   (unless (empty? lst)
20.     (let ((wins (car lst)))
21.       (for/list ([i (cdr lst)])
22.         (when (fn i wins)
23.           (set! wins i)))
24.       wins)))
25.  
26. (define (biggest lst)
27.   (best > lst))
28.  
29. (define (smallest lst)
30.   (best < lst))
31.  
32. ;; this is used to check the equality of two numbers to a set decimal point
33. ;; 0.009 -> accuracy up to 2 decimal point.
34. ;; 0.09 -> accuracy up to 1 decimal point.
35. ;; 0.9 -> integer test.
36. ;; test up to 3 decimal points.
37. (define (reasonable-equal? x y)
38.   (<= (abs (- x y)) 0.000009))
39.  
40. (define (in-between? test-num num-1 num-2)
41.   (or (and (> num-1 test-num) (< num-2 test-num))
42.       (and (> num-2 test-num) (< num-1 test-num))))
43.  
44. ;;;;;;;;;;;;;;;;;;;;;;;;;;;
45. ;; DXF specific routines ;;
46. ;;;;;;;;;;;;;;;;;;;;;;;;;;;
47.  
48. ;; pass intersect? the start and end point of select box and the struct-list
49. ;; it will traverse the struct-list to see if any elements
50. (define (intersect? x1 y1 x2 y2 struct-lst)
51.   (let ((big-x (biggest (list x1 x2)))
52.         (big-y (biggest (list y1 y2)))
53.         (small-x (smallest (list x1 x2)))
54.         (small-y (smallest (list y1 y2))))
55.     (for/list ([i struct-lst])
56.       ;calculate intersections for visible
57.       (when (dxf-entity-visible i)
58.         (when (dxf-line? i)
59.           (if (line-intersect? i small-x small-y big-x big-y)
60.               (set-dxf-entity-selected! i #t)
61.               (set-dxf-entity-selected! i #f)))
62.         (when (dxf-arc? i)
63.           (if (arc-intersect? i small-x small-y big-x big-y)
64.               (set-dxf-entity-selected! i #t)
65.               (set-dxf-entity-selected! i #f)))
66.         (when (dxf-point? i)
67.           (if (point-in-rect? (dxf-point-x i) (dxf-point-y i) small-x small-y big-x big-y)
68.               (set-dxf-entity-selected! i #t)
69.               (set-dxf-entity-selected! i #f)))))))
70.  
71. ;; these 3 functions calculate the x and y coordinates for arc points
72. (define (arc-point-x circle-x degree radius)
73.   (let ((adjusted (localize-degree degree)))
74.     (cond ((or (= degree 90) (= degree 270)) circle-x)
75.           ((= degree 180) (- circle-x radius))
76.           ((or (= degree 360) (= degree 0)) (+ circle-x radius))
77.           ((in-between? degree 0 90)    (+ circle-x (* radius (cos (degrees->radians adjusted)))))
78.           ((in-between? degree 90 180)  (- circle-x (* radius (sin (degrees->radians adjusted)))))
79.           ((in-between? degree 180 270) (- circle-x (* radius (cos (degrees->radians adjusted)))))
80.           ((in-between? degree 270 360) (+ circle-x (* radius (sin (degrees->radians adjusted)))))
81.           (else (display "error")))))
82. (define (arc-point-y circle-y degree radius)
83.   (let ((adjusted (localize-degree degree)))
84.     (cond ((or (= degree 0) (= degree 360) (= degree 180)) circle-y)
85.           ((= degree 90) (+ circle-y radius))
86.           ((= degree 270) (- circle-y radius))
87.           ((in-between? degree 0 90)    (+ circle-y (* radius (sin (degrees->radians adjusted)))))
88.           ((in-between? degree 90 180)  (+ circle-y (* radius (cos (degrees->radians adjusted)))))
89.           ((in-between? degree 180 270) (- circle-y (* radius (sin (degrees->radians adjusted)))))
90.           ((in-between? degree 270 360) (- circle-y (* radius (cos (degrees->radians adjusted)))))
91.           (else (display "error")))))
92. (define (localize-degree degree)
93.   (cond ((in-between? degree 0 90) degree)
94.         ((in-between? degree 90 180) (- degree 90))
95.         ((in-between? degree 180 270) (- degree 180))
96.         ((in-between? degree 270 360) (- degree 270))))
97.  
98. ;; 1) check for the trivial case - the arc point is inside the select box
99. ;; 2) imagine the 4 lines of the select box as an infinite line, do they intersect the circle of the arc?
100. ;; 2.1) if they do, are they in the select box's actual length/width?
101. ;; 2.2) if they are, does it intersect the arc?
102. ;; 2.3.1) arc intersection is checked by comparing the points where the lines intersect the circle.
103. ;; 2.3.2) imagine a line from arc point 1 to arc point 2 as a "dividing line", to differentiate points intersecting the circle on the "right" or "wrong" side of the arc
104. ;; 2.3.3) calculate the mid-point of the arc to determine the "right" side of the arc.
105. ;; 2.3.4) imagine a line that goes through the mid-point of the arc and is parallel to the "dividing line" (hence they have the same slope).
106. ;; 2.3.5) is the y-intercept bigger or smaller than the y-intercept of the dividing line? use that as a barometer for any point intersecting the circle.
107. ;; 2.3.6) if the line formed with the intersecting point falls on the right side of the "dividing line" together with the line formed with the mid-point line, then there is an intersection.
108. (define (arc-intersect? dxf-arc-struct xs ys xb yb)
109.   (let* ((radius (dxf-arc-radius dxf-arc-struct))
110.          (circle-x (dxf-arc-x dxf-arc-struct))
111.          (circle-y (dxf-arc-y dxf-arc-struct))
112.          (start (dxf-arc-start dxf-arc-struct))
113.          (end (dxf-arc-end dxf-arc-struct))
114.          (angle-difference (if (> end start) (- end start) (+ (- 360 start) end)))
115.          (half-angle (if (> end start) (/ (+ start end) 2) (if (< 360 (+ 180 (/ (+ start end) 2))) (- (+ 180 (/ (+ start end) 2)) 360) (+ 180 (/ (+ start end) 2)))))
116.          (radius (dxf-arc-radius dxf-arc-struct))
117.          (arc-x1 (arc-point-x circle-x start radius))
118.          (arc-y1 (arc-point-y circle-y start radius))
119.          (arc-x2 (arc-point-x circle-x end radius))
120.          (arc-y2 (arc-point-y circle-y end radius))
121.          ;we calculate the middle arc-point to determine which is the right side
122.          (half-x (arc-point-x circle-x half-angle radius))
123.          (half-y (arc-point-y circle-y half-angle radius)))
124.     (define (right-side-y? x y)
125.       (let* ((dividing-line-slope       (/ (- arc-y2 arc-y1) (- arc-x2 arc-x1)))
126.              (dividing-line-yintercept  (- arc-y1 (* dividing-line-slope arc-x1)))
127.              (right-yintercept          (- half-y (* dividing-line-slope half-x)))
128.              (right-value-test          (> right-yintercept dividing-line-yintercept))
129.              (point-yintercept          (- y (* dividing-line-slope x)))
130.              (point-test                (> point-yintercept dividing-line-yintercept)))
131.         (eq? right-value-test point-test)))
132.     (define (line-intersect-arc? x1 y1 x2 y2)
133.       ;return the point where line intersects arc. intersection of a y line with a circle, 2 possible x values
134.       (define (yline-intersect-circle? y)
135.         (let ((result1 (+ circle-x (sqrt (- (expt radius 2) (expt (- y circle-y) 2)))))
136.               (result2 (- circle-x (sqrt (- (expt radius 2) (expt (- y circle-y) 2))))))
137.           (if (real? result1)
138.               (cond ((and (in-between? result1 xs xb) (in-between? result2 xs xb))
139.                      (list (list result1 y) (list result2 y)))
140.                     ((in-between? result1 xs xb)
141.                      (list (list result1 y)))
142.                     ((in-between? result2 xs xb)
143.                      (list (list result2 y)))
144.                     (else #f))
145.               #f)))
146.       ;return the point where line intersects arc. intersection of a x line with a circle, 2 possible y values
147.       (define (xline-intersect-circle? x)
148.         (let ((result1 (+ circle-y (sqrt (- (expt radius 2) (expt (- x circle-x) 2)))))
149.               (result2 (- circle-y (sqrt (- (expt radius 2) (expt (- x circle-x) 2))))))
150.           (if (real? result1)
151.               (cond ((and (in-between? result1 ys yb) (in-between? result2 ys yb))
152.                      (list (list x result1) (list x result2)))
153.                     ((in-between? result1 ys yb)
154.                      (list (list x result1)))
155.                     ((in-between? result2 ys yb)
156.                      (list (list x result2)))
157.                     (else #f))
158.               #f)))
159.       (if (= x1 x2)
160.           ((lambda (x) (if (eq? x #f) #f (ormap (lambda (a) (apply right-side-y? a)) x))) (xline-intersect-circle? x1))    ;is a x line, find y values
161.           ((lambda (x) (if (eq? x #f) #f (ormap (lambda (a) (apply right-side-y? a)) x))) (yline-intersect-circle? y1))))  ;is a y line, find x values
162.     (cond ((or (point-in-rect? arc-x1 arc-y1 xs ys xb yb) (point-in-rect? arc-x2 arc-y2 xs ys xb yb)) #t)
163.           ((or (line-intersect-arc? xs ys xs yb)
164.                (line-intersect-arc? xs yb xb yb)
165.                (line-intersect-arc? xb yb xb ys)
166.                (line-intersect-arc? xb ys xs ys)) #t)
167.           (else #f))))
168.  
169. ;; divide the complete 2d space into 9 boxes
170. ;; cohen-sutherland algorithm to detect line-rectangle intersection. separate 2d area into 9 rectangles where 0 represents the selected area
171. ;; region numbers are bit->decimal
172. ;; 9   1   5                1001   0001   0101
173. ;; 8   0   4      --->      1000   0000   0100
174. ;; 10  2   6                1010   0010   0110
175. (define (line-intersect? dxf-line-struct xs ys xb yb)
176.   (let ((lx1 (dxf-line-x1 dxf-line-struct))
177.         (ly1 (dxf-line-y1 dxf-line-struct))
178.         (lx2 (dxf-line-x2 dxf-line-struct))
179.         (ly2 (dxf-line-y2 dxf-line-struct)))
180.     (define (compute-outcode x y)
181.       (let ((inside 0))
182.         (cond ((< x xs)
183.                (set! inside (bitwise-ior inside 1)))
184.               ((> x xb)
185.                (set! inside (bitwise-ior inside 2))))
186.         (cond ((< y ys)
187.                (set! inside (bitwise-ior inside 4)))
188.               ((> y yb)
189.                (set! inside (bitwise-ior inside 8))))
190.         inside))
191.     ;return #t if intersect
192.     (define (trivial-accept? region1 region2)
193.       (or (not (bitwise-ior region1 region2))
194.           (= region1 0)
195.           (= region2 0)
196.           (and (= region1 1) (= region2 2))
197.           (and (= region1 2) (= region2 1))
198.           (and (= region1 4) (= region2 8))
199.           (and (= region1 8) (= region2 4))))
200.     ;return #t if does not intersect
201.     (define (trivial-reject? region1 region2)
202.       (not (= (bitwise-and region1 region2) 0)))
203.     ;clip until no more ambiguous cases
204.     (define (clip-until region1 region2 tries)
205.       (cond ((= tries 0) #f)
206.             ((trivial-reject? region1 region2) #f)
207.             ((trivial-accept? region1 region2) #t)
208.             (else (apply clip-until (append (do-clip region1 region2) (list (- tries 1)))))))
209.     (define (do-clip region1 region2)
210.       (define (not0 num)
211.         (if (= num 0) #f #t))
212.       (let* ((new-x 0)
213.              (new-y 0)
214.              (slope (/ (- ly2 ly1) (- lx2 lx1)))
215.              (y-intercept (- ly2 (* slope lx2))))
216.         ;apply the formula y = y1 + slope * (x - x1), x = x1 + (y - y1) / slope
217.         (cond ((not0 (bitwise-and 8 region2))
218.                (set! new-x (/ (- yb y-intercept) slope))
219.                (set! new-y yb))
220.               ((not0 (bitwise-and 4 region2))
221.                (set! new-x (/ (- ys y-intercept) slope))
222.                (set! new-y ys))
223.               ((not0 (bitwise-and 2 region2))
224.                (set! new-x xb)
225.                (set! new-y (+ (* slope xb) y-intercept)))
226.               ((not0 (bitwise-and 1 region2))
227.                (set! new-x xs)
228.                (set! new-y (+ (* slope xs) y-intercept))))
229.         (set! lx2 new-x)
230.         (set! ly2 new-y)
231.         (set! region2 (compute-outcode lx2 ly2)))
232.       (list region1 region2))
233.     (let* ((region1 (compute-outcode lx1 ly1))
234.            (region2 (compute-outcode lx2 ly2)))
235.       (clip-until region1 region2 4))))

=>