diff --git a/Lisp/count_sep_scan.lsp b/Lisp/count_sep_scan.lsp new file mode 100644 index 0000000..c5acbc0 --- /dev/null +++ b/Lisp/count_sep_scan.lsp @@ -0,0 +1,356 @@ +;;; ============================================================ +;;; 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) diff --git a/data/ils/3D/Separator_SP.dwg b/data/ils/3D/Separator_SP.dwg new file mode 100644 index 0000000..1885a22 Binary files /dev/null and b/data/ils/3D/Separator_SP.dwg differ