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

[ADD] Erste Einbindung eines Menüs zum Konfigurieren und Einfügen von Gerüstkomponenten; TODOs: Anzahl der Gerüstkompnenten Variabel machen und für den Benutzer die Anzahl der Baugruppe sichtbar machen; Vorkonfigurierte Baugruppen anbieten; Einfachere Auswahl mit Checkbox oder Input (Anzahl)

Browse Source
This commit is contained in:
Simon Hensch
2026-09-14 12:43:17 +02:00
parent 41419763c0
commit d19bac7a1f
13 changed files with 1524 additions and 128 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Lisp/GeruestInsert.lsp
+482
View File
@@ -0,0 +1,482 @@
;; ============================================================
;; 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).
(if (null *geruest-attrib-defs*)
(setq *geruest-attrib-defs*
'(("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)
Lisp/SSG_LIB_Commands.lsp
+8
View File
@@ -400,6 +400,14 @@
)
)
;; Geruest-Baugruppen -> nativer Attribut-Editor.
;; MUSS vor dem Omniflo-Zweig stehen: Geruest-Bloecke tragen ein
;; TEILEART-Attribut und wuerden dort sonst als Omniflo-Element erkannt.
((wcmatch bname "GR_*")
(princ (ssg-textf "cmd-attribute-bearbeiten" (list bname)))
(command "_.EATTEDIT")
)
;; Omniflo-Bloecke -> OMNI_EDIT
;; Erkennung: TEILEART-Attribut vorhanden, AP110-Blockname oder rein numerisch
((progn
Lisp/ssg_core.lsp
+207
View File
@@ -1561,6 +1561,213 @@
)
;; ------------------------------------------------------------
;; STRING-LISTE VERKETTEN
;; ------------------------------------------------------------
;; (ssg-join '("a" "b" "c") ",") -> "a,b,c"; leere Liste -> "".
;; Alle Elemente muessen Strings sein (Zahlen vorher mit itoa/rtos wandeln).
(defun ssg-join (lst sep / s erst)
(setq s "" erst T)
(foreach x lst
(if erst
(setq s x erst nil)
(setq s (strcat s sep x))
)
)
s
)
;; ------------------------------------------------------------
;; REKURSIVER JSON-PARSER
;; ------------------------------------------------------------
;; Ergaenzung zu ssg-parse-json-array/ssg-cfg-parse-nested, die BEIDE
;; zeilenbasiert und flach arbeiten und daher prinzipiell weder echte
;; Verschachtelung noch mehrzeilige Arrays, maskierte Anfuehrungszeichen
;; (\") oder Kommas innerhalb von Strings lesen koennen. Die beiden alten
;; Parser bleiben unveraendert - ihre Konsumenten (Konfiguration, Sprache,
;; VF-Spec) sind auf ihr Verhalten eingestellt.
;;
;; Abbildung: Objekt -> Alist (("key" . wert) ...), Array -> Liste,
;; String -> STR, Zahl -> INT/REAL, true -> T, false/null -> nil.
;; Da false und null beide nil ergeben, ist "Feld fehlt" nicht von
;; "Feld ist false" unterscheidbar.
;; \uXXXX wird nur fuer ASCII (< 128) aufgeloest, sonst "?" - echte
;; Umlaute stehen in unseren Daten direkt als UTF-8 in der Datei.
(defun ssg-json-zeichen ( / )
(if (<= *ssg-json-pos* *ssg-json-len*)
(substr *ssg-json-txt* *ssg-json-pos* 1)
)
)
(defun ssg-json-weiter ( / )
(setq *ssg-json-pos* (1+ *ssg-json-pos*))
)
(defun ssg-json-leerraum ( / c)
(while (and (setq c (ssg-json-zeichen))
(member c '(" " "\t" "\r" "\n")))
(ssg-json-weiter)
)
)
;; String ab dem oeffnenden Anfuehrungszeichen lesen, Escapes aufloesen.
(defun ssg-json-string ( / c erg fertig code)
(ssg-json-weiter)
(setq erg "" fertig nil)
(while (and (not fertig) (setq c (ssg-json-zeichen)))
(cond
((= c "\"") (setq fertig T) (ssg-json-weiter))
((= c "\\")
(ssg-json-weiter)
(setq c (ssg-json-zeichen))
;; equal statt = : nach dem Backslash kann das Textende erreicht sein
;; (c = nil), und = ist mit nil-Argumenten nicht zuverlaessig.
(cond
((equal c "n") (setq erg (strcat erg "\n")) (ssg-json-weiter))
((equal c "t") (setq erg (strcat erg "\t")) (ssg-json-weiter))
((equal c "r") (setq erg (strcat erg "\r")) (ssg-json-weiter))
;; AutoLISP kennt nur \\ \" \e \n \r \t - Backspace/Seitenvorschub
;; daher ueber chr statt als Escape-Literal.
((equal c "b") (setq erg (strcat erg (chr 8))) (ssg-json-weiter))
((equal c "f") (setq erg (strcat erg (chr 12))) (ssg-json-weiter))
((equal c "u")
(ssg-json-weiter)
(setq code (ssg-json-hex4))
(setq erg (strcat erg (if (< code 128) (chr code) "?")))
)
;; \" \\ \/ und alles andere: Zeichen unveraendert uebernehmen
(c (setq erg (strcat erg c)) (ssg-json-weiter))
)
)
(T (setq erg (strcat erg c)) (ssg-json-weiter))
)
)
erg
)
;; Vier Hex-Ziffern lesen und als Zahl liefern (Position rueckt mit).
(defun ssg-json-hex4 ( / i c code ziffer)
(setq code 0 i 0)
(while (< i 4)
(setq c (ssg-json-zeichen))
(if c
(progn
(setq ziffer
(cond
((and (>= (ascii c) 48) (<= (ascii c) 57)) (- (ascii c) 48))
((and (>= (ascii c) 97) (<= (ascii c) 102)) (+ 10 (- (ascii c) 97)))
((and (>= (ascii c) 65) (<= (ascii c) 70)) (+ 10 (- (ascii c) 65)))
(T 0)
)
)
(setq code (+ (* code 16) ziffer))
(ssg-json-weiter)
)
(setq i 4)
)
(setq i (1+ i))
)
code
)
;; Zahl bzw. true/false/null bis zum naechsten Trennzeichen lesen.
(defun ssg-json-literal ( / start s c)
(setq start *ssg-json-pos*)
(while (and (setq c (ssg-json-zeichen))
(not (member c '("," "}" "]" " " "\t" "\r" "\n"))))
(ssg-json-weiter)
)
(setq s (substr *ssg-json-txt* start (- *ssg-json-pos* start)))
(cond
((= s "true") T)
((= s "false") nil)
((= s "null") nil)
((vl-string-search "." s) (atof s))
(T (atoi s))
)
)
(defun ssg-json-objekt ( / erg key c vorher)
(ssg-json-weiter)
(setq erg nil)
(ssg-json-leerraum)
(while (and (setq c (ssg-json-zeichen)) (/= c "}"))
(setq vorher *ssg-json-pos*)
(if (= c "\"")
(progn
(setq key (ssg-json-string))
(ssg-json-leerraum)
(if (equal (ssg-json-zeichen) ":") (ssg-json-weiter))
(setq erg (cons (cons key (ssg-json-wert)) erg))
)
;; Komma oder unerwartetes Zeichen ueberspringen
(ssg-json-weiter)
)
(ssg-json-leerraum)
;; Schutz gegen Endlosschleife bei fehlerhafter Datei: kommt die Position
;; nicht voran, wird zwangsweise weitergerueckt. Ein haengendes BricsCAD
;; waere schlimmer als ein unvollstaendig gelesenes Objekt.
(if (= vorher *ssg-json-pos*) (ssg-json-weiter))
)
(if (equal (ssg-json-zeichen) "}") (ssg-json-weiter))
(reverse erg)
)
(defun ssg-json-array ( / erg c vorher)
(ssg-json-weiter)
(setq erg nil)
(ssg-json-leerraum)
(while (and (setq c (ssg-json-zeichen)) (/= c "]"))
(setq vorher *ssg-json-pos*)
(if (= c ",")
(ssg-json-weiter)
(setq erg (cons (ssg-json-wert) erg))
)
(ssg-json-leerraum)
(if (= vorher *ssg-json-pos*) (ssg-json-weiter))
)
(if (equal (ssg-json-zeichen) "]") (ssg-json-weiter))
(reverse erg)
)
(defun ssg-json-wert ( / c)
(ssg-json-leerraum)
(setq c (ssg-json-zeichen))
(cond
((null c) nil)
((= c "{") (ssg-json-objekt))
((= c "[") (ssg-json-array))
((= c "\"") (ssg-json-string))
(T (ssg-json-literal))
)
)
;; JSON-Text parsen. Rueckgabe: Struktur (siehe Abbildung oben).
(defun ssg-json-parse (text / erg)
(setq *ssg-json-txt* text
*ssg-json-len* (strlen text)
*ssg-json-pos* 1)
(setq erg (ssg-json-wert))
;; Quelltext nicht global stehen lassen - eine Datendatei haelt sonst
;; dauerhaft mehrere KB in einer globalen Variablen fest.
(setq *ssg-json-txt* nil *ssg-json-len* 0 *ssg-json-pos* 1)
erg
)
;; JSON-Datei parsen. Rueckgabe: Struktur oder nil, wenn die Datei fehlt.
(defun ssg-json-laden (datei / zeilen)
(setq zeilen (ssg-read-file-lines datei))
(if zeilen (ssg-json-parse (ssg-join zeilen "\n")))
)
;; Feld eines geparsten JSON-Objekts lesen.
(defun ssg-json-get (obj key)
(cdr (assoc key obj))
)
;; Verschachteltes JSON-Objekt parsen (1 Ebene tief)
;; {"section": {"key": val, ...}, ...}
;; -> (("section" ("key" . val) ...) ...)