ZAEHLE_SEP_SCAN schreibt ILS-Bezeichnung in Sensor-Attribut zuordnung und markiert nicht zugeordnete Sensoren mit Gelb Kreis

Lisp/count_sep_scan.lsp

@@ -19,6 +19,15 @@
 ;;;   - 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")
 ;;; ============================================================
@@ -44,6 +53,18 @@
 ;; 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
@@ -185,19 +206,26 @@
 ;;;   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)
+  (setq done nil ok nil)
-  (while (and e (not done))
+  ;; Nur iterieren, wenn der INSERT ueberhaupt Attribute fuehrt (66=1),
-    (setq ed (entget e))
+  ;; sonst wuerde entnext in fremde Objekte weiterlaufen.
-    (cond
+  (if (= (cdr (assoc 66 (entget ins))) 1)
-      ((= (cdr (assoc 0 ed)) "ATTRIB")
+    (progn
-        (if (= (strcase (cdr (assoc 2 ed))) (strcase tag))
+      (setq e (entnext ins))
-          (progn
+      (while (and e (not done))
-            (entmod (subst (cons 1 val) (assoc 1 ed) ed))
+        (setq ed (entget e))
-            (entupd e)
+        (cond
-            (setq ok t))))
+          ((= (cdr (assoc 0 ed)) "ATTRIB")
-      ((= (cdr (assoc 0 ed)) "SEQEND") (setq done t))
+            (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))
+      )
     )
-    (setq e (entnext e))
   )
   ok
 )
@@ -231,16 +259,105 @@
   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
+(defun c:ZAEHLE_SEP_SCAN ( / ss i ent ed nm tags bb cx cy label
-                             carriers scanpts seppts kind pt
+                             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 scanpts nil seppts nil)
+  (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.
@@ -265,47 +382,62 @@
               (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)
+                              cx cy label)
                         carriers)))
               (princ (strcat "\n! Bounding-Box fehlgeschlagen fuer ILS-Block '" nm "'"
                              (if *cs-last-error*
                                (strcat " (" *cs-last-error* ")") "")))
             )
           )
-          ;; --- Sensor ---
+          ;; --- 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 scanpts (cons pt scanpts))
+                  (setq scanlist (cons (list ent pt) scanlist))
-                  (setq seppts  (cons pt seppts)))))
+                  (setq seplist  (cons (list ent pt) seplist)))))
           )
         )
         (setq i (1+ i))
       )
 
-      ;; --- 2. Sensoren den ILS-Bloecken zuordnen ---
+      ;; --- 2. Sensoren zuordnen: zuordnung schreiben bzw. markieren ---
       (setq scanCounts nil sepCounts nil
             n-scan-unassigned 0 n-sep-unassigned 0)
 
-      (foreach pt scanpts
+      (foreach s scanlist
-        (setq rec (cs-assign pt carriers))
+        (setq sent (car s) spt (cadr s))
+        (setq rec (cs-assign spt carriers))
         (if rec
-          (setq scanCounts (cs-bump scanCounts (car rec)))
+          (progn
-          (setq n-scan-unassigned (1+ n-scan-unassigned))))
+            (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 pt seppts
+      (foreach s seplist
-        (setq rec (cs-assign pt carriers))
+        (setq sent (car s) spt (cadr s))
+        (setq rec (cs-assign spt carriers))
         (if rec
-          (setq sepCounts (cs-bump sepCounts (car rec)))
+          (progn
-          (setq n-sep-unassigned (1+ n-sep-unassigned))))
+            (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. Attribute setzen und Bericht ausgeben ---
+      ;; --- 3. ANZAHL-Attribute setzen und Bericht ausgeben ---
       (princ "\n============================================")
       (princ "\n  Sensor-Zaehlung je ILS-Block")
       (princ "\n============================================")
@@ -322,8 +454,8 @@
           ;; Separator = interne Kette-Separatoren + neu zugeordnete
           (setq newS ns)
           (setq newP (+ internSep nsep))
-          ;; gefundene Anzahlen melden
+          ;; gefundene Anzahlen melden (mit Bezeichnung/Label)
-          (princ (strcat "\n  " nm2
+          (princ (strcat "\n  " nm2 " [" (nth 9 rec) "]"
                          ": Scanner(neu)=" (itoa ns)
                          ", Separator intern=" (itoa internSep)
                          " + manuell=" (itoa nsep)))
@@ -341,14 +473,18 @@
       )
       (princ (strcat "\n--------------------------------------------"
                      "\n  ILS-Bloecke gesamt: " (itoa (length carriers))
-                     "\n  Scanner gesamt:     " (itoa (length scanpts))
+                     "\n  Scanner gesamt:     " (itoa (length scanlist))
                      " (nicht zugeordnet: " (itoa n-scan-unassigned) ")"
-                     "\n  Separator gesamt:   " (itoa (length seppts))
+                     "\n  Separator gesamt:   " (itoa (length seplist))
                      " (nicht zugeordnet: " (itoa n-sep-unassigned) ")"))
-      (if (or (> n-scan-unassigned 0) (> n-sep-unassigned 0))
+      (if (> (+ n-scan-unassigned n-sep-unassigned) 0)
-        (princ (strcat "\n  Hinweis: Nicht zugeordnete Sensoren liegen"
+        (princ (strcat "\n  " (itoa (+ n-scan-unassigned n-sep-unassigned))
-                       "\n  ausserhalb aller ILS-Block-Boxen. Ggf. *senstol*"
+                       " nicht zugeordnete(r) Sensor(en) mit Kreis markiert"
-                       "\n  erhoehen oder Platzierung pruefen.")))
+                       " (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--------------------------------------------")