forked from wesen/cl-mill
-
Notifications
You must be signed in to change notification settings - Fork 0
/
arc.lisp
109 lines (94 loc) · 3.28 KB
/
arc.lisp
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
(in-package :gcode)
(defstruct arc
a b centre direction)
(defun arc-radius (arc)
(line-length (make-line :a (arc-a arc) :b (arc-centre arc))))
(defmethod object-length ((arc arc))
(* (arc-angle arc) (arc-radius arc)))
(defun arc-angle (arc)
(with-slots (a b centre direction) arc
(let ((angle (case direction
(:ccw (angle-2-segments-directed (make-line :a centre :b a)
(make-line :a centre :b b)))
(:cw (angle-2-segments-directed (make-line :a centre :b b)
(make-line :a centre :b a))))))
(if (< angle 0)
(+ angle (* 2 *PI*))
angle))))
(defmethod transform-object ((arc arc) matrix)
(make-arc :a (transform-object (arc-a arc) matrix)
:b (transform-object (arc-b arc) matrix)
:direction (arc-direction arc)
:centre (transform-object (arc-centre arc) matrix)))
(deftest :arc "Test arc angle cw"
(let ((arc (make-arc :centre (2dp 0 0)
:a (2dp -1 0)
:b (2dp 0 1)
:direction :cw)))
(test-assert (epsilon-= (arc-angle arc) (* *PI* 1/2)))))
(deftest :arc "Test arc angle ccw"
(let ((arc (make-arc :centre (2dp 0 0)
:a (2dp -1 0)
:b (2dp 0 1)
:direction :ccw)))
(test-assert (epsilon-= (arc-angle arc) (* *PI* 3/2)))))
(defun test-angle-2-segments-directed ()
(let ((l1 (make-line :a (2dp 0 0) :b (2dp 1 0)))
(l2 (make-line :a (2dp 0 0) :b (2dp 0 1)))
(l3 (make-line :a (2dp 0 0) :b (2dp -1 0))))
(format t "angle ~A ~A :~A~%" l1 l2 (angle-2-segments-directed l1 l2))
(format t "angle ~A ~A :~A~%" l2 l1 (angle-2-segments-directed l2 l1))
(format t "angle ~A ~A :~A~%" l1 l2 (angle-2-segments-directed l1 l3))
(format t "angle ~A ~A :~A~%" l2 l1 (angle-2-segments-directed l3 l1))))
;;; ON-ARC-P
(defun on-arc-p (arc p)
(and (epsilon-= (arc-radius arc) (line-length (make-line :a p :b (arc-centre arc))))
(with-slots (a b direction centre) arc
(let ((a1 (arc-angle arc))
(a2 (arc-angle (make-arc :a a :b p :centre centre
:direction direction))))
(<= a2 a1)))))
(deftest :arc "On arc tests"
(let ((arc1 (make-arc :centre (2dp 0 0)
:a (2dp -1 0)
:b (2dp 0 1)
:direction :cw))
(arc2 (make-arc :centre (2dp 0 0)
:a (2dp 0 1)
:b (2dp -1 0)
:direction :ccw))
(arc3 (make-arc :centre (2dp 0 0)
:a (2dp 0 1)
:b (2dp -1 0)
:direction :cw))
(p1 (2dp -1 0))
(p2 (2dp 0 0))
(p3 (2dp 0 1))
(p4 (2dp 0 -1))
(p5 (2dp (cos (/ *PI* 4))
(sin (/ *PI* 4))))
(p6 (2dp (cos (* *PI* 3/4))
(sin (* *PI* 3/4)))))
(test-assert (on-arc-p arc1 p1))
(test-assert (not (on-arc-p arc1 p2)))
(test-assert (on-arc-p arc1 p3))
(test-assert (not (on-arc-p arc1 p4)))
(test-assert (not (on-arc-p arc1 p5)))
(test-assert (on-arc-p arc1 p6))
(test-assert (on-arc-p arc2 p1))
(test-assert (not (on-arc-p arc2 p2)))
(test-assert (on-arc-p arc2 p3))
(test-assert (not (on-arc-p arc2 p4)))
(test-assert (not (on-arc-p arc2 p5)))
(test-assert (on-arc-p arc2 p6))
(test-assert (on-arc-p arc3 p1))
(test-assert (not (on-arc-p arc3 p2)))
(test-assert (on-arc-p arc3 p3))
(test-assert (on-arc-p arc3 p4))
(test-assert (on-arc-p arc3 p5))
(test-assert (not (on-arc-p arc3 p6)))
))
(defmethod object-start-point ((arc arc))
(arc-a arc))
(defmethod object-end-point ((arc arc))
(arc-b arc))