Schoenenberger_Systeme_GmbH/dxfmakros
7
0
Fork 0
Code Issues 1 Pull Requests Actions Packages Projects Releases Wiki Activity

feat: HOEHEN_CHECK Phase 3 (Buehnen-Familien), Menueeintrag und Rueckfrage vor EXPORTSIVAS

Browse Source 
Co-Authored-By: Claude Sonnet 5.5 <noreply@anthropic.com>
This commit is contained in:
Yuelin Wang
2026-10-26 10:50:34 +01:00
parent 2befdf2c33
commit f9eb41cdcc
10 changed files with 418 additions and 21 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Lisp/check_hoehen.lsp
+304 -19
View File
@@ -16,10 +16,12 @@
;;; - ENTER -> Markierungskreis (Layer *ch-mark-layer*),
;;; Block spaeter manuell anpassen.
;;;
;;; Phase 3 - Buehne: liegt die rohe Montagehoehe ueber
;;; *ch-buehne-schwelle-m* (Default 2,0 m), wird pro Block gefragt,
;;; ob eine Buehne vorhanden ist; deren Hoehe wird abgezogen
;;; (MONTAGEHOEHE_m = roh - Buehne).
;;; Phase 3 - Buehne nach Kreisel-Familien (siehe Abschnitt PHASE 3):
;;; liegt eine Familie ueber *ch-buehne-schwelle-m* (Default 3,0 m), wird
;;; EINMAL pro Familie gefragt; die Buehnenhoehe wird von den Kreiseln und
;;; den zugehoerigen VF/GF abgezogen (MONTAGEHOEHE_m = roh - Buehne).
;;; Bloecke, die keiner Familie zuzuordnen sind, werden wie frueher
;;; einzeln gefragt (ch-write-montage).
;;;
;;; PHASE 1-3 bewusst OHNE: QSAVE (Testmodus, UNDO moeglich).
;;;
@@ -42,7 +44,19 @@
;; Schwelle (m): ab dieser Montagehoehe wird pro Block nach einer
;; Buehne gefragt (typische Anlagenhoehe ~2 m; darueber liegt die
;; Anlage vermutlich auf einer Buehne).
(if (null *ch-buehne-schwelle-m*) (setq *ch-buehne-schwelle-m* 2.0))
(if (null *ch-buehne-schwelle-m*) (setq *ch-buehne-schwelle-m* 3.0))
;; Phase 3 (Familien): maximaler Hoehenunterschied zweier Kreisel-Familien (mm),
;; zwischen denen eine Strecke denselben Buehnenabzug bekommt, und
;; Zuordnungstoleranzen Strecken-Ende -> Kreisel (XY-Abstand zur Kreiselachse
;; ueber den Radradius hinaus, Hoehenabweichung in mm).
(if (null *ch-fam-max-hoehendiff-mm*) (setq *ch-fam-max-hoehendiff-mm* 1500.0))
(if (null *ch-zuordnung-xy-mm*) (setq *ch-zuordnung-xy-mm* 300.0))
(if (null *ch-zuordnung-z-mm*) (setq *ch-zuordnung-z-mm* 100.0))
;; Register der in Phase 1/2 geschriebenen Bloecke fuer Phase 3:
;; je Block (ent art lbl roh pein paus erledigt).
(setq *ch-rec* nil)
;;; ------------------------------------------------------------
;;; vf_core-KS-Helfer sicherstellen (extract-ks-from-block-raw).
@@ -127,12 +141,19 @@
(if entry (caddr (car entry)) nil)
)
;;; Ganzer KS-Ursprung (x y z) oder nil.
(defun ch-ks-pt (ksdata ksname / entry)
(setq entry (cadr (assoc ksname ksdata)))
(if entry (car entry) nil)
)
;;; ------------------------------------------------------------
;;; KS_EIN.Z / KS_AUS.Z eines Composite-Blocks (VF_n/GF_n) messen.
;;; Rueckgabe: (kez kaz) - fehlende Werte = nil.
;;; Rueckgabe: (kez kaz pein paus) - fehlende Werte = nil. pein/paus sind
;;; die ganzen KS-Ursprungspunkte (fuer die Kreisel-Zuordnung in Phase 3).
;;; ------------------------------------------------------------
(defun ch-measure-vfgf (ename / obj subs nm ksdata kez kaz)
(setq kez nil kaz nil)
(defun ch-measure-vfgf (ename / obj subs nm ksdata kez kaz pein paus)
(setq kez nil kaz nil pein nil paus nil)
(setq obj (vlax-ename->vla-object ename))
(setq subs (vl-catch-all-apply 'vlax-invoke (list obj 'Explode)))
(if (and (not (vl-catch-all-error-p subs)) subs)
@@ -145,10 +166,12 @@
(cond
((and (null kez) (wcmatch nm *ch-as-pattern*))
(setq ksdata (extract-ks-from-block-raw sub))
(setq kez (ch-ks-z ksdata "KS_EIN")))
(setq kez (ch-ks-z ksdata "KS_EIN")
pein (ch-ks-pt ksdata "KS_EIN")))
((and (null kaz) (wcmatch nm *ch-es-pattern*))
(setq ksdata (extract-ks-from-block-raw sub))
(setq kaz (ch-ks-z ksdata "KS_AUS")))
(setq kaz (ch-ks-z ksdata "KS_AUS")
paus (ch-ks-pt ksdata "KS_AUS")))
)
)
)
@@ -158,7 +181,7 @@
(vl-catch-all-apply 'vla-Delete (list sub))))
)
)
(list kez kaz)
(list kez kaz pein paus)
)
;;; ------------------------------------------------------------
@@ -278,7 +301,264 @@
)
;;; ============================================================
;;; HAUPTBEFEHL (Phase 1 + 2)
;;; PHASE 3 - Buehnen-Familien
;;; ------------------------------------------------------------
;;; Kreisel, die sich beruehren (Rad/Rad, Rad/Laufprofil, gleiche Hoehe -
;;; KREISEL_WEICHEN-Kern kreisel-bp-*), haben zwingend dieselbe Hoehe und
;;; bilden eine FAMILIE. Pro Familie ueber der Schwelle wird EINMAL nach
;;; der Buehne gefragt; deren Hoehe wird von den Kreiseln der Familie und
;;; von allen VF/GF abgezogen, deren beide Enden in dieser Familie liegen.
;;; Strecken zwischen zwei Familien bekommen den Abzug nur bei gleicher
;;; Buehnenhoehe UND hoechstens *ch-fam-max-hoehendiff-mm* Hoehenunterschied.
;;; Geschrieben wird nur MONTAGEHOEHE_m (aus der Rohhoehe, also wiederholbar);
;;; HOEHE/HOEHE_VON_mm bleiben, damit csv:hoehen-aktualisieren nichts zurueck-
;;; setzt.
;;; ============================================================
;;; Wurzel eines Knotens in der Eltern-Alist (Union-Find ohne Pfadkompression).
(defun ch-fam-wurzel (rep k / p)
(while (and (setq p (cdr (assoc k rep))) (/= p k))
(setq k p))
k
)
;;; Familien aus Knoten und Kanten (reiner Kern).
;;; knoten = ((schluessel idnum) ...), kanten = ((schluesselA schluesselB) ...)
;;; Rueckgabe: Liste von Familien (je Liste von Schluesseln). Mitglieder und
;;; Familien sind nach kleinster ID-Nummer geordnet (Gleichstand: Reihenfolge
;;; in knoten); unbekannte Schluessel in kanten werden uebergangen.
(defun ch-familien (knoten kanten / rep ra rb idx sortiert fams w)
(foreach k knoten (setq rep (cons (cons (car k) (car k)) rep)))
(foreach e kanten
(if (and (assoc (car e) rep) (assoc (cadr e) rep))
(progn
(setq ra (ch-fam-wurzel rep (car e))
rb (ch-fam-wurzel rep (cadr e)))
(if (/= ra rb)
(setq rep (subst (cons ra rb) (assoc ra rep) rep))))))
(setq idx 0)
(foreach k knoten
(setq sortiert (cons (list (cadr k) (car k) idx) sortiert)
idx (1+ idx)))
(setq sortiert (vl-sort sortiert 'ch-id<))
(foreach s sortiert
(setq w (ch-fam-wurzel rep (cadr s)))
(if (assoc w fams)
(setq fams (subst (append (assoc w fams) (list (cadr s))) (assoc w fams) fams))
(setq fams (append fams (list (list w (cadr s)))))))
(mapcar 'cdr fams)
)
;;; Abzugsregel fuer eine Strecke zwischen zwei VERSCHIEDENEN Familien
;;; (reiner Kern). b1/b2 = Buehnenhoehe der Familien in m (0 = keine),
;;; z1/z2 = Familienhoehen in mm, maxdiff = erlaubter Unterschied in mm.
;;; Rueckgabe (status . abzug_m): "kein" (beide ohne Buehne), "konflikt"
;;; (verschiedene Buehnenhoehen), "hoehe" (Familien zu weit auseinander),
;;; "abzug" (gleiche Buehne, abzug_m = b1).
(defun ch-kreuz-abzug (b1 b2 z1 z2 maxdiff)
(cond
((and (equal b1 0.0 1e-6) (equal b2 0.0 1e-6)) (cons "kein" 0.0))
((not (equal b1 b2 1e-6)) (cons "konflikt" 0.0))
((> (abs (- z1 z2)) maxdiff) (cons "hoehe" 0.0))
(t (cons "abzug" b1))
)
)
;;; Montagehoehe nach Buehnenabzug (reiner Kern). nil, wenn kein gueltiger
;;; Abzug moeglich ist (b <= 0 oder b >= roh).
(defun ch-abzug-anwenden (roh b)
(if (and (> b 0.0) (< b roh)) (- roh b))
)
;;; XY-Abstand eines Punktes von der Strecke a-b (reiner Kern).
(defun ch-pkt-strecke-abstand (pt a b / lot tt)
(setq lot (kreisel-bp-lot pt a b)
tt (max 0.0 (min 1.0 (car lot))))
(kreisel-bp-abst pt (kreisel-bp-plus a (kreisel-bp-mal (kreisel-bp-minus b a) tt)))
)
;;; Naechster Kreisel/Eckrad zu einem Strecken-Endpunkt (reiner Kern).
;;; pt = (x y [z]), z = Hoehe in mm, elemente = kreisel-bp-element-Records.
;;; Treffer: XY-Abstand zur Achse <= Radradius + tolxy und |z - Kreiselhoehe|
;;; <= tolz. Rueckgabe: Handle des naechsten Treffers oder nil.
(defun ch-kreisel-finden (pt z elemente tolxy tolz / best bd d ac)
(foreach e elemente
(if (<= (abs (- z (kreisel-bp-get "z" e))) tolz)
(progn
(setq ac (kreisel-bp-get "achse" e)
d (ch-pkt-strecke-abstand pt (car ac) (cadr ac)))
(if (and (<= d (+ (kreisel-bp-get "r" e) tolxy))
(or (null bd) (< d bd)))
(setq bd d best (kreisel-bp-get "handle" e))))))
best
)
;;; Abzugsregel fuer eine Strecke aus den Familiensaetzen ihrer beiden Enden
;;; (reiner Kern). fs/fe = (idx handles z b). Gleiche Familie -> ("innen" . b),
;;; sonst Ergebnis von ch-kreuz-abzug.
(defun ch-strecke-abzug (fs fe maxdiff)
(if (= (car fs) (car fe))
(cons "innen" (cadddr fs))
(ch-kreuz-abzug (cadddr fs) (cadddr fe) (caddr fs) (caddr fe) maxdiff))
)
;;; ID-Nummer eines Elements (999999 ohne gueltige ID).
(defun ch-id-nummer (id)
(if (and id (/= id "") (> (atoi id) 0)) (atoi id) 999999)
)
;;; Element-Record zu einem Handle.
(defun ch-elem-zu-handle (h elemente / res)
(foreach e elemente
(if (and (null res) (= (kreisel-bp-get "handle" e) h)) (setq res e)))
res
)
;;; Kreisel-Modul (kreisel-bp-*) sicherstellen.
(defun ch-ensure-kreisel ()
(if (null (car (atoms-family 1 '("KREISEL-BP-BERECHNEN"))))
(if (car (atoms-family 1 '("SSG-ENSURE")))
(vl-catch-all-apply '(lambda () (ssg-ensure "KreiselInsert")))))
(if (car (atoms-family 1 '("KREISEL-BP-BERECHNEN"))) t nil)
)
;;; Montage-Rohwert schreiben (ohne Rueckfrage) und fuer Phase 3 vormerken.
;;; pts = (pein paus) bei VF/GF, sonst nil. Rueckgabe: roh.
(defun ch-montage-roh (ent art raw lbl pts)
(ch-set-att ent "MONTAGEHOEHE_m" (rtos raw 2 3))
(setq *ch-rec* (append *ch-rec*
(list (list ent art lbl raw (car pts) (cadr pts)))))
raw
)
;;; Familie hervorheben (mode 3) bzw. zuruecknehmen (mode 4).
(defun ch-fam-hervorheben (handles mode / e)
(foreach h handles
(if (setq e (handent h)) (redraw e mode)))
)
;;; Buehnenhoehe (m) fuer eine Familie erfragen. nil = keine Buehne.
;;; z = Familienhoehe in mm, prev = zuletzt eingegebene Buehne (Vorgabe) oder nil.
(defun ch-frage-buehne (txt z prev / b ok)
(if (ssg-in-yesno txt nil)
(progn
(while (not ok)
(setq b (ssg-in-real (ssg-text "chh-buehne-hoehe") prev))
(cond
((null b) (setq ok T))
((and (> b 0.0) (< b (/ z 1000.0))) (setq ok T))
(t (princ (ssg-textf "chh-buehne-ungueltig" (list (rtos (/ z 1000.0) 2 3))))
(setq b nil))))
b))
)
;;; Phase 3 ausfuehren: arbeitet das Register *ch-rec* ab. Bloecke ohne
;;; Familie (Zuordnung unklar) fragen wie zuvor einzeln nach.
(defun ch-phase3 ( / elems ber knoten kanten fams famdat h2f n-fam n-bue
rep z b prev rec idx fs fe kr neu lbl h
n-kr n-innen n-kreuz n-konf n-offen ents)
(setq n-kr 0 n-innen 0 n-kreuz 0 n-konf 0 n-offen 0 n-fam 0 n-bue 0
ents nil)
(princ (ssg-text "chh-start"))
(if (ch-ensure-kreisel)
(progn
(setq elems (kreisel-bp-elemente-sammeln)
ber (car (kreisel-bp-berechnen elems (kreisel-bp-toleranz)
(kreisel-bp-toleranz-z))))
(setq knoten (mapcar '(lambda (el) (list (kreisel-bp-get "handle" el)
(ch-id-nummer (kreisel-bp-get "id" el))))
elems)
kanten (mapcar '(lambda (tr) (list (kreisel-bp-get "handle" (kreisel-bp-get "a" tr))
(kreisel-bp-get "handle" (kreisel-bp-get "b" tr))))
ber))
(setq fams (ch-familien knoten kanten))
;; --- je Familie einmal fragen ---
(setq idx 0)
(foreach fam fams
(setq idx (1+ idx) n-fam (1+ n-fam)
rep (ch-elem-zu-handle (car fam) elems)
z (kreisel-bp-get "z" rep)
b 0.0)
(if (> (/ z 1000.0) *ch-buehne-schwelle-m*)
(progn
(ch-fam-hervorheben fam 3)
(setq b (ch-frage-buehne
(ssg-textf "chh-fam-frage"
(list (itoa idx) (kreisel-bp-elem-text rep)
(itoa (length fam)) (rtos (/ z 1000.0) 2 3)))
z prev))
(ch-fam-hervorheben fam 4)
(if (null b) (setq b 0.0))
(if (> b 0.0) (setq prev b n-bue (1+ n-bue)))))
(setq famdat (cons (list idx fam z b) famdat))
(foreach h fam (setq h2f (cons (cons h idx) h2f))))
(setq famdat (reverse famdat))
;; --- Kreisel schreiben ---
(foreach rec *ch-rec*
(if (= (cadr rec) "KREISEL")
(progn
(setq h (cdr (assoc 5 (entget (car rec))))
fs (cdr (assoc h h2f)))
(if fs
(progn
(setq b (cadddr (assoc fs famdat)))
(if (> b 0.0)
(if (setq neu (ch-abzug-anwenden (nth 3 rec) b))
(progn (ch-set-att (car rec) "MONTAGEHOEHE_m" (rtos neu 2 3))
(setq n-kr (1+ n-kr)))))
(setq ents (cons (car rec) ents)))))))
;; --- Strecken zuordnen ---
(foreach rec *ch-rec*
(if (and (member (cadr rec) '("VF" "GF")) (nth 4 rec) (nth 5 rec))
(progn
(setq lbl (nth 2 rec)
fs (ch-kreisel-finden (nth 4 rec) (caddr (nth 4 rec)) elems
*ch-zuordnung-xy-mm* *ch-zuordnung-z-mm*)
fe (ch-kreisel-finden (nth 5 rec) (caddr (nth 5 rec)) elems
*ch-zuordnung-xy-mm* *ch-zuordnung-z-mm*))
(if (and fs fe)
(progn
(setq fs (assoc (cdr (assoc fs h2f)) famdat)
fe (assoc (cdr (assoc fe h2f)) famdat)
kr (ch-strecke-abzug fs fe *ch-fam-max-hoehendiff-mm*))
(setq ents (cons (car rec) ents))
(cond
((= (car kr) "konflikt")
(setq n-konf (1+ n-konf))
(princ (ssg-textf "chh-kreuz-konflikt"
(list lbl (rtos (cadddr fs) 2 3) (rtos (cadddr fe) 2 3)))))
((= (car kr) "hoehe")
(setq n-konf (1+ n-konf))
(princ (ssg-textf "chh-kreuz-hoehe"
(list lbl (rtos (abs (- (caddr fs) (caddr fe))) 2 0)
(rtos *ch-fam-max-hoehendiff-mm* 2 0)))))
((> (cdr kr) 0.0)
(if (setq neu (ch-abzug-anwenden (nth 3 rec) (cdr kr)))
(progn
(ch-set-att (car rec) "MONTAGEHOEHE_m" (rtos neu 2 3))
(if (= (car kr) "innen")
(setq n-innen (1+ n-innen))
(setq n-kreuz (1+ n-kreuz))))
(princ (ssg-textf "chh-strecke-neg"
(list lbl (rtos (cdr kr) 2 3) (rtos (nth 3 rec) 2 3))))))
)))))))
(princ (ssg-text "chh-kein-kreisel")))
;; --- Rest: blockweise wie bisher ---
(foreach rec *ch-rec*
(if (not (member (car rec) ents))
(progn
(setq n-offen (1+ n-offen))
(ch-write-montage (car rec) (nth 3 rec) (nth 2 rec)))))
(princ (ssg-textf "chh-summe"
(list (itoa n-fam) (itoa n-bue) (itoa n-kr) (itoa n-innen)
(itoa n-kreuz) (itoa n-konf) (itoa n-offen))))
)
;;; ============================================================
;;; HAUPTBEFEHL (Phase 1 + 2, danach Phase 3)
;;; ============================================================
(defun c:HOEHEN_CHECK ( / ss i idx id items it ent ed nm lbl zc meas kez kaz
montage inp delta mss
@@ -292,6 +572,7 @@
)
)
(setq n-kreisel 0 n-vf 0 n-gf 0 n-fixed 0 n-marked 0 n-fehler 0)
(setq *ch-rec* nil)
;; Alte Markierungskreise entfernen (Idempotenz)
(setq mss (ssget "_X" (list (cons 0 "CIRCLE") (cons 8 *ch-mark-layer*))))
@@ -348,7 +629,7 @@
(ch-move-z ent (- inp zc))
(setq zc inp)
(ch-set-att ent "HOEHE" (rtos zc 2 0))
(setq montage (ch-write-montage ent (/ zc 1000.0) lbl))
(setq montage (ch-montage-roh ent "KREISEL" (/ zc 1000.0) lbl nil))
(setq n-fixed (1+ n-fixed))
(princ (strcat "\n -> verschoben & gesetzt: HOEHE=" (rtos zc 2 0)
" -> MONTAGEHOEHE_m=" (rtos montage 2 3))))
@@ -362,7 +643,7 @@
;; --- gueltig ---
(progn
(ch-set-att ent "HOEHE" (rtos zc 2 0))
(setq montage (ch-write-montage ent (/ zc 1000.0) lbl))
(setq montage (ch-montage-roh ent "KREISEL" (/ zc 1000.0) lbl nil))
(princ (strcat "\n " lbl ": HOEHE=" (rtos zc 2 0)
" -> MONTAGEHOEHE_m=" (rtos montage 2 3))))
)
@@ -399,10 +680,11 @@
(progn
(ch-set-att ent "HOEHE_VON_mm" (rtos kez 2 0))
(ch-set-att ent "HOEHE_BIS_mm" (rtos kaz 2 0))
(setq montage (ch-write-montage ent
(setq montage (ch-montage-roh ent
(if (wcmatch nm "GF_*") "GF" "VF")
(if (wcmatch nm "GF_*")
(/ kez 1000.0)
(/ (+ kez kaz) 2000.0)) lbl))
(/ (+ kez kaz) 2000.0)) lbl (cddr meas)))
(setq n-fixed (1+ n-fixed))
(princ (strcat "\n -> verschoben & gesetzt: VON=" (rtos kez 2 0)
", BIS=" (rtos kaz 2 0)
@@ -420,10 +702,11 @@
(t
(ch-set-att ent "HOEHE_VON_mm" (rtos kez 2 0))
(ch-set-att ent "HOEHE_BIS_mm" (rtos kaz 2 0))
(setq montage (ch-write-montage ent
(setq montage (ch-montage-roh ent
(if (wcmatch nm "GF_*") "GF" "VF")
(if (wcmatch nm "GF_*")
(/ kez 1000.0)
(/ (+ kez kaz) 2000.0)) lbl))
(/ (+ kez kaz) 2000.0)) lbl (cddr meas)))
(princ (strcat "\n " lbl ": HOEHE_VON_mm=" (rtos kez 2 0)
", HOEHE_BIS_mm=" (rtos kaz 2 0)
" -> MONTAGEHOEHE_m=" (rtos montage 2 3))))
@@ -431,6 +714,8 @@
)
)
)
;; Phase 3: Buehnen-Familien (arbeitet das Register *ch-rec* ab)
(ch-phase3)
(princ (strcat "\n--------------------------------------------"
"\n Kreisel: " (itoa n-kreisel)
" VF: " (itoa n-vf)
@@ -449,4 +734,4 @@
)
(princ "\n>>> check_hoehen.lsp geladen (Phase 1-3). Befehl: HOEHEN_CHECK")
(princ)
(princ)
Lisp/export.lsp
+21
View File
@@ -2921,8 +2921,29 @@
)
;; Vor dem Sivas-Export anbieten, den Hoehen-Check (HOEHEN_CHECK, check_hoehen.lsp)
;; auszufuehren: Er setzt die Montagehoehen inkl. Buehnenabzug, den der Export
;; selbst nicht kennt. Bewusst eine Rueckfrage (Vorgabe Ja, Enter startet den
;; Check, "Nein" ueberspringt ihn) statt automatisch: der Check stellt Fragen
;; und wuerde Hand-Korrekturen von MONTAGEHOEHE_m bei jedem Export ueberschreiben. Entfaellt ohne GUI und bei abgeschaltetem
;; Schalter *csv-hoehencheck-fragen* (automatische Tests).
(if (null *csv-hoehencheck-fragen*) (setq *csv-hoehencheck-fragen* T))
(defun csv:hoehencheck-anbieten ()
(if (and *csv-hoehencheck-fragen*
(ssg-gui-p)
(car (atoms-family 1 '("SSG-IN-YESNO")))
(ssg-in-yesno (ssg-text "exp-hoehencheck-frage") T))
(progn
(ssg-ensure "check_hoehen")
(if (car (atoms-family 1 '("C:HOEHEN_CHECK")))
(c:HOEHEN_CHECK)
(princ (ssg-text "exp-hoehencheck-fehlt")))))
)
;; --- EXPORTSIVAS: Sivas-spezifischer CSV-Export mit Summierungszeilen ---
(defun c:EXPORTSIVAS ()
(csv:hoehencheck-anbieten)
(csv:run-export "EXPORTSIVAS"
(export:filename "sivas_script")
(export:filename "sivas_csv")