mistangl/dxfmakros
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
551f2808d789cb18a0abf0f1ddadea0c686eda4f
dxfmakros/Lisp/GeruestInsert.lsp
T
Michael Stangl 1590f8f7ed feat: GR_-Geruest-Baugruppen in EXPORTCSV/EXPORTSIVAS aufnehmen 
GR_-Bloecke werden jetzt wie BTMT eigenstaendig gesammelt (LISP: neues
pattern_geruest in cfg/export.cfg, csv:collect-export-blocks,
ssg-id-collect-blocks + ID-ATTDEF in *geruest-attrib-defs*) und in beiden
Python-Exporten als eigene TeileArt-Zeile ausgegeben: ARTINR/BEZEICHNUNG/
TEILEART/LAENGE in festen Spalten, restliche Attribute (FARBE/LAYER) im
Merkmale-/details-JSON.

Dabei zwei Bugs behoben, die beim ersten echten GR_-Export sichtbar wurden:
- csv:json-escape nutzte vl-string-subst (ersetzt nur das erste Vorkommen)
  statt des global ersetzenden ssg-str-replace-all - bei Attributwerten mit
  mehreren Anfuehrungszeichen blieb ein Zeichen unescaped und brach die
  JSON-Struktur beim Python-Parsen.
- Gradzeichen (°) in data/json/geruest.json durch "Grad" ersetzt, um das
  Encoding-Risiko (cp1252 vs. UTF-8 beim LISP-Export) zu vermeiden.
2026-09-14 14:22:45 +02:00

489 lines
17 KiB
Common Lisp
Raw Blame History

;; ============================================================
;; GeruestInsert.lsp - Geruest-Baugruppen konfigurieren und einfuegen
;;
;; Liest data/json/geruest.json (rekursiv per ssg-json-laden),
;; laesst den Nutzer im Dialog dcl/geruest.dcl eine Basis-Variante, beliebige
;; Anbauteile, Laenge und Farbe waehlen, und fuegt das Ergebnis als Block
;; GR_<id>_<Zeitstempel> ein.
;;
;; Der Block wird - wie KREISEL_n/VF_n - selbst zusammengebaut: die Dummy-DWG
;; aus data/geruest liefert nur die Geometrie, das Attribut-Schema kommt aus
;; *geruest-attrib-defs*. Damit kann kein Attribut still verlorengehen, wenn
;; die Dummy-DWG einen Tag nicht kennt (ssg-attrib-set-on schreibt nur Tags,
;; die als ATTDEF existieren).
;;
;; Das GR_-Praefix ist nicht kosmetisch: SSG_BLOCKEDIT haelt jeden Block mit
;; TEILEART-Attribut fuer ein Omniflo-Element (SSG_LIB_Commands.lsp). Der
;; Doppelklick-Dispatcher erkennt Geruest-Bloecke an diesem Praefix.
;;
;; Befehle: GERUEST_ROHRABHAENGER, GERUEST_SAEULE_2ZOLL,
;; GERUEST_SAEULE_1ZOLL, GERUEST_WANDBEFESTIGUNG
;; ============================================================
(vl-load-com)
;; Attribut-Schema des Wrapper-Blocks. Die Dummy-DWG darf eigene Tags
;; mitbringen - die bleiben erhalten (ssg-attrib-merge).
;; "ID" (leer vorbelegt, wie bei Kreisel/VF_n/GF_n) ist Voraussetzung dafuer,
;; dass ssg-id-check-all dem Block ueberhaupt eine ID zuweisen kann -
;; ssg-attrib-set-on schreibt nur auf ein bereits vorhandenes ATTDEF, siehe
;; oben. Ohne diesen Eintrag bliebe ID fuer immer leer (csv:read-attribs
;; exportiert dann eben kein "ID"-Feld statt eines Werts).
(if (null *geruest-attrib-defs*)
(setq *geruest-attrib-defs*
'(("ID" "")
("ARTINR" "")
("LAENGE" "")
("BEZEICHNUNG" "")
("TEILEART" "")
("FARBE" "")
("LAYER" "")
)
)
)
(if (null *geruest-block-counter*) (setq *geruest-block-counter* 0))
;; ============================================================
;; DATEN
;; ============================================================
(defun geruest-data-verzeichnis ( / )
(cond
((getenv "DXFM_DATA") (vl-string-translate "\\" "/" (getenv "DXFM_DATA")))
((getenv "DXFMAKRO")
(strcat (vl-string-translate "\\" "/" (getenv "DXFMAKRO")) "/data"))
)
)
(defun geruest-json-pfad ( / basis)
(if (setq basis (geruest-data-verzeichnis))
(strcat basis "/json/geruest.json")
)
)
(defun geruest-dummy-pfad (datei / basis)
(if (and datei (setq basis (geruest-data-verzeichnis)))
(strcat basis "/geruest/" datei)
)
)
;; Datendatei einmal je Zeichnungssitzung laden.
(defun geruest-daten ( / pfad)
(if (null *geruest-daten*)
(progn
(setq pfad (geruest-json-pfad))
(cond
((null pfad) (princ (ssg-text "gr-fehler-datenpfad")))
((null (findfile pfad)) (princ (ssg-textf "gr-fehler-json-fehlt" (list pfad))))
(T
(setq *geruest-daten* (ssg-json-laden pfad))
(if (null *geruest-daten*)
(princ (ssg-textf "gr-fehler-json-lesbar" (list pfad)))
)
)
)
)
)
*geruest-daten*
)
;; Baugruppe ueber ihr ASCII-Feld "id" suchen. Der aeussere JSON-Schluessel
;; ("Rohrabhaenger" mit Umlaut, "2\" Saeulen" mit Anfuehrungszeichen) taugt
;; dafuer nicht - er ist aus ASCII-Quelltext nicht vergleichbar.
(defun geruest-baugruppe (id / erg)
(foreach eintrag (geruest-daten)
;; equal statt = : fehlt einer Baugruppe das id-Feld, liefert ssg-json-get
;; nil - = ist mit nil-Argumenten nicht zuverlaessig.
(if (and (null erg)
(listp (cdr eintrag))
(equal (ssg-json-get (cdr eintrag) "id") id))
(setq erg (cdr eintrag))
)
)
erg
)
;; ============================================================
;; TEILE AUSWERTEN
;; ============================================================
;; Anzeigename eines Eintrags: benannte Gruppe ("name") oder Einzelteil
;; ("artikel").
(defun geruest-eintrag-name (eintrag / n)
(setq n (ssg-json-get eintrag "name"))
(if (and n (= (type n) 'STR) (/= n ""))
n
(ssg-json-get eintrag "artikel")
)
)
(defun geruest-menge (eintrag / m)
(setq m (ssg-json-get eintrag "menge"))
(if (and m (numberp m) (> m 0)) (fix m) 1)
)
;; Sivas-ID als String. Im JSON stehen rein numerische IDs als Zahl
;; (Projektkonvention), zusammengesetzte Codes waeren Strings.
(defun geruest-id-string (wert)
(cond
((null wert) nil)
((= (type wert) 'STR) wert)
((= (type wert) 'INT) (itoa wert))
((= (type wert) 'REAL) (rtos wert 2 0))
)
)
(defun geruest-wiederholen (wert n / erg i)
(setq erg nil i 0)
(if wert
(while (< i n)
(setq erg (cons wert erg))
(setq i (1+ i))
)
)
erg
)
;; Alle Artikelnummern eines Eintrags, jede gemaess "menge" wiederholt.
;; Benannte Gruppen ("teile") werden rekursiv aufgeloest.
(defun geruest-artikelnummern (eintrag / erg teile)
(setq erg nil)
(setq teile (ssg-json-get eintrag "teile"))
(if teile
(foreach teil teile
(setq erg (append erg (geruest-artikelnummern teil)))
)
(setq erg (geruest-wiederholen
(geruest-id-string (ssg-json-get eintrag "sivas_id"))
(geruest-menge eintrag)))
)
erg
)
;; ============================================================
;; DIALOG
;; ============================================================
;; "0 3 5" -> (0 3 5). Rueckgabe von get_tile bei multiple_select.
(defun geruest-indizes (s / erg tok i c)
(setq erg nil tok "" i 1)
(if (null s) (setq s ""))
(while (<= i (strlen s))
(setq c (substr s i 1))
(if (= c " ")
(progn
(if (/= tok "") (setq erg (cons (atoi tok) erg)))
(setq tok "")
)
(setq tok (strcat tok c))
)
(setq i (1+ i))
)
(if (/= tok "") (setq erg (cons (atoi tok) erg)))
(reverse erg)
)
;; Dialog zeigen. Rueckgabe:
;; (variante-index (anbau-indizes) laenge-string farbe-string) oder nil
(defun geruest-dialog (bg / dcl-pfad dat varianten anbauteile attr laenge-def
farb-opts frei-opt fertig rueckgabe ergebnis
dlg-variante dlg-anbau dlg-laenge dlg-farbe dlg-frei
min-l max-l wert-l farbe-txt)
(setq dcl-pfad (strcat (getenv "DXFM_DCL") "/geruest.dcl"))
(setq varianten (ssg-json-get bg "geometrie_varianten"))
(setq anbauteile (ssg-json-get bg "anbaugruppen"))
(setq attr (ssg-json-get bg "attribute"))
(setq laenge-def (if attr (ssg-json-get attr "Laenge")))
(setq farb-opts (if attr (ssg-json-get attr "Farbe")))
(setq min-l (if laenge-def (ssg-json-get laenge-def "min")))
(setq max-l (if laenge-def (ssg-json-get laenge-def "max")))
;; Farboptionen + freie Option ans Listenende; Index davon merkt sich der
;; Callback, um das Freitextfeld freizuschalten.
(setq *geruest-farb-liste* nil *geruest-frei-idx* -1)
(if farb-opts
(progn
(setq *geruest-farb-liste* (ssg-json-get farb-opts "optionen"))
(if (ssg-json-get farb-opts "frei_erlaubt")
(progn
(setq frei-opt (ssg-json-get farb-opts "frei_option"))
(if (null frei-opt) (setq frei-opt "Individuell"))
(setq *geruest-frei-idx* (length *geruest-farb-liste*))
(setq *geruest-farb-liste*
(append *geruest-farb-liste* (list frei-opt)))
)
)
)
)
(setq dlg-variante "0" dlg-anbau "" dlg-laenge "" dlg-farbe "0" dlg-frei "")
(setq fertig nil rueckgabe nil)
;; Schleife, damit der Dialog nach einer ungueltigen Laenge mit den
;; bisherigen Eingaben erneut erscheint (Projektmuster, vgl. vf_linienzug).
(while (not fertig)
(setq dat (load_dialog dcl-pfad))
(if (or (< dat 0) (not (new_dialog "geruest" dat)))
(progn
(alert (ssg-text "gr-fehler-dcl"))
(setq fertig T)
)
(progn
(set_tile "kopf" (ssg-textf "gr-dlg-kopf"
(list (ssg-json-get bg "teileart"))))
(start_list "variante")
(foreach v varianten (add_list (geruest-eintrag-name v)))
(end_list)
(set_tile "variante" dlg-variante)
(start_list "anbau")
(foreach a anbauteile (add_list (geruest-eintrag-name a)))
(end_list)
(if (/= dlg-anbau "") (set_tile "anbau" dlg-anbau))
;; Laenge/Farbe nur bei Baugruppen mit "attribute"-Block
(if laenge-def
(set_tile "laenge" dlg-laenge)
(mode_tile "laenge" 1)
)
(if *geruest-farb-liste*
(progn
(start_list "farbe")
(foreach f *geruest-farb-liste* (add_list f))
(end_list)
(set_tile "farbe" dlg-farbe)
(set_tile "farbe_frei" dlg-frei)
(mode_tile "farbe_frei"
(if (= (atoi dlg-farbe) *geruest-frei-idx*) 0 1))
(action_tile "farbe"
"(mode_tile \"farbe_frei\" (if (= (atoi $value) *geruest-frei-idx*) 0 1))")
)
(progn
(mode_tile "farbe" 1)
(mode_tile "farbe_frei" 1)
)
)
(action_tile "accept"
(strcat "(setq dlg-variante (get_tile \"variante\"))"
"(setq dlg-anbau (get_tile \"anbau\"))"
"(setq dlg-laenge (get_tile \"laenge\"))"
"(setq dlg-farbe (get_tile \"farbe\"))"
"(setq dlg-frei (get_tile \"farbe_frei\"))"
"(done_dialog 1)"))
(action_tile "cancel" "(done_dialog 0)")
(setq ergebnis (start_dialog))
(unload_dialog dat)
(cond
((/= ergebnis 1) (setq fertig T))
;; Laenge pruefen - Bereichspruefung erfolgt im Projekt immer nach
;; done_dialog, DCL kann das nicht.
((and laenge-def
(progn (setq wert-l (atof dlg-laenge))
(or (= (ssg-cfg-trim dlg-laenge) "")
(and min-l (< wert-l min-l))
(and max-l (> wert-l max-l)))))
(alert (ssg-textf "gr-alert-laenge"
(list dlg-laenge
(if min-l (rtos min-l 2 0) "0")
(if max-l (rtos max-l 2 0) "-"))))
)
(T
(setq farbe-txt
(cond
((null *geruest-farb-liste*) "")
((= (atoi dlg-farbe) *geruest-frei-idx*) dlg-frei)
(T (nth (atoi dlg-farbe) *geruest-farb-liste*))
)
)
(setq rueckgabe (list (atoi dlg-variante)
(geruest-indizes dlg-anbau)
(if laenge-def dlg-laenge "")
(if farbe-txt farbe-txt "")))
(setq fertig T)
)
)
)
)
)
rueckgabe
)
;; ============================================================
;; BLOCK BAUEN UND EINFUEGEN
;; ============================================================
;; Eindeutiger Blockname. ssg-timestamp hat Sekundenaufloesung - bei zwei
;; Aufrufen in derselben Sekunde wird ein Zaehler angehaengt (Muster aus
;; OmniModulInsert.lsp).
(defun geruest-blockname (id / bname)
(setq bname (strcat "GR_" id "_" (ssg-timestamp)))
(while (tblsearch "BLOCK" bname)
(setq *geruest-block-counter* (1+ *geruest-block-counter*))
(setq bname (strcat "GR_" id "_" (ssg-timestamp) "_"
(itoa *geruest-block-counter*)))
)
bname
)
;; Dummy-Geometrie + eigene ATTDEFs zu einem Block zusammenfassen und am
;; gewaehlten Punkt einfuegen. werte = alist der berechneten Attributwerte.
;; Rueckgabe: (blockname . entity) oder nil.
(defun geruest-block-bauen (bg werte pt / datei dummy lastEnt dummyEnt e ss
bname blockEnt dummy-attribs attribs)
(setq datei (ssg-json-get bg "dummy"))
(setq dummy (geruest-dummy-pfad datei))
(if (or (null dummy) (null (findfile dummy)))
(progn
(princ (ssg-textf "gr-fehler-dummy" (list (if dummy dummy datei))))
nil
)
(progn
(setvar "ATTREQ" 0)
(setvar "ATTDIA" 0)
(setvar "OSMODE" 0)
(setq lastEnt (entlast))
;; Dummy bei (0,0,0) einfuegen - seine Attribute liefern u.a. die
;; LAYER-Vorgabe.
(command "_.INSERT" dummy (list 0.0 0.0 0.0) 1 1 0)
(setq dummyEnt (entlast))
(setq dummy-attribs (ssg-attrib-read dummyEnt))
;; Unser Schema gewinnt an Struktur, die Dummy-Werte an Inhalt:
;; ssg-attrib-merge legt alle Tags aus *geruest-attrib-defs* an und
;; uebernimmt zusaetzlich alle Tags der Dummy-DWG.
(setq attribs (ssg-attrib-merge dummy-attribs *geruest-attrib-defs*))
(foreach paar werte
(if (assoc (car paar) attribs)
(setq attribs (subst paar (assoc (car paar) attribs) attribs))
(setq attribs (append attribs (list paar)))
)
)
(ssg-attrib-make-defs (ssg-attrib-alist-to-defs attribs) 50.0)
;; Alles Neue seit lastEnt einsammeln (Dummy-INSERT + ATTDEFs)
(setq ss (ssadd))
(setq e (if lastEnt (entnext lastEnt) (entnext)))
(while e
(ssadd e ss)
(setq e (entnext e))
)
(setq bname (geruest-blockname (ssg-json-get bg "id")))
(command "_.-BLOCK" bname (list 0.0 0.0 0.0) ss "")
;; Stand VOR dem Einfuegen merken: bricht der Nutzer die Drehung mit ESC
;; ab, entsteht kein neues INSERT und (entlast) zeigt auf ein voellig
;; fremdes Objekt - ohne diesen Vergleich wuerden dessen Attribute
;; ueberschrieben.
(setq lastEnt (entlast))
;; pause = Drehwinkel interaktiv am Cursor
(command "_.INSERT" bname pt 1 1 pause)
;; Laufende Einfuegung sicher beenden (z.B. ESC waehrend der Drehung)
(if (> (getvar "CMDACTIVE") 0) (command))
(if (> (getvar "CMDACTIVE") 0) (command))
(setq blockEnt (entlast))
(if (and blockEnt (not (eq blockEnt lastEnt))
(= (cdr (assoc 0 (entget blockEnt))) "INSERT"))
(progn
(ssg-attrib-set-on blockEnt attribs)
(ssg-block-layer-vorgabe blockEnt bname attribs)
(cons bname blockEnt)
)
)
)
)
)
;; ============================================================
;; ABLAUF
;; ============================================================
(defun geruest-run (id / bg wahl varianten anbauteile variante gewaehlt
artnr bezeichnung teile-namen werte pt ergebnis)
(setq bg (geruest-baugruppe id))
(cond
((null bg)
(if (geruest-daten) (princ (ssg-textf "gr-fehler-baugruppe" (list id))))
)
((null (setq varianten (ssg-json-get bg "geometrie_varianten")))
(princ (ssg-textf "gr-fehler-keine-varianten" (list id)))
)
(T
(setq anbauteile (ssg-json-get bg "anbaugruppen"))
(setq wahl (geruest-dialog bg))
(if (null wahl)
(princ (ssg-text "gr-abgebrochen"))
(progn
(setq variante (nth (car wahl) varianten))
(setq gewaehlt nil)
(foreach i (cadr wahl)
(if (< i (length anbauteile))
(setq gewaehlt (append gewaehlt (list (nth i anbauteile))))
)
)
;; ARTINR: jede Sivas-ID so oft, wie "menge" es vorgibt
(setq artnr (geruest-artikelnummern variante))
(foreach a gewaehlt
(setq artnr (append artnr (geruest-artikelnummern a)))
)
;; BEZEICHNUNG: mit " + " verketten - die Artikelbezeichnungen
;; enthalten selbst Kommas ("ROHR R 1\" 33,7 x 2,6").
(setq teile-namen (list (ssg-json-get bg "teileart")
(geruest-eintrag-name variante)))
(foreach a gewaehlt
(setq teile-namen (append teile-namen
(list (geruest-eintrag-name a))))
)
(setq bezeichnung (ssg-join teile-namen " + "))
(setq werte (list (cons "ARTINR" (ssg-join artnr ","))
(cons "BEZEICHNUNG" bezeichnung)
(cons "TEILEART" (ssg-json-get bg "teileart"))))
(if (/= (caddr wahl) "")
(setq werte (append werte (list (cons "LAENGE" (caddr wahl))))))
(if (/= (cadddr wahl) "")
(setq werte (append werte (list (cons "FARBE" (cadddr wahl))))))
(setq pt (getpoint (ssg-text "gr-prompt-einfuegepunkt")))
(if (null pt)
(princ (ssg-text "gr-abgebrochen"))
(progn
(ssg-start "Geruest" '(("OSMODE") ("ATTREQ") ("ATTDIA")))
(setq ergebnis (geruest-block-bauen bg werte pt))
(ssg-end)
(if ergebnis
(princ (ssg-textf "gr-fertig"
(list (ssg-json-get bg "teileart") (car ergebnis))))
)
)
)
)
)
)
)
(princ)
)
(defun c:GERUEST_ROHRABHAENGER () (geruest-run "Rohrabhaenger"))
(defun c:GERUEST_SAEULE_2ZOLL () (geruest-run "Saeulen_2Zoll"))
(defun c:GERUEST_SAEULE_1ZOLL () (geruest-run "Saeulen_1Zoll"))
(defun c:GERUEST_WANDBEFESTIGUNG () (geruest-run "Wandbefestigung"))
(princ "\nGeruestInsert.lsp geladen. Befehle: GERUEST_ROHRABHAENGER, GERUEST_SAEULE_2ZOLL, GERUEST_SAEULE_1ZOLL, GERUEST_WANDBEFESTIGUNG")
(princ)
Reference in New Issue View Git Blame Copy Permalink