737 lines
31 KiB
Common Lisp
737 lines
31 KiB
Common Lisp
;;; ============================================================
|
|
;;; 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))
|
|
)
|
|
;;; 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
|
|
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) |