;; ------------------------ BEVELQUERY.LSP -------------------------------
;; Purpose: Displays the global angle and bevel expressed as inches in 12
;;          for a selected LINE, or POLYLINE or LWPOLYLINE segment
;;          This routine was written primarily for steel detailers,
;;          so the bevel is always expressed as less than or = 12 in 12
;; Version: 1.0
;; Date: 20 October 2001
;; Author:  Herman Mayfarth
;; Copyright © 2001 by Herman Mayfarth. All rights reserved.
;; Provided "as is" and without warranty.
;;
;; Usage:  AutoCAD R14 ->?
;; Visit website @ www.tktn.com for other AutoLISP routines
;;---------------------------------------------------------------------
;;---------------------  -----bevel--------------------------------
;;      Purpose: find the bevel (inches in 12) for a given angle
;;      Needs:   -2PI <= angle in radians <=2PI
;;      Returns: two element list of which the first element is the bevel
;;               (a real) and the second element is its octant
;;               (integer in the range 1-4)
;;converts the supplied angle to a non-negative real <= PI
;;if the angle is 0,PI or PI/2 to within a fuzz factor,
;;the function returns 0 for the octant and 0.0 for the bevel
;;----------------------------------------------------------------

(defun bevel (a / fuzz bev octant)
  (setq fuzz 0.0025) ; ~1/32 in 12
  (if (< a 0) (setq a (+ a PI)))
  (if (> a PI) (setq a (- a PI)))
  (if (or (equal a 0.0 fuzz) (equal a PI fuzz) (equal a (/ PI 2) fuzz))
        (setq bev 0.0 octant 0)
        (progn
          (cond ((> a (* 3 (/ PI 4))) (setq octant 4 a (- PI a)))
                ((> a (/ PI 2)) (setq octant 3 a (- a (/ PI 2))))
                ((> a (/ PI 4)) (setq octant 2 a (- (/ PI 2) a)))
                (T (setq octant 1))
          );cond
          (setq bev (* 12 (/ (sin a) (cos a))))
        );progn
  );if
  (list bev octant)
);bevel
(defun rtd (r) (* r (/ 180 PI)));radians to degrees
;;command to find & display the bevel of a selected entity
(defun C:BEVELQUERY ( /
                        aline
                        alist
                        bev
                        dtype
                        head
                        enext
                        errstrg
                        etype
                        flag
                        fuzz
                        langle
                        p1
                        p2
                        stypes
                        vhead
                        vpos
                    )
;;list of supported etypes
 (setq stypes '("LINE" "LWPOLYLINE" "VERTEX"))
;;set flag until etype can be verified
  (setq flag T)
;;select one entity of supported type
  (while flag
    (while (null (setq alist (nentsel "\nSelect a Line/Polyline:"))))
    (setq aline (entget (car alist)))
    (if (member (setq etype (cdr (assoc 0 aline))) stypes)
        (setq flag nil)
    );if
  );while
;;process entity
(cond ((equal etype "LINE")
       (setq  p1 (cdr(assoc 10 aline))
              p2 (cdr(assoc 11 aline))
              langle (angle p1 p2)
              dtype "LINE."))
      ((equal etype "LWPOLYLINE")
        (progn
          (setq vhead (- (length aline) (length (member (assoc 10 aline) aline)))
                vpos  (nth 2 (car(ssnamex(ssget(cadr alist)))))
                p1    (cdr (nth (+ vhead (* 4 (- vpos 1))) aline))
                dtype "LWPOLYLINE."
          );setq
          (if (= (cdr (nth (+ -1 vhead (* 4 vpos)) aline)) 0.0);straight segment
              ;proceed
              (progn
                (if (and (= (cdr (assoc 70 aline)) 1) (= vpos (cdr (assoc 90 aline))))
                  (setq p2 (cdr (assoc 10 aline)));1st vertex same as last
                  (setq p2 (cdr (nth (+ vhead (* 4 vpos)) aline)))
                );if
                (setq langle (angle p1 p2))
              );progn
              (setq errstrg "Segment is curved.")
          );if
        );progn
      );pred
      ((equal etype "VERTEX")
        (setq p1 (cdr (assoc 10 aline)) dtype "POLYLINE.")
        (if (= (cdr (assoc 42 aline)) 0.0);straight segment
            ;proceed
            (progn
              (setq enext (entget (entnext (cdr (assoc -1 aline)))))
              (if (= (cdr (assoc 0 enext)) "VERTEX")
                  (setq p2 (cdr (assoc 10 enext)))
                  (setq head
                    (entget (cdr (assoc -2 (entget (entnext (cdr (assoc -1 aline)))))))
                       p2 (cdr (assoc 10 (entget (entnext (cdar head)))))
                  );setq
              );if
              (setq langle (angle p1 p2))
            );progn
            (setq errstrg "Segment is curved.")
        );if
      );pred
);cond
;;check to see if a bevel is defined
(setq  fuzz 0.0025)  ;tolerance in radians - this is ~ 1/32 in 12
(if (equal (car p1) (car p2) fuzz)
    (setq errstrg (strcat "Endpoints are vertical to within " (rtos fuzz 5 5)
     " in 12." "\nAngle: " (rtos (rtd langle) 2 2) "°")))
(if (equal (cadr p1) (cadr p2) fuzz)
    (setq errstrg (strcat "Endpoints are horizontal to within " (rtos fuzz 5 5)
     " in 12." "\nAngle: " (rtos (rtd langle) 2 2) "°")))
(if errstrg (alert (strcat errstrg "\nBevel is undefined.\n\nThis is a " dtype))
;;otherwise run the main routine
  (progn
;;calculate the bevel
    (setq bev (car (bevel langle)))
;;and display it
    (alert (strcat "Bevel: " (rtos bev 5 4) " in 12."
                   "\nAngle: " (rtos (rtd langle) 2 2) "°"
                   "\n\nThis is a " dtype
           )
    )
  );progn
);if
(princ)
);C:BEVELQUERY
;;load prompts
(princ "\n BevelQuery v1.0 Copyright © 2001 Tekton Construction Services")
(princ "\nType BEVELQUERY to run.")
(princ)