;;; ============================================================
;;; count_sep_scan.lsp  -  Eigenstaendiges Zaehl-Werkzeug
;;; ------------------------------------------------------------
;;; Zaehlt die manuell platzierten Bloecke "Scanner" und
;;; "Separator_SP" je ILS-Block (Kreisel / VarioFoerderer /
;;; Gefaellestrecke) und schreibt die Anzahlen in die Attribute
;;; des jeweiligen ILS-Blocks. Anschliessend QSAVE.
;;;
;;; Zuordnung eines Sensors zu einem ILS-Block (Z wird ignoriert):
;;;   - Scanner: der Einfuegepunkt (X/Y) muss in der Bounding-Box
;;;     des ILS-Blocks liegen. Die 3D-Geometrie des Scanners kann
;;;     weit vom Einfuegepunkt entfernt sein, daher zaehlt hier der
;;;     Einfuegepunkt (dort klickt der Benutzer auf den Block).
;;;   - Separator: der geometrische Mittelpunkt (Zentrum der eigenen
;;;     Bounding-Box, unabhaengig vom $INSBASE) muss in der
;;;     Bounding-Box des ILS-Blocks liegen.
;;;   - Liegt der Punkt in mehreren Boxen (Ueberlappung), wird
;;;     der ILS-Block mit dem naechstgelegenen Box-Zentrum gewaehlt.
;;;   - Ein optionaler Toleranzrand (*senstol*) vergroessert die
;;;     Box, damit Sensoren knapp am Rand noch erfasst werden.
;;;
;;; Zusaetzlich:
;;;   - Bei zugeordneten Sensoren wird die Bezeichnung des ILS-Blocks
;;;     (Attribut "Bezeichnung", Fallback Blockname) in das Sensor-
;;;     Attribut *zuordnung-tag* geschrieben.
;;;   - Nicht zugeordnete Sensoren werden mit einem Kreis auf dem
;;;     Layer *mark-layer* markiert (zentriert auf den Sensor).
;;;   - Der Befehl ist wiederholbar: alte Markierungskreise werden
;;;     zu Beginn entfernt.
;;;
;;; Aufruf:  ZAEHLE_SEP_SCAN
;;; Laden:   per APPLOAD oder (load "count_sep_scan")
;;; ============================================================

(vl-load-com)

;;; ------------------------------------------------------------
;;; KONFIGURATION (bei Bedarf anpassen)
;;; ------------------------------------------------------------

;; Toleranzrand um die ILS-Block-Box in Zeichnungseinheiten (mm).
;; 0.0 = exakte Box. Groesserer Wert = Sensoren knapp ausserhalb
;; werden noch dem ILS-Block zugerechnet.
(if (null *senstol*) (setq *senstol* 0.0))

;; Blockname-Muster (wcmatch, Grossschreibung) fuer die manuell
;; platzierten Sensoren.
(setq *scanner-pattern*   "SCANNER,SCANNER_*")
(setq *separator-pattern* "SEPARATOR_SP,SEPARATOR_SP_*")

;; Blockname-Muster fuer die INTERN im ILS-Block (in der Kette)
;; gezeichneten Separatoren. Diese bilden die Basis fuer
;; ANZAHL_SEPARATOR und werden bei jedem Lauf frisch gezaehlt.
(setq *intern-separator-pattern* "STAUSTRECKE_SEPARATOR_SP*")

;; Attribut-Tag im Scanner-/Separator-Block, in das die Bezeichnung
;; des zugeordneten ILS-Blocks geschrieben wird (Gross/Klein egal).
(setq *zuordnung-tag* "zuordnung")

;; Markierung nicht zugeordneter Sensoren: Kreis auf eigenem Layer.
(setq *mark-layer* "S_SENSOR_UNZUGEORDNET")
(setq *mark-color* 2)  ;; 2 = Gelb
;; Kreisradius = Faktor * halbe XY-Diagonale der Sensor-Box,
;; mindestens *mark-radius-min* (mm).
(if (null *mark-radius-factor*) (setq *mark-radius-factor* 1.5))
(if (null *mark-radius-min*)    (setq *mark-radius-min* 500.0))

;;; ------------------------------------------------------------
;;; ILS-Block-Erkennung und zugehoerige Attribut-Tags
;;;   Alle ILS-Bloecke (Kreisel / VF / GF) verwenden einheitlich
;;;   ANZAHL_SCANNER und ANZAHL_SEPARATOR.
;;;   Rueckgabe: (scanner-tag  separator-tag)  oder nil
;;; ------------------------------------------------------------
(defun cs-carrier-tags (nm / up)
  (setq up (strcase nm))
  (if (or (wcmatch up "KREISEL_*")
          (wcmatch up "VF_*")
          (wcmatch up "GF_*"))
    (list "ANZAHL_SCANNER" "ANZAHL_SEPARATOR")
    nil
  )
)

;;; ------------------------------------------------------------
;;; Sensor-Erkennung
;;;   Rueckgabe: 'scanner | 'separator | nil
;;; ------------------------------------------------------------
(defun cs-sensor-kind (nm / up)
  (setq up (strcase nm))
  (cond
    ((wcmatch up *scanner-pattern*)   'scanner)
    ((wcmatch up *separator-pattern*) 'separator)
    (t nil)
  )
)

;;; ------------------------------------------------------------
;;; Punkt-Rueckgabe von vla-getboundingbox in eine Liste wandeln.
;;;   BricsCAD liefert ein Safearray, AutoCAD ein Variant mit
;;;   Safearray - beide Faelle werden hier abgedeckt.
;;; ------------------------------------------------------------
(defun cs-pt->list (v)
  (cond
    ((= (type v) 'variant)   (vlax-safearray->list (vlax-variant-value v)))
    ((= (type v) 'safearray) (vlax-safearray->list v))
    ((listp v)               v)
    (t                       nil)
  )
)

;;; ------------------------------------------------------------
;;; Bounding-Box eines INSERT holen (WCS, achsparallel).
;;;   Erzwingt vorher ein vla-update (Regen des Objekts), da
;;;   vla-getboundingbox sonst auf nicht-regenerierten oder auf
;;;   eingefrorenen Layern liegenden Bloecken scheitert.
;;;   Rueckgabe: (minx miny maxx maxy)  oder nil bei Fehler.
;;;   *cs-last-error* enthaelt bei Fehler den echten COM-Fehlertext.
;;; ------------------------------------------------------------
(defun cs-bbox (ent / obj res)
  (setq *cs-last-error* nil)
  (setq obj (vlax-ename->vla-object ent))
  ;; Objekt regenerieren (Fehler ignorieren)
  (vl-catch-all-apply 'vla-update (list obj))
  (setq res
    (vl-catch-all-apply
      '(lambda ( / ll ur)
         (vla-getboundingbox obj 'll 'ur)
         (list (cs-pt->list ll) (cs-pt->list ur)))))
  (if (vl-catch-all-error-p res)
    (progn
      (setq *cs-last-error* (vl-catch-all-error-message res))
      nil)
    (list (car  (car res)) (cadr (car res))    ;; minx miny
          (car  (cadr res)) (cadr (cadr res))) ;; maxx maxy
  )
)

;;; ------------------------------------------------------------
;;; Referenzpunkt eines Sensors (X/Y), je nach Typ:
;;;   - Scanner   : Einfuegepunkt (DXF-Gruppe 10).
;;;   - Separator : geometrischer Mittelpunkt seiner eigenen
;;;                 Bounding-Box (unabhaengig vom $INSBASE),
;;;                 Fallback auf den Einfuegepunkt.
;;; ------------------------------------------------------------
(defun cs-sensor-point (ent ed kind / bb)
  (if (eq kind 'scanner)
    (cdr (assoc 10 ed))
    (progn
      (setq bb (cs-bbox ent))
      (if bb
        (list (/ (+ (nth 0 bb) (nth 2 bb)) 2.0)
              (/ (+ (nth 1 bb) (nth 3 bb)) 2.0))
        (cdr (assoc 10 ed))
      )
    )
  )
)

;;; ------------------------------------------------------------
;;; Liegt Punkt pt (X/Y) in ILS-Block-Record rec (mit Toleranz)?
;;;   rec = (ename tagScan tagSep minx miny maxx maxy cx cy)
;;; ------------------------------------------------------------
(defun cs-in-box (pt rec / x y)
  (setq x (car pt) y (cadr pt))
  (and (>= x (- (nth 3 rec) *senstol*))
       (<= x (+ (nth 5 rec) *senstol*))
       (>= y (- (nth 4 rec) *senstol*))
       (<= y (+ (nth 6 rec) *senstol*)))
)

;;; ------------------------------------------------------------
;;; Sensor-Punkt einem ILS-Block zuordnen.
;;;   Rueckgabe: ILS-Block-Record oder nil (keine Zuordnung).
;;;   Bei mehreren Treffern: naechstes Box-Zentrum (X/Y).
;;; ------------------------------------------------------------
(defun cs-assign (pt carriers / matches best bestd d)
  (setq matches nil)
  (foreach rec carriers
    (if (cs-in-box pt rec) (setq matches (cons rec matches))))
  (cond
    ((null matches) nil)
    ((= (length matches) 1) (car matches))
    (t
      (setq best nil bestd nil)
      (foreach rec matches
        (setq d (distance (list (car pt) (cadr pt))
                          (list (nth 7 rec) (nth 8 rec))))
        (if (or (null bestd) (< d bestd))
          (setq bestd d  best rec)))
      best)
  )
)

;;; ------------------------------------------------------------
;;; Zaehler in einer Assoc-Liste (Schluessel = ename) erhoehen.
;;; ------------------------------------------------------------
(defun cs-bump (alist key / pair)
  (setq pair (assoc key alist))
  (if pair
    (subst (cons key (1+ (cdr pair))) pair alist)
    (cons (cons key 1) alist))
)

;;; ------------------------------------------------------------
;;; Attributwert an einem INSERT setzen (Tag ohne Gross/Klein).
;;;   Rueckgabe: T wenn Tag gefunden und gesetzt, sonst nil.
;;; ------------------------------------------------------------
(defun cs-set-att (ins tag val / e ed done ok)
  (setq done nil ok nil)
  ;; Nur iterieren, wenn der INSERT ueberhaupt Attribute fuehrt (66=1),
  ;; sonst wuerde entnext in fremde Objekte weiterlaufen.
  (if (= (cdr (assoc 66 (entget ins))) 1)
    (progn
      (setq e (entnext ins))
      (while (and e (not done))
        (setq ed (entget e))
        (cond
          ((= (cdr (assoc 0 ed)) "ATTRIB")
            (if (= (strcase (cdr (assoc 2 ed))) (strcase tag))
              (progn
                (entmod (subst (cons 1 val) (assoc 1 ed) ed))
                (entupd e)
                (setq ok t))))
          ((= (cdr (assoc 0 ed)) "SEQEND") (setq done t))
        )
        (setq e (entnext e))
      )
    )
  )
  ok
)

;;; ------------------------------------------------------------
;;; Zaehlt rekursiv, wie oft ein Block (Muster pat) in der
;;; Definition des Blocks bname verwendet wird - inklusive
;;; verschachtelter Unterbloecke. Damit wird die interne Anzahl
;;; der Kette-Separatoren aus der Geometrie ermittelt.
;;; ------------------------------------------------------------
(defun cs-count-nested (bname pat / e ed nm n stop)
  (setq n 0 stop nil)
  (setq e (tblobjname "BLOCK" bname))
  (if e
    (progn
      (setq e (entnext e))
      (while (and e (not stop))
        (setq ed (entget e))
        (cond
          ((= (cdr (assoc 0 ed)) "ENDBLK") (setq stop t))
          ((= (cdr (assoc 0 ed)) "INSERT")
            (setq nm (cdr (assoc 2 ed)))
            (if (wcmatch (strcase nm) pat)
              (setq n (1+ n))
              (setq n (+ n (cs-count-nested nm pat)))))
        )
        (if (not stop) (setq e (entnext e)))
      )
    )
  )
  n
)

;;; ------------------------------------------------------------
;;; Attributwert (String) an einem INSERT lesen. "" wenn nicht
;;; vorhanden. Tag ohne Gross/Klein-Unterscheidung.
;;; ------------------------------------------------------------
(defun cs-get-att-str (ins tag / e ed done val)
  (setq done nil val "")
  (if (= (cdr (assoc 66 (entget ins))) 1)
    (progn
      (setq e (entnext ins))
      (while (and e (not done))
        (setq ed (entget e))
        (cond
          ((= (cdr (assoc 0 ed)) "ATTRIB")
            (if (= (strcase (cdr (assoc 2 ed))) (strcase tag))
              (progn (setq val (cdr (assoc 1 ed))) (setq done t))))
          ((= (cdr (assoc 0 ed)) "SEQEND") (setq done t))
        )
        (setq e (entnext e))
      )
    )
  )
  val
)

;;; ------------------------------------------------------------
;;; Bezeichnung eines ILS-Blocks ermitteln: Attribut "Bezeichnung",
;;; Fallback auf den Blocknamen.
;;; ------------------------------------------------------------
(defun cs-carrier-label (ent nm / bez)
  (setq bez (cs-get-att-str ent "Bezeichnung"))
  (if (and bez (/= bez "")) bez nm)
)

;;; ------------------------------------------------------------
;;; Layer anlegen (falls fehlend), ohne den aktuellen Layer zu aendern.
;;; ------------------------------------------------------------
(defun cs-ensure-layer (name color / lay ed)
  (if (tblsearch "LAYER" name)
    ;; Layer existiert bereits: Standardfarbe angleichen
    (progn
      (setq lay (tblobjname "LAYER" name))
      (setq ed  (entget lay))
      (if (assoc 62 ed)
        (entmod (subst (cons 62 color) (assoc 62 ed) ed)))
    )
    ;; Layer neu anlegen
    (entmake (list '(0 . "LAYER")
                   '(100 . "AcDbSymbolTableRecord")
                   '(100 . "AcDbLayerTableRecord")
                   (cons 2 name)
                   (cons 70 0)
                   (cons 62 color)
                   (cons 6 "Continuous")))
  )
)

;;; ------------------------------------------------------------
;;; Nicht zugeordneten Sensor mit einem Kreis markieren, zentriert
;;; auf die Sensor-Geometrie. Radius aus der XY-Box des Sensors
;;; (Faktor), mindestens *mark-radius-min*.
;;; ------------------------------------------------------------
(defun cs-mark-unassigned (ent / bb ipt cx cy cz r)
  (setq bb  (cs-bbox ent))
  (setq ipt (cdr (assoc 10 (entget ent))))
  (setq cz  (if (and ipt (caddr ipt)) (caddr ipt) 0.0))
  (if bb
    (progn
      (setq cx (/ (+ (nth 0 bb) (nth 2 bb)) 2.0)
            cy (/ (+ (nth 1 bb) (nth 3 bb)) 2.0))
      (setq r (* *mark-radius-factor*
                 (/ (distance (list (nth 0 bb) (nth 1 bb))
                              (list (nth 2 bb) (nth 3 bb))) 2.0)))
      (if (< r *mark-radius-min*) (setq r *mark-radius-min*)))
    (progn
      (setq cx (car ipt) cy (cadr ipt) r *mark-radius-min*))
  )
  (cs-ensure-layer *mark-layer* *mark-color*)
  (entmake (list '(0 . "CIRCLE")
                 (cons 8 *mark-layer*)
                 (cons 10 (list cx cy cz))
                 (cons 40 r)))
)

;;; ============================================================
;;; HAUPTBEFEHL
;;; ============================================================
(defun c:ZAEHLE_SEP_SCAN ( / ss i ent ed nm tags bb cx cy label
                             carriers scanlist seplist kind pt
                             scanCounts sepCounts
                             rec en nm2 ns nsep internSep newS newP
                             s sent spt
                             n-scan-unassigned n-sep-unassigned
                             n-zuordnung-fehlt mss
                             okS okP)
  (setq carriers nil scanlist nil seplist nil n-zuordnung-fehlt 0)

  ;; Alte Markierungskreise entfernen (Idempotenz)
  (setq mss (ssget "_X" (list (cons 0 "CIRCLE") (cons 8 *mark-layer*))))
  (if mss (command "_.ERASE" mss ""))

  ;; Vor der Extents-Berechnung einmal regenerieren, damit
  ;; vla-getboundingbox verlaessliche Werte liefert.
  (vl-catch-all-apply '(lambda () (command "_.REGEN")))

  ;; --- 1. Alle INSERTs sammeln und klassifizieren ---
  (setq ss (ssget "_X" '((0 . "INSERT"))))
  (if (null ss)
    (progn (princ "\n>>> Keine Bloecke in der Zeichnung gefunden.") (princ))
    (progn
      (setq i 0)
      (while (< i (sslength ss))
        (setq ent (ssname ss i))
        (setq ed  (entget ent))
        (setq nm  (cdr (assoc 2 ed)))
        (setq tags (cs-carrier-tags nm))
        (cond
          ;; --- ILS-Block ---
          (tags
            (setq bb (cs-bbox ent))
            (if bb
              (progn
                (setq cx (/ (+ (nth 0 bb) (nth 2 bb)) 2.0))
                (setq cy (/ (+ (nth 1 bb) (nth 3 bb)) 2.0))
                (setq label (cs-carrier-label ent nm))
                (setq carriers
                  (cons (list ent (car tags) (cadr tags)
                              (nth 0 bb) (nth 1 bb) (nth 2 bb) (nth 3 bb)
                              cx cy label)
                        carriers)))
              (princ (strcat "\n! Bounding-Box fehlgeschlagen fuer ILS-Block '" nm "'"
                             (if *cs-last-error*
                               (strcat " (" *cs-last-error* ")") "")))
            )
          )
          ;; --- Sensor (Entity + Referenzpunkt merken) ---
          (t
            (setq kind (cs-sensor-kind nm))
            (if kind
              (progn
                (setq pt (cs-sensor-point ent ed kind))
                (if (eq kind 'scanner)
                  (setq scanlist (cons (list ent pt) scanlist))
                  (setq seplist  (cons (list ent pt) seplist)))))
          )
        )
        (setq i (1+ i))
      )

      ;; --- 2. Sensoren zuordnen: zuordnung schreiben bzw. markieren ---
      (setq scanCounts nil sepCounts nil
            n-scan-unassigned 0 n-sep-unassigned 0)

      (foreach s scanlist
        (setq sent (car s) spt (cadr s))
        (setq rec (cs-assign spt carriers))
        (if rec
          (progn
            (setq scanCounts (cs-bump scanCounts (car rec)))
            (if (not (cs-set-att sent *zuordnung-tag* (nth 9 rec)))
              (setq n-zuordnung-fehlt (1+ n-zuordnung-fehlt))))
          (progn
            (setq n-scan-unassigned (1+ n-scan-unassigned))
            (cs-set-att sent *zuordnung-tag* "")
            (cs-mark-unassigned sent))))

      (foreach s seplist
        (setq sent (car s) spt (cadr s))
        (setq rec (cs-assign spt carriers))
        (if rec
          (progn
            (setq sepCounts (cs-bump sepCounts (car rec)))
            (if (not (cs-set-att sent *zuordnung-tag* (nth 9 rec)))
              (setq n-zuordnung-fehlt (1+ n-zuordnung-fehlt))))
          (progn
            (setq n-sep-unassigned (1+ n-sep-unassigned))
            (cs-set-att sent *zuordnung-tag* "")
            (cs-mark-unassigned sent))))

      ;; --- 3. ANZAHL-Attribute setzen und Bericht ausgeben ---
      (princ "\n============================================")
      (princ "\n  Sensor-Zaehlung je ILS-Block")
      (princ "\n============================================")
      (if (null carriers)
        (princ "\n  (Keine ILS-Bloecke KREISEL_/VF_/GF_ gefunden)")
        (foreach rec carriers
          (setq en   (car rec))
          (setq nm2  (cdr (assoc 2 (entget en))))
          (setq ns   (cond ((assoc en scanCounts) (cdr (assoc en scanCounts))) (t 0)))
          (setq nsep (cond ((assoc en sepCounts)  (cdr (assoc en sepCounts)))  (t 0)))
          ;; interne Kette-Separatoren frisch aus der Blockdefinition zaehlen
          (setq internSep (cs-count-nested nm2 *intern-separator-pattern*))
          ;; Scanner  = nur neu zugeordnete
          ;; Separator = interne Kette-Separatoren + neu zugeordnete
          (setq newS ns)
          (setq newP (+ internSep nsep))
          ;; gefundene Anzahlen melden (mit Bezeichnung/Label)
          (princ (strcat "\n  " nm2 " [" (nth 9 rec) "]"
                         ": Scanner(neu)=" (itoa ns)
                         ", Separator intern=" (itoa internSep)
                         " + manuell=" (itoa nsep)))
          ;; Werte schreiben und Ergebnis bestaetigen
          (setq okS (cs-set-att en (nth 1 rec) (itoa newS)))
          (setq okP (cs-set-att en (nth 2 rec) (itoa newP)))
          (if (and okS okP)
            (princ (strcat "\n     -> geschrieben: "
                           "ANZAHL_SCANNER=" (itoa newS)
                           ", ANZAHL_SEPARATOR=" (itoa newP)))
            (princ (strcat "\n     -> FEHLER beim Schreiben: "
                           (if okS "" "ANZAHL_SCANNER fehlt  ")
                           (if okP "" "ANZAHL_SEPARATOR fehlt"))))
        )
      )
      (princ (strcat "\n--------------------------------------------"
                     "\n  ILS-Bloecke gesamt: " (itoa (length carriers))
                     "\n  Scanner gesamt:     " (itoa (length scanlist))
                     " (nicht zugeordnet: " (itoa n-scan-unassigned) ")"
                     "\n  Separator gesamt:   " (itoa (length seplist))
                     " (nicht zugeordnet: " (itoa n-sep-unassigned) ")"))
      (if (> (+ n-scan-unassigned n-sep-unassigned) 0)
        (princ (strcat "\n  " (itoa (+ n-scan-unassigned n-sep-unassigned))
                       " nicht zugeordnete(r) Sensor(en) mit Kreis markiert"
                       " (Layer '" *mark-layer* "').")))
      (if (> n-zuordnung-fehlt 0)
        (princ (strcat "\n  WARNUNG: " (itoa n-zuordnung-fehlt)
                       " zugeordnete(r) Sensor(en) ohne Attribut '"
                       *zuordnung-tag* "' - Bezeichnung nicht schreibbar.")))

      ;; --- 4. Zeichnung speichern ---
      (princ "\n--------------------------------------------")
      (princ "\n  Speichere Zeichnung (QSAVE) ...")
      (command "_.QSAVE")
      (princ "\n>>> Fertig.")
      (princ)
    )
  )
  (princ)
)

(princ "\n>>> count_sep_scan.lsp geladen. Befehl: ZAEHLE_SEP_SCAN")
(princ)