Schoenenberger_Systeme_GmbH/dxfmakros
7
0
Fork 0
Code Issues 1 Pull Requests Actions Packages Projects Releases Wiki Activity
Files
e5ba096a1698754327204f5a59c5b3cb01f54126
dxfmakros/Lisp/KreiselInsert.lsp
T
s.ayadi 166c94f715 [FIX] Kreisel-Weichen: Ende-an-Ende-Raeder und Zeichentoleranz 
- Rad/Rad an beiden Flanken gilt nur bei gleich ausgerichteten Raedern als
  "Seite an Seite"; in Gegenrichtung (Kreisel seitlich versetzt Ende an Ende)
  ist es eine Weiche
- toleranz_beruehrung von 1 auf 10 mm (Zeichenungenauigkeiten, Spalt und
  Ueberlappung)
- Unit-Tests fuer Ende-an-Ende, Seite-an-Seite und den Fall aus test.dxf (E3/C7)

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
2026-10-14 16:08:50 +02:00

1913 lines
73 KiB
Common Lisp
Raw Blame History

;; KreiselInsert.lsp
;; Kreisel Modul-Einfuegesystem mit Compound-Block + Attribute
;; Version: 6.0 (Attribute, Redraw, 2-Linien-Connect)
;; Setzt ssg_core.lsp voraus.
;; ============================================
;; ============================================================
;; TEIL 1: GLOBALE EINSTELLUNGEN
;; ============================================================
;; Zähler für Nummerierung (werden in Zeichnung gespeichert)
(if (null #Kreisel_LetzteNr)
(setq #Kreisel_LetzteNr 0)
)
(if (null #Eckrad_LetzteNr)
(setq #Eckrad_LetzteNr 0)
)
;; DXFM_DIM sicher lesen (type-Guard gegen nicht-String Rueckgabewerte)
(setq *ki-dxfm-dim* (getenv "DXFM_DIM"))
(if (not (= (type *ki-dxfm-dim*) 'STR)) (setq *ki-dxfm-dim* "3D"))
;; Modul-eigener Block-Pfad: seit dem Flach-Refactor liegen alle Bloecke direkt
;; unter data/ils/ (die Dimension steckt jetzt im Dateinamen, z.B. AN8_2D.dwg).
;; KI ist DXFM_DIM-abhaengig (*ki-dxfm-dim*); der Dateiname wird an der Einfuege-
;; stelle mit dem Suffix gebildet.
(setq *block-path*
(cond
((and (getenv "DXFMAKRO") (= (type (getenv "DXFMAKRO")) 'STR))
(strcat (vl-string-right-trim "/" (vl-string-translate "\\" "/" (getenv "DXFMAKRO")))
"/data/ils/"))
((and (boundp '*ssg-lisp-pfad*) (= (type *ssg-lisp-pfad*) 'STR)
(vl-string-search "/Lisp" *ssg-lisp-pfad*))
(strcat (substr *ssg-lisp-pfad* 1 (vl-string-search "/Lisp" *ssg-lisp-pfad*))
"/data/ils/"))
(t
(princ (ssg-text "kreisel-warn-blockpfad"))
nil)
)
)
;; ssg_core laden falls noch nicht geschehen (Schutz bei direktem Laden ohne ssg-ensure)
(if (null (car (atoms-family 1 '("SSG-CFG-OR"))))
(progn
(setq *ssg-core-datei*
(cond
((getenv "DXFM_LISP")
(strcat (vl-string-translate "\\" "/" (getenv "DXFM_LISP")) "/ssg_core.lsp"))
((findfile "ssg_core.lsp")
(findfile "ssg_core.lsp"))
(t nil)
)
)
(if *ssg-core-datei*
(progn
(load *ssg-core-datei*)
(if (car (atoms-family 1 '("SSG-LOAD-CONFIG"))) (ssg-load-config))
(princ (strcat "\n[KreiselInsert] ssg_core geladen: " *ssg-core-datei*))
)
(progn
(defun ssg-cfg-or (sektion schluessel standard) standard)
(defun ssg-cfg (sektion schluessel) nil)
(defun ssg-load-config () nil)
(princ (ssg-text "kreisel-warn-core-fehlt"))
)
)
)
)
;; Kreisel-Geometrie-Konstanten (aus Config oder Fallback)
(setq *kreisel-durchmesser* (ssg-cfg-or "kreisel" "durchmesser" 800.0))
(setq *kreisel-pin-abstand* (ssg-cfg-or "kreisel" "pin_abstand" 100.0))
(setq *kreisel-default-laenge* (ssg-cfg-or "kreisel" "default_laenge" 2300.0))
(setq *kreisel-default-hoehe* (ssg-cfg-or "kreisel" "default_hoehe" 2000.0))
;; Attribut-Definitionen: ((TAG DEFAULT) ...)
;; Anzeige-/Attributreihenfolge im Block (ID zuerst, dann Bezeichnung,
;; ARTINR fest 6200, Montage-/Hoehendaten, dann Ausstattung).
;; NUMMER steht am Ende (wird intern fuer Nummerierung/Blockname
;; benoetigt; Entfernen erfordert Refactor der Nummernvergabe).
(setq *kreisel-attrib-defs*
'(("ID" "")
("Bezeichnung" "")
("ARTINR" "6200")
("MONTAGEHOEHE_m" "0.000")
("HOEHE" "0")
("KREISELART" "STANDARD")
("ABSTAND" "2300")
("ANZAHL_SEPARATOR" "2")
("ANZAHL_SCANNER" "0")
("ANZAHL_RAMPEN" "0")
("GERUEST_EINZELMODUL" "1")
("GERUEST_TYP" "Schoenenberger Geruest")
("DREHRICHTUNG" "UZS")
("DREHUNG" "0")
("NUMMER" "0"))
)
;; Eckrad-Einstellungen
(setq *eckrad-default-hoehe* (ssg-cfg-or "eckrad" "default_hoehe" 2000.0))
;; Eckrad Attribut-Definitionen: ((TAG DEFAULT) ...)
(setq *eckrad-attrib-defs*
'(("Bezeichnung" "")
("DREHRICHTUNG" "UZS")
("DREHUNG" "0")
("NUMMER" "0")
("HOEHE" "0")
("GERUEST_EINZELMODUL" "1")
("GERUEST_TYP" "Schoenenberger Geruest")
("ID" ""))
)
;; Letzter gewaehlter Typ (gespeichert zwischen Aufrufen)
(if (null #Kreisel_Typ) (setq #Kreisel_Typ "STANDARD"))
;; Beschriftungs-Einstellungen (NUR EINMAL definieren!)
(setq *kreisel-beschriftung-layer* "S_KRS_BESCHR")
(setq *kreisel-beschriftung-hoehe* (ssg-cfg-or "kreisel" "label_hoehe" 100.0))
(setq *kreisel-beschriftung-farbe* (ssg-cfg-or "kreisel" "label_farbe" 7))
(setq *kreisel-beschriftung-abstand-oben* (ssg-cfg-or "kreisel" "label_abstand_oben" 0.0))
(setq *kreisel-beschriftung-schriftart* "Arial") ;; Schriftart
;; ============================================================
;; TEIL 2: HILFSFUNKTIONEN
;; ============================================================
;; Funktion zum Erstellen/Setzen der Schriftart Arial
(defun kreisel-setup-textstyle ( / style-name)
(setq style-name "Kreisel_Arial")
;; Prüfen ob der Textstil bereits existiert
(if (not (tblsearch "STYLE" style-name))
(progn
;; Neuen Textstil mit Arial erstellen
(command "_.STYLE" style-name "Arial" 0 1 0 "N" "N" "N")
(princ (ssg-textf "kreisel-textstil-erstellt" (list style-name)))
)
)
;; Aktuellen Textstil setzen
(setvar "TEXTSTYLE" style-name)
style-name
)
;; Allgemeine Nummerierung: Naechste freie Nummer fuer einen Komponententyp ermitteln
;; blockprefix = Blockname-Praefix fuer ssget (z.B. "KREISEL_*" oder "ECKRAD_*")
;; lastNrVar = Symbol der globalen Zaehler-Variable (z.B. '#Kreisel_LetzteNr)
;; Rueckgabe: naechste freie Nummer (integer)
(defun component-next-number (blockprefix lastNrVar / maxNr tag val ss i ent attribs lastNr result)
(dbgf "component-next-number")
(dbg 'blockprefix)
(dbg 'lastNrVar)
(setq maxNr 0)
(setq lastNr (eval lastNrVar))
(dbgp (strcat "lastNr=" (itoa lastNr)))
(if (setq ss (ssget "_X" (list '(0 . "INSERT") (cons 2 blockprefix))))
(progn
(dbgp (strcat "Gefundene Bloecke: " (itoa (sslength ss))))
(setq i 0)
(repeat (sslength ss)
(setq ent (ssname ss i))
(setq attribs (ssg-attrib-read ent))
(setq tag (cdr (assoc "NUMMER" attribs)))
(if (and tag (setq val (atoi tag)) (> val maxNr))
(setq maxNr val)
)
(setq i (1+ i))
)
)
(dbgp "Keine bestehenden Bloecke gefunden")
)
(if (= maxNr 0)
(setq maxNr lastNr)
)
(set lastNrVar (1+ maxNr))
(setq result (eval lastNrVar))
(dbgp (strcat "Naechste Nummer: " (itoa result)))
(dbgreturn result)
)
;; Wrapper: Naechste Kreisel-Nummer
(defun kreisel-next-number ( / result)
(dbgf "kreisel-next-number")
(setq result (component-next-number "KREISEL_*" '#Kreisel_LetzteNr))
(dbgreturn result)
)
;; Wrapper: Naechste Eckrad-Nummer
(defun eckrad-next-number ( / result)
(dbgf "eckrad-next-number")
(setq result (component-next-number "ECKRAD_*" '#Eckrad_LetzteNr))
(dbgreturn result)
)
;; Beschriftungstext (reiner Kern, in tests/test_unit.lsp getestet):
;; "KREISEL 1: Pufferkreisel PIN_4000" - mit eigenem Namen
;; "KREISEL 1: PIN_4000" - Name leer oder Vorgabe "Kreisel1"
(defun kreisel-label-text (nummer name kreiselart abstand)
(strcat "KREISEL " (itoa nummer) ": "
(if (or (null name) (= name "") (= name (strcat "Kreisel" (itoa nummer))))
""
(strcat name " "))
kreiselart "_" (rtos abstand 2 0))
)
;; Beschriftung in einer BESTEHENDEN Blockdefinition auf textStr setzen.
;; draw-module verwendet eine vorhandene Definition KREISEL_n_TYP_ABSTAND
;; wieder (Edit/Redraw) - ein geaenderter Name kaeme sonst nie in die
;; Beschriftung. Wirkt auf alle Referenzen dieser Definition.
(defun kreisel-label-aktualisieren (bname textStr / e ed)
(setq e (tblobjname "BLOCK" bname))
(while (setq e (entnext e))
(setq ed (entget e))
(if (and (= (cdr (assoc 0 ed)) "TEXT")
(/= (cdr (assoc 1 ed)) textStr))
(entmod (subst (cons 1 textStr) (assoc 1 ed) ed))
)
)
)
;; Beschriftungstext erzeugen
(defun kreisel-make-label (nummer abstand kreiselart name / textStr insertPoint radius mitteX mitteY textHoehe lay)
(setq textStr (kreisel-label-text nummer name kreiselart abstand))
;; Geometrie berechnen
(setq radius (/ *kreisel-durchmesser* 2.0))
;; Mitte zwischen AN8 und SP8 (X-Mitte des gesamten Kreisels)
(setq mitteX (+ radius (/ abstand 2.0)))
;; Y-Position: Leicht über der mitteX
(setq mitteY *kreisel-beschriftung-abstand-oben*)
;; Texthöhe
(setq textHoehe *kreisel-beschriftung-hoehe*) ;; 100 mm
;; Position
(setq insertPoint (list mitteX mitteY 0))
;; Schriftart Arial einstellen
(kreisel-setup-textstyle)
;; Layer erstellen: bevorzugt aus cfg/layer.cfg (Baugruppe
;; "kreisel_beschriftung"), sonst der bisherige Hartwert.
(setq lay (ssg-layer-anlegen "kreisel_beschriftung" T))
(if (null lay)
(progn
(setq lay *kreisel-beschriftung-layer*)
(ssg-make-layer lay (itoa *kreisel-beschriftung-farbe*) T)
)
)
;; Text mit entmake erstellen (zentriert)
(entmake (list
'(0 . "TEXT")
(cons 8 lay)
(cons 10 insertPoint)
(cons 40 textHoehe)
(cons 1 textStr)
(cons 50 0.0)
(cons 7 "Kreisel_Arial") ;; Arial Textstil
(cons 62 *kreisel-beschriftung-farbe*)
'(72 . 1) ;; Horizontale Ausrichtung: Mitte
'(73 . 2) ;; Vertikale Ausrichtung: Mitte
(cons 11 insertPoint) ;; Ausrichtungspunkt
))
(princ (ssg-textf "kreisel-beschriftung-erzeugt" (list textStr (rtos textHoehe 2 0))))
textStr
)
;; ... Rest Ihrer Funktionen (kreisel-ask-typ, kreisel-project-point, etc.)
;; Kreiselart abfragen. Rueckgabe: "PIN" oder "STANDARD"
(defun kreisel-ask-typ ( / typNum typ)
(princ (ssg-text "kreisel-typ-opt-standard"))
(princ (ssg-text "kreisel-typ-opt-pin"))
(princ (ssg-textf "kreisel-typ-prompt" (list (if (= #Kreisel_Typ "PIN") "2" "1"))))
(setq typNum (getstring ""))
(cond
((= typNum "2") (setq typ "PIN"))
(t (setq typ "STANDARD"))
)
(setq #Kreisel_Typ typ)
typ
)
;; Punkt auf Gerade projizieren (Fusspunkt der Senkrechten)
(defun kreisel-project-point (pt lstart lend / dx dy tval)
(setq dx (- (car lend) (car lstart))
dy (- (cadr lend) (cadr lstart)))
(setq tval (/ (+ (* (- (car pt) (car lstart)) dx)
(* (- (cadr pt) (cadr lstart)) dy))
(+ (* dx dx) (* dy dy))))
(list (+ (car lstart) (* tval dx))
(+ (cadr lstart) (* tval dy)))
)
;; Linien-Endpunkte aus LINE-Entity lesen. Rueckgabe: ((sx sy sz) (ex ey ez))
(defun kreisel-get-line-pts (ent / ed p10 p11)
(setq ed (entget ent))
(setq p10 (cdr (assoc 10 ed))
p11 (cdr (assoc 11 ed)))
(list p10 p11)
)
;; Pruefen ob zwei Richtungsvektoren parallel sind
(defun kreisel-parallel-p (d1 d2 / cross len1 len2)
(setq cross (abs (- (* (car d1) (cadr d2)) (* (cadr d1) (car d2))))
len1 (sqrt (+ (* (car d1) (car d1)) (* (cadr d1) (cadr d1))))
len2 (sqrt (+ (* (car d2) (car d2)) (* (cadr d2) (cadr d2)))))
(< (/ cross (* len1 len2)) (ssg-cfg-or "kreisel" "toleranz_kollinear" 0.01))
)
;; Attribut-Funktionen: ssg-attrib-read, ssg-attrib-merge,
;; ssg-attrib-defaults, ssg-attrib-make-defs aus ssg_core.lsp
;; ============================================================
;; TEIL 3: COMPOUND BLOCK ERZEUGEN UND EINFUEGEN
;; ============================================================
;; Zeichnet Kreisel-Geometrie bei (0,0), erzeugt Block mit Attributen,
;; fuegt ihn ein und setzt Attribut-Werte.
;;
;; basePoint = Einfuegepunkt (2D-Liste), AN-Seite
;; abstand = Tangentenlaenge zwischen Kreismitten
;; rotation = Einfuegewinkel in Grad (0=rechts, 90=oben, 180=links, 270=unten)
;; attribs = alist mit Attribut-Ueberschreibungen (nil = alles Defaults)
;; ABSTAND und DREHUNG werden automatisch aus den Parametern gesetzt.
;; KREISELART bestimmt ob PIN-Linien gezeichnet werden.
;;
;; Blockgeometrie (bei Rotation 0, horizontal):
;; Basispunkt (0,0) = linke Kreistangente (AN-Seite)
;; AN8 Zentrum bei (radius, 0)
;; SP8 Zentrum bei (radius+abstand, 0)
;; Gesamtbreite = durchmesser + abstand
;;
;; Rueckgabe: Entity-Name des eingefuegten Blocks
(defun draw-module (basePoint abstand rotation attribs / lastEnt ss e bname
radius pin-y is-pin
oldAttreq oldAttdia
kreisel-nummer block-exists
z-hoehe block-hoehe
insertPoint block-ent
att-entity att-data att-tag new-value
beforeAtt)
;; Attribute vorbereiten
(setq attribs (ssg-attrib-merge attribs *kreisel-attrib-defs*))
(setq attribs (subst (cons "ABSTAND" (rtos abstand 2 0))
(assoc "ABSTAND" attribs) attribs))
(setq attribs (subst (cons "DREHUNG" (rtos rotation 2 1))
(assoc "DREHUNG" attribs) attribs))
(setq attribs (subst (cons "HOEHE" (rtos (if (caddr basePoint) (caddr basePoint) 0.0) 2 1))
(assoc "HOEHE" attribs) attribs))
(setq is-pin (equal (cdr (assoc "KREISELART" attribs)) "PIN"))
;; NUMMER: Bestehende beibehalten (Redraw/Edit), sonst neue vergeben
(setq kreisel-nummer (atoi (cdr (assoc "NUMMER" attribs))))
(if (<= kreisel-nummer 0)
(progn
(setq kreisel-nummer (kreisel-next-number))
(setq attribs (subst (cons "NUMMER" (itoa kreisel-nummer))
(assoc "NUMMER" attribs) attribs))
)
)
;; Bezeichnung: eigener Name (KreiselEdit) bleibt erhalten, sonst Vorgabe "KreiselN"
(if (member (cdr (assoc "Bezeichnung" attribs)) '(nil ""))
(setq attribs (subst (cons "Bezeichnung" (strcat "Kreisel" (itoa kreisel-nummer)))
(assoc "Bezeichnung" attribs) attribs))
)
;; --- HÖHE BESTIMMEN ---
;; Priorität 1: Aus basePoint (wenn 3D Punkt mit Z > 0)
;; Priorität 2: Aus Attribut HOEHE (wenn vorhanden)
;; Priorität 3: Default 0
(if (and basePoint (caddr basePoint) (> (caddr basePoint) 0))
(progn
(setq z-hoehe (caddr basePoint))
(setq block-hoehe (rtos z-hoehe 2 0))
(princ (ssg-textf "kreisel-hoehe-aus-basispunkt" (list block-hoehe)))
)
(progn
;; Höhe aus Attributen lesen
(setq block-hoehe (cdr (assoc "HOEHE" attribs)))
(if (or (null block-hoehe) (= block-hoehe ""))
(setq block-hoehe "0")
)
(setq z-hoehe (atof block-hoehe))
)
)
;; Attribut HOEHE aktualisieren
(setq attribs (subst (cons "HOEHE" block-hoehe)
(assoc "HOEHE" attribs) attribs))
;; Montagehoehe in Metern ableiten (Default = HOEHE / 1000, mm->m).
;; Bleibt ein normales Attribut und kann vom Benutzer geaendert werden.
(setq attribs (subst (cons "MONTAGEHOEHE_m" (rtos (/ z-hoehe 1000.0) 2 3))
(assoc "MONTAGEHOEHE_m" attribs) attribs))
;; Abgeleitete Masse
(setq radius (/ *kreisel-durchmesser* 2.0))
(setq pin-y (- radius *kreisel-pin-abstand*))
;; Blockname Format: KREISEL_1_PIN_2300 oder KREISEL_1_STANDARD_2300
(setq bname (strcat "KREISEL_"
(itoa kreisel-nummer) "_"
(if is-pin "PIN" "STANDARD") "_"
(rtos abstand 2 0)))
;; Blocknamen bereinigen (Punkt durch nichts ersetzen, da wir keine Dezimalstellen wollen)
(setq bname (vl-string-subst "" "." bname))
;; Pruefen ob Block bereits existiert
(setq block-exists (tblsearch "BLOCK" bname))
;; ATTREQ/ATTDIA und OSMODE VOR Sub-Block-Insertions setzen, damit INSERT
;; nicht nach Attributwerten fragt und OSNAP die Koordinaten nicht verschiebt
(setvar "ATTREQ" 0)
(setvar "ATTDIA" 0)
(setvar "OSMODE" 0)
;; --- Geometrie NUR zeichnen, wenn Block noch nicht existiert ---
(if (not block-exists)
(progn
;; WICHTIG: Vor dem Zeichnen den aktuellen letzten Entity merken
;; (SEQEND-Schutz fuer INSERT mit Attributen, nil bei leerer Zeichnung)
(setq lastEnt (ssg-lastent-ohne-attribute))
;; AN8 Kreis (Antriebsstation) bei (radius, 0) - Dim-Suffix im Dateinamen
(command "_.INSERT" (strcat *block-path* "AN8_" *ki-dxfm-dim* ".dwg") (list radius 0.0 0.0) 1 1 0)
;; SP8 Kreis (Spannstation) bei (radius+abstand, 0) - Dim-Suffix im Dateinamen
(command "_.INSERT" (strcat *block-path* "SP8_" *ki-dxfm-dim* ".dwg") (list (+ radius abstand) 0.0 0.0) 1 1 0)
;; Tangenten-Layer: bevorzugt aus cfg/layer.cfg (Baugruppe
;; "kreisel_tangente"), sonst der bisherige Hartwert S_LP.
(if (null (ssg-layer-anlegen "kreisel_tangente" T))
(ssg-make-layer "S_LP" "7" T)
)
(if is-pin
(setvar "CECOLOR" (itoa (ssg-cfg-or "kreisel" "color_linie_1" 5)))
(setvar "CECOLOR" (itoa (ssg-cfg-or "kreisel" "color_linie_2" 1)))
)
;; Obere Tangente
(command "_.LINE" (list radius radius 0) (list (+ radius abstand) radius 0) "")
;; Untere Tangente
(command "_.LINE" (list radius (- radius) 0) (list (+ radius abstand) (- radius) 0) "")
;; PIN-Linien
(if is-pin
(progn
;; PIN-Layer: bevorzugt aus cfg/layer.cfg (Baugruppe
;; "kreisel_pinbereich"), sonst der bisherige Hartwert pinbereich.
(if (null (ssg-layer-anlegen "kreisel_pinbereich" T))
(ssg-make-layer "pinbereich" (itoa (ssg-cfg-or "kreisel" "color_pin" 3)) T)
)
(setvar "CECOLOR" (itoa (ssg-cfg-or "kreisel" "color_pin" 3)))
;; Obere PIN-Linie
(command "_.LINE" (list *kreisel-durchmesser* pin-y 0) (list (float abstand) pin-y 0) "")
;; Untere PIN-Linie
(command "_.LINE" (list *kreisel-durchmesser* (- pin-y) 0) (list (float abstand) (- pin-y) 0) "")
)
)
;; BESCHRIFTUNG einfügen (vor Block-Erzeugung, damit sie im Block ist)
(kreisel-make-label kreisel-nummer abstand (if is-pin "PIN" "STANDARD")
(cdr (assoc "Bezeichnung" attribs)))
;; Unsichtbare Attribut-Definitionen erzeugen
(ssg-attrib-make-defs *kreisel-attrib-defs* 50.0)
;; --- Neue Entities einsammeln ---
(setq ss (ssadd))
;; Korrekte Behandlung wenn lastEnt nil ist (Zeichnung war leer)
(if (null lastEnt)
(setq e (entnext))
(setq e (entnext lastEnt))
)
(while e
(ssadd e ss)
(setq e (entnext e))
)
;; --- Block erzeugen (Entities werden aus Zeichnung entfernt) ---
(if (> (sslength ss) 0)
(command "_.-BLOCK" bname (list 0.0 0.0 0.0) ss "")
(princ (ssg-text "kreisel-fehler-keine-entities"))
)
(princ (ssg-textf "kreisel-neue-blockdef" (list bname)))
)
(progn
(princ (ssg-textf "kreisel-bestehende-blockdef" (list bname)))
;; Beschriftung der wiederverwendeten Definition an den Namen anpassen
(kreisel-label-aktualisieren bname
(kreisel-label-text kreisel-nummer (cdr (assoc "Bezeichnung" attribs))
(if is-pin "PIN" "STANDARD") abstand))
)
)
;; --- Block am Zielpunkt einfuegen (ohne Attribut-Dialog) ---
;; ATTREQ/ATTDIA wurden bereits oben gesetzt
;; Einfügepunkt: X,Y aus basePoint, Z aus ermittelter Höhe
(setq insertPoint (list (car basePoint) (cadr basePoint) z-hoehe))
(command "_.INSERT" bname insertPoint 1 1 rotation)
;; --- Attribut-Werte durch direkte Datenbankänderung setzen ---
(setq block-ent (entlast))
;; Ziel-Layer der Baugruppe aus cfg/layer.cfg. Wichtig: der Wrapper hing
;; bisher am CLAYER-Seiteneffekt von ssg-make-layer (S_LP bzw. pinbereich)
;; und landete bei bereits vorhandener Blockdefinition auf dem aktiven Layer -
;; jetzt ist er in beiden Faellen gleich. Ohne cfg-Eintrag bleibt es beim
;; bisherigen Verhalten.
(ssg-layer-setzen block-ent (if is-pin "kreisel_pin" "kreisel"))
(setq att-entity (entnext block-ent))
(while att-entity
(setq att-data (entget att-entity))
(if (= (cdr (assoc 0 att-data)) "ATTRIB")
(progn
(setq att-tag (cdr (assoc 2 att-data)))
(setq new-value (cdr (assoc att-tag attribs)))
(if new-value
(progn
(setq att-data (subst (cons 1 new-value) (assoc 1 att-data) att-data))
(entmod att-data)
)
)
)
)
(setq att-entity (entnext att-entity))
)
(entupd block-ent)
;; Eindeutige ID zuweisen
(if (atoms-family 1 '("ssg-id-generate"))
(ssg-id-generate block-ent)
)
(princ (ssg-textf "kreisel-eingefuegt" (list (itoa kreisel-nummer) bname block-hoehe)))
(entlast)
)
;; ============================================================
;; TEIL 4: BEFEHLE
;; ============================================================
;; --------------------------------------------
;; KreiselInsert: Manuell Position + Parameter
;; --------------------------------------------
;; --------------------------------------------
;; KreiselInsert: Manuell Position + Parameter
;; --------------------------------------------
(defun c:KreiselInsert ( / pt abstand typ rotation rotStr hoehe
selectedEnt blockAttribs oldOsmode)
(ssg-start (ssg-text "kreisel-start-insert") '(("OSMODE") ("CECOLOR")))
;; Temporär Osnap für Blockerkennung setzen
(setq oldOsmode (getvar "OSMODE"))
(setvar "OSMODE" (logior oldOsmode 512)) ;; 512 = INS (Block-Einfügepunkt)
;; 1. Einfuegepunkt
(setq pt (getpoint (ssg-text "kreisel-prompt-basispunkt")))
(if (null pt)
(progn
(setvar "OSMODE" oldOsmode)
(ssg-end)
(princ (ssg-text "kreisel-abbruch-befehl"))
(princ)
(return)
)
)
;; Osnap zurücksetzen auf den ursprünglichen Wert
(setvar "OSMODE" oldOsmode)
;; 2. Prüfen ob ein Block getroffen wurde
(setq selectedEnt (nentselp pt))
;; --- HÖHE BESTIMMEN ---
(cond
;; Fall 1: Auf einem Kreisel-Block geklickt
((and selectedEnt
(setq selectedEnt (car selectedEnt))
(setq blockAttribs (ssg-attrib-read selectedEnt))
(assoc "HOEHE" blockAttribs))
(setq hoehe (atof (cdr (assoc "HOEHE" blockAttribs))))
(princ (ssg-textf "kreisel-hoehe-von-bestehendem" (list (rtos hoehe 2 0))))
)
;; Fall 2: Punkt hat Z-Koordinate > 0
((and (> (length pt) 2) (> (caddr pt) 0))
(setq hoehe (caddr pt))
(princ (ssg-textf "kreisel-hoehe-aus-3dpunkt" (list (rtos hoehe 2 0))))
)
;; Fall 3: Sonst separat abfragen
(t
(setq hoehe (getreal (ssg-textf "kreisel-prompt-hoehe-z" (list (rtos *kreisel-default-hoehe* 2 0)))))
(if (null hoehe) (setq hoehe *kreisel-default-hoehe*))
)
)
;; 3. Abstand
(initget 6)
(setq abstand (getdist (list (car pt) (cadr pt))
(ssg-textf "kreisel-prompt-abstand" (list (rtos *kreisel-default-laenge* 2 0)))))
(if (null abstand) (setq abstand *kreisel-default-laenge*))
(princ (ssg-textf "kreisel-abstand-ausgabe" (list (rtos abstand 2 0))))
;; 4. Rotation
(setq rotStr (getstring (ssg-text "kreisel-prompt-rotation")))
(if (= rotStr "")
(setq rotation 0.0)
(setq rotation (atof rotStr))
)
;; 5. Kreiselart
(setq typ (kreisel-ask-typ))
(princ (ssg-textf "kreisel-insert-zusammenfassung"
(list (rtos rotation 2 1) (rtos hoehe 2 0) typ)))
;; 6. Modul einfuegen
(draw-module (list (car pt) (cadr pt) hoehe) abstand rotation
(list (cons "KREISELART" typ)
(cons "HOEHE" (rtos hoehe 2 0))))
;; KEIN weiteres (setvar "OSMODE" ...) mehr nötig!
;; ssg-end stellt nur CLAYER und CMDECHO wieder her, nicht OSMODE
(princ (ssg-text "kreisel-insert-fertig"))
(ssg-end)
)
;; -----------------------------------------------
;; KreiselConnect: Linie zeichnen fuer Kreisel-Platzierung
;;
;; Ablauf:
;; 1. Startpunkt anklicken -> aeusserster AN-Punkt (Antriebsstation)
;; 2. Endpunkt anklicken -> aeusserster SP-Punkt (Spannstation)
;; 3. Abstand = Distanz - Durchmesser, Rotation aus Winkel
;; 4. Hoehe aus Z-Koordinate des Startpunkts
;; 5. Nur Kreiselart (PIN/STANDARD) wird abgefragt
;; -----------------------------------------------
(defun c:KreiselConnect ( / ptStart ptEnd dx dy dist abstand rotation typ hoehe)
(ssg-start (ssg-text "kreisel-start-connect") '(("OSMODE") ("CECOLOR")))
(princ (ssg-text "kreisel-connect-header"))
;; 1. Startpunkt (aeusserster Punkt AN-Seite)
(setq ptStart (getpoint (ssg-text "kreisel-prompt-startpunkt")))
(if (null ptStart)
(progn (ssg-end) (princ (ssg-text "kreisel-abgebrochen")) (princ) (exit))
)
;; 2. Endpunkt (aeusserster Punkt SP-Seite) mit Gummiband
(setq ptEnd (getpoint ptStart (ssg-text "kreisel-prompt-endpunkt")))
(if (null ptEnd)
(progn (ssg-end) (princ (ssg-text "kreisel-abgebrochen")) (princ) (exit))
)
;; 3. Geometrie berechnen
(setq dx (- (car ptEnd) (car ptStart))
dy (- (cadr ptEnd) (cadr ptStart)))
(setq dist (sqrt (+ (* dx dx) (* dy dy))))
(setq abstand (- dist *kreisel-durchmesser*))
(if (<= abstand 0.0)
(progn
(ssg-emsg (ssg-textf "kreisel-emsg-distanz-klein"
(list (rtos dist 2 0) (rtos *kreisel-durchmesser* 2 0))))
(ssg-end)
(exit)
)
)
;; 4. Rotation aus Winkel Start->End
(setq rotation (* (/ 180.0 pi) (atan dy dx)))
;; 5. Hoehe aus Z-Koordinate des Startpunkts
(if (and (> (length ptStart) 2) (caddr ptStart))
(setq hoehe (caddr ptStart))
(setq hoehe 0.0)
)
(if (<= hoehe 0.0)
(progn
(setq hoehe (getreal (ssg-textf "kreisel-prompt-hoehe-z" (list (rtos *kreisel-default-hoehe* 2 0)))))
(if (null hoehe) (setq hoehe *kreisel-default-hoehe*))
)
(princ (ssg-textf "kreisel-hoehe-aus-startpunkt" (list (rtos hoehe 2 0))))
)
;; 6. Kreiselart abfragen
(setq typ (kreisel-ask-typ))
(princ (ssg-textf "kreisel-connect-zusammenfassung"
(list (rtos abstand 2 0) (rtos rotation 2 1) (rtos hoehe 2 0) typ)))
;; 7. Modul einfuegen
(draw-module (list (car ptStart) (cadr ptStart) hoehe) abstand rotation
(list (cons "KREISELART" typ)
(cons "HOEHE" (rtos hoehe 2 0))))
(princ (ssg-text "kreisel-connect-erfolgreich"))
(ssg-end)
)
;; ============================================================
;; Script-Funktionen (ohne User-Interaktion, fuer Tests)
;; ============================================================
;; Kreisel per Script einfuegen (Insert)
;; pt : Einfuegepunkt (x y z)
;; abstand : Abstand in mm
;; rotation : Drehwinkel in Grad
;; typ : Kreiselart ("STANDARD", "PIN", ...)
;; hoehe : Hoehe in mm (oder nil fuer Z aus pt)
;; drehrichtung : "GUZ"/"UZS" (optional, nil -> Default aus *kreisel-attrib-defs*)
;; Rueckgabe: Entity-Name des erzeugten Blocks oder nil
(defun kreisel-insert-script (pt abstand rotation typ hoehe drehrichtung
/ z blockEnt attribs)
(ssg-start (ssg-text "kreisel-start-script-insert") '(("OSMODE") ("CECOLOR")))
(if (null typ) (setq typ "STANDARD"))
(setq z (if hoehe hoehe
(if (and pt (caddr pt)) (caddr pt) *kreisel-default-hoehe*)))
(setq attribs (list (cons "KREISELART" typ)
(cons "HOEHE" (rtos z 2 0))))
(if drehrichtung
(setq attribs (cons (cons "DREHRICHTUNG" drehrichtung) attribs)))
(setq blockEnt
(draw-module (list (car pt) (cadr pt) z) abstand rotation attribs))
(ssg-end)
blockEnt
)
;; Kreisel per Script einfuegen (Connect: Start- zu Endpunkt)
;; ptStart : Startpunkt (x y z)
;; ptEnd : Endpunkt (x y z)
;; typ : Kreiselart ("STANDARD", "PIN", ...)
;; hoehe : Hoehe in mm (oder nil fuer Z aus ptStart)
;; Rueckgabe: Entity-Name des erzeugten Blocks oder nil
(defun kreisel-connect-script (ptStart ptEnd typ hoehe / dx dy dist abstand rotation z blockEnt)
(ssg-start (ssg-text "kreisel-start-script-connect") '(("OSMODE") ("CECOLOR")))
(if (null typ) (setq typ "STANDARD"))
(setq dx (- (car ptEnd) (car ptStart))
dy (- (cadr ptEnd) (cadr ptStart)))
(setq dist (sqrt (+ (* dx dx) (* dy dy))))
(setq abstand (- dist *kreisel-durchmesser*))
(if (<= abstand 0.0)
(progn (princ (ssg-textf "kreisel-script-distanz-klein" (list (rtos dist 2 0))))
(ssg-end) nil)
(progn
(setq rotation (* (/ 180.0 pi) (atan dy dx)))
(setq z (if hoehe hoehe
(if (and ptStart (caddr ptStart)) (caddr ptStart) *kreisel-default-hoehe*)))
(setq blockEnt
(draw-module (list (car ptStart) (cadr ptStart) z) abstand rotation
(list (cons "KREISELART" typ)
(cons "HOEHE" (rtos z 2 0)))))
(ssg-end) blockEnt))
)
;; Ende kreisel-connect-script
;; Neue Befehle für Beschriftungs-Einstellungen
(defun c:KreiselLabelPos ( / dx dy)
(setq dx (getreal (ssg-textf "kreisel-prompt-x-abstand" (list (rtos *kreisel-beschriftung-abstand-x* 2 0)))))
(if dx (setq *kreisel-beschriftung-abstand-x* dx))
(setq dy (getreal (ssg-textf "kreisel-prompt-y-abstand" (list (rtos *kreisel-beschriftung-abstand-y* 2 0)))))
(if dy (setq *kreisel-beschriftung-abstand-y* dy))
(princ (ssg-textf "kreisel-neue-beschriftungsposition"
(list (rtos *kreisel-beschriftung-abstand-x* 2 0) (rtos *kreisel-beschriftung-abstand-y* 2 0))))
(princ)
)
(defun c:KreiselLabelHoehe ( / h)
(setq h (getreal (ssg-textf "kreisel-prompt-texthoehe" (list (rtos *kreisel-beschriftung-hoehe* 2 0)))))
(if h (setq *kreisel-beschriftung-hoehe* h))
(princ (ssg-textf "kreisel-neue-texthoehe" (list (rtos *kreisel-beschriftung-hoehe* 2 0))))
(princ)
)
;; -----------------------------------------------
;; KreiselRedraw: Bestehenden Kreisel neu zeichnen
;;
;; Liest Attribute aus dem bestehenden Block,
;; loescht ihn, und zeichnet ihn mit (optional
;; geaendertem) Abstand neu. Alle Attribute bleiben
;; erhalten.
;; -----------------------------------------------
(defun c:KreiselRedraw ( / sel ent ed attribs basePoint rotation newAbstand)
(ssg-start (ssg-text "kreisel-start-redraw") '(("CECOLOR")))
;; 1. Bestehenden Kreisel-Block auswaehlen
(setq sel (entsel (ssg-text "kreisel-prompt-block-auswaehlen")))
(if (null sel) (exit))
(setq ent (car sel))
(setq ed (entget ent))
;; Pruefen ob INSERT
(if (/= (cdr (assoc 0 ed)) "INSERT")
(progn (ssg-emsg (ssg-text "kreisel-emsg-kein-block")) (exit))
)
;; 2. Bestehende Werte auslesen
(setq attribs (ssg-attrib-read ent))
(setq basePoint (cdr (assoc 10 ed)))
(setq rotation (* (/ 180.0 pi) (cdr (assoc 50 ed))))
;; NEU - Höhe aus Attributen lesen und anzeigen:
(princ (ssg-textf "kreisel-redraw-bestehend"
(list (cdr (assoc "ABSTAND" attribs))
(cdr (assoc "DREHUNG" attribs))
(cdr (assoc "HOEHE" attribs))
(cdr (assoc "KREISELART" attribs)))))
;; 3. Neuen Abstand abfragen (Enter = beibehalten)
(initget 6)
(setq newAbstand (getdist (ssg-textf "kreisel-prompt-neuer-abstand" (list (cdr (assoc "ABSTAND" attribs))))))
(if (null newAbstand)
(setq newAbstand (atof (cdr (assoc "ABSTAND" attribs))))
)
;; NEU - Neue Höhe abfragen:
(setq newHoehe (getreal (ssg-textf "kreisel-prompt-neue-hoehe" (list (cdr (assoc "HOEHE" attribs))))))
(if (null newHoehe)
(setq newHoehe (atof (cdr (assoc "HOEHE" attribs))))
)
;; 4. Alten Block loeschen
(command "_.ERASE" ent "")
;; 5. Neu zeichnen mit bestehenden Attributen + neuem Abstand
(draw-module (list (car basePoint) (cadr basePoint) newHoehe)
newAbstand rotation attribs)
(princ (ssg-textf "kreisel-redraw-fertig" (list (rtos newAbstand 2 0))))
(ssg-end)
)
;; --------------------------------------------
;; KreiselQuick: Schnell mit Defaults (horizontal)
;; --------------------------------------------
(defun c:KreiselQuick ( / pt)
(ssg-start (ssg-text "kreisel-start-quick") '(("CECOLOR")))
(setq pt (getpoint (ssg-text "kreisel-prompt-basispunkt")))
;; NEU - Höhe abfragen:
(setq hoehe (getreal (ssg-textf "kreisel-prompt-hoehe-z" (list "0"))))
(if (null hoehe) (setq hoehe 0.0))
(if pt
;; NEU - Höhe im Aufruf übergeben:
(draw-module (list (car pt) (cadr pt) hoehe) *kreisel-default-laenge* 0.0
(list (cons "HOEHE" (rtos hoehe 2 0))))
)
(princ (ssg-text "kreisel-quick-fertig"))
(ssg-end)
)
;; ============================================================
;; TEIL 5: KREISEL BEARBEITEN (DCL-Dialog)
;; ============================================================
;; Ausrichtungs-Definitionen: ((Label Rotation) ...)
;; Rotation in Grad: 0=rechts, 90=oben, 180=links, 270=unten
(setq *kreisel-ausrichtungen*
'(("Horizontal MS" 0.0)
("Horizontal SM" 180.0)
("Vertikal MS" 90.0)
("Vertikal SM" 270.0))
)
;; Rotation (Grad) -> Ausrichtungs-Index (fuer popup_list)
(defun kreisel-rotation-to-idx (rot / idx i entry diff)
(setq idx 0 i 0)
(foreach entry *kreisel-ausrichtungen*
(setq diff (abs (- (rem (+ rot 360.0) 360.0)
(rem (+ (cadr entry) 360.0) 360.0))))
(if (< diff (ssg-cfg-or "kreisel" "toleranz_winkel" 1.0)) (setq idx i))
(setq i (1+ i))
)
idx
)
;; Ausrichtungs-Index -> Rotation (Grad)
(defun kreisel-idx-to-rotation (idx)
(cadr (nth idx *kreisel-ausrichtungen*))
)
;; -----------------------------------------------
;; KreiselEdit: Bestehenden Kreisel per Dialog bearbeiten
;;
;; Ablauf:
;; 1. Kreisel-Block auswaehlen (oder vorselektiert)
;; 2. DCL-Dialog mit aktuellen Werten oeffnen
;; 3. Bei OK: Block loeschen und mit neuen Werten neu zeichnen
;; -----------------------------------------------
(defun c:KreiselEdit ( / sel ss ent ed attribs basePoint rotation
dcl-pfad dat ergebnis
dlg-name dlg-abstand dlg-hoehe dlg-ausrichtung
dlg-drehrichtung dlg-kreiselart dlg-geruest-einzelmodul
dlg-geruest-typ
newAbstand newRotation ausrichtLabels)
;; Implied Selection VOR ssg-start pruefen (ssg-start hebt Selektion auf)
(setq ss (ssget "I"))
(if (and ss (= (sslength ss) 1)
(= (cdr (assoc 0 (entget (ssname ss 0)))) "INSERT"))
(setq ent (ssname ss 0))
)
(ssg-start (ssg-text "kreisel-start-edit") '(("OSMODE") ("CECOLOR") ("ATTREQ") ("ATTDIA")))
(setvar "OSMODE" 0)
;; 1. Block auswaehlen (falls nicht vorselektiert)
(if (null ent)
(progn
(setq sel (entsel (ssg-text "kreisel-prompt-block-auswaehlen")))
(if sel (setq ent (car sel)))
)
)
(if (null ent) (progn (ssg-end) (exit)))
(setq ed (entget ent))
(if (/= (cdr (assoc 0 ed)) "INSERT")
(progn (ssg-emsg (ssg-text "kreisel-emsg-kein-block")) (ssg-end) (exit))
)
;; 2. Bestehende Werte auslesen
(setq attribs (ssg-attrib-read ent))
(setq basePoint (cdr (assoc 10 ed)))
(setq rotation (* (/ 180.0 pi) (cdr (assoc 50 ed))))
;; Pruefen ob Block Kreisel-Attribute hat (mindestens ABSTAND)
(if (null (assoc "ABSTAND" attribs))
(progn
(ssg-emsg (ssg-text "kreisel-emsg-kein-kreisel-block"))
(ssg-end)
(exit)
)
)
;; Fehlende Attribute mit Defaults auffuellen
(foreach def *kreisel-attrib-defs*
(if (null (assoc (car def) attribs))
(setq attribs (append attribs (list (cons (car def) (cadr def)))))
)
)
;; HOEHE immer aus Z-Koordinate des Einfuegepunkts befuellen
(setq attribs (subst (cons "HOEHE" (rtos (if (caddr basePoint) (caddr basePoint) 0.0) 2 1))
(assoc "HOEHE" attribs) attribs))
(princ (ssg-textf "kreisel-edit-bestehend"
(list (cdr (assoc "ABSTAND" attribs)) (rtos rotation 2 1) (cdr (assoc "KREISELART" attribs)))))
;; 3. DCL-Dialog laden
(setq dcl-pfad (strcat (getenv "DXFM_DCL") "/kreisel_edit.dcl"))
(setq dat (load_dialog dcl-pfad))
(if (not (new_dialog "kreisel_edit" dat))
(progn (alert (ssg-textf "kreisel-edit-dialog-fehlt" (list dcl-pfad))) (ssg-end) (exit))
)
;; Ausrichtungs-Labels fuer popup_list aufbauen
(setq ausrichtLabels "")
(foreach entry *kreisel-ausrichtungen*
(if (= ausrichtLabels "")
(setq ausrichtLabels (car entry))
(setq ausrichtLabels (strcat ausrichtLabels "\n" (car entry)))
)
)
;; Tiles initialisieren
(set_tile "name" (cdr (assoc "Bezeichnung" attribs)))
(set_tile "abstand" (cdr (assoc "ABSTAND" attribs)))
(set_tile "hoehe" (cdr (assoc "HOEHE" attribs)))
(start_list "ausrichtung")
(foreach entry *kreisel-ausrichtungen*
(add_list (car entry))
)
(end_list)
(set_tile "ausrichtung" (itoa (kreisel-rotation-to-idx rotation)))
(start_list "drehrichtung")
(add_list "UZS")
(add_list "GUZ")
(end_list)
(set_tile "drehrichtung" (if (equal (cdr (assoc "DREHRICHTUNG" attribs)) "GUZ") "1" "0"))
(start_list "kreiselart")
(add_list "STANDARD")
(add_list "PIN")
(end_list)
(set_tile "kreiselart" (if (equal (cdr (assoc "KREISELART" attribs)) "PIN") "1" "0"))
(set_tile "geruest_einzelmodul"
(if (equal (cdr (assoc "GERUEST_EINZELMODUL" attribs)) "1") "1" "0"))
(start_list "geruest_typ")
(foreach opt *ssg-geruest-optionen* (add_list opt))
(end_list)
(set_tile "geruest_typ" (itoa (ssg-geruest-typ-to-idx (cdr (assoc "GERUEST_TYP" attribs)))))
;; Actions
(action_tile "accept"
(strcat
"(setq dlg-name (get_tile \"name\"))"
"(setq dlg-abstand (get_tile \"abstand\"))"
"(setq dlg-hoehe (get_tile \"hoehe\"))"
"(setq dlg-ausrichtung (get_tile \"ausrichtung\"))"
"(setq dlg-drehrichtung (get_tile \"drehrichtung\"))"
"(setq dlg-kreiselart (get_tile \"kreiselart\"))"
"(setq dlg-geruest-einzelmodul (get_tile \"geruest_einzelmodul\"))"
"(setq dlg-geruest-typ (get_tile \"geruest_typ\"))"
"(done_dialog 1)"
)
)
(action_tile "cancel" "(done_dialog 0)")
(setq ergebnis (start_dialog))
(unload_dialog dat)
;; 4. Bei OK: Block loeschen und neu zeichnen
(if (= ergebnis 1)
(progn
;; Werte aufbereiten
(setq newAbstand (atof dlg-abstand))
(setq newRotation (kreisel-idx-to-rotation (atoi dlg-ausrichtung)))
;; Attribute aktualisieren
(setq attribs (subst (cons "Bezeichnung" dlg-name)
(assoc "Bezeichnung" attribs) attribs))
(setq attribs (subst (cons "HOEHE" dlg-hoehe)
(assoc "HOEHE" attribs) attribs))
(setq attribs (subst (cons "KREISELART"
(if (= dlg-kreiselart "1") "PIN" "STANDARD"))
(assoc "KREISELART" attribs) attribs))
(setq attribs (subst (cons "DREHRICHTUNG"
(if (= dlg-drehrichtung "1") "GUZ" "UZS"))
(assoc "DREHRICHTUNG" attribs) attribs))
(setq attribs (subst (cons "GERUEST_EINZELMODUL" dlg-geruest-einzelmodul)
(assoc "GERUEST_EINZELMODUL" attribs) attribs))
(setq attribs (subst (cons "GERUEST_TYP" (ssg-geruest-idx-to-typ (atoi dlg-geruest-typ)))
(assoc "GERUEST_TYP" attribs) attribs))
;; Alten Block loeschen
(command "_.ERASE" ent "")
;; Neu zeichnen mit Z-Koordinate aus Hoehe-Dialogwert
(draw-module (list (car basePoint) (cadr basePoint) (atof dlg-hoehe))
newAbstand newRotation attribs)
(princ (ssg-textf "kreisel-edit-aktualisiert"
(list dlg-name (rtos newAbstand 2 0) dlg-hoehe (rtos newRotation 2 1))))
)
(princ (ssg-text "kreisel-abgebrochen"))
)
(ssg-end)
)
;; --------------------------------------------
;; KreiselParams: Aktuelle Parameter anzeigen
;; --------------------------------------------
(defun c:KreiselParams ()
(princ (ssg-text "kreisel-params-header"))
(princ (ssg-textf "kreisel-params-typ" (list #Kreisel_Typ)))
(princ (ssg-textf "kreisel-params-durchmesser" (list (rtos *kreisel-durchmesser* 2 0))))
(princ (ssg-textf "kreisel-params-default-laenge" (list (rtos *kreisel-default-laenge* 2 0))))
;; NEU - Default-Höhe anzeigen:
(princ (ssg-textf "kreisel-params-default-hoehe" (list (rtos *kreisel-default-hoehe* 2 0))))
(princ (ssg-text "kreisel-params-attribute-header"))
(foreach def *kreisel-attrib-defs*
(princ (strcat "\n " (car def) " = " (cadr def)))
)
(princ "\n=========================\n")
(princ)
)
;; --------------------------------------------
;; ILS_Eckrad: Befehl - fragt Eingaben ab und fuegt Eckrad ein
;;
;; Ablauf:
;; 1. Beruehrpunkt anklicken (wo der Kreis tangential anliegen soll)
;; 2. Richtungspunkt anklicken (bestimmt Versatzrichtung zum Kreismittelpunkt)
;; 3. Kreismittelpunkt = Beruehrpunkt + Radius in Richtung des 2. Klicks
;; 4. Hoehe aus Z-Koordinate oder manuell
;; --------------------------------------------
(defun c:ILS_Eckrad ( / ptTangent ptDir dx dy dist ux uy radius
centerPt rotation hoehe hoehe-aus-z attribs ergebnis
geruest-einzelmodul geruest-typ)
(dbgf "c:ILS_Eckrad")
;; 1. Beruehrpunkt (Tangentenpunkt)
(setq ptTangent (getpoint (ssg-text "kreisel-eckrad-beruehrpunkt")))
(if (null ptTangent) (progn (dbgreturn nil) (exit)))
(dbg 'ptTangent)
;; 2. Richtungspunkt (Gummiband vom Beruehrpunkt)
(setq ptDir (getpoint ptTangent (ssg-text "kreisel-eckrad-richtung")))
(if (null ptDir) (progn (dbgreturn nil) (exit)))
(dbg 'ptDir)
;; 3. Winkel und Versatz berechnen
(setq dx (- (car ptDir) (car ptTangent))
dy (- (cadr ptDir) (cadr ptTangent)))
(setq dist (sqrt (+ (* dx dx) (* dy dy))))
(if (<= dist (ssg-cfg-or "kreisel" "toleranz_min_distanz" 0.001))
(progn
(princ (ssg-text "kreisel-eckrad-fehler-identisch"))
(dbgreturn nil)
(exit)
)
)
;; Einheitsvektor in Richtung Beruehrpunkt -> Richtungspunkt
(setq ux (/ dx dist)
uy (/ dy dist))
;; Radius = halber Kreisdurchmesser
(setq radius (/ *kreisel-durchmesser* 2.0))
;; Kreismittelpunkt = Beruehrpunkt + Radius * Richtung
(setq centerPt (list (+ (car ptTangent) (* radius ux))
(+ (cadr ptTangent) (* radius uy))))
(dbg 'centerPt)
;; Rotation = Winkel der Versatzrichtung
(setq rotation (* (/ 180.0 pi) (atan dy dx)))
(dbg 'rotation)
;; 4. Hoehe vorbelegen: aus Z des Beruehrpunkts, sonst Default
(setq hoehe-aus-z (and (> (length ptTangent) 2) (caddr ptTangent) (> (caddr ptTangent) 0)))
(if hoehe-aus-z
(progn
(setq hoehe (caddr ptTangent))
(princ (ssg-textf "kreisel-hoehe-aus-3dpunkt" (list (rtos hoehe 2 0))))
)
(setq hoehe *eckrad-default-hoehe*)
)
(dbg 'hoehe)
(if (ssg-gui-p)
;; 5a. Dialog: Bezeichnung, Hoehe, Drehung, Drehrichtung, Geruest
(progn
(setq attribs (ssg-attrib-merge (list (cons "HOEHE" (rtos hoehe 2 0)))
*eckrad-attrib-defs*))
(setq ergebnis (eckrad-dialog attribs rotation))
(if (null ergebnis)
(progn (princ (ssg-text "kreisel-abgebrochen")) (dbgreturn nil) (exit))
)
(setq attribs (car ergebnis)
rotation (cdr ergebnis)
hoehe (atof (cdr (assoc "HOEHE" attribs))))
)
;; 5b. Ohne GUI (Tests): Konsolenabfrage wie bisher
(progn
(if (not hoehe-aus-z)
(progn
(setq hoehe (getreal (ssg-textf "kreisel-prompt-hoehe-z" (list (rtos *eckrad-default-hoehe* 2 0)))))
(if (null hoehe) (setq hoehe *eckrad-default-hoehe*))
)
)
(setq geruest-einzelmodul (if (ssg-ques (ssg-text "kreisel-eckrad-geruest-frage") T) "1" "0"))
(setq geruest-typ (ssg-ask-geruest-typ))
(setq attribs (list (cons "GERUEST_EINZELMODUL" geruest-einzelmodul)
(cons "GERUEST_TYP" geruest-typ)))
)
)
;; 6. Einfuegen (centerPt ist der Kreismittelpunkt)
(ils-eckrad-insert (list (car centerPt) (cadr centerPt) hoehe) rotation attribs)
(dbgreturn nil)
)
;; --------------------------------------------
;; eckrad-dialog-werte: Dialogeingaben -> (attribs . rotation)
;; Reiner Kern (ohne DCL/Zeichnung, in tests/test_unit.lsp getestet).
;; Parameter:
;; attribs - bisherige Attribut-alist ((TAG . WERT) ...)
;; name - Bezeichnung (String)
;; hoehe-str - Hoehe in mm (String aus edit_box)
;; drehung-str - Drehung in Grad (String aus edit_box)
;; drehr-idx - popup_list-Index Drehrichtung ("0"=UZS, "1"=GUZ)
;; einzelmodul - toggle-Wert "0"/"1"
;; geruest-idx - popup_list-Index in *ssg-geruest-optionen* (String)
;; Rueckgabe: (attribs-neu . rotation) oder nil bei ungueltiger Zahl.
;; Drehung wird auf [0, 360) normiert.
;; --------------------------------------------
(defun eckrad-dialog-werte (attribs name hoehe-str drehung-str drehr-idx
einzelmodul geruest-idx / hoehe drehung neu)
(setq hoehe (distof hoehe-str 2)
drehung (distof drehung-str 2))
(if (and hoehe drehung)
(progn
(setq drehung (rem (+ (rem drehung 360.0) 360.0) 360.0))
(setq neu (list (cons "Bezeichnung" name)
(cons "HOEHE" (rtos hoehe 2 0))
(cons "DREHUNG" (rtos drehung 2 1))
(cons "DREHRICHTUNG" (if (= drehr-idx "1") "GUZ" "UZS"))
(cons "GERUEST_EINZELMODUL" (if (= einzelmodul "1") "1" "0"))
(cons "GERUEST_TYP" (ssg-geruest-idx-to-typ (atoi geruest-idx)))))
;; Neue Werte ueber die bestehenden legen (attribs als Default-Schema)
(cons (ssg-attrib-merge neu (mapcar '(lambda (p) (list (car p) (cdr p))) attribs))
drehung)
)
)
)
;; --------------------------------------------
;; eckrad-dialog: DCL-Dialog fuer Einfuegen und Bearbeiten
;; Parameter:
;; attribs - Attribut-alist zur Vorbelegung (mit *eckrad-attrib-defs* gemergt)
;; rotation - aktuelle Drehung in Grad
;; Rueckgabe: (attribs-neu . rotation-neu) oder nil (Abbruch/DCL fehlt)
;; --------------------------------------------
(defun eckrad-dialog (attribs rotation / dcl-pfad dat eckrad-dlg-ergebnis)
(setq attribs (ssg-attrib-merge attribs *eckrad-attrib-defs*))
(setq dcl-pfad (strcat (getenv "DXFM_DCL") "/eckrad_edit.dcl"))
(setq dat (load_dialog dcl-pfad))
(if (or (< dat 0) (not (new_dialog "eckrad_edit" dat)))
(progn
(if (>= dat 0) (unload_dialog dat))
(alert (ssg-textf "kreisel-edit-dialog-fehlt" (list dcl-pfad)))
nil
)
(progn
(set_tile "name" (cdr (assoc "Bezeichnung" attribs)))
(set_tile "hoehe" (cdr (assoc "HOEHE" attribs)))
(set_tile "drehung" (rtos rotation 2 1))
(start_list "drehrichtung")
(add_list "UZS")
(add_list "GUZ")
(end_list)
(set_tile "drehrichtung" (if (equal (cdr (assoc "DREHRICHTUNG" attribs)) "GUZ") "1" "0"))
(set_tile "geruest_einzelmodul"
(if (equal (cdr (assoc "GERUEST_EINZELMODUL" attribs)) "1") "1" "0"))
(start_list "geruest_typ")
(foreach opt *ssg-geruest-optionen* (add_list opt))
(end_list)
(set_tile "geruest_typ" (itoa (ssg-geruest-typ-to-idx (cdr (assoc "GERUEST_TYP" attribs)))))
;; OK nur bei gueltigen Zahlen, sonst Fehlerzeile und Dialog bleibt offen
(action_tile "accept"
(strcat
"(setq eckrad-dlg-ergebnis (eckrad-dialog-werte attribs"
" (get_tile \"name\") (get_tile \"hoehe\") (get_tile \"drehung\")"
" (get_tile \"drehrichtung\") (get_tile \"geruest_einzelmodul\")"
" (get_tile \"geruest_typ\")))"
"(if eckrad-dlg-ergebnis (done_dialog 1)"
" (set_tile \"error\" (ssg-text \"kreisel-eckrad-ungueltige-zahl\")))"
)
)
(action_tile "cancel" "(setq eckrad-dlg-ergebnis nil) (done_dialog 0)")
(start_dialog)
(unload_dialog dat)
eckrad-dlg-ergebnis
)
)
)
;; -----------------------------------------------
;; EckradEdit: Bestehendes Eckrad per Dialog bearbeiten
;; (Doppelklick auf ECKRAD_n ueber SSG_BLOCKEDIT)
;;
;; Ablauf:
;; 1. Eckrad-Block auswaehlen (oder vorselektiert)
;; 2. Dialog mit aktuellen Werten oeffnen
;; 3. Bei OK: Block loeschen und mit gleicher Nummer neu einfuegen
;; -----------------------------------------------
(defun c:EckradEdit ( / ss sel ent ed attribs basePoint rotation ergebnis)
;; Implied Selection VOR ssg-start pruefen (ssg-start hebt Selektion auf)
(setq ss (ssget "I"))
(if (and ss (= (sslength ss) 1)
(= (cdr (assoc 0 (entget (ssname ss 0)))) "INSERT"))
(setq ent (ssname ss 0))
)
(ssg-start (ssg-text "kreisel-start-eckrad-edit") '(("OSMODE") ("CECOLOR") ("ATTREQ") ("ATTDIA")))
(setvar "OSMODE" 0)
(if (null ent)
(progn
(setq sel (entsel (ssg-text "kreisel-prompt-eckrad-auswaehlen")))
(if sel (setq ent (car sel)))
)
)
(if (null ent) (progn (ssg-end) (exit)))
(setq ed (entget ent))
(if (or (/= (cdr (assoc 0 ed)) "INSERT")
(not (wcmatch (strcase (cdr (assoc 2 ed))) "ECKRAD_*")))
(progn (ssg-emsg (ssg-text "kreisel-emsg-kein-eckrad-block")) (ssg-end) (exit))
)
;; Bestehende Werte auslesen, fehlende mit Defaults auffuellen
(setq attribs (ssg-attrib-merge (ssg-attrib-read ent) *eckrad-attrib-defs*))
(setq basePoint (cdr (assoc 10 ed)))
(setq rotation (* (/ 180.0 pi) (cdr (assoc 50 ed))))
;; HOEHE immer aus Z-Koordinate des Einfuegepunkts
(setq attribs (subst (cons "HOEHE" (rtos (if (caddr basePoint) (caddr basePoint) 0.0) 2 0))
(assoc "HOEHE" attribs) attribs))
(setq ergebnis (eckrad-dialog attribs rotation))
(if ergebnis
(progn
(setq attribs (car ergebnis)
rotation (cdr ergebnis))
(command "_.ERASE" ent "")
(ils-eckrad-insert (list (car basePoint) (cadr basePoint)
(atof (cdr (assoc "HOEHE" attribs))))
rotation attribs)
(princ (ssg-textf "kreisel-eckrad-edit-aktualisiert"
(list (cdr (assoc "Bezeichnung" attribs))
(cdr (assoc "HOEHE" attribs))
(rtos rotation 2 1))))
)
(princ (ssg-text "kreisel-abgebrochen"))
)
(ssg-end)
)
;; --------------------------------------------
;; ils-eckrad-insert: Erzeugt Eckrad als Compound-Block mit Attributen
;; Parameter:
;; pt - Einfuegepunkt (Liste x y z)
;; rotation - Drehwinkel in Grad
;; attribs - alist mit Attribut-Ueberschreibungen (nil = Defaults)
;; Rueckgabe: Entity-Name des eingefuegten Blocks
;; --------------------------------------------
(defun ils-eckrad-insert (pt rotation attribs / lastEnt ss e bname
eckrad-nummer block-exists
z-hoehe block-hoehe
insertPoint block-ent
att-entity att-data att-tag new-value)
(dbgf "ils-eckrad-insert")
(dbg 'pt)
(dbg 'rotation)
(ssg-start (ssg-text "kreisel-start-eckrad") '(("ATTREQ") ("ATTDIA") ("OSMODE") ("CECOLOR")))
;; Attribute vorbereiten
(setq attribs (ssg-attrib-merge attribs *eckrad-attrib-defs*))
(setq attribs (subst (cons "DREHUNG" (rtos rotation 2 1))
(assoc "DREHUNG" attribs) attribs))
(dbgp "Attribute nach merge vorbereitet")
;; Hoehe bestimmen
(if (and pt (caddr pt) (> (caddr pt) 0))
(progn
(setq z-hoehe (caddr pt))
(setq block-hoehe (rtos z-hoehe 2 0))
)
(progn
(setq block-hoehe (cdr (assoc "HOEHE" attribs)))
(if (or (null block-hoehe) (= block-hoehe ""))
(setq block-hoehe "0")
)
(setq z-hoehe (atof block-hoehe))
)
)
(setq attribs (subst (cons "HOEHE" block-hoehe)
(assoc "HOEHE" attribs) attribs))
(dbg 'z-hoehe)
(dbg 'block-hoehe)
;; NUMMER: Bestehende beibehalten (EckradEdit), sonst neue vergeben -
;; so behaelt ein bearbeitetes Eckrad seinen Blocknamen ECKRAD_n
(setq eckrad-nummer (atoi (cdr (assoc "NUMMER" attribs))))
(if (<= eckrad-nummer 0)
(progn
(setq eckrad-nummer (eckrad-next-number))
(setq attribs (subst (cons "NUMMER" (itoa eckrad-nummer))
(assoc "NUMMER" attribs) attribs))
)
)
(dbg 'eckrad-nummer)
;; Blockname: ECKRAD_1, ECKRAD_2, ...
(setq bname (strcat "ECKRAD_" (itoa eckrad-nummer)))
(dbg 'bname)
;; Pruefen ob Block bereits existiert
(setq block-exists (tblsearch "BLOCK" bname))
(dbgp (strcat "block-exists=" (if block-exists "JA" "NEIN")))
;; ATTREQ/ATTDIA und OSMODE setzen
(setvar "ATTREQ" 0)
(setvar "ATTDIA" 0)
(setvar "OSMODE" 0)
;; --- Geometrie NUR zeichnen, wenn Block noch nicht existiert ---
(if (not block-exists)
(progn
(dbgp "Erzeuge neue Blockdefinition...")
;; Letzten Entity merken (mit SEQEND-Schutz wie bei draw-module)
(setq lastEnt (ssg-lastent-ohne-attribute))
(if lastEnt
(dbgp (strcat "lastEnt Typ=" (cdr (assoc 0 (entget lastEnt))))))
;; AN8 Block einfuegen bei (0,0) - Eckrad ist ein einzelner Kreis (Dim-Suffix im Dateinamen)
(dbgp (strcat "INSERT Block: " *block-path* "AN8_" *ki-dxfm-dim* ".dwg"))
(command "_.INSERT" (strcat *block-path* "AN8_" *ki-dxfm-dim* ".dwg") (list 0.0 0.0 0.0) 1 1 0)
;; Unsichtbare Attribut-Definitionen erzeugen
(dbgp (strcat "Erzeuge " (itoa (length *eckrad-attrib-defs*)) " Attribut-Definitionen"))
(ssg-attrib-make-defs *eckrad-attrib-defs* 50.0)
;; Neue Entities einsammeln
(setq ss (ssadd))
(if (null lastEnt)
(setq e (entnext))
(setq e (entnext lastEnt))
)
(while e
(ssadd e ss)
(setq e (entnext e))
)
(dbgp (strcat "Entities eingesammelt: " (itoa (sslength ss))))
;; Block erzeugen
(if (> (sslength ss) 0)
(progn
(command "_.-BLOCK" bname (list 0.0 0.0 0.0) ss "")
(dbgp (strcat "Blockdefinition erzeugt: " bname))
)
(progn
(princ (ssg-text "kreisel-fehler-keine-entities"))
(dbgp "FEHLER: Keine Entities fuer Block!")
)
)
(princ (ssg-textf "kreisel-neue-blockdef" (list bname)))
)
(progn
(princ (ssg-textf "kreisel-bestehende-blockdef" (list bname)))
(dbgp (strcat "Verwende bestehende Blockdefinition: " bname))
)
)
;; Block am Zielpunkt einfuegen
(setq insertPoint (list (car pt) (cadr pt) z-hoehe))
(dbg 'insertPoint)
(dbgp (strcat "INSERT " bname " bei " (rtos (car insertPoint) 2 1)
"," (rtos (cadr insertPoint) 2 1)
"," (rtos (caddr insertPoint) 2 1)
" Rotation=" (rtos rotation 2 1)))
(command "_.INSERT" bname insertPoint 1 1 rotation)
;; Attribut-Werte durch direkte Datenbankaenderung setzen
(setq block-ent (entlast))
;; Ziel-Layer der Baugruppe aus cfg/layer.cfg (der Eckrad-Zweig setzte bisher
;; gar keinen Layer, das ECKRAD_n landete also immer auf Layer "0").
(ssg-layer-setzen block-ent "eckrad")
(setq att-entity (entnext block-ent))
(dbgp "Setze Attribut-Werte:")
(while att-entity
(setq att-data (entget att-entity))
(if (= (cdr (assoc 0 att-data)) "ATTRIB")
(progn
(setq att-tag (cdr (assoc 2 att-data)))
(setq new-value (cdr (assoc att-tag attribs)))
(if new-value
(progn
(dbgp (strcat " " att-tag "=" new-value))
(setq att-data (subst (cons 1 new-value) (assoc 1 att-data) att-data))
(entmod att-data)
)
)
)
)
(setq att-entity (entnext att-entity))
)
(entupd block-ent)
(princ (ssg-textf "kreisel-eckrad-eingefuegt"
(list (itoa eckrad-nummer) bname (rtos (car pt) 2 1) (rtos (cadr pt) 2 1)
(rtos rotation 2 1) block-hoehe)))
(ssg-end)
(dbgreturn (entlast))
)
;; NEU: KreiselLabelSetup - Hier einfügen!
(defun c:KreiselLabelSetup ( / hoehe farbe abstand schriftart)
(setq hoehe (getreal (ssg-textf "kreisel-prompt-schrifthoehe" (list (rtos *kreisel-beschriftung-hoehe* 2 0)))))
(if hoehe (setq *kreisel-beschriftung-hoehe* hoehe))
(setq farbe (getint (ssg-textf "kreisel-prompt-schriftfarbe" (list (itoa *kreisel-beschriftung-farbe*)))))
(if farbe (setq *kreisel-beschriftung-farbe* farbe))
(setq abstand (getreal (ssg-textf "kreisel-prompt-abstand-oben" (list (rtos *kreisel-beschriftung-abstand-oben* 2 0)))))
(if abstand (setq *kreisel-beschriftung-abstand-oben* abstand))
(princ (ssg-textf "kreisel-labelsetup-fertig"
(list (rtos *kreisel-beschriftung-hoehe* 2 0)
(itoa *kreisel-beschriftung-farbe*)
(rtos *kreisel-beschriftung-abstand-oben* 2 0))))
(princ)
)
;; ============================================================
;; TEIL 5: BERUEHRPUNKTE / WEICHEN ZWISCHEN KREISELN UND ECKRAEDERN
;; ============================================================
;; Ermittelt, wo sich Kreisel (KREISEL_n) und Eckraeder (ECKRAD_n) gleicher
;; Hoehe beruehren - dort sitzt eine ILS-Weiche. Gerechnet wird NUR aus den
;; Blockparametern (Einfuegepunkt, Drehung, ABSTAND), nicht aus der
;; gezeichneten Geometrie - dasselbe Modell wie draw-module:
;; Kreisel: Rad AN8 bei P+R(r,0), Rad SP8 bei P+R(r+abstand,0), Laufprofile
;; = die beiden Tangenten bei lokal y=+-r. Frei ist je Rad nur der
;; aeussere Halbkreis (die "drei freien Seiten": vorn + beide
;; Flanken), die innere Haelfte liegt zwischen den Laufprofilen.
;; Eckrad: Vollkreis um P, ganz frei, kein Laufprofil.
;; Paar-Logik:
;; - Mindestabstand der Achsen (Kapsel-Modell) < 2r - tol -> KOLLISION
;; (Rad ragt hinein, Laufprofile kreuzen sich) - keine Weiche.
;; - Sonst je Rad: Rad/Rad mit |Abstand - 2r| <= tol bzw. Rad/Laufprofil
;; mit |Lot - r| <= tol, Beruehrpunkt auf einer freien Radseite ->
;; BERUEHRUNG ("Kreis/Kreis" bzw. "Kreis/Tangente", Namen wie im Python-
;; Export export_neighbors.compute_kreisel_touch_switches).
;; - Beruehren sich nur Laufprofile (Kreisel liegen Seite an Seite) ->
;; KOLLISION "Tangente/Tangente". Rad/Rad an beiden Flanken zaehlt nur bei
;; GLEICH ausgerichteten Raedern als Seite an Seite; in Gegenrichtung
;; (Kreisel seitlich versetzt Ende an Ende) ist es eine Weiche.
;; - Toleranz (toleranz_beruehrung, Standard 10 mm) faengt Zeichenungenauig-
;; keiten ab - gilt fuer Spalt UND Ueberlappung.
;; Die reinen Kerne (kreisel-bp-element/-paar/-berechnen) laufen ohne
;; Zeichnung und sind in tests/test_unit.lsp getestet.
(setq *kreisel-bp-app* "SSG_KR_WEICHE")
;; --- 2D-Vektorhelfer (Punkte als (x y)) ---
(defun kreisel-bp-plus (a b) (list (+ (car a) (car b)) (+ (cadr a) (cadr b))))
(defun kreisel-bp-minus (a b) (list (- (car a) (car b)) (- (cadr a) (cadr b))))
(defun kreisel-bp-mal (a s) (list (* (car a) s) (* (cadr a) s)))
(defun kreisel-bp-dot (a b) (+ (* (car a) (car b)) (* (cadr a) (cadr b))))
(defun kreisel-bp-abst (a b) (distance (list (car a) (cadr a)) (list (car b) (cadr b))))
(defun kreisel-bp-mitte (a b) (kreisel-bp-mal (kreisel-bp-plus a b) 0.5))
;; Element-Record aus Blockparametern (reiner Kern).
;; typ "KREISEL" oder "ECKRAD"
;; p Einfuegepunkt (x y [z]) - Kreisel: AN-seitige Tangente, Eckrad: Mitte
;; z Hoehe (Einfuege-Z)
;; rot Drehung in Grad
;; abstand Achsabstand AN8->SP8 (Kreisel), beim Eckrad ignoriert
;; r Radradius
;; id/handle/name nur zur Ausgabe/Zuordnung
;; Rueckgabe: alist mit "raeder" ((label mitte freie-richtung|nil) ...),
;; "profile" ((p1 p2) (p1 p2)) und "achse" (a b) fuer den Kapsel-Abstand.
(defun kreisel-bp-element (typ p z rot abstand r id handle name / u n p2 a b)
(setq u (list (cos (* pi (/ rot 180.0))) (sin (* pi (/ rot 180.0))))
n (list (- (cadr u)) (car u))
p2 (list (car p) (cadr p)))
(if (= typ "KREISEL")
(progn
(setq a (kreisel-bp-plus p2 (kreisel-bp-mal u r))
b (kreisel-bp-plus p2 (kreisel-bp-mal u (+ r abstand))))
(list (cons "typ" typ) (cons "id" id) (cons "handle" handle) (cons "name" name)
(cons "z" z) (cons "r" r)
(cons "achse" (list a b))
(cons "raeder" (list (list "AN8" a (kreisel-bp-mal u -1.0))
(list "SP8" b u)))
(cons "profile" (list (list (kreisel-bp-plus a (kreisel-bp-mal n r))
(kreisel-bp-plus b (kreisel-bp-mal n r)))
(list (kreisel-bp-minus a (kreisel-bp-mal n r))
(kreisel-bp-minus b (kreisel-bp-mal n r)))))))
(list (cons "typ" typ) (cons "id" id) (cons "handle" handle) (cons "name" name)
(cons "z" z) (cons "r" r)
(cons "achse" (list p2 p2))
(cons "raeder" (list (list "ECKRAD" p2 nil)))
(cons "profile" nil)))
)
(defun kreisel-bp-get (key elem) (cdr (assoc key elem)))
;; Naechstgelegene Punkte zweier Strecken [p1,q1] und [p2,q2] (Ericson,
;; Real-Time Collision Detection - wie export_neighbors._closest_pts_segments).
;; Rueckgabe (c1 c2).
(defun kreisel-bp-naechste-punkte (p1 q1 p2 q2 / eps d1 d2 rr a e f c b den s tt)
(setq eps 1e-9
d1 (kreisel-bp-minus q1 p1)
d2 (kreisel-bp-minus q2 p2)
rr (kreisel-bp-minus p1 p2)
a (kreisel-bp-dot d1 d1)
e (kreisel-bp-dot d2 d2)
f (kreisel-bp-dot d2 rr))
(cond
((and (<= a eps) (<= e eps)) (setq s 0.0 tt 0.0))
((<= a eps) (setq s 0.0 tt (max 0.0 (min 1.0 (/ f e)))))
(t
(setq c (kreisel-bp-dot d1 rr))
(if (<= e eps)
(setq tt 0.0 s (max 0.0 (min 1.0 (/ (- c) a))))
(progn
(setq b (kreisel-bp-dot d1 d2)
den (- (* a e) (* b b)))
(setq s (if (> den eps) (max 0.0 (min 1.0 (/ (- (* b f) (* c e)) den))) 0.0))
(setq tt (/ (+ (* b s) f) e))
(cond
((< tt 0.0) (setq tt 0.0 s (max 0.0 (min 1.0 (/ (- c) a)))))
((> tt 1.0) (setq tt 1.0 s (max 0.0 (min 1.0 (/ (- b c) a)))))
)
)
))
)
(list (kreisel-bp-plus p1 (kreisel-bp-mal d1 s))
(kreisel-bp-plus p2 (kreisel-bp-mal d2 tt)))
)
;; Liegt Punkt pt auf der freien Seite des Rades (label mitte richtung)?
;; Richtung nil = Vollkreis (Eckrad). Die Flanken (90 Grad) zaehlen mit.
(defun kreisel-bp-frei-p (rad pt tol)
(or (null (caddr rad))
(>= (kreisel-bp-dot (kreisel-bp-minus pt (cadr rad)) (caddr rad)) (- tol)))
)
;; Liegt pt genau auf einer Flanke (90 Grad zur Achse) eines Kreiselrades?
;; Dort beginnt das eigene Laufprofil - eine Beruehrung NUR an der Flanke
;; bedeutet parallel aneinanderliegende Kreisel, keine Weiche.
(defun kreisel-bp-flanke-p (rad pt tol)
(and (caddr rad)
(<= (abs (kreisel-bp-dot (kreisel-bp-minus pt (cadr rad)) (caddr rad))) tol))
)
;; Lotfusspunkt von c auf die Strecke (p1 p2). Rueckgabe (t fusspunkt), t
;; unbegrenzt (0 = p1, 1 = p2).
(defun kreisel-bp-lot (c p1 p2 / d l2 tt)
(setq d (kreisel-bp-minus p2 p1)
l2 (kreisel-bp-dot d d))
(setq tt (if (> l2 1e-12) (/ (kreisel-bp-dot (kreisel-bp-minus c p1) d) l2) 0.0))
(list tt (kreisel-bp-plus p1 (kreisel-bp-mal d tt)))
)
;; Ergebnis-Record (reiner Kern)
(defun kreisel-bp-treffer (status art ea eb pt rad-elem rad detail)
(list (cons "status" status) (cons "art" art)
(cons "a" ea) (cons "b" eb)
(cons "p" pt)
(cons "z" (/ (+ (kreisel-bp-get "z" ea) (kreisel-bp-get "z" eb)) 2.0))
(cons "achse_von" rad-elem)
;; Ausrichtung der Weiche: Radiale vom beruehrenden Rad zum Punkt
(cons "achse_rot" (if rad (* (/ 180.0 pi) (angle (cadr rad) pt)) 0.0))
(cons "detail" detail))
)
;; Alle Beruehrungen eines Rades von ew mit Raedern/Profilen von eo.
;; Rueckgabe: Liste von (pt art rad detail).
(defun kreisel-bp-rad-kontakte (ew eo tol / r res d pt lot tt l)
(setq r (kreisel-bp-get "r" ew))
(foreach rad (kreisel-bp-get "raeder" ew)
;; Rad/Rad
(foreach rad2 (kreisel-bp-get "raeder" eo)
(setq d (kreisel-bp-abst (cadr rad) (cadr rad2)))
(if (<= (abs (- d (+ r (kreisel-bp-get "r" eo)))) tol)
(progn
(setq pt (kreisel-bp-mitte (cadr rad) (cadr rad2)))
;; Beide Kreiselraeder nur an der Flanke UND gleich ausgerichtet =
;; Kreisel Seite an Seite. Zeigen die Raeder in Gegenrichtung, stossen
;; die Kreisel seitlich versetzt Ende an Ende (Raeder liegen nebeneinander,
;; die Laufprofile treffen sich nur in einem Punkt) - das ist eine Weiche.
(if (and (kreisel-bp-frei-p rad pt tol) (kreisel-bp-frei-p rad2 pt tol)
(not (and (kreisel-bp-flanke-p rad pt tol)
(kreisel-bp-flanke-p rad2 pt tol)
(> (kreisel-bp-dot (caddr rad) (caddr rad2)) 0.0))))
(setq res (cons (list pt "Kreis/Kreis" rad
(strcat (car rad) "/" (car rad2)))
res))))))
;; Rad/Laufprofil
(foreach pr (kreisel-bp-get "profile" eo)
(setq lot (kreisel-bp-lot (cadr rad) (car pr) (cadr pr))
tt (car lot)
pt (cadr lot)
l (kreisel-bp-abst (car pr) (cadr pr)))
(if (and (> l 0.0)
(>= tt (- (/ tol l))) (<= tt (+ 1.0 (/ tol l)))
(<= (abs (- (kreisel-bp-abst (cadr rad) pt) r)) tol)
(kreisel-bp-frei-p rad pt tol)
;; Flanke an Laufprofil = Profile liegen parallel aufeinander
(not (kreisel-bp-flanke-p rad pt tol)))
(setq res (cons (list pt "Kreis/Tangente" rad (strcat (car rad) "/Profil")) res))))
)
(reverse res)
)
;; Ein Paar pruefen (reiner Kern). Rueckgabe: Liste von Treffer-Records
;; (leer = kein Kontakt). Unterschiedliche Hoehe wird VORHER ausgefiltert.
(defun kreisel-bp-paar (ea eb tol / ac bc cp dmin soll res kont pt doppelt)
(setq ac (kreisel-bp-get "achse" ea)
bc (kreisel-bp-get "achse" eb)
cp (kreisel-bp-naechste-punkte (car ac) (cadr ac) (car bc) (cadr bc))
dmin (kreisel-bp-abst (car cp) (cadr cp))
soll (+ (kreisel-bp-get "r" ea) (kreisel-bp-get "r" eb)))
(cond
;; Weit auseinander - nichts
((> dmin (+ soll tol)) nil)
;; Ueberschneidung - Kollision, keine Weiche
((< dmin (- soll tol))
(list (kreisel-bp-treffer "kollision" "Ueberschneidung" ea eb
(kreisel-bp-mitte (car cp) (cadr cp)) (kreisel-bp-get "id" ea) nil
(strcat "Achsabstand " (rtos dmin 2 1)))))
;; Beruehrung innerhalb Toleranz - Kontaktpunkte aufzaehlen
(t
(foreach k (append
(mapcar '(lambda (x) (cons ea x)) (kreisel-bp-rad-kontakte ea eb tol))
(mapcar '(lambda (x) (cons eb x)) (kreisel-bp-rad-kontakte eb ea tol)))
;; k = (elem pt art rad detail); Dubletten (gleicher Punkt) verwerfen
(setq pt (cadr k) doppelt nil)
(foreach t2 res
(if (<= (kreisel-bp-abst pt (kreisel-bp-get "p" t2)) (+ (* 2.0 tol) 1.0))
(setq doppelt T)))
(if (not doppelt)
(setq res (append res
(list (kreisel-bp-treffer "beruehrung" (nth 2 k) ea eb pt
(kreisel-bp-get "id" (car k)) (nth 3 k) (nth 4 k)))))))
(if res
res
;; Nur Laufprofile liegen aneinander (Seite an Seite) - keine Weiche
(list (kreisel-bp-treffer "kollision" "Tangente/Tangente" ea eb
(kreisel-bp-mitte (car cp) (cadr cp)) (kreisel-bp-get "id" ea) nil
"Laufprofile liegen aneinander"))))
)
)
;; Alle Paare auswerten (reiner Kern).
;; elemente = Liste von kreisel-bp-element-Records
;; Rueckgabe: (beruehrungen kollisionen)
(defun kreisel-bp-berechnen (elemente tol tol-z / rest ea ber kol)
(setq rest elemente)
(while rest
(setq ea (car rest) rest (cdr rest))
(foreach eb rest
(if (<= (abs (- (kreisel-bp-get "z" ea) (kreisel-bp-get "z" eb))) tol-z)
(foreach tr (kreisel-bp-paar ea eb tol)
(if (= (kreisel-bp-get "status" tr) "kollision")
(setq kol (cons tr kol))
(setq ber (cons tr ber)))))))
(list (reverse ber) (reverse kol))
)
;; ABSTAND eines Kreisels: Attribut, sonst letzter Token des Blocknamens
;; KREISEL_n_TYP_ABSTAND (reiner Kern).
(defun kreisel-bp-abstand (attr-wert bname / pos)
(cond
((and attr-wert (> (atof attr-wert) 0.0)) (atof attr-wert))
((setq pos (vl-string-position (ascii "_") bname 0 T))
(atof (substr bname (+ pos 2))))
(t 0.0))
)
;; Toleranzen aus data/json/component_defaults.json (Sektion kreisel)
(defun kreisel-bp-toleranz () (float (ssg-cfg-or "kreisel" "toleranz_beruehrung" 10.0)))
(defun kreisel-bp-toleranz-z () (float (ssg-cfg-or "kreisel" "toleranz_hoehe" 1.0)))
;; Alle KREISEL_n/ECKRAD_n im Modellbereich als Element-Records sammeln.
;; Bloecke auf gefrorenen Layern bleiben aussen vor (wie im Export).
(defun kreisel-bp-elemente-sammeln ( / ss i ent ed bname typ attribs p r res)
(setq r (/ *kreisel-durchmesser* 2.0))
(if (setq ss (ssget "_X" '((0 . "INSERT") (2 . "KREISEL_*,ECKRAD_*") (410 . "Model"))))
(progn
(setq i 0)
(while (setq ent (ssname ss i))
(setq ed (entget ent)
bname (strcase (cdr (assoc 2 ed)))
typ (if (wcmatch bname "KREISEL_*") "KREISEL" "ECKRAD"))
(if (not (and (car (atoms-family 1 '("SSG-ENT-LAYER-GEFROREN-P")))
(ssg-ent-layer-gefroren-p ent)))
(progn
(setq attribs (ssg-attrib-read ent)
p (cdr (assoc 10 ed)))
(setq res (cons (kreisel-bp-element typ p (if (caddr p) (caddr p) 0.0)
(* (/ 180.0 pi) (cdr (assoc 50 ed)))
(if (= typ "KREISEL")
(kreisel-bp-abstand (cdr (assoc "ABSTAND" attribs)) bname)
0.0)
r
(cond ((cdr (assoc "ID" attribs))) (""))
(cdr (assoc 5 ed))
(cond ((cdr (assoc "Bezeichnung" attribs))
(if (= (cdr (assoc "Bezeichnung" attribs)) "")
bname (cdr (assoc "Bezeichnung" attribs))))
(bname)))
res))))
(setq i (1+ i))
)
)
)
(reverse res)
)
;; Einstieg fuer Befehl UND Export: (beruehrungen kollisionen) der Zeichnung
(defun kreisel-bp-ermitteln ()
(kreisel-bp-berechnen (kreisel-bp-elemente-sammeln)
(kreisel-bp-toleranz) (kreisel-bp-toleranz-z))
)
;; Anzeigetext eines Elements: "Kreisel3 (ID 0007)" bzw. ohne ID mit Handle
(defun kreisel-bp-elem-text (e)
(strcat (kreisel-bp-get "name" e)
(if (/= (kreisel-bp-get "id" e) "")
(strcat " (ID " (kreisel-bp-get "id" e) ")")
(strcat " (#" (kreisel-bp-get "handle" e) ")")))
)
;; Alte Marker (Kreise mit XDATA *kreisel-bp-app*) entfernen. Rueckgabe: Anzahl
(defun kreisel-bp-marker-loeschen ( / ss i n)
(setq n 0)
(if (setq ss (ssget "_X" (list '(0 . "CIRCLE") (list -3 (list *kreisel-bp-app*)))))
(progn
(setq i 0)
(while (< i (sslength ss))
(entdel (ssname ss i))
(setq i (1+ i) n (1+ n)))))
n
)
;; Marker-Kreis fuer einen Treffer zeichnen
(defun kreisel-bp-marker (tr lay radius)
(if (not (tblsearch "APPID" *kreisel-bp-app*)) (regapp *kreisel-bp-app*))
(entmake (list '(0 . "CIRCLE") (cons 8 lay)
(list 10 (car (kreisel-bp-get "p" tr)) (cadr (kreisel-bp-get "p" tr))
(kreisel-bp-get "z" tr))
(cons 40 radius)
(list -3 (list *kreisel-bp-app*
(cons 1000 (kreisel-bp-get "status" tr))
(cons 1000 (kreisel-bp-get "art" tr))))))
)
;; Layer fuer Marker: cfg/layer.cfg [allgemein] key, sonst Rueckfall
(defun kreisel-bp-layer (key fallback farbe / lay)
(if (null (setq lay (ssg-layer-anlegen key nil)))
(progn (ssg-make-layer fallback farbe nil) (setq lay fallback)))
lay
)
;; Konsolenzeile fuer einen Treffer
(defun kreisel-bp-zeile (key nr tr)
(princ (ssg-textf key
(list nr
(kreisel-bp-elem-text (kreisel-bp-get "a" tr))
(kreisel-bp-elem-text (kreisel-bp-get "b" tr))
(strcat (kreisel-bp-get "art" tr) ", " (kreisel-bp-get "detail" tr))
(rtos (car (kreisel-bp-get "p" tr)) 2 1)
(rtos (cadr (kreisel-bp-get "p" tr)) 2 1)
(rtos (kreisel-bp-get "z" tr) 2 1))))
)
;; --------------------------------------------
;; KREISEL_WEICHEN: Beruehrpunkte (Weichen) und Kollisionen aller Kreisel/
;; Eckraeder ermitteln, in der Konsole auflisten und als Kreise markieren.
;; Ein erneuter Aufruf ersetzt die Marker des vorigen Laufs.
;; --------------------------------------------
(defun c:KREISEL_WEICHEN ( / erg ber kol nr lay-w lay-k radius)
(ssg-start (ssg-text "kreisel-bp-start") nil)
(setq erg (kreisel-bp-ermitteln)
ber (car erg)
kol (cadr erg))
(dbgmsg (strcat "KREISEL_WEICHEN: " (itoa (length ber)) " Beruehrungen, "
(itoa (length kol)) " Kollisionen"))
(kreisel-bp-marker-loeschen)
(princ (ssg-textf "kreisel-bp-summe"
(list (itoa (length ber)) (itoa (length kol)) (rtos (kreisel-bp-toleranz) 2 1))))
(setq radius (float (ssg-cfg-or "kreisel" "weiche_marker_radius" 50.0)))
(if ber
(setq lay-w (kreisel-bp-layer "kreisel_weiche" "ZZ_Kreisel_Weichen" "4")))
(if kol
(setq lay-k (kreisel-bp-layer "kreisel_kollision" "ZZ_Kreisel_Kollision" "1")))
(setq nr 0)
(foreach tr ber
(setq nr (1+ nr))
(kreisel-bp-zeile "kreisel-bp-zeile" (itoa nr) tr)
(kreisel-bp-marker tr lay-w radius))
(setq nr 0)
(foreach tr kol
(setq nr (1+ nr))
(kreisel-bp-zeile "kreisel-bp-kollision" (itoa nr) tr)
(kreisel-bp-marker tr lay-k (* 2.0 radius)))
(if (or ber kol)
(princ (ssg-textf "kreisel-bp-marker"
(list (itoa (+ (length ber) (length kol)))
(cond (lay-w) (lay-k))))))
(ssg-end)
(princ)
)
(princ "\n>>> KreiselInsert geladen")
(princ)
Reference in New Issue View Git Blame Copy Permalink