(vl-load-com)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SAFE UTIL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun safe-num (x)
  (if (numberp x) x 0.0)
)

(defun safe-vec (v)
  (cond
    ((and (listp v) (>= (length v) 2))
     (list (safe-num (car v)) (safe-num (cadr v))))
    ((listp v)
     '(0.0 0.0))
    (T '(0.0 0.0))
  )
)

(defun clean-point (p)
  (if (and p (listp p))
    (list
      (safe-num (car p))
      (safe-num (cadr p))
    )
    '(0.0 0.0)
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; LAYER MANAGEMENT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun ensure-layer (name color / doc layers layerObj)

  (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (setq layers (vla-get-Layers doc))

  (if (not (tblsearch "LAYER" name))
    (setq layerObj (vla-add layers name))
    (setq layerObj (vla-item layers name))
  )

  (vla-put-Color layerObj color)
  layerObj
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GEOMETRY CORE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun point-distance (a b)
  (sqrt
    (+ (expt (- (car a) (car b)) 2)
       (expt (- (cadr a) (cadr b)) 2)))
)

(defun vec-sub (a b)
  (setq a (safe-vec a))
  (setq b (safe-vec b))
  (list (- (car a) (car b))
        (- (cadr a) (cadr b)))
)

(defun point-distance-segment (p a b / ap ab denom t-val proj)
  (setq p (safe-vec p))
  (setq a (safe-vec a))
  (setq b (safe-vec b))
  (setq ap (vec-sub p a))
  (setq ab (vec-sub b a))
  ;; GUARD: ab muss eine Liste mit 2 Zahlen sein
  (if (not (and (listp ab)
                (= (length ab) 2)
                (numberp (car ab))
                (numberp (cadr ab))))
    (point-distance p a)  ;; Fallback
    (progn
      (setq denom (+ (* (car ab) (car ab))
                     (* (cadr ab) (cadr ab))))
      (if (<= denom 1e-12)
        (point-distance p a)
        (progn
          (setq t-val (/ (+ (* (car ap) (car ab))
                            (* (cadr ap) (cadr ab)))
                         denom))
          (setq t-val (safe-num t-val))
          (if (< t-val 0.0) (setq t-val 0.0))
          (if (> t-val 1.0) (setq t-val 1.0))
          (setq proj (list (+ (car a) (* t-val (car ab)))
                           (+ (cadr a) (* t-val (cadr ab)))))
          (point-distance p proj)
        )
      )
    )
  )
)

;; Liegt ein Punkt strikt zwischen den Endpunkten einer Linie?
;; (nicht am Endpunkt, mit kleiner Toleranz für numerischen Drift)
(defun point-on-segment-interior (pt a b tol / t-val ab ap denom)
  (setq ab (vec-sub b a))
  (setq ap (vec-sub pt a))
  (setq denom (+ (* (car ab) (car ab)) (* (cadr ab) (cadr ab))))
  (if (<= denom 1e-12)
    nil
    (progn
      (setq t-val (/ (+ (* (car ap) (car ab)) (* (cadr ap) (cadr ab))) denom))
      ;; "innen" = klar weg von beiden Endpunkten
      (and (> t-val (/ tol (sqrt denom)))
           (< t-val (- 1.0 (/ tol (sqrt denom)))))
    )
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Endpunkt-zu-Endpunkt Prüfung (Stoß-Erkennung)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun endpoints-touch-raw (l1 l2 tol / p1 p2 p3 p4)
  ;; Rohpunkte direkt aus der Linienliste (clean-point bereits angewendet)
  (setq p1 (clean-point (car l1)))
  (setq p2 (clean-point (cadr l1)))
  (setq p3 (clean-point (car l2)))
  (setq p4 (clean-point (cadr l2)))
  (cond
    ((< (point-distance p1 p3) tol) p1)
    ((< (point-distance p1 p4) tol) p1)
    ((< (point-distance p2 p3) tol) p2)
    ((< (point-distance p2 p4) tol) p2)
    (T nil)
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; INTERSECTION CORE (SAFE + TOLERANT)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun intersect-lines (l1 l2 / o1 o2 result arr)

  (setq o1 (vlax-ename->vla-object (caddr l1)))
  (setq o2 (vlax-ename->vla-object (caddr l2)))

  (setq result
    (vl-catch-all-apply
      'vla-IntersectWith
      (list o1 o2 0)
    )
  )

  (if (vl-catch-all-error-p result)
    nil
    (progn

      (setq result
        (vl-catch-all-apply 'vlax-variant-value (list result))
      )

      (if (vl-catch-all-error-p result)
        (setq result (vla-IntersectWith o1 o2 0))
      )

      (setq arr
        (vl-catch-all-apply 'vlax-safearray->list (list result))
      )

      (if (vl-catch-all-error-p arr)
        nil
        (if (>= (length arr) 3)
          (list (nth 0 arr) (nth 1 arr) 0.0)
        )
      )
    )
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PIPELINE INTERSECTION (MAIN BRAIN)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; normalize-point ersatzlos streichen

(defun find-intersection (l1 l2 tol / p1 p2 p3 p4 ip touch-pt)
  (if (not (and (listp l1) (listp (car l1))
                (listp l2) (listp (car l2))))
    nil
    (progn
      (setq p1 (clean-point (car l1)))
      (setq p2 (clean-point (cadr l1)))
      (setq p3 (clean-point (car l2)))
      (setq p4 (clean-point (cadr l2)))

      ;; Schritt 1: Endpunkt-Stoß
      (setq touch-pt (endpoints-touch-raw l1 l2 tol))
      (if touch-pt
        (cons touch-pt (classify-intersection touch-pt l1 l2 tol))

        ;; Schritt 2: Echter Schnitt
        (progn
          (setq ip (intersect-lines l1 l2))
          (if ip
            (progn
              ;; Sicherheitsnetz: liegt SP nahe einem Endpunkt?
              (if (or (< (point-distance ip p1) tol)
                      (< (point-distance ip p2) tol)
                      (< (point-distance ip p3) tol)
                      (< (point-distance ip p4) tol))
                (cons ip (classify-intersection ip l1 l2 tol))
                (if (and (point-on-segment-interior ip p1 p2 tol)
                         (point-on-segment-interior ip p3 p4 tol))
                  (cons ip "Kreuzung")
                  (cons ip (classify-intersection ip l1 l2 tol))
                )
              )
            )
            ;; Schritt 3: Toleranz-Fallback
            (cond
              ((< (point-distance-segment p1 p3 p4) tol)
               (cons p1 (classify-intersection p1 l1 l2 tol)))
              ((< (point-distance-segment p2 p3 p4) tol)
               (cons p2 (classify-intersection p2 l1 l2 tol)))
              ((< (point-distance-segment p3 p1 p2) tol)
               (cons p3 (classify-intersection p3 l1 l2 tol)))
              ((< (point-distance-segment p4 p1 p2) tol)
               (cons p4 (classify-intersection p4 l1 l2 tol)))
              (T nil)
            )
          )
        )
      )
    )
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; CLASSIFICATION
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun is-endpoint (pt line tol)
  (or
    (< (point-distance pt (car line)) tol)
    (< (point-distance pt (cadr line)) tol)
  )
)

(defun classify-intersection (pt l1 l2 tol / e1 e2)

  (setq e1 (is-endpoint pt l1 tol))
  (setq e2 (is-endpoint pt l2 tol))

  (cond
    ((and e1 e2) "Eckverbindung")
    ((or e1 e2) "T-Verbindung")
    (T "Kreuzung")
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DEDUP
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun point-exists (pt list tol)
  (vl-some
    '(lambda (p)
       (< (point-distance pt p) tol)
     )
    list
  )
)

(defun count-by-type (lst typ)
  (length
    (vl-remove-if-not
      '(lambda (p) (= (caddr p) typ))
      lst
    )
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DRAW
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun create-circle (pt radius layer)
  (entmakex
    (list
      '(0 . "CIRCLE")
      (cons 8 layer)
      (cons 10 pt)
      (cons 40 radius)
    )
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; INPUT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun get-lines-by-layer (layers / ss i ent obj lines)

  (setq lines '())

  (foreach lay layers
    (setq ss
      (ssget "_X"
        (list '(0 . "LINE") (cons 8 lay))
      )
    )

    (if ss
      (progn
        (setq i 0)
        (repeat (sslength ss)

          (setq ent (ssname ss i))
          (setq obj (vlax-ename->vla-object ent))

          (setq lines
            (cons
              (list
                (clean-point (vlax-get obj 'StartPoint))
                (clean-point (vlax-get obj 'EndPoint))
                ent
              )
              lines
            )
          )

          (setq i (1+ i))
        )
      )
    )
  )

  lines
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TEXTDATEI-EXPORT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun write-report (all-pts filepath layers / f n-kr n-tv n-ek n-kontakt n-gesamt)
  (setq n-kr      (count-by-type all-pts "Kreuzung"))
  (setq n-tv      (count-by-type all-pts "T-Verbindung"))
  (setq n-ek      (count-by-type all-pts "Eckverbindung"))
  (setq n-kontakt (+ n-tv n-ek))
  (setq n-gesamt  (length all-pts))

  (setq f (open filepath "w"))
  (if (not f)
    (prompt (strcat "\nFehler: Datei konnte nicht erstellt werden: " filepath))
    (progn
      (write-line "================================================" f)
      (write-line " VERBINDUNGSZAEHLER - ERGEBNIS" f)
      (write-line "================================================" f)
      (write-line "" f)
      (write-line (strcat " Datum/Zeit : " (menucmd "M=$(edtime,$(getvar,DATE),DD.MM.YYYY HH:MM:SS)")) f)
      (write-line (strcat " Zeichnung  : " (vla-get-FullName (vla-get-ActiveDocument (vlax-get-acad-object)))) f)
      ;; Layer-Zeile im Report dynamisch:
      (write-line
        (strcat " Layer      : "
          (apply 'strcat
            (cons (car layers)
                  (mapcar '(lambda (l) (strcat ", " l)) (cdr layers))
            )
          )
        )
        f
      )
      (write-line "" f)
      (write-line "------------------------------------------------" f)
      (write-line " VERBINDUNGSTYPEN" f)
      (write-line "------------------------------------------------" f)
      (write-line "" f)
      (write-line (strcat "  Kreuzungen      : " (itoa n-kr)) f)
      (write-line (strcat "  T-Verbindungen  : " (itoa n-tv)) f)
      (write-line (strcat "  Eckverbindungen : " (itoa n-ek)) f)
      (write-line "" f)
      (write-line "------------------------------------------------" f)
      (write-line " SUMMEN" f)
      (write-line "------------------------------------------------" f)
      (write-line "" f)
      (write-line (strcat "  Kreuzungen                       : " (itoa n-kr)) f)
      (write-line (strcat "  Kontaktpunkte (T + Eck)          : " (itoa n-kontakt)) f)
      (write-line (strcat "    davon T-Verbindungen           : " (itoa n-tv)) f)
      (write-line (strcat "    davon Eckverbindungen          : " (itoa n-ek)) f)
      (write-line "" f)
      (write-line (strcat "  GESAMT                           : " (itoa n-gesamt)) f)
      (write-line "" f)
      (write-line "================================================" f)
      (close f)
      (prompt (strcat "\nBericht gespeichert: " filepath))
    )
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; INPUT MIT DEFAULTS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun prompt-layers (default-layers / input parts result)
  ;; default-layers ist eine Liste z.B. '("D-1" "D-5")
  (setq input
    (getstring
      (strcat "\nLayer (kommagetrennt) [" 
              (apply 'strcat 
                (cons (car default-layers)
                      (mapcar '(lambda (l) (strcat ", " l)) (cdr default-layers))
                )
              )
              "]: ")
    )
  )
  (if (= input "")
    default-layers
    ;; Eingabe splitten an Komma, Whitespace trimmen
    (progn
      ;; einfaches Splitten: Zeichen für Zeichen
      (setq parts (split-string-by input ","))
      (foreach p parts
        (setq p (string-trim p))
        (if (/= p "")
          (setq result (cons p result))
        )
      )
      (reverse result)
    )
  )
)

(defun prompt-tolerance (default-tol / input val)
  (setq input
    (getstring
      (strcat "\nToleranz [" (rtos default-tol 2 2) "]: ")
    )
  )
  (if (= input "")
    default-tol
    (progn
      (setq val (atof input))
      (if (> val 0.0)
        val
        (progn
          (prompt (strcat "\nUngueltige Toleranz, verwende Default: " (rtos default-tol 2 2)))
          default-tol
        )
      )
    )
  )
)

;; Hilfsfunktion: String an Trennzeichen splitten
(defun split-string-by (str sep / result current i ch)
  (setq result '())
  (setq current "")
  (setq i 0)
  (while (< i (strlen str))
    (setq ch (substr str (1+ i) 1))
    (if (= ch sep)
      (progn
        (setq result (cons current result))
        (setq current "")
      )
      (setq current (strcat current ch))
    )
    (setq i (1+ i))
  )
  ;; letztes Segment
  (setq result (cons current result))
  (reverse result)
)

;; Hilfsfunktion: führende/nachfolgende Leerzeichen entfernen
(defun string-trim (str / i j)
  (setq i 1)
  (setq j (strlen str))
  (while (and (<= i j) (= (substr str i 1) " "))
    (setq i (1+ i))
  )
  (while (and (>= j i) (= (substr str j 1) " "))
    (setq j (1- j))
  )
  (if (> j (1- i))
    (substr str i (- (1+ j) i))
    ""
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MAIN COMMAND
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:VZAEHLER (/ layers tol radius lines i j l1 l2 pt typ all-pts result report-path)

  ;; ── Defaults ────────────────────────────────────────────
  (setq default-layers '("D-1" "D-5"))
  (setq default-tol 0.5)

  ;; ── Benutzereingabe ──────────────────────────────────────
  (prompt "\n===== VERBINDUNGSZAEHLER =====")
  (setq layers (prompt-layers default-layers))
  (setq tol    (prompt-tolerance default-tol))
  (setq radius 100)

  (prompt (strcat "\nLayer     : "))
  (foreach l layers (prompt (strcat l " ")))
  (prompt (strcat "\nToleranz  : " (rtos tol 2 2)))
  (prompt "\n------------------------------")

  ;; ── Logik ────────────────────────────────────

  (setq all-pts '())
  (setq lines (get-lines-by-layer layers))

  (ensure-layer "D-KREUZUNG" 1)
  (ensure-layer "D-T_VERBINDUNG" 3)
  (ensure-layer "D-ECKVERBINDUNG" 5)

  (prompt (strcat "\nLinien gefunden: " (itoa (length lines))))

  (setq i 0)

  (while (< i (length lines))

    (setq j (+ i 1))

    (while (< j (length lines))

      (setq l1 (nth i lines))
      (setq l2 (nth j lines))

      (setq result (find-intersection l1 l2 tol))
      (if result
        (progn
          (setq pt  (car result))   ;; Punkt
          (setq typ (cdr result))   ;; Typ — direkt aus find-intersection
          (if (not (point-exists pt all-pts tol))
            (progn
              (setq all-pts (cons (list (car pt) (cadr pt) typ) all-pts))
              (cond
                ((= typ "Kreuzung")      (create-circle pt radius "D-KREUZUNG"))
                ((= typ "T-Verbindung")  (create-circle pt radius "D-T_VERBINDUNG"))
                ((= typ "Eckverbindung") (create-circle pt radius "D-ECKVERBINDUNG"))
              )
            )
          )
        )
      )

      (setq j (1+ j))
    )

    (setq i (1+ i))
  )

  (prompt "\n\n===== ERGEBNIS =====")
  (prompt (strcat "\nKreuzungen: " (itoa (count-by-type all-pts "Kreuzung"))))
  (prompt (strcat "\nT-Verbindungen: " (itoa (count-by-type all-pts "T-Verbindung"))))
  (prompt (strcat "\nEckverbindungen: " (itoa (count-by-type all-pts "Eckverbindung"))))
  (prompt (strcat "\nGESAMT: " (itoa (length all-pts))))

  ;; ── Report schreiben ──────────────────────────────────────
  (setq dwg-name
    (vla-get-Name (vla-get-ActiveDocument (vlax-get-acad-object)))
  )
  ;; ".dwg" abschneiden falls vorhanden
  (if (wcmatch dwg-name "*.dwg")
    (setq dwg-name (substr dwg-name 1 (- (strlen dwg-name) 4)))
  )
  (setq timestamp
    (menucmd "M=$(edtime,$(getvar,DATE),YYYYMMDD-HHMMSS)")
  )
  (setq report-path
    (strcat
      (vla-get-Path (vla-get-ActiveDocument (vlax-get-acad-object)))
      "\\"
      dwg-name
      "_"
      timestamp
      "_vzaehler.txt"
    )
  )

  (write-report all-pts report-path layers)

  (princ)
)