;;; ---------------------------------------------------------------------------
;;; SegmentReport.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Reports every segment of a polyline in full detail, as a table, a text file
;;; or a CSV.
;;;
;;; For each segment you get:
;;;
;;;     segment number
;;;     start X and Y, end X and Y
;;;     start width and end width
;;;     length - the true arc length where the segment is curved
;;;     arc centre X and Y, and radius, for curved segments
;;;
;;; This is the tool for producing a setting-out schedule from a boundary, or
;;; for checking a polyline that measures wrong somewhere and you cannot see
;;; where.
;;;
;;; OUTPUT FORMATS
;;; Choose Output at the prompt to switch between them. The choice is
;;; remembered between AutoCAD sessions.
;;;
;;;   Table  - an AutoCAD table object placed in the drawing
;;;   TXT    - a tab-delimited text file, opened automatically
;;;   CSV    - a comma-delimited file for a spreadsheet, opened automatically
;;;
;;; The Table option is only offered where the AutoCAD version supports table
;;; objects, which is why the output prompt is built at load time rather than
;;; written out fixed.
;;;
;;; Text and CSV files are written beside the drawing, named from the
;;; polyline's own handle - so repeated runs on different polylines do not
;;; overwrite one another.
;;;
;;; THE ARC COLUMNS ONLY APPEAR IF NEEDED
;;; A polyline with no curved segments produces a report without the centre and
;;; radius columns at all, rather than three columns of blanks.
;;;
;;;   SEGREPORT  - report every segment of a polyline
;;; ---------------------------------------------------------------------------

(vl-load-com)

;; Environment key for the remembered output format.
(setq SegmentReport:Key "YZ\\SegmentReport")

;; ---------------------------------------------------------------------------
;; SegmentReport:Doc  -  cached active document
;; ---------------------------------------------------------------------------
(defun SegmentReport:Doc nil
    (eval (list 'defun 'SegmentReport:Doc 'nil
                (vla-get-activedocument (vlax-get-acad-object))
          )
    )
    (SegmentReport:Doc)
)

;; ---------------------------------------------------------------------------
;; SegmentReport:Vertices
;; ---------------------------------------------------------------------------
;; Returns the polyline's vertices as sublists of their four defining groups:
;; 10 position, 40 start width, 41 end width, 42 bulge.
;; ---------------------------------------------------------------------------
(defun SegmentReport:Vertices ( enx )
    (if (setq enx (member (assoc 10 enx) enx))
        (cons (list (assoc 10 enx) (assoc 40 enx) (assoc 41 enx) (assoc 42 enx))
              (SegmentReport:Vertices (cdr enx))
        )
    )
)

;; ---------------------------------------------------------------------------
;; SegmentReport:BulgeRadius
;; ---------------------------------------------------------------------------
;; Returns the radius of the arc described by two vertices and a bulge.
;;
;; Bulge is the tangent of one quarter of the arc's included angle. From the
;; chord length and that ratio, the radius follows directly. The absolute value
;; is taken because a negative bulge means the arc curves the other way, not
;; that it has a negative radius.
;; ---------------------------------------------------------------------------
(defun SegmentReport:BulgeRadius ( p1 p2 b )
    (/ (* (distance p1 p2) (1+ (* b b))) 4 (abs b))
)

;; ---------------------------------------------------------------------------
;; SegmentReport:BulgeCentre
;; ---------------------------------------------------------------------------
;; Returns the centre of the arc described by two vertices and a bulge.
;;
;; The sign is deliberately NOT stripped here - the direction to the centre
;; depends on which way the arc curves, so a negative bulge must place the
;; centre on the opposite side of the chord.
;; ---------------------------------------------------------------------------
(defun SegmentReport:BulgeCentre ( p1 p2 b )
    (polar p1
        (+ (angle p1 p2) (- (/ pi 2) (* 2 (atan b))))
        (/ (* (distance p1 p2) (1+ (* b b))) 4 b)
    )
)

;; ---------------------------------------------------------------------------
;; SegmentReport:Annotative
;; ---------------------------------------------------------------------------
;; True if the named text style is annotative. The flag lives in the style's
;; extended data under "AcadAnnotative", as group 1070 with value 1.
;; ---------------------------------------------------------------------------
(defun SegmentReport:Annotative ( sty )
    (and (setq sty (tblobjname "style" sty))
         (setq sty (cadr (assoc -3 (entget sty '("AcadAnnotative")))))
         (= 1 (cdr (assoc 1070 (reverse sty))))
    )
)

;; ---------------------------------------------------------------------------
;; SegmentReport:CellWidth
;; ---------------------------------------------------------------------------
;; Returns the width a string needs in a table cell, including padding.
;; ---------------------------------------------------------------------------
(defun SegmentReport:CellWidth ( str hgt sty / box )
    (setq box (textbox (list (cons 01 str) (cons 40 hgt) (cons 07 sty))))
    (if box
        (+ (* 2.5 hgt) (- (caadr box) (caar box)))
        0.0
    )
)

;; ---------------------------------------------------------------------------
;; SegmentReport:AddTable
;; ---------------------------------------------------------------------------
;; Builds a table at the given point from a matrix of cell strings.
;;
;; Column widths are measured from the widest entry in each column, so the
;; table fits its content. Regeneration is suppressed while the cells are
;; filled - a table that regenerates after every cell is dramatically slower on
;; a polyline with a few hundred segments.
;;
;; spc - [vla-object] model or paper space
;; ins - [list] WCS insertion point
;; ttl - [str] title, or nil
;; lst - [list] rows of cell strings, the first being the headings
;; eqc - [boolean] T to force equal column widths
;; ---------------------------------------------------------------------------
(defun SegmentReport:AddTable ( spc ins ttl lst eqc / dif hgt i j obj stn sty wid )

    (setq sty
        (vlax-ename->vla-object
            (cdr (assoc -1
                (dictsearch
                    (cdr (assoc -1 (dictsearch (namedobjdict) "acad_tablestyle")))
                    (getvar 'ctablestyle)
                )
            ))
        )
    )
    (setq hgt (vla-gettextheight sty acdatarow)
          stn (vla-gettextstyle  sty acdatarow)
    )

    ;; An annotative style reports its PLOTTED height, so it must be divided by
    ;; the annotation scale to give the model-space height.
    (if (SegmentReport:Annotative stn)
        (setq hgt (/ hgt (cond ((getvar 'cannoscalevalue)) (1.0))))
    )

    ;; Transposing the matrix groups the cells by column rather than by row.
    (setq wid
        (mapcar
            (function
                (lambda ( col )
                    (apply 'max
                        (mapcar (function (lambda ( str ) (SegmentReport:CellWidth str hgt stn))) col)
                    )
                )
            )
            (apply 'mapcar (cons 'list lst))
        )
    )

    ;; Widen the columns if a title would not otherwise fit across them.
    (if (and ttl
             (< 0.0 (setq dif (/ (- (SegmentReport:CellWidth ttl hgt stn) (apply '+ wid))
                                 (length wid)
                              )
                    )
             )
        )
        (setq wid (mapcar (function (lambda ( x ) (+ x dif))) wid))
    )

    (setq obj
        (vla-addtable spc
            (vlax-3D-point ins)
            (1+ (length lst))
            (length (car lst))
            (* 2.0 hgt)
            (if eqc
                (apply 'max wid)
                (/ (apply '+ wid) (float (length (car lst))))
            )
        )
    )

    (vla-put-regeneratetablesuppressed obj :vlax-true)
    (vla-put-stylename obj (getvar 'ctablestyle))

    (setq i -1)
    (if (null eqc)
        (foreach col wid
            (vla-setcolumnwidth obj (setq i (1+ i)) col)
        )
    )

    ;; A table is created with a title row; with no title that row is deleted
    ;; and the data starts one row higher.
    (if ttl
        (progn (vla-settext obj 0 0 ttl) (setq i 1))
        (progn (vla-deleterows obj 0 1)  (setq i 0))
    )

    (foreach row lst
        (setq j 0)
        (foreach val row
            (vla-settext obj i j val)
            (setq j (1+ j))
        )
        (setq i (1+ i))
    )

    (vla-put-regeneratetablesuppressed obj :vlax-false)
    obj
)

;; ---------------------------------------------------------------------------
;; SegmentReport:Join
;; ---------------------------------------------------------------------------
;; Concatenates a list of strings with a delimiter between each.
;; ---------------------------------------------------------------------------
(defun SegmentReport:Join ( lst del )
    (if (cdr lst)
        (strcat (car lst) del (SegmentReport:Join (cdr lst) del))
        (car lst)
    )
)

;; ---------------------------------------------------------------------------
;; SegmentReport:Quote
;; ---------------------------------------------------------------------------
;; Quotes a CSV field if it contains the separator or a quote character, and
;; doubles any quotes inside it - which is the CSV escaping convention.
;;
;; Without this, a value containing a comma would silently split into two
;; columns when the file is opened in a spreadsheet.
;; ---------------------------------------------------------------------------
(defun SegmentReport:Quote ( str sep / pos )
    (cond
        (   (wcmatch str (strcat "*[`" sep "\"]*"))
            (setq pos 0)
            (while (setq pos (vl-string-position 34 str pos))
                (setq str (vl-string-subst "\"\"" "\"" str pos)
                      pos (+ pos 2)
                )
            )
            (strcat "\"" str "\"")
        )
        (   str )
    )
)

;; ---------------------------------------------------------------------------
;; SegmentReport:WriteCsv
;; ---------------------------------------------------------------------------
;; Writes the matrix to a CSV file. Returns T on success.
;;
;; The separator is read from the Windows regional settings rather than assumed
;; to be a comma - in much of Europe the list separator is a semicolon, and a
;; comma-delimited file opens there as one column.
;; ---------------------------------------------------------------------------
(defun SegmentReport:WriteCsv ( lst csv / des sep )
    (if (setq des (open csv "w"))
        (progn
            (setq sep
                (cond
                    ((vl-registry-read "HKEY_CURRENT_USER\\Control Panel\\International" "sList"))
                    (",")
                )
            )
            (foreach row lst
                (write-line
                    (SegmentReport:Join
                        (mapcar (function (lambda ( s ) (SegmentReport:Quote s sep))) row)
                        sep
                    )
                    des
                )
            )
            (close des)
            t
        )
    )
)

;; ---------------------------------------------------------------------------
;; SegmentReport:WriteTxt
;; ---------------------------------------------------------------------------
;; Writes the matrix to a tab-delimited text file. Returns T on success.
;; ---------------------------------------------------------------------------
(defun SegmentReport:WriteTxt ( lst txt / des )
    (if (setq des (open txt "w"))
        (progn
            (foreach row lst
                (write-line (SegmentReport:Join row "\t") des)
            )
            (close des)
            t
        )
    )
)

;; ---------------------------------------------------------------------------
;; SegmentReport:FormatName
;; ---------------------------------------------------------------------------
;; Returns the readable name of an output format code.
;; ---------------------------------------------------------------------------
(defun SegmentReport:FormatName ( out )
    (cond
        ((= out "TXT") "Text File")
        ((= out "CSV") "CSV File")
        ("AutoCAD Table")
    )
)

;; ---------------------------------------------------------------------------
;; SegmentReport:Build
;; ---------------------------------------------------------------------------
;; Returns the report as a matrix of cell strings, headings first.
;;
;; The heading row gains the three arc columns only if at least one segment is
;; actually curved - which is what the vl-some test decides.
;;
;; For each segment the LENGTH column holds:
;;   straight segment - the distance between its two vertices
;;   curved segment   - the true arc length, computed as radius times the
;;                      included angle. Since bulge is the tangent of a quarter
;;                      of that angle, the angle is 4 * atan(bulge), giving
;;                      radius * 4 * atan(bulge).
;;
;; Reporting the chord length for a curved segment would be a quietly wrong
;; answer on a setting-out schedule, which is why the two cases differ.
;;
;; enx - [list] the polyline's entity data
;; ---------------------------------------------------------------------------
(defun SegmentReport:Build ( enx / lst flg seg )

    (setq lst (SegmentReport:Vertices enx)
          seg 0
          flg (vl-some (function (lambda ( x ) (not (zerop (cdr (assoc 42 x)))))) lst)
    )

    (cons
        ;; Heading row.
        (append '("SEG." "START X" "START Y" "END X" "END Y" "WIDTH 1" "WIDTH 2" "LENGTH")
                (if flg '("CENTRE X" "CENTRE Y" "RADIUS"))
        )
        ;; One row per segment, pairing each vertex with the next. A CLOSED
        ;; polyline gets its first vertex appended to the end of the second
        ;; list, which produces the closing segment - omitting that was the bug
        ;; version 1.2 of the original was published to fix.
        (mapcar
            (function
                (lambda ( v1 v2 / b p q )
                    (setq p (cdr (assoc 10 v1))
                          q (cdr (assoc 10 v2))
                          b (cdr (assoc 42 v1))
                    )
                    (append
                        (list (itoa (setq seg (1+ seg))))
                        (mapcar 'rtos p)
                        (mapcar 'rtos q)
                        (list (rtos (cdr (assoc 40 v1)))
                              (rtos (cdr (assoc 41 v1)))
                        )
                        (if (zerop b)
                            ;; Straight: chord length, and blank arc columns if
                            ;; the table has them.
                            (cons (rtos (distance p q)) (if flg '("" "" "")))
                            ;; Curved: arc length, centre and radius.
                            (append
                                (list (rtos (abs (* (SegmentReport:BulgeRadius p q b) (atan b) 4))))
                                (mapcar 'rtos (SegmentReport:BulgeCentre p q b))
                                (list (rtos (SegmentReport:BulgeRadius p q b)))
                            )
                        )
                    )
                )
            )
            lst
            (if (= 1 (logand 1 (cdr (assoc 70 enx))))
                (append (cdr lst) (list (car lst)))   ; closed - wrap round
                (cdr lst)                             ; open - one fewer segment
            )
        )
    )
)

;; ---------------------------------------------------------------------------
;; c:SEGREPORT  -  main routine
;; ---------------------------------------------------------------------------
(defun c:SEGREPORT ( / *error* vars vals ent enx lst out ins tmp )

    (setq vars '("CMDECHO")
          vals (mapcar 'getvar vars)
    )

    (defun SegmentReport: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 )
        ;; The chosen output format is saved even on the error path, so a
        ;; cancelled run does not lose a format the user just changed.
        (if (= 'str (type out)) (setenv SegmentReport:Key out))
        (SegmentReport:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** SEGREPORT error: " msg " **"))
        )
        (princ)
    )

    (setvar "CMDECHO" 0)

    (if (null (setq out (getenv SegmentReport:Key)))
        (setq out "TXT")
    )
    (princ (strcat "\nOutput format: " (SegmentReport:FormatName out)))

    ;; Re-prompt until a polyline is picked or the user gives up. Choosing
    ;; Output changes the format and asks again rather than ending the command.
    (while
        (progn
            (setvar 'errno 0)
            (initget "Output")
            (setq ent (entsel "\nSelect polyline [Output]: "))
            (cond
                (   (= 7 (getvar 'errno))
                    (princ "\nMissed, try again.")
                )
                (   (null ent) nil)
                (   (= "Output" ent)
                    (SegmentReport:ChooseOutput 'out)
                    (setenv SegmentReport:Key out)
                    (princ (strcat "\nOutput format: " (SegmentReport:FormatName out)))
                    t
                )
                (   (/= "LWPOLYLINE" (cdr (assoc 0 (entget (setq ent (car ent))))))
                    (princ "\nThat object is not an LWPolyline.")
                )
            )
        )
    )

    (cond
        ;; The table is created on the current layer, so it must be unlocked -
        ;; checked before the work is done rather than after.
        (   (and (= 'ename (type ent))
                 (= "Table" out)
                 (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (getvar 'clayer))))))
            )
            (princ "\nThe current layer is locked - unlock it, or choose TXT or CSV output.")
        )

        (   (= 'ename (type ent))
            (setq enx (entget ent)
                  lst (SegmentReport:Build enx)
            )

            (cond
                (   (= out "TXT")
                    ;; Named from the polyline's handle, so runs on different
                    ;; polylines do not overwrite one another.
                    (if (SegmentReport:WriteTxt lst
                            (setq tmp (vl-filename-mktemp (cdr (assoc 5 enx)) (getvar 'dwgprefix) ".txt"))
                        )
                        (progn (startapp "explorer" tmp)
                               (princ (strcat "\n" (itoa (1- (length lst)))
                                              " segments written to " tmp))
                        )
                        (princ "\nThe text file could not be written.")
                    )
                )

                (   (= out "CSV")
                    (if (SegmentReport:WriteCsv lst
                            (setq tmp (vl-filename-mktemp (cdr (assoc 5 enx)) (getvar 'dwgprefix) ".csv"))
                        )
                        (progn (startapp "explorer" tmp)
                               (princ (strcat "\n" (itoa (1- (length lst)))
                                              " segments written to " tmp))
                        )
                        (princ "\nThe CSV file could not be written.")
                    )
                )

                (   (setq ins (getpoint "\nSpecify point for the table: "))
                    ;; AutoCAD 2015 and later refuse (command) inside an *error* handler
                    ;; unless the routine says up front that it will use one. Restore does,
                    ;; to close this undo group. The declaring call is absent on older
                    ;; releases, so it is wrapped rather than tested for.
                    (vl-catch-all-apply '(lambda ( ) (*push-error-using-command*)) '())
                    (command "_.UNDO" "_Begin")
                    (SegmentReport:AddTable
                        (vlax-get-property (SegmentReport:Doc)
                            (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)
                        )
                        (trans ins 1 0) nil lst nil
                    )
                    (princ (strcat "\nTable created with " (itoa (1- (length lst))) " segments."))
                )

                (   t
                    (princ "\n*Cancelled*")
                )
            )
        )
    )

    (SegmentReport:Restore)
    (princ)
)

;; ---------------------------------------------------------------------------
;; SegmentReport:ChooseOutput
;; ---------------------------------------------------------------------------
;; Prompts for the output format, setting the supplied symbol.
;;
;; The prompt is BUILT at load time rather than written out fixed, because the
;; Table option must only be offered on AutoCAD versions that support table
;; objects - offering it on a version without them would let the user pick an
;; output that then cannot be produced.
;; ---------------------------------------------------------------------------
(eval
    (append
        (list 'defun 'SegmentReport:ChooseOutput '( sym ))
        (if (vlax-method-applicable-p (vla-get-modelspace (SegmentReport:Doc)) 'addtable)
            (list
               '(initget "Table TXT CSV")
               '(set sym (cond ((getkword (strcat "\nChoose output [Table/TXT/CSV] <" (eval sym) ">: ")))
                               ((eval sym))
                         )
                )
            )
            (list
               '(initget "TXT CSV")
               '(set sym (cond ((getkword (strcat "\nChoose output [TXT/CSV] <" (eval sym) ">: ")))
                               ((eval sym))
                         )
                )
            )
        )
    )
)

(princ)