;;; ============================================================
;;; check_hoehen.lsp  -  Hoehen-Check (PHASE 1-3)
;;; ------------------------------------------------------------
;;; Phase 1 - messen & schreiben:
;;;   Kreisel : Z des Einfuegepunkts            -> HOEHE
;;;   VF/GF   : KS_EIN.Z (aus AS_Element)        -> HOEHE_VON_mm
;;;             KS_AUS.Z (aus ES_Element)        -> HOEHE_BIS_mm
;;;   MONTAGEHOEHE_m:
;;;     Kreisel          = HOEHE / 1000
;;;     Gefaellestrecke  = HOEHE_VON_mm / 1000
;;;     VarioFoerderer   = (HOEHE_VON_mm + HOEHE_BIS_mm) / 2 / 1000
;;;
;;; Phase 2 - 0-/Negativ-Pruefung (ungueltig = Wert <= 0 oder nicht
;;;   messbar):
;;;   - Hoehe eingeben  -> Block in Z verschieben, Attribute neu.
;;;   - ENTER           -> Markierungskreis (Layer *ch-mark-layer*),
;;;                        Block spaeter manuell anpassen.
;;;
;;; 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).
;;;
;;; Aufruf:  HOEHEN_CHECK
;;; Nutzt die KS-Extraktion aus vf_core (extract-ks-from-block-raw).
;;; ============================================================

(vl-load-com)

;; Blockname-Muster (Grossschreibung) der KS-tragenden Teilbloecke.
(setq *ch-as-pattern* "AS_ELEMENT*")   ;; enthaelt KS_EIN (Hoehe von)
(setq *ch-es-pattern* "ES_ELEMENT*")   ;; enthaelt KS_AUS (Hoehe bis)

;; Markierung ungueltiger Hoehen: Kreis auf eigenem Layer.
(setq *ch-mark-layer* "S_HOEHE_PRUEFEN")
(setq *ch-mark-color* 1)  ;; 1 = Rot
(if (null *ch-mark-radius-factor*) (setq *ch-mark-radius-factor* 1.1))
(if (null *ch-mark-radius-min*)    (setq *ch-mark-radius-min* 1000.0))

;; 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* 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).
;;; ------------------------------------------------------------
(defun ch-ensure-vfcore ( / p)
  (if (null (car (atoms-family 1 '("EXTRACT-KS-FROM-BLOCK-RAW"))))
    (cond
      ((car (atoms-family 1 '("SSG-ENSURE")))
       (vl-catch-all-apply '(lambda () (ssg-ensure "VarioFoerderer"))))
      ((getenv "DXFM_LISP")
       (setq p (strcat (vl-string-translate "\\" "/" (getenv "DXFM_LISP")) "/vf_core.lsp"))
       (if (findfile p) (vl-catch-all-apply 'load (list p))))
    )
  )
  (if (car (atoms-family 1 '("EXTRACT-KS-FROM-BLOCK-RAW"))) t nil)
)

;;; ------------------------------------------------------------
;;; Attributwert an einem INSERT setzen (Tag ohne Gross/Klein).
;;; Nur wenn der Block Attribute fuehrt (66=1). Rueckgabe: T/nil.
;;; ------------------------------------------------------------
(defun ch-set-att (ins tag val / e ed done ok)
  (setq done nil ok nil)
  (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
                (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
)

;;; ------------------------------------------------------------
;;; Attributwert (String) an einem INSERT lesen. "" wenn fehlend.
;;; ------------------------------------------------------------
(defun ch-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
)

;;; ------------------------------------------------------------
;;; Sortier-Vergleich fuer Kandidaten (idnum ename idx).
;;; Primaer nach ID-Nummer, sekundaer nach Fund-Index (verhindert,
;;; dass vl-sort Eintraege mit gleicher ID verwirft).
;;; ------------------------------------------------------------
(defun ch-id< (a b)
  (if (= (car a) (car b)) (< (caddr a) (caddr b)) (< (car a) (car b)))
)

;;; ------------------------------------------------------------
;;; Z-Koordinate des KS-Ursprungs aus einem ks-data-Satz holen.
;;; ------------------------------------------------------------
(defun ch-ks-z (ksdata ksname / entry)
  (setq entry (cadr (assoc ksname ksdata)))
  (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 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 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)
    (progn
      (foreach sub subs
        (if (and (not (vlax-erased-p sub))
                 (= (vla-get-ObjectName sub) "AcDbBlockReference"))
          (progn
            (setq nm (strcase (vla-get-Name sub)))
            (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")
                      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")
                      paus (ch-ks-pt ksdata "KS_AUS")))
            )
          )
        )
      )
      (foreach sub subs
        (if (not (vlax-erased-p sub))
          (vl-catch-all-apply 'vla-Delete (list sub))))
    )
  )
  (list kez kaz pein paus)
)

;;; ------------------------------------------------------------
;;; getboundingbox-Punkt (Safearray/Variant) in Liste wandeln.
;;; ------------------------------------------------------------
(defun ch-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 (WCS, XY) eines INSERT: (minx miny maxx maxy) oder nil.
;;; ------------------------------------------------------------
(defun ch-bbox (ent / obj res)
  (setq obj (vlax-ename->vla-object ent))
  (vl-catch-all-apply 'vla-update (list obj))
  (setq res
    (vl-catch-all-apply
      '(lambda ( / ll ur)
         (vla-getboundingbox obj 'll 'ur)
         (list (ch-pt->list ll) (ch-pt->list ur)))))
  (if (vl-catch-all-error-p res)
    nil
    (list (car (car res)) (cadr (car res)) (car (cadr res)) (cadr (cadr res)))
  )
)

;;; ------------------------------------------------------------
;;; Layer anlegen / Farbe angleichen (ohne aktuellen Layer zu aendern).
;;; ------------------------------------------------------------
(defun ch-ensure-layer (name color / lay ed)
  (if (tblsearch "LAYER" name)
    (progn
      (setq lay (tblobjname "LAYER" name) ed (entget lay))
      (if (assoc 62 ed)
        (entmod (subst (cons 62 color) (assoc 62 ed) ed))))
    (entmake (list '(0 . "LAYER")
                   '(100 . "AcDbSymbolTableRecord")
                   '(100 . "AcDbLayerTableRecord")
                   (cons 2 name) (cons 70 0) (cons 62 color) (cons 6 "Continuous")))
  )
)

;;; ------------------------------------------------------------
;;; Block mit einem Kreis markieren (zentriert, Radius aus XY-Box).
;;; ------------------------------------------------------------
(defun ch-mark (ent / bb ipt cx cy cz r)
  (setq bb  (ch-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 (* *ch-mark-radius-factor*
                 (/ (distance (list (nth 0 bb) (nth 1 bb))
                              (list (nth 2 bb) (nth 3 bb))) 2.0)))
      (if (< r *ch-mark-radius-min*) (setq r *ch-mark-radius-min*)))
    (progn (setq cx (car ipt) cy (cadr ipt) r *ch-mark-radius-min*))
  )
  (ch-ensure-layer *ch-mark-layer* *ch-mark-color*)
  (entmake (list '(0 . "CIRCLE") (cons 8 *ch-mark-layer*)
                 (cons 10 (list cx cy cz)) (cons 40 r)))
)

;;; ------------------------------------------------------------
;;; Ungueltig = nil oder <= 0.
;;; ------------------------------------------------------------
(defun ch-invalid-p (v) (or (null v) (<= v 0)))

;;; ------------------------------------------------------------
;;; Block um dz in Z verschieben (WCS).
;;; ------------------------------------------------------------
(defun ch-move-z (ent dz)
  (vla-Move (vlax-ename->vla-object ent)
            (vlax-3d-point 0 0 0) (vlax-3d-point 0 0 dz))
)

;;; ------------------------------------------------------------
;;; MONTAGEHOEHE_m schreiben (roher Wert in m). Liegt der rohe Wert
;;; ueber *ch-buehne-schwelle-m*, wird pro Block nach einer Buehne
;;; gefragt und deren Hoehe abgezogen (real = roh - buehne).
;;; Rueckgabe: der geschriebene (evtl. reduzierte) Wert.
;;; ------------------------------------------------------------
(defun ch-write-montage (ent raw lbl / real ans buehne)
  (setq real raw)
  (if (> raw *ch-buehne-schwelle-m*)
    (progn
      (initget "Ja Nein")
      (setq ans (getkword (strcat "\n     " lbl ": Montagehoehe " (rtos raw 2 3)
                                  " m (> " (rtos *ch-buehne-schwelle-m* 2 1)
                                  " m). Buehne vorhanden? [Ja/Nein] <Nein>: ")))
      (if (= ans "Ja")
        (progn
          (setq buehne (getreal "\n     Buehnenhoehe in m: "))
          (if (and buehne (> buehne 0))
            (if (>= buehne raw)
              (princ (strcat "\n     ! Buehne (" (rtos buehne 2 3)
                             " m) >= Montagehoehe (" (rtos raw 2 3)
                             " m) - kein Abzug, roher Wert bleibt."))
              (progn
                (setq real (- raw buehne))
                (princ (strcat "\n     Buehne " (rtos buehne 2 3)
                               " m abgezogen -> " (rtos real 2 3) " m")))
            )
          )
        )
      )
    )
  )
  (ch-set-att ent "MONTAGEHOEHE_m" (rtos real 2 3))
  real
)

;;; ============================================================
;;; 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))
)
;;; Flache Schleife (reiner Kern): Strecke startet und endet am SELBEN Kreisel
;;; (h1 = h2) und hat gleiche Anfangs-/Endhoehe (|z1 - z2| <= tol, mm). Ihre
;;; Buehne laesst sich nicht aus der Familie ableiten und wird einzeln gefragt.
(defun ch-schleife-p (h1 h2 z1 z2 tol)
  (and h1 h2 (= h1 h2) (<= (abs (- z1 z2)) tol))
)

;;; 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)
              (if (ch-schleife-p fs fe (caddr (nth 4 rec)) (caddr (nth 5 rec)) 1.0)
                ;; Flache Schleife am selben Kreisel: Buehne nicht ableitbar ->
                ;; bleibt unentschieden und wird im Rest einzeln gefragt
                (princ (ssg-textf "chh-schleife" (list lbl)))
              (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
                          n-kreisel n-vf n-gf n-fixed n-marked n-fehler)
  (if (not (ch-ensure-vfcore))
    (progn
      (princ "\n>>> FEHLER: vf_core (extract-ks-from-block-raw) nicht geladen.")
      (princ "\n    Bitte das SSG_LIB-Menue laden oder DXFM_LISP setzen.")
      (princ)
      (exit)
    )
  )
  (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*))))
  (if mss (command "_.ERASE" mss ""))
  (vl-catch-all-apply '(lambda () (command "_.REGEN")))

  (princ "\n============================================")
  (princ "\n  Hoehen-Check  (Phase 1-3)")
  (princ "\n============================================")

  (setq ss (ssget "_X" '((0 . "INSERT"))))
  (if (null ss)
    (princ "\n  Keine Bloecke gefunden.")
    (progn
      ;; Kandidaten (KREISEL/VF/GF) sammeln und nach ID-Attribut sortieren
      (setq items nil i 0 idx 0)
      (while (< i (sslength ss))
        (setq ent (ssname ss i)
              nm  (strcase (cdr (assoc 2 (entget ent)))))
        (if (or (wcmatch nm "KREISEL_*") (wcmatch nm "VF_*") (wcmatch nm "GF_*"))
          (progn
            (setq id (ch-get-att-str ent "ID"))
            (setq items (cons (list (if (and id (/= id "")) (atoi id) 999999)
                                    ent idx)
                              items))
            (setq idx (1+ idx))))
        (setq i (1+ i))
      )
      (setq items (vl-sort items 'ch-id<))
      (if (> (length items) 0)
        (princ (strcat "\n  (" (itoa (length items))
                       " Bloecke, Verarbeitung in ID-Reihenfolge)")))

      ;; in ID-Reihenfolge verarbeiten
      (foreach it items
        (setq ent (cadr it)
              ed  (entget ent)
              nm  (strcase (cdr (assoc 2 ed)))
              lbl (cdr (assoc 2 ed)))
        (cond
          ;; ===================== KREISEL =====================
          ((wcmatch nm "KREISEL_*")
            (setq n-kreisel (1+ n-kreisel))
            (setq zc (caddr (cdr (assoc 10 ed))))
            (if (null zc) (setq zc 0.0))
            (if (ch-invalid-p zc)
              ;; --- ungueltig: eingeben/verschieben oder markieren ---
              (progn
                (setq inp (getreal (strcat "\n  " lbl " ungueltige Hoehe ("
                                           (rtos zc 2 0)
                                           " mm). Neue Hoehe in mm [ENTER=markieren]: ")))
                (if (and inp (> inp 0))
                  (progn
                    (ch-move-z ent (- inp zc))
                    (setq zc inp)
                    (ch-set-att ent "HOEHE" (rtos zc 2 0))
                    (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))))
                  (progn
                    (ch-mark ent)
                    (setq n-marked (1+ n-marked))
                    (princ (strcat "\n     -> markiert (Layer " *ch-mark-layer*
                                   "), spaeter anpassen")))
                )
              )
              ;; --- gueltig ---
              (progn
                (ch-set-att ent "HOEHE" (rtos zc 2 0))
                (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))))
            )
          )
          ;; ===================== VF / GF =====================
          ((or (wcmatch nm "VF_*") (wcmatch nm "GF_*"))
            (if (wcmatch nm "GF_*") (setq n-gf (1+ n-gf)) (setq n-vf (1+ n-vf)))
            (setq meas (ch-measure-vfgf ent) kez (car meas) kaz (cadr meas))
            (cond
              ;; --- nicht messbar -> markieren ---
              ((or (null kez) (null kaz))
                (setq n-fehler (1+ n-fehler))
                (ch-mark ent)
                (setq n-marked (1+ n-marked))
                (princ (strcat "\n  " lbl ": ! KS nicht messbar (VON="
                               (if kez (rtos kez 2 0) "?") ", BIS="
                               (if kaz (rtos kaz 2 0) "?") ") -> markiert")))
              ;; --- ungueltig (<=0) -> eingeben/verschieben oder markieren ---
              ((or (ch-invalid-p kez) (ch-invalid-p kaz))
                (setq inp (getreal (strcat "\n  " lbl " ungueltig (VON=" (rtos kez 2 0)
                                           ", BIS=" (rtos kaz 2 0)
                                           "). KS_EIN-Hoehe in mm [ENTER=markieren]: ")))
                (if (and inp (> inp 0))
                  (progn
                    (setq delta (- inp kez))
                    (ch-move-z ent delta)
                    (setq kez inp kaz (+ kaz delta))
                    (if (or (ch-invalid-p kez) (ch-invalid-p kaz))
                      (progn
                        (ch-mark ent)
                        (setq n-marked (1+ n-marked))
                        (princ (strcat "\n     -> verschoben, aber BIS weiter ungueltig ("
                                       (rtos kaz 2 0) " mm) -> markiert")))
                      (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-montage-roh ent
                                        (if (wcmatch nm "GF_*") "GF" "VF")
                                        (if (wcmatch nm "GF_*")
                                          (/ kez 1000.0)
                                          (/ (+ 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)
                                       " -> MONTAGEHOEHE_m=" (rtos montage 2 3))))
                    )
                  )
                  (progn
                    (ch-mark ent)
                    (setq n-marked (1+ n-marked))
                    (princ (strcat "\n     -> markiert (Layer " *ch-mark-layer*
                                   "), spaeter anpassen")))
                )
              )
              ;; --- gueltig ---
              (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-montage-roh ent
                                (if (wcmatch nm "GF_*") "GF" "VF")
                                (if (wcmatch nm "GF_*")
                                  (/ kez 1000.0)
                                  (/ (+ 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))))
            )
          )
        )
      )
      ;; Phase 3: Buehnen-Familien (arbeitet das Register *ch-rec* ab)
      (ch-phase3)
      (princ (strcat "\n--------------------------------------------"
                     "\n  Kreisel: " (itoa n-kreisel)
                     "   VF: " (itoa n-vf)
                     "   GF: " (itoa n-gf)
                     "\n  korrigiert (verschoben): " (itoa n-fixed)
                     "   markiert: " (itoa n-marked)
                     "   nicht messbar: " (itoa n-fehler)))
      (if (> n-marked 0)
        (princ (strcat "\n  Markierte Bloecke: Layer '" *ch-mark-layer*
                       "' - spaeter Hoehe anpassen und erneut ausfuehren.")))
      (princ "\n  Hinweis: Phase 1-3 - kein QSAVE (UNDO moeglich).")
    )
  )
  (princ "\n>>> Fertig.")
  (princ)
)

(princ "\n>>> check_hoehen.lsp geladen (Phase 1-3). Befehl: HOEHEN_CHECK")
(princ)