Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
109 lines (94 sloc) 3.28 KB
(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*))
(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))
Something went wrong with that request. Please try again.