;;; ============================================================
;;; 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:
;;;   - Der geometrische Mittelpunkt (X/Y) des Sensors (Zentrum
;;;     seiner eigenen Bounding-Box, unabhaengig vom $INSBASE)
;;;     muss in der achsparallelen Bounding-Box des ILS-Blocks
;;;     liegen (Z wird ignoriert).
;;;   - 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.
;;;
;;; 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*")

;;; ------------------------------------------------------------
;;; 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: geometrischer Mittelpunkt seiner
;;; eigenen Bounding-Box (X/Y). Unabhaengig vom $INSBASE der
;;; Sensor-DWG. Fallback auf den Einfuegepunkt, falls die Box
;;; nicht ermittelbar ist.
;;; ------------------------------------------------------------
(defun cs-sensor-point (ent ed / bb)
  (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 e (entnext ins) done nil ok nil)
  (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
)

;;; ============================================================
;;; HAUPTBEFEHL
;;; ============================================================
(defun c:ZAEHLE_SEP_SCAN ( / ss i ent ed nm tags bb cx cy
                             carriers scanpts seppts kind pt
                             scanCounts sepCounts
                             rec en nm2 ns nsep internSep newS newP
                             n-scan-unassigned n-sep-unassigned
                             okS okP)
  (setq carriers nil scanpts nil seppts nil)

  ;; 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 carriers
                  (cons (list ent (car tags) (cadr tags)
                              (nth 0 bb) (nth 1 bb) (nth 2 bb) (nth 3 bb)
                              cx cy)
                        carriers)))
              (princ (strcat "\n! Bounding-Box fehlgeschlagen fuer ILS-Block '" nm "'"
                             (if *cs-last-error*
                               (strcat " (" *cs-last-error* ")") "")))
            )
          )
          ;; --- Sensor ---
          (t
            (setq kind (cs-sensor-kind nm))
            (if kind
              (progn
                (setq pt (cs-sensor-point ent ed))
                (if (eq kind 'scanner)
                  (setq scanpts (cons pt scanpts))
                  (setq seppts  (cons pt seppts)))))
          )
        )
        (setq i (1+ i))
      )

      ;; --- 2. Sensoren den ILS-Bloecken zuordnen ---
      (setq scanCounts nil sepCounts nil
            n-scan-unassigned 0 n-sep-unassigned 0)

      (foreach pt scanpts
        (setq rec (cs-assign pt carriers))
        (if rec
          (setq scanCounts (cs-bump scanCounts (car rec)))
          (setq n-scan-unassigned (1+ n-scan-unassigned))))

      (foreach pt seppts
        (setq rec (cs-assign pt carriers))
        (if rec
          (setq sepCounts (cs-bump sepCounts (car rec)))
          (setq n-sep-unassigned (1+ n-sep-unassigned))))

      ;; --- 3. 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
          (princ (strcat "\n  " nm2
                         ": 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 scanpts))
                     " (nicht zugeordnet: " (itoa n-scan-unassigned) ")"
                     "\n  Separator gesamt:   " (itoa (length seppts))
                     " (nicht zugeordnet: " (itoa n-sep-unassigned) ")"))
      (if (or (> n-scan-unassigned 0) (> n-sep-unassigned 0))
        (princ (strcat "\n  Hinweis: Nicht zugeordnete Sensoren liegen"
                       "\n  ausserhalb aller ILS-Block-Boxen. Ggf. *senstol*"
                       "\n  erhoehen oder Platzierung pruefen.")))

      ;; --- 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)