366 lines
14 KiB
Common Lisp
366 lines
14 KiB
Common Lisp
;;; ============================================================
|
|
;;; 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.
|
|
;;;
|
|
;;; 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 (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 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 kind))
|
|
(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)
|