;*******************************************************************************************
;* Useful AutoLisp Functions
;*******************************************************************************************

;Basic Functions
(setq 2pi (* 2 pi))
(defun ² (x) (* x x))
(defun tan (x / cosx) (setq cosx (cos x)) (if (/= cosx 0) (/ (sin x) cosx)
 (*ERROR* "Tangent undefined for argument.")
));d
(defun quadratic (A B C / t1) (setq t1 (- (² B) (* 4.0 A C)))
 (if (>= t1 0) (list (/ (+ (- B) (setq t1 (sqrt t1))) (* 2.0 A)) (/ (- (- B) t1) (* 2.0 A))))
);d
(defun =~ (x y / n i) (or (= x y); approx
 (if (and (numberp x) (numberp y)) (equal x y 1E-6)
  (and (listp x) (listp y) (= (length x) (length y)) (not (vl-some '(lambda (x y) (/=~ x y)) x y)))
 );i
));d
(defun /=~ (x y) (not (=~ x y))); /approx
(defun pt (x y) (list x y 0.0))
(defun unbuldge (plist / plist2) (foreach p plist
 (if (listp p) (setq plist2 (append plist2 (list p)))) plist2
));d
(defun xmin (plist) (apply 'min (mapcar 'car (unbuldge plist))))
(defun xmax (plist) (apply 'max (mapcar 'car (unbuldge plist))))
(defun define-fillet (p1 p2 theta / p0 t1) (if (= theta 0) (*ERROR* "Infinite fillet radius encountered.") (progn
 (setq
 theta (* 2pi (+ (rem (1- (/ theta 2pi)) 2) (if (> theta 2pi) -1 1))); saw tooth
 rfillet (/ (* 0.5 (distance p1 p2)) (sin (* 0.5 (abs theta))))
 p0 (polar p2 (+ (angle p1 p2) (* 0.5 theta) (* (if (> theta 0) 1 -1) 0.5 pi)) rfillet); (if (> (abs theta) pi) (if (> theta 0) (- 2pi theta) (+ 2pi theta)) theta)
 theta1 (angle p0 p1) theta2 (angle p0 p2)
 );s
 (if (< theta 0) (setq t1 theta1 theta1 theta2 theta2 t1)); must swap because arc functions go counter clockwise
 p0
)));d

;Entity Functions
(defun length2 (plist / i) (setq i 0) (foreach p plist (if (listp p) (setq i (1+ i)))) i); excludes buldges
(defun getplist (ent / data plist) (if (and ent (setq data (entget ent))) (progn
 (foreach t1 data
  (if (= (car t1) 10) (setq plist (append plist (list (cdr t1)))))
  (if (and (= (car t1) 42) (/=~ (cdr t1) 0)) (setq plist (append plist (list (* 4 (atan (cdr t1)))))))
 );f
 (append plist (if (= (cdr (assoc 70 data)) 1) (list (car plist))))
)));d
(defun circle (p r) (entmake (list '(0 . "CIRCLE") (cons 10 p) (cons 40 r))))
(defun draw (plist / t1 data) (if plist (progn; draws polylines including buldges
 (setq t1 (=~ (car plist) (last plist)) data (append
 '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (100 . "AcDbPolyline"))
  (list (cons 90 (length2 plist)) (cons 70 (if t1 1 0)))
 ));s
 (foreach p (if t1 (ldr plist) plist) (setq data (append data
  (list (if (numberp p) (cons 42 (tan (* 0.25 p))) (cons 10 p)))
 )));f
 (entmake data)
)));d

;Intersection Point Functions
(defun inters-circle (p theta p0 r / x0 y0 x y t1 t2 A B C); returns both roots
 (setq x0 (car p0) y0 (cadr p0) x (- (car p) x0))
 (if (=~ (cos theta) 0)
  (if (<= (- r) x r) (progn (setq y (sqrt (- (² r) (² x))))
   (list (pt (+ x0 x) (+ y0 y)) (pt (+ x0 x) (- y0 y)))
  ));i
  (progn (setq y (- (cadr p) y0) t1 (tan theta) t2 (/ (- (* x t1) y) r))
   (setq A (1+ (² t1)) B (* -2 t2 t1) C (1- (² t2)))
   (mapcar (function (lambda (x2) (pt (+ x0 (* x2 r)) (+ y0 y (* (- (* x2 r) x) t1))))) (quadratic A B C))
  );p
 );i
);d
(defun inters-arc (p1 p2 p1` p2` theta` onseg / p0 rfillet theta1 theta2 theta plist p)
 (if (or (not theta`) (= theta` 0.0)) (if (setq p (inters p1 p2 p1` p2` onseg)) (list p)) (progn
  (setq p0 (define-fillet p1` p2` theta`))
  (foreach p (inters-circle p1 (angle p1 p2) p0 rfillet)
   (if p (setq theta (angle p0 p)))
   (if
    (and p
     (or (not onseg) (< (car p1) (car p) (car p2)) (< (car p2) (car p) (car p1)) (< (cadr p1) (cadr p) (cadr p2)) (< (cadr p2) (cadr p) (cadr p1))); p lies between p1 and p2
     (if (< theta1 theta2) (<= theta1 theta theta2) (if (< theta theta2) (<= (- theta1 2pi) theta theta2) (<= theta1 theta (+ theta2 2pi)))); theta lies between theta1 and theta2
    );a
    (setq plist (append plist (list p)))
   );i
  );f
  plist
 ));i
);d
(defun inters-plist (p1 p2 plist1 onseg / i p p1` p2` plist2) (setq p1` (car plist1)); onplist
 (foreach p2` (cdr plist1) (if (numberp p2`) (setq theta p2`) (setq
  plist2 (append plist2 (inters-arc p1 p2 p1` p2` theta onseg))
  p1` p2` theta nil
 )));f
 plist2
);d

;Function to Calculate Enclosed Area
(defun Area (plist / Area p0 p1 theta theta1 theta2 a b c r)
 (if (/=~ (car plist) (last plist)) (setq plist (append plist (list (car plist))))); plist must be closed
 (setq Area 0 p0 (last plist) p1 (car plist) a (distance p0 p1) theta1 (angle p0 p1))
 (foreach p2 (cdr plist) (if (numberp p2) (setq theta p2) (progn
  (setq b (distance p0 p2) theta2 (angle p0 p2) Area (+ Area (* 0.5 (* a b (sin (- theta2 theta1))))))
  (if theta (setq; buldge correction
   c (distance p1 p2) r (/ (* 0.5 c) (sin (* 0.5 theta))); r can be negative
   Area (+ Area (* 0.5 theta (² r)) (* -0.5 c r (cos (* 0.5 theta)))) theta nil
  ));i
  (setq p1 p2 theta1 theta2 a b)
 )));f
 (abs Area)
);d


;Function to determine whether a point is inside a region.
(defun inside (p plist / n vp1 p1 p2 thetasum theta) (if (vl-some 'numberp plist)
 (progn (setq n 0 p1 (car plist)); intersection test vector, this code was adapted from: http://www.autocode.com/lisp/inout.zip
  (setq vp1 (pt (+ (car p) (* 3 (- (xmax plist) (xmin plist)))) (cadr p))); virtual point (assumes this point is outside)
  (foreach p2 (cdr plist) (if (numberp p2) (setq theta p2) (progn
   (if theta (setq n (+ n (length (inters-arc p vp1 p1 p2 theta T)))) (if (inters p vp1 p1 p2) (setq n (1+ n))))
   (setq p1 p2 theta nil)
  )));f
  (/= (rem n 2) 0); oneofeach
 );p
 (progn (setq thetasum 0 theta2 (if plist (angle p (last plist)))); no buldges (faster)
  (foreach p2 plist (setq theta1 (angle p p2) theta (- theta2 theta1))
   (if (> (abs theta) pi) (setq theta (+ theta (* (if (minusp theta) -1 1) 2pi))))
   (setq thetasum (+ thetasum theta) theta2 theta1)
  );f
  (/=~ thetasum 0)
 );p
));d

;Draw Arbitrary Demo Polyline
(draw '(
 (-37 -29) -1.2 (-33 -32) 3.4 (-28 -29) -2.3 (-25 -24) -2.0 (-19 -34) 3.7 (-12 -36) -1.3
 (-7 -26) -3.5 (-5 -34) 4.5 (-3 -36) -2.8 (3 -36) 3.2 (6 -35) -1.2 (11 -20) 3.7 (6 -16)
 -1.9 (-8 -19) 2.2 (-13 -21) -3.5 (-20 -19) 3.4 (-29 -16) -3.2 (-38 -14) -1.3 (-24 -1) 4.1
 (-28 4) -2.6 (-38 7) -1.8 (-27 16) 3.4 (-27 20) -1.5 (-32 24) -1.2 (-27 33) -3.0 (-21 25)
 2.8 (-17 19) -2.6 (-14 15) 1.5 (-13 10) -1.5 (-12 -2) 1.1 (-12 -11) 3.8 (-5 -4) -4.1
 (-3 -2) 2.5 (4 -3) -2.9 (10 -6) 4.2 (17 -4) -1.6 (17 2) 3.5 (11 7) -2.7 (2 10) -0.5 (6 20)
 -1.9 (14 20) 4.0 (17 25) 0.4 (3 23) 1.1 (-4 14) -2.5 (-6 14) -0.7 (-10 27) 1.4 (-12 30)
 -3.5 (-10 34) 1.7 (-3 35) -3.0 (2 33) 2.3 (5 30) -0.5 (18 32) -1.6 (24 25) 4.0 (31 27)
 -3.1 (38 35) -0.1 (43 29) -3.8 (39 27) 3.8 (36 26) 0.6 (45 21) -2.5 (46 17) -1.1 (38 17)
 1.6 (31 16) -1.4 (22 14) 3.5 (21 12) -2.1 (25 4) 3.8 (32 2) -1.1 (37 13) -2.4 (42 9) -1.3
 (38 6) 3.9 (40 2) -4.4 (40 -3) 2.3 (31 -9) 1.8 (36 -11) -2.7 (40 -17) -2.4 (28 -13) 1.4
 (24 -9) 1.9 (17 -18) 2.0 (23 -19) -2.2 (25 -21) -2.3 (16 -26) 3.2 (14 -28) 1.0 (24 -29)
 0.1 (33 -24) -1.0 (41 -24) -1.8 (42 -29) -2.1 (37 -28) 2.5 (34 -27) 1.9 (38 -33) -4.1
 (36 -37) 1.5 (21 -34) -0.9 (-28 -40)
));d
(setq ent (entlast))
(command "zoom" "window" (pt -50 -50) (pt 50 50))
(defun c:inters (/ p1 p2)
 (setq p1 (getpoint "\nSpecify first point: ") p2 (getpoint p1 "\nSecond point: "))
 (foreach p (inters-plist p1 p2 (getplist ent) T) (circle p 1)); (car (entsel "Select object: "))
);d
(defun c:area2 () (Area (getplist ent))); (car (entsel "Select object: "))
(defun c:inside ()
 (prompt (strcat "\nThe point is "
  (if (inside (getpoint "\nSpecify a point: ") (getplist ent)) "inside" "outside") "."; (car (entsel "Select object: "))
 ));p
 (princ)
);d

(alert (strcat
"Here is an arbitrary demo polyline.\n"
"Type \"inters\" to find the points where a line segment intersects the polyline.\n"
"Type \"area2\" to calculate the area inside the polyline.\n"
"Type \"inside\" to test if a point is inside the polyline.\n"
"You can also manually distort the polyline and these commands will adjust accordingly."
));a