;;; ---------------------------------------------------------------------------
;;; LineMerge.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; MERGE COLLINEAR LINES INTO ONE
;;;
;;; PURPOSE
;;;   Finds lines that lie along the same straight and joins them into single
;;;   lines. A wall drawn in eight pieces because it was trimmed round doorways
;;;   becomes one. Fragments left over from a scan trace, a bad DXF import or
;;;   years of editing collapse into what they were meant to be.
;;;
;;;   Gaps are bridged up to a tolerance you set, so a run broken by a door is
;;;   rejoined if you want it to be and left alone if you do not.
;;;
;;; WHY NOT JUST USE JOIN
;;;   AutoCAD's JOIN needs the lines to be collinear AND requires you to pick
;;;   them in a set it can reason about. It will not sift a hundred selected
;;;   lines into the twelve straights they belong to. This does that sifting -
;;;   grouping by direction first, then by which straight line each sits on,
;;;   then merging along each straight in turn.
;;;
;;; WHAT WAS FIXED
;;;   The original took the whole selection, found the largest and smallest X
;;;   and Y across ALL of it, and drew ONE line across that bounding box -
;;;   whatever the lines actually were. Two parallel walls ten metres apart
;;;   became a single diagonal between their far corners. It only gave the right
;;;   answer when every line picked was already part of the same straight, which
;;;   is the case where you did not need it.
;;;
;;;   It also counted how many lines leaned left versus right to decide the
;;;   direction of its one output line, deleted every input before deciding what
;;;   to draw, and kept eleven variables global.
;;;
;;;   LINEMERGE  - join collinear lines into single lines
;;; ---------------------------------------------------------------------------

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

;;; Two lines lie on the same straight when their directions agree AND a point
;;; from one sits on the other's line. Direction alone is not enough - that is
;;; merely parallel, which is what the original confused it with.
(defun Merge:SameLine ( a b angTol distTol / d1 d2 diff off )
    (setq d1 (angle (car a) (cadr a))
          d2 (angle (car b) (cadr b))
          diff (abs (- (rem (+ d1 pi) pi) (rem (+ d2 pi) pi))))
    (if (> diff (/ pi 2.0)) (setq diff (- pi diff)))
    (and (< diff angTol)
         ;; Perpendicular distance from B's start to A's infinite line.
         (progn
             (setq off (Merge:OffLine (car b) (car a) d1))
             (< (abs off) distTol)))
)

;;; How far P sits off the line through BASE at angle ANG.
(defun Merge:OffLine ( p base ang / dx dy )
    (setq dx (- (car p) (car base))
          dy (- (cadr p) (cadr base)))
    (- (* dy (cos ang)) (* dx (sin ang)))
)

;;; Distance of P along the line through BASE at angle ANG - can be negative.
(defun Merge:Along ( p base ang / dx dy )
    (setq dx (- (car p) (car base))
          dy (- (cadr p) (cadr base)))
    (+ (* dx (cos ang)) (* dy (sin ang)))
)

(defun Merge:Ends ( ent / d )
    (setq d (entget ent))
    (list (cdr (assoc 10 d)) (cdr (assoc 11 d)))
)

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

(defun c:LINEMERGE ( / *error* vars vals ss i ent lines groups g found
                       angTol gapTol offTol base ang spans lo hi seg
                       merged removed data v runs )

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

    (defun Merge: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 )
        (Merge:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** LINEMERGE error: " msg " **")))
        (princ)
    )

    (setvar "CMDECHO" 0)
    (setvar "BLIPMODE" 0)
    (setvar "HIGHLIGHT" 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")

    (princ "\nSelect the lines to sift and merge.")
    (setq ss (ssget '((0 . "LINE"))))

    (if (null ss)
        (princ "\nNo lines selected.")
        (progn
            (initget 4)
            (setq gapTol (getdist "\nBridge gaps up to <0>: "))
            (if (null gapTol) (setq gapTol 0.0))

            ;; How far off the straight a line may sit and still count as part
            ;; of it. Loose enough for hand-traced work, tight enough not to
            ;; swallow a genuinely separate line alongside.
            (initget 4)
            (setq offTol (getdist "\nHow far off the straight still counts <0.001>: "))
            (if (null offTol) (setq offTol 0.001))
            (setq angTol 0.001)      ; radians, about a twentieth of a degree

            ;; --- read everything up front --------------------------------
            (setq lines nil i 0)
            (while (< i (sslength ss))
                (setq ent (ssname ss i))
                (if (> (distance (car (Merge:Ends ent)) (cadr (Merge:Ends ent))) 1e-9)
                    (setq lines (cons (list ent (Merge:Ends ent) (entget ent)) lines)))
                (setq i (1+ i)))

            ;; --- sort into straights --------------------------------------
            ;; Each group is a list of lines that all lie on the same infinite
            ;; straight. This is the step the original skipped.
            (setq groups nil)
            (foreach L lines
                (setq found nil)
                (foreach G groups
                    (if (and (null found)
                             (Merge:SameLine (cadr (car G)) (cadr L) angTol offTol))
                        (setq found G)))
                (if found
                    (setq groups (subst (cons L found) found groups))
                    (setq groups (cons (list L) groups))))

            ;; --- merge along each straight --------------------------------
            (setq merged 0 removed 0 runs 0)

            (foreach G groups
                (setq base (car (cadr (car G)))
                      ang  (apply 'angle (cadr (car G)))
                      data (caddr (car G))
                      ;; Every line as a span along the straight, sorted so
                      ;; overlaps and touching ends fall next to each other.
                      spans (vl-sort
                                (mapcar
                                    '(lambda ( L )
                                        (list (min (Merge:Along (car (cadr L)) base ang)
                                                   (Merge:Along (cadr (cadr L)) base ang))
                                              (max (Merge:Along (car (cadr L)) base ang)
                                                   (Merge:Along (cadr (cadr L)) base ang))))
                                    G)
                                '(lambda ( a b ) (< (car a) (car b)))))

                (setq lo (car (car spans)) hi (cadr (car spans)) seg nil)
                (foreach s (cdr spans)
                    (if (<= (car s) (+ hi gapTol))
                        ;; Touches or overlaps - extend the run.
                        (setq hi (max hi (cadr s)))
                        ;; A real gap - bank this run and start another.
                        (progn (setq seg (cons (list lo hi) seg)
                                     lo (car s) hi (cadr s)))))
                (setq seg (reverse (cons (list lo hi) seg)))

                ;; Only worth touching if this straight actually collapsed.
                (if (< (length seg) (length G))
                    (progn
                        (foreach L G (entdel (car L)) (setq removed (1+ removed)))
                        (foreach s seg
                            (entmake (append
                                (list '(0 . "LINE")
                                      (cons 10 (polar base ang (car s)))
                                      (cons 11 (polar base ang (cadr s))))
                                (vl-remove-if
                                    '(lambda ( x ) (member (car x) '(-1 0 5 10 11 100 330)))
                                    data)))
                            (setq merged (1+ merged)))
                        (setq runs (1+ runs)))))

            (if (zerop runs)
                (princ "\nNothing to merge - no two of those lie on the same straight.")
                (princ (strcat "\n" (itoa removed) " lines on " (itoa runs)
                               " straight" (if (= runs 1) "" "s")
                               " became " (itoa merged) " line"
                               (if (= merged 1) "" "s") "."))))
    )

    (Merge:Restore)
    (princ)
)

(princ)