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

[REFACTOR] KS-Extraktion + Einfuegeprimitiven zentral in ssg_ks_insert.lsp

Browse Source 
Neun Funktionen waren doppelt gepflegt in vf_core.lsp (unbedingt) UND
Gefaellestrecke.lsp (geguardet 'Fallback wenn vf_core nicht geladen'). Da
vf_core im MNL immer nach Gefaellestrecke laedt, gewann bisher stillschweigend
die vf_core-Version - die Gefaellestrecke-Kopien waren de facto tot und wichen
leicht ab. Jetzt EINE Quelle:

  ssg_ks_insert.lsp: vec-length, ks-line-axis, ks-normalize-name, ks-relativize,
  ks-absolutize, ensure-block-loaded, extract-ks-from-block[-raw],
  insert-block-by-ks, insert-inclined-scaled-block, insert-rotated-block-with-ks

- Kanonische vf_core-Variante uebernommen (inkl. Null-Check, ssg-ils-block-auf-ebene,
  hz-Guard, Statusmeldungen). Gefaellestrecke erhaelt dadurch dieselbe Behandlung
  wie im MNL-Fluss ohnehin schon aktiv.
- Cache vereinheitlicht auf *ks-cache* (guarded init im Shared-File);
  *gf-ks-cache* entfaellt.
- MNL laedt ssg_ks_insert als Core-Modul VOR Gefaellestrecke/VarioFoerderer.
- vf_core + Gefaellestrecke: guarded Nachlade-Load fuer isoliertes Test/Dev-Laden.

Paren-Balance geprueft; jede der 9 Funktionen jetzt genau 1x definiert.
Beruehrt Block-Platzierung -> BricsCAD-Test Standard/Etage/Linienzug/Gefaelle
(2D+3D) noetig.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
This commit is contained in:
Michael Stangl
2026-08-29 08:37:35 +02:00
parent 6cf54f646b
commit 80804a321a
4 changed files with 408 additions and 632 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Lisp/ssg_ks_insert.lsp
+357
View File
@@ -0,0 +1,357 @@
;; ============================================================
;; SSG_KS_INSERT.LSP - Gemeinsame KS-Extraktion + Block-Einfuegeprimitiven
;; ============================================================
;; Frueher doppelt gepflegt in vf_core.lsp (unbedingt) UND Gefaellestrecke.lsp
;; (geguardet als "Fallback wenn vf_core nicht geladen"). Da vf_core im MNL-Fluss
;; immer nach Gefaellestrecke laedt, gewann bisher STILLSCHWEIGEND die
;; vf_core-Version - die Gefaellestrecke-Fallbacks waren de facto tot und wichen
;; zudem leicht ab (Layer-Setzung, hz-Guard, Null-Check, Meldungs-Keys). Diese
;; Datei ist jetzt die EINZIGE Quelle (kanonische vf_core-Variante); beide
;; Cluster laden sie ueber die MNL VOR Gefaellestrecke/vf_core.
;;
;; Abhaengigkeiten (aus ssg_core, daher zuerst laden): ssg-ils-block-laden,
;; ssg-ils-blockname, ssg-ils-block-auf-ebene, ssg-rot-matrix-zy, ssg-text/-textf.
;; ============================================================
(vl-load-com)
;; Cache fuer extract-ks-from-block (Blockname -> relative KS-Punkte). Guard,
;; damit ein Neu-Laden dieser Datei den Cache nicht verwirft.
(if (not (boundp '*ks-cache*)) (setq *ks-cache* nil))
;; ------------------------------------------------------------
;; KS-MATHEMATIK (Basis)
;; ------------------------------------------------------------
(defun vec-length (v)
(sqrt (+ (* (car v) (car v)) (* (cadr v) (cadr v)) (* (caddr v) (caddr v)))))
;; Achsenkennung aus Linienlaenge fuer die KS-Extraktion (X=1 bzw. 100, Y=2, Z=3).
(defun ks-line-axis (len)
(cond
((and (> len 0.5) (< len 1.5)) "X")
((and (> len 99) (< len 101)) "X")
((and (> len 1.5) (< len 2.5)) "Y")
((and (> len 2.5) (< len 3.5)) "Z")
(t nil)))
;; Normalisiert die verschiedenen KS-Blocknamen auf "KS_EIN"/"KS_AUS".
;; Standard ist KS_EIN/KS_AUS; historische Bestandsbloecke koennen noch
;; KSYS_EIN/KSYS_AUS fuehren. Rueckgabe nil, wenn kein KS-Block.
(defun ks-normalize-name (nm)
(cond
((or (= nm "KS_EIN") (= nm "KSYS_EIN")) "KS_EIN")
((or (= nm "KS_AUS") (= nm "KSYS_AUS")) "KS_AUS")
(t nil)))
(defun ks-relativize (ks-data base-pt)
(mapcar '(lambda (item)
(list (car item)
(mapcar '(lambda (pt)
(list (- (car pt) (car base-pt))
(- (cadr pt) (cadr base-pt))
(- (caddr pt) (caddr base-pt))))
(cadr item))))
ks-data))
(defun ks-absolutize (ks-rel base-pt)
(mapcar '(lambda (item)
(list (car item)
(mapcar '(lambda (pt)
(list (+ (car pt) (car base-pt))
(+ (cadr pt) (cadr base-pt))
(+ (caddr pt) (caddr base-pt))))
(cadr item))))
ks-rel))
;; ------------------------------------------------------------
;; BLOCK-LADER
;; ------------------------------------------------------------
;; Zentraler Loader (flache Ablage). Laedt den Block in der AKTUELLEN Dimension
;; (ssg-ils-dim-aktuell: *ssg-ils-dim*-Override -> DXFM_DIM) mit automatischem
;; 3D-Fallback, sodass 2D- und 3D-Aufbau gleichermassen funktionieren. Laedt den
;; Block unter seinem effektiven, dim-suffigierten Namen und GIBT DIESEN ZURUECK,
;; damit Aufrufer ihn zum Einfuegen (vla-InsertBlock/tblsearch) verwenden.
;; Meldung nur bei Fehlschlag.
(defun ensure-block-loaded (blockname / )
(if (not (ssg-ils-block-laden blockname))
(princ (ssg-textf "vfc-fehler-block-datei-fehlt" (list blockname)))
)
(ssg-ils-blockname blockname)
)
;; ------------------------------------------------------------
;; KS-EXTRAKTION (mit Cache *ks-cache*)
;; ------------------------------------------------------------
(defun extract-ks-from-block-raw (block-obj / sub-entities sub-obj ks-results
ks-ref inner-entities inner-obj origin x-end y-end z-end
line-start line-end axis line-len line-vec)
(setq ks-results '())
(setq sub-entities (vlax-invoke block-obj 'Explode))
(foreach sub-obj sub-entities
(setq ks-ref
(if (and (not (vlax-erased-p sub-obj))
(= (vla-get-ObjectName sub-obj) "AcDbBlockReference"))
(ks-normalize-name (vla-get-Name sub-obj))
nil))
(if ks-ref
(progn
(setq inner-entities (vlax-invoke sub-obj 'Explode))
(setq origin nil x-end nil y-end nil z-end nil)
(foreach inner-obj inner-entities
(if (and (not (vlax-erased-p inner-obj))
(= (vla-get-ObjectName inner-obj) "AcDbLine"))
(progn
(setq line-start (vlax-safearray->list
(vlax-variant-value (vla-get-StartPoint inner-obj))))
(setq line-end (vlax-safearray->list
(vlax-variant-value (vla-get-EndPoint inner-obj))))
(setq line-vec (list (- (car line-end) (car line-start))
(- (cadr line-end) (cadr line-start))
(- (caddr line-end) (caddr line-start))))
(setq line-len (vec-length line-vec))
(setq axis (ks-line-axis line-len))
(if (null origin) (setq origin line-start))
(cond
((= axis "X") (setq x-end line-end))
((= axis "Y") (setq y-end line-end))
((= axis "Z") (setq z-end line-end))
)
)
)
(if (not (vlax-erased-p inner-obj)) (vla-Delete inner-obj))
)
(if (and origin x-end y-end z-end)
(setq ks-results (cons (list ks-ref (list origin x-end y-end z-end)) ks-results))
)
)
)
)
(foreach sub-obj sub-entities
(if (not (vlax-erased-p sub-obj)) (vla-Delete sub-obj))
)
ks-results
)
(defun extract-ks-from-block (block-obj / blockname insert-pt cached result ks-rel)
(setq blockname (vla-get-Name block-obj))
(setq insert-pt (vlax-safearray->list
(vlax-variant-value (vla-get-InsertionPoint block-obj))))
(setq cached (assoc blockname *ks-cache*))
(if cached
(ks-absolutize (cdr cached) insert-pt)
(progn
(setq result (extract-ks-from-block-raw block-obj))
(if result
(progn
(setq ks-rel (ks-relativize result insert-pt))
(setq *ks-cache* (cons (cons blockname ks-rel) *ks-cache*))
)
)
result
)
)
)
;; ------------------------------------------------------------
;; EINFUEGEPRIMITIVEN
;; ------------------------------------------------------------
;; --- Block per KS_EIN/KS_AUS einfuegen (nur horizontale Rz-Rotation) ---
;; KS_EIN (nicht der Block-Ursprung) kommt auf einfuegepunkt zu liegen.
;; Rueckgabe: Weltpunkt von KS_AUS (fuer Verkettung), sonst einfuegepunkt.
(defun insert-block-by-ks (blockname einfuegepunkt hz / block-obj temp-obj ks-data ks-ein ks-aus
rad-h chv shv ein-x ein-y ein-z dx-loc dy-loc dz-loc offset ausgang)
(if (or (null einfuegepunkt) (not (listp einfuegepunkt)))
(progn
(princ (ssg-textf "vfc-fehler-ungueltiger-einfuegepunkt" (list blockname)))
(exit)
)
)
(setq blockname (ensure-block-loaded blockname))
(if (not (tblsearch "BLOCK" blockname))
(progn
(princ (ssg-textf "vfc-fehler-block-nicht-in-bibliothek-abgebrochen" (list blockname)))
(exit)
)
)
(princ (ssg-textf "vfc-fuege-block-ein-hz" (list blockname (rtos (float hz) 2 1) (chr 176))))
(setq rad-h (* (float hz) (/ pi 180.0)))
(setq chv (cos rad-h) shv (sin rad-h))
;; KS_EIN/KS_AUS ueber eigenes Temp-Objekt am Ursprung ermitteln (nicht am
;; spaeter tatsaechlich platzierten block-obj - extract-ks-from-block
;; exploded das uebergebene Objekt intern), siehe insert-block-ks-to-ks.
(setq temp-obj (vla-InsertBlock modelspace
(vlax-3D-point '(0 0 0))
blockname 1.0 1.0 1.0 0))
(setq ks-data (extract-ks-from-block temp-obj))
(if (not (vlax-erased-p temp-obj)) (vla-Delete temp-obj))
(setq ks-ein (cadr (assoc "KS_EIN" ks-data)))
(setq ks-aus (cadr (assoc "KS_AUS" ks-data)))
;; Block am Ursprung einfuegen (nicht direkt am einfuegepunkt), damit die
;; Rz-Rotation um den Block-Ursprung dreht, nicht um die Weltachse.
(setq block-obj (vla-InsertBlock modelspace
(vlax-3D-point '(0 0 0))
blockname 1.0 1.0 1.0 0))
(ssg-ils-block-auf-ebene block-obj blockname)
(if (> (abs hz) 0.0001)
(vla-TransformBy block-obj (vlax-tmatrix
(list (list chv (- shv) 0 0)
(list shv chv 0 0)
(list 0 0 1 0)
(list 0 0 0 1))))
)
(if (and ks-ein ks-aus)
(progn
(setq ein-x (car (car ks-ein)) ein-y (cadr (car ks-ein)) ein-z (caddr (car ks-ein)))
;; Block-Ursprung so verschieben, dass das ROTIERTE KS_EIN exakt auf
;; einfuegepunkt zu liegen kommt: Ursprung = einfuegepunkt - Rz(hz)*ks_ein_lokal
(setq offset (list
(- (car einfuegepunkt) (- (* chv ein-x) (* shv ein-y)))
(- (cadr einfuegepunkt) (+ (* shv ein-x) (* chv ein-y)))
(- (caddr einfuegepunkt) ein-z)))
(vla-Move block-obj
(vlax-3D-point '(0 0 0))
(vlax-3D-point offset))
;; KS_AUS = einfuegepunkt + Rz(hz)*(ks_aus_lokal - ks_ein_lokal)
(setq dx-loc (- (car (car ks-aus)) ein-x))
(setq dy-loc (- (cadr (car ks-aus)) ein-y))
(setq dz-loc (- (caddr (car ks-aus)) ein-z))
(setq ausgang (list
(+ (car einfuegepunkt) (- (* chv dx-loc) (* shv dy-loc)))
(+ (cadr einfuegepunkt) (+ (* shv dx-loc) (* chv dy-loc)))
(+ (caddr einfuegepunkt) dz-loc)))
(princ (ssg-textf "vfc-ks-aus-xyz"
(list (rtos (car ausgang) 2 2) (rtos (cadr ausgang) 2 2) (rtos (caddr ausgang) 2 2))))
ausgang
)
(progn
(princ (ssg-text "vfc-warnung-ks-nicht-gefunden"))
einfuegepunkt
)
)
)
;; --- Skalierter geneigter Block (Staustrecke, Richtung X), Rz(hz)*Ry(winkel) ---
(defun insert-inclined-scaled-block (blockname startpunkt laenge winkel hz /
rad-v rad-h chv shv cvv svv scale block-obj matrix endpunkt)
(if (<= laenge 0.1)
(progn
(princ (ssg-textf "vfc-laenge-uebersprungen" (list (rtos laenge 2 2))))
startpunkt
)
(progn
(setq blockname (ensure-block-loaded blockname))
(if (not (tblsearch "BLOCK" blockname))
(progn
(princ (ssg-textf "vfc-fehler-block-nicht-in-bibliothek-abgebrochen" (list blockname)))
(exit)
)
)
(princ (ssg-textf "vfc-fuege-ein-lwhz"
(list blockname (rtos laenge 2 2) (itoa winkel) (chr 176) (rtos (float hz) 2 1) (chr 176))))
(setq scale (/ laenge (ssg-cfg-or "vario" "skalierung_basis" 1000.0)))
(setq rad-v (* (float winkel) (/ pi 180.0)))
(setq rad-h (* (float hz) (/ pi 180.0)))
(setq chv (cos rad-h) shv (sin rad-h) cvv (cos rad-v) svv (sin rad-v))
(setq block-obj (vla-InsertBlock modelspace
(vlax-3D-point '(0 0 0))
blockname scale 1.0 1.0 0))
(ssg-ils-block-auf-ebene block-obj blockname)
(setq matrix (ssg-rot-matrix-zy chv shv cvv svv))
(vla-TransformBy block-obj (vlax-tmatrix matrix))
(vla-Move block-obj
(vlax-3D-point '(0 0 0))
(vlax-3D-point startpunkt))
(setq endpunkt (list
(+ (car startpunkt) (* laenge chv cvv))
(+ (cadr startpunkt) (* laenge shv cvv))
(+ (caddr startpunkt) (* laenge (- svv)))))
(princ (ssg-textf "vfc-endpunkt-xyz"
(list (rtos (car endpunkt) 2 2) (rtos (cadr endpunkt) 2 2) (rtos (caddr endpunkt) 2 2))))
endpunkt
)
)
)
;; --- Rotierter Block mit manuellem dx/dz-Fallback, Rz(hz)*Ry(winkel) ---
;; block-dx/block-dz: Fallback-Laenge (aus Config), nur verwendet falls
;; KS_EIN/KS_AUS am Block nicht extrahiert werden koennen. Ist KS_AUS
;; vorhanden, wird der ECHTE gemessene Versatz KS_AUS-KS_EIN verwendet -
;; das schuetzt vor veralteten Config-Zahlen. KS_EIN (nicht der Block-Ursprung)
;; kommt auf startpunkt zu liegen.
(defun insert-rotated-block-with-ks (blockname startpunkt winkel block-dx block-dz hz /
rad-v rad-h chv shv cvv svv matrix block-obj temp-obj ks-data
ks-ein-raw ks-aus-raw
ein-x ein-y ein-z aus-x aus-y aus-z
dx dz ins-pt endpunkt)
(if (or (null startpunkt) (not (listp startpunkt)))
(progn
(princ (ssg-textf "vfc-fehler-ungueltiger-einfuegepunkt" (list blockname)))
startpunkt
)
(progn
(setq blockname (ensure-block-loaded blockname))
(if (not (tblsearch "BLOCK" blockname))
(progn
(princ (ssg-textf "vfc-fehler-block-nicht-in-bibliothek-abgebrochen" (list blockname)))
(exit)
)
)
(princ (ssg-textf "vfc-fuege-block-ein-rotation-hz"
(list blockname (itoa winkel) (chr 176) (rtos (float hz) 2 1) (chr 176))))
(setq rad-v (* winkel (/ pi 180.0)))
(setq rad-h (* (float hz) (/ pi 180.0)))
(setq chv (cos rad-h) shv (sin rad-h) cvv (cos rad-v) svv (sin rad-v))
;; Lokale KS_EIN/KS_AUS-Position ueber EIGENES Temp-Objekt ermitteln.
(setq temp-obj (vla-InsertBlock modelspace
(vlax-3D-point '(0 0 0))
blockname 1.0 1.0 1.0 0))
(setq ks-data (extract-ks-from-block temp-obj))
(if (not (vlax-erased-p temp-obj)) (vla-Delete temp-obj))
(setq ks-ein-raw (cadr (assoc "KS_EIN" ks-data)))
(setq ks-aus-raw (cadr (assoc "KS_AUS" ks-data)))
(setq ein-x 0.0 ein-y 0.0 ein-z 0.0)
(if ks-ein-raw
(setq ein-x (car (car ks-ein-raw))
ein-y (cadr (car ks-ein-raw))
ein-z (caddr (car ks-ein-raw)))
)
;; Echten Versatz KS_AUS-KS_EIN verwenden, sofern messbar.
(setq dx block-dx dz block-dz)
(if ks-aus-raw
(progn
(setq aus-x (car (car ks-aus-raw))
aus-y (cadr (car ks-aus-raw))
aus-z (caddr (car ks-aus-raw)))
(setq dx (- aus-x ein-x) dz (- aus-z ein-z))
)
)
(setq block-obj (vla-InsertBlock modelspace
(vlax-3D-point '(0 0 0))
blockname 1.0 1.0 1.0 0))
(ssg-ils-block-auf-ebene block-obj blockname)
(setq matrix (ssg-rot-matrix-zy chv shv cvv svv))
(vla-TransformBy block-obj (vlax-tmatrix matrix))
;; Block-Ursprung so verschieben, dass das ROTIERTE KS_EIN exakt auf
;; startpunkt liegt: Ursprung = startpunkt - Rz(hz)*Ry(winkel)*ks_ein_lokal
(setq ins-pt (list
(- (car startpunkt) (+ (* ein-x chv cvv) (* ein-y (- shv)) (* ein-z chv svv)))
(- (cadr startpunkt) (+ (* ein-x shv cvv) (* ein-y chv) (* ein-z shv svv)))
(- (caddr startpunkt) (+ (* ein-x (- svv)) (* ein-z cvv)))))
(vla-Move block-obj
(vlax-3D-point '(0 0 0))
(vlax-3D-point ins-pt))
;; KS_AUS-Weltpunkt = startpunkt + Rz(hz)*Ry(winkel)*(dx 0 dz)
(setq endpunkt (list
(+ (car startpunkt) (+ (* dx chv cvv) (* dz chv svv)))
(+ (cadr startpunkt) (+ (* dx shv cvv) (* dz shv svv)))
(+ (caddr startpunkt) (+ (* dx (- svv)) (* dz cvv)))))
(princ (ssg-textf "vfc-endpunkt-xyz-dxdz"
(list (rtos (car endpunkt) 2 2) (rtos (cadr endpunkt) 2 2) (rtos (caddr endpunkt) 2 2)
(rtos dx 2 1) (rtos dz 2 1))))
endpunkt
)
)
)
(princ)