;;; ---------------------------------------------------------------------------
;;; ScrewThread.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; SCREW THREAD IN SECTION
;;;
;;; PURPOSE
;;;   Draws a 60 degree V thread along a centreline you specify - the detailed
;;;   representation, with the actual crests and roots, rather than the two
;;;   parallel lines of the simplified convention.
;;;
;;;   For a drawing where the thread form matters: a detail of a screw, a tapped
;;;   hole in section, a leadscrew, an acme-adjacent form, or anything being
;;;   made from the drawing rather than bought to a standard.
;;;
;;; THE THREAD FORM
;;;   60 degrees included, which is the ISO metric and the Unified form both.
;;;   The pitch is the distance from one crest to the next; you give either the
;;;   pitch itself or the number of threads per unit, whichever your data is in.
;;;
;;;   The crest and root are drawn flat rather than sharp - a real thread is
;;;   truncated at both, and a sharp V is a form that cannot be cut. The flat is
;;;   an eighth of the pitch at the crest and a quarter at the root, which is
;;;   close enough to the ISO profile to read correctly at any drawing scale.
;;;
;;;   Handedness: right hand is the default, left hand slopes the other way.
;;;
;;; WHAT WAS FIXED
;;;   - It ended with (setvar "cmdecho" 1) and (setvar "blipmode" <saved>) -
;;;     so blip mode was restored properly but command echo was set to 1
;;;     regardless of what it had been.
;;;   - It drew the last crest with (command "line" g f "") AFTER the loop,
;;;     using two variables left over from the final pass. If the thread was too
;;;     short to fit even one turn the loop never ran, both were nil, and the
;;;     routine stopped on a bad argument.
;;;   - Left-hand threads were had by typing a NEGATIVE diameter - an
;;;     undocumented trick that worked because a negative radius makes POLAR go
;;;     the other way. It is a proper option now.
;;;   - There was no error handler and no undo group, so a cancelled thread left
;;;     half its lines behind and took one U each to remove.
;;;   - The source file ended in a run of corrupted bytes.
;;;
;;;   THREAD  - draw a screw thread in section
;;; ---------------------------------------------------------------------------

(setq *Thread:Dia*   nil
      *Thread:Pitch* nil)

;;; ---------------------------------------------------------------------------
;;; SUPPORT
;;; ---------------------------------------------------------------------------

(defun Thread:Layer ( name colour )
    (if (not (tblsearch "LAYER" name))
        (entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord")
                       '(100 . "AcDbLayerTableRecord") (cons 2 name)
                       '(70 . 0) (cons 62 colour) '(6 . "Continuous"))))
    name
)

;;; A polyline through a list of points.
(defun Thread:Poly ( pts layer )
    (entmake (append
        (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") (cons 8 layer)
              '(100 . "AcDbPolyline") (cons 90 (length pts)) '(70 . 0))
        (mapcar '(lambda ( p ) (cons 10 (list (car p) (cadr p)))) pts)))
)

;;; A point in thread coordinates: ALONG the axis from the start, and OUT from
;;; the centreline. Turned into a drawing point by the axis direction.
(defun Thread:P ( origin ang along out )
    (polar (polar origin ang along) (+ ang (/ pi 2.0)) out)
)

;;; ---------------------------------------------------------------------------
;;; MAIN COMMAND
;;; ---------------------------------------------------------------------------

(defun c:THREAD ( / *error* vars vals org ang dia pitch len depth lay v
                    hand lead rad root n i side crest flat rflat pts
                    a0 turns )

    (setq vars '("CMDECHO" "BLIPMODE" "OSMODE" "CLAYER")
          vals (mapcar 'getvar vars))

    (defun Thread:Restore ( )
        (mapcar 'setvar vars vals)
        (while (= 8 (logand 8 (getvar 'undoctl))) (command "_.UNDO" "_End"))
        (vl-catch-all-apply '(lambda ( ) (*pop-error-mode*)) '())
        (princ)
    )

    (defun *error* ( msg )
        (Thread:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** THREAD error: " msg " **")))
        (princ)
    )

    (setvar "CMDECHO" 0)
    (setvar "BLIPMODE" 0)
    ;; AutoCAD 2015 and later refuse (command) inside an *error* handler unless
    ;; the routine says up front that it will use one.
    (vl-catch-all-apply '(lambda ( ) (*push-error-using-command*)) '())
    (command "_.UNDO" "_Begin")

    (setq org (getpoint "\nStart of the thread, on the centreline: "))
    (if org (setq ang (getangle org "\nDirection of the centreline: ")))

    (if (or (null org) (null ang))
        (princ "\nCancelled.")
        (progn
            (setvar "OSMODE" 0)
            (initget 6)
            (setq dia (getdist org (strcat "\nOutside diameter"
                                           (if *Thread:Dia*
                                               (strcat " <" (rtos *Thread:Dia* 2 3) ">")
                                               "") ": ")))
            (if (null dia) (setq dia *Thread:Dia*))

            (initget "Pitch Count")
            (setq v (getkword "\nSpecify the thread by [Pitch/Count] <Pitch>: "))

            (if (= v "Count")
                (progn
                    (initget 6)
                    (setq v (getreal "\n  Threads per unit: "))
                    (if v (setq pitch (/ 1.0 v))))
                (progn
                    (initget 6)
                    (setq pitch (getdist (strcat "\n  Pitch, crest to crest"
                                                 (if *Thread:Pitch*
                                                     (strcat " <" (rtos *Thread:Pitch* 2 4) ">")
                                                     "") ": ")))
                    (if (null pitch) (setq pitch *Thread:Pitch*))))

            (initget 6)
            (setq len (getdist org "\nLength of the threaded part: "))

            (if (not (and dia pitch len))
                (princ "\nNot enough given to draw a thread.")
                (progn
                    (setq *Thread:Dia* dia *Thread:Pitch* pitch)

                    (initget "Right Left")
                    (setq hand (getkword "\nHand [Right/Left] <Right>: "))
                    (setq lead (if (= hand "Left") -1.0 1.0))

                    (setq turns (fix (/ len pitch)))
                    (if (< turns 1)
                        (princ (strcat "\n** The threaded length is shorter than one"
                                       " pitch - nothing to draw. **"))
                        (progn
                            ;; --- the form -----------------------------------
                            ;; A 60 degree V of full depth would be
                            ;; 0.866 x pitch. Truncating an eighth off the crest
                            ;; and a quarter off the root leaves the working
                            ;; depth used here.
                            (setq rad   (/ dia 2.0)
                                  depth (* 0.6134 pitch)
                                  root  (- rad depth)
                                  flat  (/ pitch 8.0)
                                  rflat (/ pitch 4.0)
                                  lay   (Thread:Layer "Thread" 7))

                            (if (<= root 0.0)
                                (princ "\n** That pitch is too coarse for that diameter - the thread would cut through the centre. **")
                                (progn
                                    ;; --- both flanks --------------------------
                                    ;; Drawn as one zigzag polyline each side of
                                    ;; the centreline. The two sides are offset
                                    ;; from each other by half a pitch, which is
                                    ;; what makes a thread look like a helix cut
                                    ;; through rather than a row of rings.
                                    (foreach side '(1.0 -1.0)
                                        (setq pts nil i 0
                                              a0  (if (> side 0.0) 0.0 (* lead (/ pitch 2.0))))
                                        ;; Stopping one short keeps the last
                                        ;; crest inside the length asked for -
                                        ;; each pass draws a full pitch beyond
                                        ;; its own start.
                                        (while (< i turns)
                                            (setq crest (+ a0 (* i pitch)))
                                            ;; root, up the flank to the crest,
                                            ;; across the crest, down the far
                                            ;; flank, along the root.
                                            (setq pts (append pts (list
                                                (Thread:P org ang crest (* side root))
                                                (Thread:P org ang (+ crest (- (/ pitch 2.0) (/ flat 2.0)))
                                                          (* side rad))
                                                (Thread:P org ang (+ crest (+ (/ pitch 2.0) (/ flat 2.0)))
                                                          (* side rad))
                                                (Thread:P org ang (+ crest pitch (- rflat))
                                                          (* side root))
                                                (Thread:P org ang (+ crest pitch)
                                                          (* side root)))))
                                            (setq i (1+ i)))
                                        (Thread:Poly pts lay))

                                    ;; The centreline itself.
                                    (entmake (list '(0 . "LINE")
                                                   (cons 8 (Thread:Layer "Thread-Centre" 8))
                                                   (cons 10 org)
                                                   (cons 11 (polar org ang len))))

                                    (princ (strcat "\n" (itoa turns) " threads at "
                                                   (rtos pitch 2 4) " pitch, "
                                                   (rtos dia 2 3) " outside diameter, "
                                                   (rtos (* 2.0 root) 2 3) " at the root, "
                                                   (if (= hand "Left") "left" "right")
                                                   " hand.")))))))))
    )

    (Thread:Restore)
    (princ)
)

(princ)