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

Co-Authored-By: Claude Sonnet 5.5 <noreply@anthropic.com>

Lisp/check_hoehen.lsp

@@ -16,10 +16,12 @@
 ;;;   - ENTER           -> Markierungskreis (Layer *ch-mark-layer*),
 ;;;                        Block spaeter manuell anpassen.
 ;;;
-;;; Phase 3 - Buehne: liegt die rohe Montagehoehe ueber
+;;; Phase 3 - Buehne nach Kreisel-Familien (siehe Abschnitt PHASE 3):
-;;;   *ch-buehne-schwelle-m* (Default 2,0 m), wird pro Block gefragt,
+;;;   liegt eine Familie ueber *ch-buehne-schwelle-m* (Default 3,0 m), wird
-;;;   ob eine Buehne vorhanden ist; deren Hoehe wird abgezogen
+;;;   EINMAL pro Familie gefragt; die Buehnenhoehe wird von den Kreiseln und
-;;;   (MONTAGEHOEHE_m = roh - Buehne).
+;;;   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)
+(defun ch-measure-vfgf (ename / obj subs nm ksdata kez kaz pein paus)
-  (setq kez nil kaz nil)
+  (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)

Lisp/export.lsp

@@ -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")

doc/kommandos.md

@@ -145,7 +145,7 @@ Gross-/Kleinschreibung spielt an der Kommandozeile keine Rolle.
 | `IDSCHECK` | Alle Bloecke auf doppelte IDs pruefen und korrigieren |
 | `IDGENERATE` | Gewaehltem Block eine neue ID zuweisen |
 | `ZAEHLE_SEP_SCAN` | Scanner/Separatoren je Kreisel/VF/GF zaehlen und in ANZAHL_SCANNER/ANZAHL_SEPARATOR schreiben (laeuft auch automatisch vor jedem Export) |
-| `HOEHEN_CHECK` | Hoehen von Kreiseln/VF/GF messen und in HOEHE/HOEHE_VON_mm/HOEHE_BIS_mm/MONTAGEHOEHE_m schreiben |
+| `HOEHEN_CHECK` | Hoehen von Kreiseln/VF/GF messen und in HOEHE/HOEHE_VON_mm/HOEHE_BIS_mm/MONTAGEHOEHE_m schreiben; Phase 3: Buehnenabzug einmal pro Kreisel-Familie (beruehrende Kreisel gleicher Hoehe), wirkt auf Kreisel und die VF/GF der Familie |
 | `CALLPYTHON` (`external_call.lsp`) | Test des LISP->Python-Aufrufs (`lib/testpycall.py`) |
 
 ### Konfiguration, Planquadrate, Doppelklick

lang/de_DE.json

@@ -722,6 +722,8 @@
     "plq-geloescht": "\n[DELETE_PLANQUADRATE] Planquadrat-Raster entfernt (%1 Einfuegung(en)).",
     "plq-nichts-zu-loeschen": "\n[DELETE_PLANQUADRATE] Kein Planquadrat-Raster in der Zeichnung vorhanden.",
     "exp-check-ids": "\n[%1] Pruefe und vergebe IDs...",
+    "exp-hoehencheck-frage": "\nVor dem Export den Hoehen-Check (Montagehoehe/Buehnen) ausfuehren?",
+    "exp-hoehencheck-fehlt": "\nHinweis: HOEHEN_CHECK nicht verfuegbar - Export laeuft ohne Hoehen-Check.",
     "exp-hoehen-aktualisiert": "\nHoehen-Attribute von %1 verschobenen Bloecken aus der Z-Koordinate neu gesetzt.",
     "exp-sep-proxy-fehler": "\n[EXPORT] WARNUNG: Kopie von '%1' aus Block '%2' fehlgeschlagen (%3) - dieses Element fehlt im Export.",
     "exp-sep-zuordnung": "\n[%1] verpackte Separator-Kopie(n): ZUORDNUNG aus der ID des Wrapper-Blocks gesetzt.",
@@ -1167,6 +1169,15 @@
     "kreisel-bp-zeile": "\n  Weiche %1: %2 <-> %3 [%4] bei X=%5 Y=%6 Z=%7",
     "kreisel-bp-kollision": "\n  KOLLISION %1: %2 <-> %3 [%4] bei X=%5 Y=%6 Z=%7",
     "kreisel-bp-marker": "\n%1 Marker gezeichnet (Layer %2).",
+    "chh-start": "\n--- Phase 3: Buehnen-Familien ---",
+    "chh-kein-kreisel": "\n  Hinweis: Kreisel-Modul nicht verfuegbar - nur blockweise Abfrage.",
+    "chh-fam-frage": "\n  Familie %1 (%2, %3 Kreisel, Montagehoehe %4 m): liegt auf einer Buehne?",
+    "chh-buehne-hoehe": "Buehnenhoehe in m",
+    "chh-buehne-ungueltig": "\n     ! Buehnenhoehe muss > 0 und < %1 m sein.",
+    "chh-kreuz-konflikt": "\n  ! %1: Enden in Familien mit verschiedener Buehnenhoehe (%2 / %3 m) - nicht geaendert.",
+    "chh-kreuz-hoehe": "\n  ! %1: Familienhoehen unterscheiden sich um %2 mm (> %3 mm) - nicht geaendert.",
+    "chh-strecke-neg": "\n  ! %1: Buehne %2 m >= Montagehoehe %3 m - nicht geaendert.",
+    "chh-summe": "\n  Phase 3: %1 Familie(n), %2 mit Buehne; angepasst: Kreisel %3, Strecken innerhalb %4, zwischen Familien %5; Konflikte %6; einzeln gefragt %7",
     "exp-kreisel-weichen": "\n[%1] Kreisel-Weichenpunkte: %2 Beruehrung(en), %3 Kollision(en) -> %4",
     "exp-kreisel-kollision": "\n[%1] WARNUNG: %2 Kreisel-Kollision(en) - Befehl KREISEL_WEICHEN zeigt sie an.",
     "kf-fehler-daten-fehlt": "\nFEHLER: Kettenfoerderer-Daten nicht gefunden: %1",

lang/en_GB.json

@@ -722,6 +722,8 @@
     "plq-geloescht": "\n[DELETE_PLANQUADRATE] Planquadrat grid removed (%1 insertion(s)).",
     "plq-nichts-zu-loeschen": "\n[DELETE_PLANQUADRATE] No Planquadrat grid found in the drawing.",
     "exp-check-ids": "\n[%1] Checking and assigning IDs...",
+    "exp-hoehencheck-frage": "\nRun the height check (mounting height/platforms) before the export?",
+    "exp-hoehencheck-fehlt": "\nNote: HOEHEN_CHECK not available - export runs without height check.",
     "exp-hoehen-aktualisiert": "\nHeight attributes of %1 moved blocks reset from their Z coordinate.",
     "exp-sep-proxy-fehler": "\n[EXPORT] WARNING: copying '%1' out of block '%2' failed (%3) - this element is missing from the export.",
     "exp-sep-zuordnung": "\n[%1] packed separator copy/copies: ZUORDNUNG set from the wrapper block ID.",
@@ -1167,6 +1169,15 @@
     "kreisel-bp-zeile": "\n  Switch %1: %2 <-> %3 [%4] at X=%5 Y=%6 Z=%7",
     "kreisel-bp-kollision": "\n  COLLISION %1: %2 <-> %3 [%4] at X=%5 Y=%6 Z=%7",
     "kreisel-bp-marker": "\n%1 markers drawn (layer %2).",
+    "chh-start": "\n--- Phase 3: platform families ---",
+    "chh-kein-kreisel": "\n  Note: Kreisel module not available - per-block questions only.",
+    "chh-fam-frage": "\n  Family %1 (%2, %3 Kreisel, mounting height %4 m): is it on a platform?",
+    "chh-buehne-hoehe": "Platform height in m",
+    "chh-buehne-ungueltig": "\n     ! Platform height must be > 0 and < %1 m.",
+    "chh-kreuz-konflikt": "\n  ! %1: ends in families with different platform heights (%2 / %3 m) - unchanged.",
+    "chh-kreuz-hoehe": "\n  ! %1: family heights differ by %2 mm (> %3 mm) - unchanged.",
+    "chh-strecke-neg": "\n  ! %1: platform %2 m >= mounting height %3 m - unchanged.",
+    "chh-summe": "\n  Phase 3: %1 family(ies), %2 on a platform; adjusted: Kreisel %3, sections within family %4, between families %5; conflicts %6; asked individually %7",
     "exp-kreisel-weichen": "\n[%1] Kreisel switch points: %2 contact(s), %3 collision(s) -> %4",
     "exp-kreisel-kollision": "\n[%1] WARNING: %2 Kreisel collision(s) - command KREISEL_WEICHEN shows them.",
     "kf-fehler-daten-fehlt": "\nERROR: chain conveyor data not found: %1",

menu/SSG_LIB.mnl

@@ -156,6 +156,10 @@
     (ssg-ensure "VarioFoerderer")
     (ssg-ensure "EtageVarioFoerderer")
     (ssg-ensure "export")
+    ;; Hoehen-Check vorladen: EXPORTSIVAS bietet ihn per Rueckfrage an und ruft
+    ;; c:HOEHEN_CHECK im selben Lauf auf (ein Nachladen waere dort erst nach
+    ;; Rueckkehr zum Top-Level sichtbar).
+    (ssg-ensure "check_hoehen")
     (ssg-ensure "external_call")
     (ssg-ensure "OmniModulInsert")
     ;; Kettenfoerderer vorladen statt lazy: der erste Menueklick musste sonst

menu/SSG_LIB.mnu

@@ -150,6 +150,7 @@
 [Ausgang]^C^C(ssg-ensure "SSG_LIB_Commands") ILS_AUSGANG_INSERT
 [<-SPS Schliessen]^C^C
 [->Export]
+[Hoehen-Check (Montagehoehe/Buehne)]^C^C(ssg-ensure "check_hoehen") HOEHEN_CHECK
 [Export Sivas]^C^C(ssg-ensure "export") EXPORTSIVAS
 [<-Export CSV]^C^C(ssg-ensure "export") EXPORTCSV
 [->Konfiguration]

tests/test_export_all.lsp

@@ -183,6 +183,7 @@
     (if (findfile csv-pfad)   (vl-file-delete csv-pfad))
     (if (findfile sivas-pfad) (vl-file-delete sivas-pfad))
 
+    (setq *csv-hoehencheck-fragen* nil) ;; keine Rueckfrage im Testlauf
     (princ (strcat "\n[TEST_EXPORT_ALL] CSV-Export -> " csv-name))
     (c:EXPORTCSV)
     (setq csv-ok (export_all:wait-for-file csv-pfad 30.0))

tests/test_unit.lsp

@@ -2771,6 +2771,68 @@
 )
 
 
+;; ------------------------------------------------------------
+;; TESTS: check_hoehen.lsp - Phase 3 (Buehnen-Familien), reine Kerne
+;; ------------------------------------------------------------
+(defun tu-tests-hoehen-fam ( / _els)
+  (princ "\n[check_hoehen/Phase 3 Familien]")
+
+  ;; --- ch-familien: transitive Verbindung, Sortierung nach ID-Nummer ---
+  (tu-eq "ch-familien/einzeln-und-kette"
+    '(("b") ("c" "a" "d") ("e"))
+    (ch-familien '(("a" 3) ("b" 1) ("c" 2) ("d" 5) ("e" 4))
+                 '(("a" "c") ("c" "d") ("x" "a"))))
+  (tu-eq "ch-familien/kette-ueber-mittleren"
+    '(("a" "b" "c"))
+    (ch-familien '(("a" 1) ("b" 2) ("c" 3)) '(("a" "b") ("b" "c"))))
+  (tu-eq "ch-familien/ohne-kanten"
+    '(("a") ("b"))
+    (ch-familien '(("a" 1) ("b" 2)) nil))
+  (tu-eq "ch-familien/ring"
+    '(("a" "b" "c"))
+    (ch-familien '(("a" 1) ("b" 2) ("c" 3)) '(("a" "b") ("b" "c") ("c" "a"))))
+
+  ;; --- ch-kreuz-abzug ---
+  (tu-eq "ch-kreuz-abzug/kein"      '("kein" . 0.0)     (ch-kreuz-abzug 0.0 0.0 5000.0 5000.0 1500.0))
+  (tu-eq "ch-kreuz-abzug/konflikt"  '("konflikt" . 0.0) (ch-kreuz-abzug 1.5 0.0 5000.0 5000.0 1500.0))
+  (tu-eq "ch-kreuz-abzug/konflikt2" '("konflikt" . 0.0) (ch-kreuz-abzug 1.5 2.0 5000.0 5000.0 1500.0))
+  (tu-eq "ch-kreuz-abzug/hoehe"     '("hoehe" . 0.0)    (ch-kreuz-abzug 1.5 1.5 5000.0 6600.0 1500.0))
+  (tu-eq "ch-kreuz-abzug/grenze"    '("abzug" . 1.5)    (ch-kreuz-abzug 1.5 1.5 5000.0 6500.0 1500.0))
+  (tu-eq "ch-kreuz-abzug/abzug"     '("abzug" . 1.5)    (ch-kreuz-abzug 1.5 1.5 5000.0 5200.0 1500.0))
+
+  ;; --- ch-strecke-abzug (Familiensaetze: idx handles z b) ---
+  (tu-eq "ch-strecke-abzug/innen"
+    '("innen" . 1.5)
+    (ch-strecke-abzug '(1 ("a") 5000.0 1.5) '(1 ("a") 5000.0 1.5) 1500.0))
+  (tu-eq "ch-strecke-abzug/innen-ohne-buehne"
+    '("innen" . 0.0)
+    (ch-strecke-abzug '(1 ("a") 5000.0 0.0) '(1 ("a") 5000.0 0.0) 1500.0))
+  (tu-eq "ch-strecke-abzug/zwischen"
+    '("abzug" . 1.5)
+    (ch-strecke-abzug '(1 ("a") 5000.0 1.5) '(2 ("b") 5400.0 1.5) 1500.0))
+
+  ;; --- ch-abzug-anwenden ---
+  (tu-eqf "ch-abzug-anwenden/normal" 2.5 (ch-abzug-anwenden 3.5 1.0))
+  (tu-nil "ch-abzug-anwenden/gleich" (ch-abzug-anwenden 3.5 3.5))
+  (tu-nil "ch-abzug-anwenden/groesser" (ch-abzug-anwenden 3.5 4.0))
+  (tu-nil "ch-abzug-anwenden/null" (ch-abzug-anwenden 3.5 0.0))
+
+  ;; --- ch-kreisel-finden: Kreisel r=400, Achse (400,0)-(2400,0) bzw. (400,5000)-(2400,5000) ---
+  (setq _els (list (tu-bp-el "KREISEL" 0.0 0.0    5000.0 0.0 2000.0 "K1")
+                   (tu-bp-el "KREISEL" 0.0 5000.0 5000.0 0.0 2000.0 "K2")))
+  (tu-eq "ch-kreisel-finden/auf-achse"
+    "K1" (ch-kreisel-finden '(1000.0 100.0 5000.0) 5000.0 _els 300.0 100.0))
+  (tu-eq "ch-kreisel-finden/zweiter"
+    "K2" (ch-kreisel-finden '(1000.0 4900.0 5000.0) 5000.0 _els 300.0 100.0))
+  (tu-eq "ch-kreisel-finden/hinter-dem-rad"
+    "K1" (ch-kreisel-finden '(-200.0 0.0 5000.0) 5000.0 _els 300.0 100.0))
+  (tu-nil "ch-kreisel-finden/zu-weit"
+    (ch-kreisel-finden '(1000.0 1000.0 5000.0) 5000.0 _els 300.0 100.0))
+  (tu-nil "ch-kreisel-finden/falsche-hoehe"
+    (ch-kreisel-finden '(1000.0 0.0 5300.0) 5300.0 _els 300.0 100.0))
+)
+
+
 (defun c:TEST_UNIT ( / out-dir report)
   (tu-reset)
   (princ "\n================================================================")
@@ -2783,7 +2845,7 @@
                 "tu-tests-export" "tu-tests-hoehen" "tu-tests-gf" "tu-tests-omni" "tu-tests-kreisel" "tu-tests-kreisel-bp"
                 "tu-tests-sepliste" "tu-tests-json" "tu-tests-geruest"
                 "tu-tests-sepscan" "tu-tests-vfl-segs" "tu-tests-vfl-abbruch"
-                "tu-tests-werkzeuge" "tu-tests-kf")
+                "tu-tests-werkzeuge" "tu-tests-kf" "tu-tests-hoehen-fam")
     (tu-run-block fn))
 
   (princ "\n\n----------------------------------------------------------------")

tests/test_unit.scr

@@ -11,6 +11,7 @@
 (load (strcat (getenv "DXFM_LISP") "/GeruestInsert.lsp")  "GeruestInsert.lsp nicht gefunden")
 (load (strcat (getenv "DXFM_LISP") "/count_sep_scan.lsp") "count_sep_scan.lsp nicht gefunden")
 (load (strcat (getenv "DXFM_LISP") "/KettenFoerderer.lsp") "KettenFoerderer.lsp nicht gefunden")
+(load (strcat (getenv "DXFM_LISP") "/check_hoehen.lsp")   "check_hoehen.lsp nicht gefunden")
 (load (strcat (getenv "DXFMAKRO") "/tests/test_unit.lsp"))
 (c:TEST_UNIT)
 (command "_.QUIT")