2599 lines
112 KiB
Common Lisp
2599 lines
112 KiB
Common Lisp
;; ============================================================
|
|
;; LagerInsert.lsp - Lagerplanung GOH-Buehnenlager (Phase 1: Mengen, 2D)
|
|
;;
|
|
;; Erzeugt parametrische Attributbloecke fuer ein mehrgeschossiges
|
|
;; Haengewarenlager und sammelt daraus die Mengen fuer die RFQ-YAML
|
|
;; (Overlay, siehe doc/plan/lager_rfq.md):
|
|
;;
|
|
;; LG_GESCHOSS Geschoss-Kopfsymbol, verknuepft mit seiner Belagskontur
|
|
;; LG_BEREICH Lagerbereich (Kontur + Parameter), fuellt sich selbst
|
|
;; mit Regalreihen und Gaengen (Auto-Fuellung)
|
|
;; LG_REIHE_<L>_<T> Regalreihe (Rechteck L x T + Schienenlinie)
|
|
;; LG_GANG_<L>_<B>_<BELAG> Gang/Quergang/Randgang (Rechteck L x B, Schraffur
|
|
;; je Belag aus lager.json belag_schraffur)
|
|
;; goh_rack parametrischer BricsCAD-Block (Bestand), wird als
|
|
;; Regalreihe mitgezaehlt (lg-racks-sammeln)
|
|
;;
|
|
;; Befehle: LG_GESCHOSS, LG_GESCHOSS_AKTIV, LG_GESCHOSS_KOPIEREN, LG_BEREICH,
|
|
;; LG_REIHE, LG_GANG, LG_EDIT, LG_REGALE, LAGER_EXPORT, LAGER_HAND_YAML
|
|
;;
|
|
;; Grundsaetze (CLAUDE.md):
|
|
;; - Alle Werte selbstbeschreibend in mm/Grad, keine Index-Codes.
|
|
;; - Verknuepfungen (Kontur <-> Block, Kind -> Bereich) als XDATA-Handles
|
|
;; (App SSG_LG), nie in .dbg.
|
|
;; - Jeder Block traegt ID, GESCHOSS, LAYER.
|
|
;; - Layer je Geschoss: Basis aus cfg/layer.cfg [lager] + "_G<nr>", damit
|
|
;; LG_GESCHOSS_AKTIV die uebrigen Geschosse frieren kann.
|
|
;; - Blockdefinitionen entstehen per entmake (BLOCK...ENDBLK), Einfuegen per
|
|
;; vla-InsertBlock in Weltkoordinaten - kein _.-BLOCK/_.INSERT, damit weder
|
|
;; BKS noch ATTREQ/ATTDIA dazwischenfunken.
|
|
;; ============================================================
|
|
|
|
(vl-load-com)
|
|
|
|
;; Regelprofile aus LagerPruefung. Guarded Nachlade-Load fuer das isolierte
|
|
;; Laden dieses Moduls; im Normalfall hat die MNL es schon geladen.
|
|
(if (and (not (car (atoms-family 1 '("LG-REGEL-AUFLOESEN"))))
|
|
(ssg-lisp-datei-pfad "LagerPruefung.lsp"))
|
|
(load (ssg-lisp-datei-pfad "LagerPruefung.lsp") nil))
|
|
|
|
(setq *lg-app* "SSG_LG")
|
|
(if (not (boundp '*lg-daten*)) (setq *lg-daten* nil))
|
|
|
|
;; ============================================================
|
|
;; DATEN (data/json/lager.json)
|
|
;; ============================================================
|
|
|
|
(defun lg-daten-pfad ( / basis)
|
|
(setq basis (cond ((getenv "DXFM_DATA") (vl-string-translate "\\" "/" (getenv "DXFM_DATA")))
|
|
((getenv "DXFMAKRO")
|
|
(strcat (vl-string-translate "\\" "/" (getenv "DXFMAKRO")) "/data"))))
|
|
(if basis (strcat (vl-string-right-trim "/" basis) "/json/lager.json"))
|
|
)
|
|
|
|
(defun lg-daten ( / pfad)
|
|
(if (null *lg-daten*)
|
|
(progn
|
|
(setq pfad (lg-daten-pfad))
|
|
(if (and pfad (findfile pfad))
|
|
(setq *lg-daten* (ssg-json-laden pfad))
|
|
(princ (ssg-textf "lg-daten-fehlt" (list (if pfad pfad "lager.json"))))))
|
|
)
|
|
*lg-daten*
|
|
)
|
|
|
|
;; Wert unter einem Schluesselpfad, z.B. (lg-vorgabe '("bereich" "gangbreite_mm") 1000)
|
|
(defun lg-vorgabe (pfad vorgabe / obj)
|
|
(setq obj (lg-daten))
|
|
(foreach k pfad (setq obj (if (listp obj) (ssg-json-get obj k))))
|
|
(if (null obj) vorgabe obj)
|
|
)
|
|
|
|
(defun lg-land ( / l)
|
|
(setq l (lg-vorgabe '("land") "DE"))
|
|
(if (= (type l) 'STR) l "DE")
|
|
)
|
|
|
|
;; ============================================================
|
|
;; ZAHL-/TEXT-HELFER (rein, getestet in tests/test_unit.lsp)
|
|
;; ============================================================
|
|
|
|
;; Zahl aus String/Zahl, Komma wie Punkt. nil bei leer/ungueltig.
|
|
(defun lg-zahl (v / s)
|
|
(cond
|
|
((numberp v) (float v))
|
|
((= (type v) 'STR)
|
|
(setq s (vl-string-translate "," "." (vl-string-trim " \t" v)))
|
|
(if (/= s "") (distof s 2)))
|
|
(T nil)
|
|
)
|
|
)
|
|
|
|
;; mm-Wert als Attributtext: ganze Zahl ohne Nachkommastelle, sonst eine
|
|
;; Stelle (unabhaengig von DIMZIN).
|
|
(defun lg-mm-str (w / r s)
|
|
(if (null w)
|
|
""
|
|
(progn
|
|
(setq w (float w)
|
|
r (if (< w 0) (fix (- w 0.5)) (fix (+ w 0.5))))
|
|
(if (equal w r 1e-6)
|
|
(itoa r)
|
|
(progn
|
|
(setq s (rtos w 2 1))
|
|
(if (not (vl-string-search "." s)) (setq s (strcat s ".0")))
|
|
s)))
|
|
)
|
|
)
|
|
|
|
;; Auf ganze mm runden (Blocknamen und Geometrie muessen uebereinstimmen).
|
|
(defun lg-mm-runden (w)
|
|
(float (if (< w 0) (fix (- w 0.5)) (fix (+ w 0.5))))
|
|
)
|
|
|
|
;; Haengeebenen "2300/1200;1100/1100" -> ((2300.0 1200.0) (1100.0 1100.0)).
|
|
;; Ungueltige Teile fallen weg; fehlende Warenlaenge = 0.
|
|
(defun lg-haengeebenen-parse (s / erg teil ab h w)
|
|
(setq erg nil)
|
|
(if (and s (= (type s) 'STR))
|
|
(foreach teil (ssg-sepliste-split-feld s ";")
|
|
(setq ab (ssg-sepliste-split-feld teil "/")
|
|
h (lg-zahl (car ab))
|
|
w (lg-zahl (cadr ab)))
|
|
(if h (setq erg (cons (list h (if w w 0.0)) erg)))
|
|
)
|
|
)
|
|
(reverse erg)
|
|
)
|
|
|
|
(defun lg-haengeebenen-string (ebenen)
|
|
(ssg-join (mapcar '(lambda (e) (strcat (lg-mm-str (car e)) "/" (lg-mm-str (cadr e))))
|
|
ebenen)
|
|
";")
|
|
)
|
|
|
|
;; Haengeebenen auf n Ebenen begrenzen (goh_rack kennt nur die Anzahl):
|
|
;; die obersten n der Vorgabe. Fehlen Ebenen in der Vorgabe, bleibt es bei
|
|
;; dem, was da ist.
|
|
(defun lg-haengeebenen-n (s n / ebenen erg i)
|
|
(setq ebenen (lg-haengeebenen-parse s) erg nil i 0)
|
|
(while (and ebenen (< i n))
|
|
(setq erg (cons (car ebenen) erg) ebenen (cdr ebenen) i (1+ i)))
|
|
(lg-haengeebenen-string (reverse erg))
|
|
)
|
|
|
|
;; Feldwert pruefen/normalisieren. art: "mm" (Zahl >= 0), "mm_leer" (wie mm,
|
|
;; leer erlaubt), "int" (ganze Zahl >= 1), "int0" (>= 0), "grad" (beliebige
|
|
;; Zahl), "mm_vz" (mm mit Vorzeichen, z.B. Versatz), "text", "ebenen"
|
|
;; (Haengeebenen-Liste, mind. eine Ebene).
|
|
;; Rueckgabe: normalisierter String oder nil (ungueltig).
|
|
(defun lg-feld-pruefen (art s / w)
|
|
(if (null s) (setq s ""))
|
|
(setq s (vl-string-trim " \t" s))
|
|
(cond
|
|
((= art "text") s)
|
|
((and (= art "mm_leer") (= s "")) "")
|
|
((member art '("mm" "mm_leer"))
|
|
(if (and (setq w (lg-zahl s)) (>= w 0.0)) (lg-mm-str w)))
|
|
((member art '("grad" "mm_vz"))
|
|
(if (setq w (lg-zahl s)) (lg-mm-str w)))
|
|
((member art '("int" "int0"))
|
|
(if (and (setq w (lg-zahl s)) (equal w (fix w) 1e-9)
|
|
(>= w (if (= art "int") 1 0)))
|
|
(itoa (fix w))))
|
|
((= art "ebenen")
|
|
(if (lg-haengeebenen-parse s) (lg-haengeebenen-string (lg-haengeebenen-parse s))))
|
|
(T s)
|
|
)
|
|
)
|
|
|
|
;; ============================================================
|
|
;; LAYER JE GESCHOSS
|
|
;; ============================================================
|
|
|
|
;; Basis-Layername eines Lager-Schluessels aus cfg/layer.cfg [lager].
|
|
;; Rueckgabe: (name . farbe), Rueckfall "LG_<Schluessel>" / Farbe 7.
|
|
(defun lg-layer-basis (schluessel / e)
|
|
(setq e (ssg-layer-cfg-eintrag (ssg-layer-cfg-load) "lager" schluessel))
|
|
(if e e (cons (strcat "LG_" schluessel) "7"))
|
|
)
|
|
|
|
;; Reiner Kern: Layername fuer Geschoss nr (nil/"" -> ohne Suffix).
|
|
(defun lg-layer-name (basis nr)
|
|
(if (and nr (/= (vl-princ-to-string nr) ""))
|
|
(strcat basis "_G" (vl-princ-to-string nr))
|
|
basis)
|
|
)
|
|
|
|
;; Layer anlegen (Farbe nur bei Neuanlage) und Namen liefern.
|
|
(defun lg-layer (schluessel nr / b name)
|
|
(setq b (lg-layer-basis schluessel)
|
|
name (lg-layer-name (car b) nr))
|
|
(ssg-make-layer name (cdr b) nil)
|
|
name
|
|
)
|
|
|
|
;; ============================================================
|
|
;; ZEICHNUNGSWEITE EINSTELLUNGEN (Dictionary per vlax-ldata)
|
|
;; ============================================================
|
|
|
|
(defun lg-ldata-lesen (key / r)
|
|
(setq r (vl-catch-all-apply 'vlax-ldata-get (list "SSG_LAGER" key)))
|
|
(if (vl-catch-all-error-p r) nil r)
|
|
)
|
|
|
|
(defun lg-ldata-setzen (key wert)
|
|
(vl-catch-all-apply 'vlax-ldata-put (list "SSG_LAGER" key wert))
|
|
wert
|
|
)
|
|
|
|
;; ============================================================
|
|
;; XDATA (App SSG_LG): Folge von (1000 . schluessel) + Wertgruppe
|
|
;; (1005 = Handle, 1000 = Text). Gelesen als Alist (schluessel . wert).
|
|
;; ============================================================
|
|
|
|
(defun lg-regapp ()
|
|
(if (not (tblsearch "APPID" *lg-app*)) (regapp *lg-app*))
|
|
)
|
|
|
|
;; paare = (("kontur" 1005 . "2A") ("rolle" 1000 . "reihe") ...)
|
|
(defun lg-xdata-setzen (ent paare / ed gruppen)
|
|
(lg-regapp)
|
|
(setq gruppen nil)
|
|
(foreach p paare
|
|
(setq gruppen (append gruppen (list (cons 1000 (car p)) (cons (cadr p) (cddr p))))))
|
|
(setq ed (vl-remove-if '(lambda (g) (= (car g) -3)) (entget ent)))
|
|
(entmod (append ed (list (list -3 (cons *lg-app* gruppen)))))
|
|
(entupd ent)
|
|
)
|
|
|
|
(defun lg-xdata-lesen (ent / xd gruppen erg)
|
|
(setq xd (assoc -3 (entget ent (list *lg-app*))))
|
|
(setq gruppen (if xd (cdr (assoc *lg-app* (cdr xd)))))
|
|
(setq erg nil)
|
|
(while (cadr gruppen)
|
|
(if (= (car (car gruppen)) 1000)
|
|
(setq erg (cons (cons (cdr (car gruppen)) (cdr (cadr gruppen))) erg)))
|
|
(setq gruppen (cddr gruppen))
|
|
)
|
|
(reverse erg)
|
|
)
|
|
|
|
(defun lg-xdata-wert (ent key) (cdr (assoc key (lg-xdata-lesen ent))))
|
|
|
|
(defun lg-handle (ent) (cdr (assoc 5 (entget ent))))
|
|
|
|
(defun lg-ent-aus-handle (h / e)
|
|
(if (and h (setq e (handent h)) (entget e)) e)
|
|
)
|
|
|
|
;; ============================================================
|
|
;; BLOCKBAU
|
|
;; ============================================================
|
|
|
|
(defun lg-geom-linie (p1 p2)
|
|
(list '(0 . "LINE") '(8 . "0") (cons 10 p1) (cons 11 p2))
|
|
)
|
|
|
|
(defun lg-geom-rechteck (x0 y0 x1 y1)
|
|
(list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(8 . "0")
|
|
'(100 . "AcDbPolyline") '(90 . 4) '(70 . 1)
|
|
(list 10 x0 y0) (list 10 x1 y0) (list 10 x1 y1) (list 10 x0 y1))
|
|
)
|
|
|
|
(defun lg-geom-kreis (pt r)
|
|
(list '(0 . "CIRCLE") '(8 . "0") (cons 10 pt) (cons 40 r))
|
|
)
|
|
|
|
;; ATTDEF fuer eine Blockdefinition. sichtbar = nil -> unsichtbar.
|
|
(defun lg-geom-attdef (tag wert pt hoehe sichtbar)
|
|
(list '(0 . "ATTDEF") '(8 . "0") (cons 10 pt) (cons 40 hoehe)
|
|
(cons 1 wert) (cons 3 tag) (cons 2 tag)
|
|
(cons 70 (if sichtbar 0 1)))
|
|
)
|
|
|
|
;; Unsichtbare ATTDEFs fuer alle Tags eines Schemas ((TAG . vorgabe) ...).
|
|
(defun lg-attdefs-unsichtbar (schema / y erg)
|
|
(setq y 0.0 erg nil)
|
|
(foreach p schema
|
|
(setq erg (cons (lg-geom-attdef (car p) "" (list 0.0 y 0.0) 50.0 nil) erg)
|
|
y (- y 100.0)))
|
|
(reverse erg)
|
|
)
|
|
|
|
(defun lg-blockdef-anlegen (bname ents)
|
|
(entmake (list '(0 . "BLOCK") (cons 2 bname) '(70 . 2) '(10 0.0 0.0 0.0)))
|
|
(foreach e ents (entmake e))
|
|
(entmake '((0 . "ENDBLK")))
|
|
)
|
|
|
|
;; Objekte einer vorhandenen Blockdefinition (entget-Listen).
|
|
(defun lg-blockdef-objekte (bname / e ed erg)
|
|
(setq e (cdr (assoc -2 (tblsearch "BLOCK" bname))) erg nil)
|
|
(while (and e (setq ed (entget e)) (/= (cdr (assoc 0 ed)) "ENDBLK"))
|
|
(setq erg (cons ed erg) e (entnext e)))
|
|
(reverse erg)
|
|
)
|
|
|
|
;; Blockdefinition anlegen, falls sie fehlt. ents = entmake-Listen.
|
|
;; Altbestand: fehlen einer vorhandenen Definition ATTDEFs aus ents (Schema
|
|
;; wurde erweitert), wird sie neu definiert und per ATTSYNC auf die
|
|
;; Referenzen uebertragen - sonst verschluckt lg-attribute-setzen die neuen
|
|
;; Tags still.
|
|
(defun lg-blockdef (bname ents / vorhanden fehlt)
|
|
(if (not (tblsearch "BLOCK" bname))
|
|
(lg-blockdef-anlegen bname ents)
|
|
(progn
|
|
(setq vorhanden (mapcar '(lambda (ed) (strcase (cdr (assoc 2 ed))))
|
|
(vl-remove-if-not '(lambda (ed) (= (cdr (assoc 0 ed)) "ATTDEF"))
|
|
(lg-blockdef-objekte bname))))
|
|
(setq fehlt (vl-remove-if '(lambda (tg) (member tg vorhanden))
|
|
(mapcar '(lambda (e) (strcase (cdr (assoc 2 e))))
|
|
(vl-remove-if-not '(lambda (e) (= (cdr (assoc 0 e)) "ATTDEF")) ents))))
|
|
(if fehlt
|
|
(progn
|
|
(lg-blockdef-anlegen bname ents)
|
|
(vl-catch-all-apply '(lambda () (command "_.ATTSYNC" "_N" bname)))
|
|
(princ (ssg-textf "lg-blockdef-ergaenzt" (list bname (ssg-join fehlt ", "))))))
|
|
)
|
|
)
|
|
bname
|
|
)
|
|
|
|
(defun lg-modelspace ()
|
|
(vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
|
|
)
|
|
|
|
;; Wert zu einem Attribut-Tag aus werte (("TAG" . "wert") ...), Gross-/
|
|
;; Kleinschreibung egal: die Tags tragen gemischte Schreibweise
|
|
;; (HOEHE_BELAG_mm), Attribut-Tags gelten aber case-insensitiv.
|
|
(defun lg-wert-fuer-tag (tag werte / g)
|
|
(setq g (strcase tag))
|
|
(cdr (vl-some '(lambda (p) (if (= (strcase (car p)) g) p)) werte))
|
|
)
|
|
|
|
;; Block bei pt (WCS) mit Drehung rot (Bogenmass) einfuegen, Layer setzen,
|
|
;; Attribute aus werte (("TAG" . "wert") ...) eintragen.
|
|
;; Rueckgabe: ename oder nil.
|
|
(defun lg-block-einfuegen (bname pt rot layer werte / obj res w)
|
|
(setq res
|
|
(vl-catch-all-apply
|
|
'(lambda ()
|
|
(setq obj (vla-InsertBlock (lg-modelspace) (vlax-3d-point pt) bname 1.0 1.0 1.0 rot))
|
|
(if layer (vla-put-Layer obj layer))
|
|
(foreach a (vlax-invoke obj 'GetAttributes)
|
|
(if (setq w (lg-wert-fuer-tag (vla-get-TagString a) werte))
|
|
(vla-put-TextString a w)))
|
|
(vlax-vla-object->ename obj))))
|
|
(if (vl-catch-all-error-p res)
|
|
(progn (princ (ssg-textf "lg-einfuegen-fehler" (list bname (vl-catch-all-error-message res)))) nil)
|
|
res)
|
|
)
|
|
|
|
;; Attribute eines vorhandenen Blocks setzen (nur bestehende Tags).
|
|
(defun lg-attribute-setzen (ent werte / obj w)
|
|
(setq obj (vlax-ename->vla-object ent))
|
|
(foreach a (vlax-invoke obj 'GetAttributes)
|
|
(if (setq w (lg-wert-fuer-tag (vla-get-TagString a) werte))
|
|
(vla-put-TextString a w)))
|
|
ent
|
|
)
|
|
|
|
;; Effektiver Blockname (unsere Bloecke sind nie dynamisch, aber
|
|
;; Benutzerkopien koennten es sein).
|
|
(defun lg-blockname (ent / r)
|
|
(setq r (vl-catch-all-apply 'vla-get-EffectiveName (list (vlax-ename->vla-object ent))))
|
|
(if (vl-catch-all-error-p r) (cdr (assoc 2 (entget ent))) r)
|
|
)
|
|
|
|
(defun lg-alle-bloecke (muster / ss i erg)
|
|
(setq erg nil)
|
|
(if (setq ss (ssget "_X" (list '(0 . "INSERT") (cons 2 muster))))
|
|
(progn
|
|
(setq i 0)
|
|
(repeat (sslength ss)
|
|
(setq erg (cons (ssname ss i) erg) i (1+ i)))))
|
|
(reverse erg)
|
|
)
|
|
|
|
;; ============================================================
|
|
;; ATTRIBUT-SCHEMATA (Tag . Vorgabe)
|
|
;; ============================================================
|
|
|
|
(setq *lg-schema-geschoss*
|
|
'(("ID" . "") ("GESCHOSS" . "") ("LAYER" . "") ("NR" . "") ("BEZEICHNUNG" . "")
|
|
("HOEHE_BELAG_mm" . "0") ("KONSTR_HOEHE_mm" . "") ("LICHTE_HOEHE_mm" . "")
|
|
("BELAG_ART" . "") ("PERSONEN" . "") ("BRANDGEFAEHRDUNG" . "")))
|
|
|
|
(setq *lg-schema-bereich*
|
|
'(("ID" . "") ("GESCHOSS" . "") ("LAYER" . "") ("NR" . "")
|
|
("GANGBREITE_mm" . "") ("REGALTIEFE_mm" . "") ("REIHEN_JE_GANG" . "")
|
|
("SCHIENEN_JE_GANG" . "") ("QUERGANG_ABSTAND_mm" . "") ("QUERGANG_BREITE_mm" . "")
|
|
("RICHTUNG" . "") ("HAENGEEBENEN" . "") ("BELAG" . "")
|
|
("RANDGANG_N_mm" . "0") ("RANDGANG_O_mm" . "0") ("RANDGANG_S_mm" . "0") ("RANDGANG_W_mm" . "0")
|
|
("RESTBREITE_mm" . "")))
|
|
|
|
(setq *lg-schema-reihe*
|
|
'(("ID" . "") ("GESCHOSS" . "") ("LAYER" . "") ("LAENGE" . "") ("TIEFE_mm" . "")
|
|
("HAENGEEBENEN" . "") ("SCHIENEN" . "") ("BEREICH" . "") ("QUELLE" . "")))
|
|
|
|
(setq *lg-schema-gang*
|
|
'(("ID" . "") ("GESCHOSS" . "") ("LAYER" . "") ("LAENGE" . "") ("BREITE_mm" . "")
|
|
("ART" . "") ("BELAG" . "") ("BEREICH" . "") ("QUELLE" . "")))
|
|
|
|
;; ============================================================
|
|
;; GESCHOSSE
|
|
;; ============================================================
|
|
|
|
(defun lg-geschoss-blockdef ( / )
|
|
(lg-blockdef "LG_GESCHOSS"
|
|
(append
|
|
(list (lg-geom-kreis '(0.0 0.0 0.0) 300.0)
|
|
(lg-geom-linie '(-300.0 0.0 0.0) '(300.0 0.0 0.0)))
|
|
;; sichtbar: Nummer, Bezeichnung, Belagshoehe
|
|
(list (lg-geom-attdef "NR" "" '(-120.0 40.0 0.0) 180.0 T)
|
|
(lg-geom-attdef "BEZEICHNUNG" "" '(400.0 60.0 0.0) 150.0 T)
|
|
(lg-geom-attdef "HOEHE_BELAG_mm" "" '(400.0 -200.0 0.0) 150.0 T))
|
|
(lg-attdefs-unsichtbar
|
|
(vl-remove-if '(lambda (p) (member (car p) '("NR" "BEZEICHNUNG" "HOEHE_BELAG_mm")))
|
|
*lg-schema-geschoss*))))
|
|
)
|
|
|
|
;; Record eines Geschoss-Blocks: (ent nr attribs kontur-punkte)
|
|
(defun lg-geschoss-record (ent / attribs k)
|
|
(setq attribs (ssg-attrib-read ent)
|
|
k (lg-ent-aus-handle (lg-xdata-wert ent "kontur")))
|
|
(list ent (atoi (cond ((cdr (assoc "NR" attribs))) ("0"))) attribs
|
|
(if k (ssg-lwpoly-punkte k)))
|
|
)
|
|
|
|
(defun lg-geschosse ( / )
|
|
(vl-sort (mapcar 'lg-geschoss-record (lg-alle-bloecke "LG_GESCHOSS"))
|
|
'(lambda (a b) (< (cadr a) (cadr b))))
|
|
)
|
|
|
|
(defun lg-geschoss-finden (nr)
|
|
(vl-some '(lambda (g) (if (= (cadr g) nr) g)) (lg-geschosse))
|
|
)
|
|
|
|
(defun lg-geschoss-hoehe (rec)
|
|
(cond ((lg-zahl (cdr (assoc "HOEHE_BELAG_mm" (caddr rec))))) (0.0))
|
|
)
|
|
|
|
;; Z einer Kontur (Erhebung des ersten Punkts) eines Kandidaten.
|
|
(defun lg-kandidat-z (k)
|
|
(cond ((caddr (car (caddr k)))) (0.0))
|
|
)
|
|
|
|
;; Reiner Kern der Geschosszuordnung.
|
|
;; kandidaten = ((nr hoehe-mm kontur-punkte) ...), pt = (x y z).
|
|
;; Liegt pt in genau einer Kontur -> deren nr. Liegt er in mehreren, hilft
|
|
;; nur Z: liegen die Konturen auf verschiedenen Hoehen (3D), gewinnt die
|
|
;; hoechste Kontur bis z + 50 mm. Liegen sie alle auf derselben Hoehe
|
|
;; (2D-Grundrisse uebereinander), ist die Zuordnung nicht eindeutig -> nil.
|
|
(defun lg-geschoss-fuer-punkt-kern (pt kandidaten / innen z z0 passend)
|
|
(setq innen (vl-remove-if-not '(lambda (k) (and (caddr k) (ssg-punkt-in-poly-p pt (caddr k))))
|
|
kandidaten))
|
|
(cond
|
|
((null innen) nil)
|
|
((null (cdr innen)) (car (car innen)))
|
|
(T
|
|
(setq z (if (caddr pt) (caddr pt) 0.0)
|
|
z0 (lg-kandidat-z (car innen)))
|
|
(if (vl-every '(lambda (k) (equal (lg-kandidat-z k) z0 1.0)) innen)
|
|
nil
|
|
(progn
|
|
(setq passend (vl-remove-if-not '(lambda (k) (<= (lg-kandidat-z k) (+ z 50.0))) innen))
|
|
(if passend
|
|
(car (car (vl-sort passend '(lambda (a b) (> (lg-kandidat-z a) (lg-kandidat-z b))))))))))
|
|
)
|
|
)
|
|
|
|
(defun lg-geschoss-kandidaten ( / )
|
|
(mapcar '(lambda (g) (list (cadr g) (lg-geschoss-hoehe g) (cadddr g))) (lg-geschosse))
|
|
)
|
|
|
|
;; Aktives Geschoss (Zahl) oder nil.
|
|
(defun lg-geschoss-aktiv ( / nr)
|
|
(setq nr (lg-ldata-lesen "GESCHOSS_AKTIV"))
|
|
(if (and (numberp nr) (> nr 0) (lg-geschoss-finden nr)) nr)
|
|
)
|
|
|
|
;; Geschoss fuer ein neues Objekt: aktives Geschoss, sonst Kontur-Zuordnung,
|
|
;; sonst Rueckfrage. nil = kein Geschoss vorhanden.
|
|
(defun lg-geschoss-ermitteln (pt / nr gs)
|
|
(setq gs (lg-geschosse))
|
|
(cond
|
|
((null gs) (princ (ssg-text "lg-kein-geschoss")) nil)
|
|
((setq nr (lg-geschoss-aktiv)) nr)
|
|
((setq nr (lg-geschoss-fuer-punkt-kern pt (lg-geschoss-kandidaten))) nr)
|
|
((null (cdr gs)) (cadr (car gs)))
|
|
(T
|
|
(setq nr (ssg-in-int (ssg-text "lg-prompt-geschoss-nr") (cadr (car gs))))
|
|
(if (lg-geschoss-finden nr) nr
|
|
(progn (princ (ssg-textf "lg-geschoss-unbekannt" (list (itoa nr)))) nil)))
|
|
)
|
|
)
|
|
|
|
(defun lg-geschoss-naechste-nr ( / gs)
|
|
(setq gs (lg-geschosse))
|
|
(if gs (1+ (apply 'max (mapcar 'cadr gs))) 1)
|
|
)
|
|
|
|
;; ------------------------------------------------------------
|
|
;; Konturen
|
|
;; ------------------------------------------------------------
|
|
|
|
(defun lg-kontur-p (ent / ed)
|
|
(setq ed (entget ent))
|
|
(and (= (cdr (assoc 0 ed)) "LWPOLYLINE")
|
|
(>= (length (ssg-lwpoly-punkte ent)) 3))
|
|
)
|
|
|
|
;; Kontur geschlossen setzen (Flag 1), Duplikat-Schlusspunkt stoert nicht.
|
|
(defun lg-kontur-schliessen (ent / ed f)
|
|
(setq ed (entget ent) f (cdr (assoc 70 ed)))
|
|
(if (= 0 (logand f 1))
|
|
(progn (entmod (subst (cons 70 (logior f 1)) (assoc 70 ed) ed)) (entupd ent)))
|
|
ent
|
|
)
|
|
|
|
;; Kopie einer Polylinie ohne Handle/Besitzer/XDATA (fuer eine Kontur, die
|
|
;; schon einem anderen Geschoss/Bereich gehoert - die 2D-Grundrisse liegen
|
|
;; uebereinander, jede Kontur gehoert genau einem Block).
|
|
(defun lg-kontur-kopieren (ent)
|
|
(entmakex (vl-remove-if '(lambda (g) (member (car g) '(-1 5 330 102 360 -3)))
|
|
(entget ent)))
|
|
)
|
|
|
|
;; Kontur fuer einen neuen Block vorbereiten: kopieren, falls schon
|
|
;; vergeben, schliessen, auf layer legen. Rueckgabe: ename der Kontur.
|
|
(defun lg-kontur-uebernehmen (ent layer / ed)
|
|
(if (lg-xdata-wert ent "besitzer") (setq ent (lg-kontur-kopieren ent)))
|
|
(lg-kontur-schliessen ent)
|
|
(setq ed (entget ent))
|
|
(entmod (subst (cons 8 layer) (assoc 8 ed) ed))
|
|
(entupd ent)
|
|
ent
|
|
)
|
|
|
|
;; Interaktiv: geschlossene Polylinie waehlen, Enter = neu zeichnen.
|
|
(defun lg-kontur-waehlen (prompt / sel ent fertig)
|
|
(while (not fertig)
|
|
(setq sel (entsel prompt))
|
|
(cond
|
|
((null sel)
|
|
(if (= (getvar "ERRNO") 52)
|
|
(progn
|
|
;; Enter: neue Kontur zeichnen
|
|
(princ (ssg-text "lg-kontur-zeichnen"))
|
|
(setq ent (entlast))
|
|
(command "_.PLINE")
|
|
(while (> (getvar "CMDACTIVE") 0) (command pause))
|
|
(if (and (entlast) (not (eq ent (entlast))) (lg-kontur-p (entlast)))
|
|
(setq ent (entlast))
|
|
(setq ent nil))
|
|
(setq fertig T))
|
|
(setq fertig T ent nil)))
|
|
((lg-kontur-p (car sel)) (setq ent (car sel) fertig T))
|
|
(T (princ (ssg-text "lg-keine-kontur")))
|
|
)
|
|
)
|
|
ent
|
|
)
|
|
|
|
;; ------------------------------------------------------------
|
|
;; Geschoss anlegen / aendern
|
|
;; ------------------------------------------------------------
|
|
|
|
(defun lg-geschoss-vorgaben (nr / )
|
|
(list (cons "NR" (itoa nr))
|
|
(cons "GESCHOSS" (itoa nr))
|
|
(cons "BEZEICHNUNG" (if (= nr 0) "ground floor" (strcat "Level " (itoa nr))))
|
|
(cons "HOEHE_BELAG_mm" "0")
|
|
(cons "KONSTR_HOEHE_mm" (lg-mm-str (lg-zahl (lg-vorgabe '("geschoss" "konstr_hoehe_mm") 250))))
|
|
(cons "LICHTE_HOEHE_mm" "")
|
|
(cons "BELAG_ART" (lg-vorgabe '("geschoss" "belag_art") "spanplatte"))
|
|
(cons "PERSONEN" (itoa (fix (lg-zahl (lg-vorgabe '("geschoss" "personen") 20)))))
|
|
(cons "BRANDGEFAEHRDUNG" (lg-vorgabe '("geschoss" "brandgefaehrdung") "erhoeht_ohne_loeschanlage")))
|
|
)
|
|
|
|
;; Geschoss-Block zur Kontur anlegen (nicht interaktiv - auch fuer Tests).
|
|
;; werte = vollstaendige Attributwerte (lg-geschoss-vorgaben + Dialog).
|
|
;; Rueckgabe: ename des Blocks oder nil.
|
|
(defun lg-geschoss-anlegen (kontur werte / nr lay pts bb pt blk)
|
|
(setq nr (atoi (cdr (assoc "NR" werte))))
|
|
(if (lg-geschoss-finden nr)
|
|
(progn (princ (ssg-textf "lg-geschoss-existiert" (list (itoa nr)))) nil)
|
|
(progn
|
|
(setq lay (lg-layer "geschoss" nr))
|
|
(setq kontur (lg-kontur-uebernehmen kontur lay))
|
|
(setq pts (ssg-lwpoly-punkte kontur)
|
|
bb (ssg-poly-bbox pts))
|
|
;; Kopfsymbol unten links an der Kontur, auf deren Z
|
|
(setq pt (list (car (car bb)) (cadr (car bb)) (if (caddr (car pts)) (caddr (car pts)) 0.0)))
|
|
(lg-geschoss-blockdef)
|
|
(setq werte (append (list (cons "GESCHOSS" (itoa nr)) (cons "LAYER" lay)
|
|
(cons "ID" (strcat "G" (itoa nr))))
|
|
werte))
|
|
(if (setq blk (lg-block-einfuegen "LG_GESCHOSS" pt 0.0 lay werte))
|
|
(progn
|
|
(lg-xdata-setzen blk (list (cons "kontur" (cons 1005 (lg-handle kontur)))))
|
|
(lg-xdata-setzen kontur (list (cons "besitzer" (cons 1005 (lg-handle blk)))
|
|
(cons "rolle" (cons 1000 "geschoss"))))
|
|
blk))
|
|
)
|
|
)
|
|
)
|
|
|
|
;; ============================================================
|
|
;; DIALOGE (generisch: Feldliste -> DCL bzw. Konsole)
|
|
;; ============================================================
|
|
;; feld = (tile-key attribut-tag art optionen)
|
|
;; art siehe lg-feld-pruefen, zusaetzlich "wahl" (popup_list aus optionen)
|
|
;; Konsolen-Prompt: ssg-text "lg-feld-<tile-key>".
|
|
|
|
(setq *lg-felder-geschoss*
|
|
'(("nr" "NR" "int0" nil)
|
|
("bezeichnung" "BEZEICHNUNG" "text" nil)
|
|
("hoehe" "HOEHE_BELAG_mm" "mm" nil)
|
|
("konstr" "KONSTR_HOEHE_mm" "mm" nil)
|
|
("lichte" "LICHTE_HOEHE_mm" "mm_leer" nil)
|
|
("belag" "BELAG_ART" "wahl" belag)
|
|
("personen" "PERSONEN" "int0" nil)
|
|
("brand" "BRANDGEFAEHRDUNG" "wahl" brand)))
|
|
|
|
(setq *lg-felder-bereich*
|
|
'(("gang" "GANGBREITE_mm" "mm" nil)
|
|
("tiefe" "REGALTIEFE_mm" "mm" nil)
|
|
("reihen" "REIHEN_JE_GANG" "wahl" reihen)
|
|
("schienen" "SCHIENEN_JE_GANG" "int0" nil)
|
|
("q_abstand" "QUERGANG_ABSTAND_mm" "mm" nil)
|
|
("q_breite" "QUERGANG_BREITE_mm" "mm" nil)
|
|
("richtung" "RICHTUNG" "grad" nil)
|
|
("ebenen" "HAENGEEBENEN" "ebenen" nil)
|
|
("belag" "BELAG" "wahl" belag)
|
|
("rand_n" "RANDGANG_N_mm" "mm" nil)
|
|
("rand_o" "RANDGANG_O_mm" "mm" nil)
|
|
("rand_s" "RANDGANG_S_mm" "mm" nil)
|
|
("rand_w" "RANDGANG_W_mm" "mm" nil)))
|
|
|
|
(setq *lg-felder-gang*
|
|
'(("laenge" "LAENGE" "mm" nil)
|
|
("breite" "BREITE_mm" "mm" nil)
|
|
("art" "ART" "wahl" gangart)
|
|
("belag" "BELAG" "wahl" belag)))
|
|
|
|
(setq *lg-felder-reihe*
|
|
'(("laenge" "LAENGE" "mm" nil)
|
|
("tiefe" "TIEFE_mm" "mm" nil)
|
|
("ebenen" "HAENGEEBENEN" "ebenen" nil)
|
|
("schienen" "SCHIENEN" "int0" nil)))
|
|
|
|
;; LG_GESCHOSS_KOPIEREN - die Tags sind reine Dialogwerte, kein Block-Schema.
|
|
(setq *lg-felder-kopie*
|
|
'(("quelle" "QUELLE" "wahl" geschosse)
|
|
("anzahl" "ANZAHL" "int" nil)
|
|
("abstand" "ABSTAND_mm" "mm" nil)
|
|
("belag" "BELAG_ART" "wahl" belag)
|
|
("versatz_x" "VERSATZ_X_mm" "mm_vz" nil)
|
|
("versatz_y" "VERSATZ_Y_mm" "mm_vz" nil)))
|
|
|
|
(defun lg-optionen (sym)
|
|
(cond
|
|
((eq sym 'belag) (lg-vorgabe '("geschoss" "belag_arten") '("spanplatte" "gitterrost" "hallenboden")))
|
|
((eq sym 'brand) (lg-vorgabe '("brandgefaehrdungen") '("normal" "erhoeht_mit_loeschanlage" "erhoeht_ohne_loeschanlage")))
|
|
((eq sym 'reihen) '("1" "2"))
|
|
((eq sym 'gangart) '("gang" "randgang" "quergang"))
|
|
((eq sym 'geschosse) (mapcar '(lambda (g) (itoa (cadr g))) (lg-geschosse)))
|
|
)
|
|
)
|
|
|
|
(defun lg-dcl-pfad ( / d)
|
|
(setq d (getenv "DXFM_DCL"))
|
|
(if d (strcat (vl-string-right-trim "/\\" (vl-string-translate "\\" "/" d)) "/lager.dcl"))
|
|
)
|
|
|
|
;; Dialog zeigen. gesperrt = Liste von tile-keys, die nicht editierbar sind.
|
|
;; Rueckgabe: aktualisierte werte oder nil (Abbruch). Faellt bei fehlender
|
|
;; GUI/DCL auf die Konsole zurueck.
|
|
(defun lg-dialog (dlg-name felder werte gesperrt / pfad dat erg)
|
|
(setq pfad (lg-dcl-pfad))
|
|
(cond
|
|
((not (ssg-gui-p)) werte) ; Tests/Batch: Vorgaben uebernehmen
|
|
((or (null pfad) (not (findfile pfad)) (< (setq dat (load_dialog pfad)) 0))
|
|
(princ (ssg-textf "lg-dialog-fehlt" (list (if pfad pfad "lager.dcl"))))
|
|
(lg-konsole felder werte gesperrt))
|
|
((not (new_dialog dlg-name dat))
|
|
(unload_dialog dat)
|
|
(lg-konsole felder werte gesperrt))
|
|
(T
|
|
(setq *lg-dlg-werte* werte *lg-dlg-felder* felder *lg-dlg-ergebnis* nil)
|
|
(foreach f felder
|
|
(if (= (caddr f) "wahl")
|
|
(progn
|
|
(start_list (car f))
|
|
(mapcar 'add_list (lg-optionen (cadddr f)))
|
|
(end_list)
|
|
(set_tile (car f)
|
|
(itoa (cond ((vl-position (cdr (assoc (cadr f) werte)) (lg-optionen (cadddr f))))
|
|
(0)))))
|
|
(set_tile (car f) (cond ((cdr (assoc (cadr f) werte))) (""))))
|
|
(if (member (car f) gesperrt) (mode_tile (car f) 1))
|
|
)
|
|
(action_tile "accept" "(lg-dialog-ok)")
|
|
(action_tile "cancel" "(done_dialog 0)")
|
|
(setq erg (start_dialog))
|
|
(unload_dialog dat)
|
|
(if (= erg 1) *lg-dlg-ergebnis*)
|
|
)
|
|
)
|
|
)
|
|
|
|
;; OK-Knopf: alle Felder pruefen; bei Fehler Dialog offen lassen.
|
|
(defun lg-dialog-ok ( / werte fehler f s n)
|
|
(setq werte *lg-dlg-werte* fehler nil)
|
|
(foreach f *lg-dlg-felder*
|
|
(setq s (get_tile (car f)))
|
|
(if (= (caddr f) "wahl")
|
|
(setq n (nth (atoi s) (lg-optionen (cadddr f))))
|
|
(setq n (lg-feld-pruefen (caddr f) s)))
|
|
(if (null n)
|
|
(if (null fehler) (setq fehler (car f)))
|
|
(setq werte (lg-wert-setzen werte (cadr f) n)))
|
|
)
|
|
(if fehler
|
|
(progn (set_tile "error" (ssg-textf "lg-feld-ungueltig" (list (ssg-text (strcat "lg-feld-" fehler)))))
|
|
(mode_tile fehler 2))
|
|
(progn (setq *lg-dlg-ergebnis* werte) (done_dialog 1)))
|
|
)
|
|
|
|
(defun lg-wert-setzen (werte tag wert)
|
|
(if (assoc tag werte)
|
|
(subst (cons tag wert) (assoc tag werte) werte)
|
|
(append werte (list (cons tag wert))))
|
|
)
|
|
|
|
;; Konsolen-Rueckfall: jedes Feld mit Vorgabe abfragen (Enter = Vorgabe).
|
|
(defun lg-konsole (felder werte gesperrt / f alt neu opts)
|
|
(foreach f felder
|
|
(if (not (member (car f) gesperrt))
|
|
(progn
|
|
(setq alt (cond ((cdr (assoc (cadr f) werte))) ("")))
|
|
(setq neu nil)
|
|
(while (null neu)
|
|
(if (= (caddr f) "wahl")
|
|
(progn
|
|
(setq opts (lg-optionen (cadddr f)))
|
|
(princ (strcat "\n " (ssg-join opts " | ")))
|
|
(setq neu (ssg-in-string (ssg-text (strcat "lg-feld-" (car f))) alt))
|
|
(if (not (member neu opts)) (progn (princ (ssg-text "lg-wahl-ungueltig")) (setq neu nil))))
|
|
(progn
|
|
(setq neu (lg-feld-pruefen (caddr f)
|
|
(ssg-in-string (ssg-text (strcat "lg-feld-" (car f))) alt)))
|
|
(if (null neu) (princ (ssg-text "lg-wert-ungueltig")))))
|
|
)
|
|
(setq werte (lg-wert-setzen werte (cadr f) neu))
|
|
)
|
|
)
|
|
)
|
|
werte
|
|
)
|
|
|
|
;; ============================================================
|
|
;; REGALREIHEN UND GAENGE
|
|
;; ============================================================
|
|
|
|
(defun lg-reihe-blockname (laenge tiefe)
|
|
(strcat "LG_REIHE_" (lg-mm-str laenge) "_" (lg-mm-str tiefe))
|
|
)
|
|
|
|
;; Der Belag steht im Namen, weil die Definition seine Schraffur enthaelt
|
|
;; und je Geometrie wiederverwendet wird.
|
|
(defun lg-gang-blockname (laenge breite belag)
|
|
(strcat "LG_GANG_" (lg-mm-str laenge) "_" (lg-mm-str breite)
|
|
(if (and belag (= (type belag) 'STR) (/= belag ""))
|
|
(strcat "_" (strcase (vl-string-translate " " "_" belag)))
|
|
""))
|
|
)
|
|
|
|
;; Reihe: Rechteck L x T um die Schienenlinie (0,0)-(L,0).
|
|
(defun lg-reihe-blockdef (laenge tiefe / h)
|
|
(setq h (/ tiefe 2.0))
|
|
(lg-blockdef (lg-reihe-blockname laenge tiefe)
|
|
(append (list (lg-geom-rechteck 0.0 (- h) laenge h)
|
|
(lg-geom-linie '(0.0 0.0 0.0) (list laenge 0.0 0.0)))
|
|
(lg-attdefs-unsichtbar *lg-schema-reihe*)))
|
|
)
|
|
|
|
;; Schraffur-Vorgabe eines Belags aus der Tabelle belag_schraffur
|
|
;; (lager.json). Rueckgabe: (muster massstab winkel-grad) oder nil (keine
|
|
;; Schraffur: Belag null, unbekannt oder ohne Muster). Rein, getestet.
|
|
(defun lg-schraffur-vorgabe (belag tabelle / e m)
|
|
(if (and belag (= (type belag) 'STR))
|
|
(progn
|
|
(setq e (ssg-json-get tabelle belag))
|
|
(if (and e (listp e))
|
|
(progn
|
|
(setq m (ssg-json-get e "muster"))
|
|
(if (and m (= (type m) 'STR) (/= m ""))
|
|
(list m
|
|
(float (cond ((ssg-json-get e "massstab")) (1.0)))
|
|
(float (cond ((ssg-json-get e "winkel")) (0.0)))))))))
|
|
)
|
|
|
|
(if (not (boundp '*lg-schraffur-gemeldet*)) (setq *lg-schraffur-gemeldet* nil))
|
|
|
|
;; Schraffur in eine vorhandene Blockdefinition einsetzen: umrandet die
|
|
;; erste Polylinie der Definition, Layer 0 + Farbe VONBLOCK (erbt den
|
|
;; Geschoss-Layer der Referenz). vorgabe = (muster massstab winkel-grad).
|
|
;; Rueckgabe: T oder nil (Muster unbekannt o.ae., Meldung).
|
|
(defun lg-schraffur-einsetzen (bname vorgabe / blk pl h res)
|
|
(setq res
|
|
(vl-catch-all-apply
|
|
'(lambda ()
|
|
(setq blk (vla-Item (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) bname))
|
|
(vlax-for o blk
|
|
(if (and (null pl) (= (vla-get-ObjectName o) "AcDbPolyline")) (setq pl o)))
|
|
(setq h (vla-AddHatch blk 1 (car vorgabe) :vlax-false)) ; 1 = vordefiniert
|
|
(vla-put-Layer h "0")
|
|
(vla-put-Color h 0) ; 0 = VONBLOCK
|
|
(vla-put-PatternScale h (cadr vorgabe))
|
|
(vla-put-PatternAngle h (* (/ (caddr vorgabe) 180.0) pi))
|
|
(vlax-invoke h 'AppendOuterLoop (list pl))
|
|
(vla-Evaluate h)
|
|
T)))
|
|
(if (vl-catch-all-error-p res)
|
|
(progn
|
|
(if h (vl-catch-all-apply 'vla-Delete (list h)))
|
|
(princ (ssg-textf "lg-schraffur-fehler" (list (car vorgabe) bname (vl-catch-all-error-message res))))
|
|
nil)
|
|
res)
|
|
)
|
|
|
|
(defun lg-gang-blockdef (laenge breite belag / h bname tab vorgabe)
|
|
(setq h (/ breite 2.0)
|
|
bname (lg-gang-blockname laenge breite belag)
|
|
tab (lg-vorgabe '("belag_schraffur") nil)
|
|
vorgabe (lg-schraffur-vorgabe belag tab))
|
|
(if (and belag (= (type belag) 'STR) (/= belag "")
|
|
(not (assoc belag tab)) (not (member belag *lg-schraffur-gemeldet*)))
|
|
(progn
|
|
(setq *lg-schraffur-gemeldet* (cons belag *lg-schraffur-gemeldet*))
|
|
(princ (ssg-textf "lg-schraffur-unbekannt" (list belag)))))
|
|
(lg-blockdef bname
|
|
(append (list (lg-geom-rechteck 0.0 (- h) laenge h))
|
|
(lg-attdefs-unsichtbar *lg-schema-gang*)))
|
|
;; Schraffur nur einmal je Definition (auch nach einer Neudefinition)
|
|
(if (and vorgabe
|
|
(not (vl-some '(lambda (ed) (= (cdr (assoc 0 ed)) "HATCH")) (lg-blockdef-objekte bname))))
|
|
(lg-schraffur-einsetzen bname vorgabe))
|
|
bname
|
|
)
|
|
|
|
;; Linienobjekt (Reihe/Gang) von p1 nach p2 (WCS) einfuegen.
|
|
;; art = "reihe"|"gang", werte = Attribute ohne LAENGE/LAYER/ID.
|
|
;; Rueckgabe: ename oder nil (zu kurz).
|
|
(defun lg-linie-einfuegen (art p1 p2 werte bereich-ent / laenge quer gs lay bname ent)
|
|
(setq laenge (lg-mm-runden (distance (list (car p1) (cadr p1)) (list (car p2) (cadr p2)))))
|
|
(if (> laenge 0.0)
|
|
(progn
|
|
(setq gs (cdr (assoc "GESCHOSS" werte)))
|
|
(if (= art "reihe")
|
|
(setq quer (lg-zahl (cdr (assoc "TIEFE_mm" werte)))
|
|
lay (lg-layer "reihe" gs)
|
|
bname (progn (lg-reihe-blockdef laenge quer) (lg-reihe-blockname laenge quer)))
|
|
(setq quer (lg-zahl (cdr (assoc "BREITE_mm" werte)))
|
|
lay (lg-layer "gang" gs)
|
|
bname (lg-gang-blockdef laenge quer (cdr (assoc "BELAG" werte)))))
|
|
(setq werte (append (list (cons "LAENGE" (lg-mm-str laenge)) (cons "LAYER" lay)) werte))
|
|
(if (setq ent (lg-block-einfuegen bname p1 (angle p1 p2) lay werte))
|
|
(progn
|
|
(lg-attribute-setzen ent (list (cons "ID" (lg-handle ent))))
|
|
(if bereich-ent
|
|
(lg-xdata-setzen ent (list (cons "bereich" (cons 1005 (lg-handle bereich-ent))))))
|
|
ent))
|
|
)
|
|
)
|
|
)
|
|
|
|
;; Wie lg-linie-neu-aufbauen, danach schneidet das neue Objekt seine
|
|
;; Flaeche aus den rangniedrigeren Reihen/Gaengen heraus (lg-sperre-
|
|
;; anwenden) - fuer das Bearbeiten von Hand. Rueckgabe: neuer ename.
|
|
(defun lg-linie-neu-aufbauen-sperre (ent werte / neu)
|
|
(if (setq neu (lg-linie-neu-aufbauen ent werte))
|
|
(lg-sperre-anwenden neu))
|
|
neu
|
|
)
|
|
|
|
;; Reihe/Gang mit neuen Werten (inkl. LAENGE) an derselben Stelle neu
|
|
;; aufbauen. Rueckgabe: neuer ename.
|
|
(defun lg-linie-neu-aufbauen (ent werte / ed p1 rot art laenge p2 bereich neu)
|
|
(setq ed (entget ent)
|
|
p1 (cdr (assoc 10 ed))
|
|
rot (cond ((cdr (assoc 50 ed))) (0.0))
|
|
art (if (wcmatch (strcase (lg-blockname ent)) "LG_REIHE_*") "reihe" "gang")
|
|
laenge (lg-zahl (cdr (assoc "LAENGE" werte)))
|
|
bereich (lg-ent-aus-handle (lg-xdata-wert ent "bereich")))
|
|
(setq p2 (polar p1 rot laenge))
|
|
(setq werte (vl-remove-if '(lambda (p) (member (car p) '("LAENGE" "LAYER" "ID"))) werte))
|
|
(if (setq neu (lg-linie-einfuegen art p1 (list (car p2) (cadr p2) (caddr p1)) werte bereich))
|
|
(entdel ent))
|
|
neu
|
|
)
|
|
|
|
;; ============================================================
|
|
;; AUTO-FUELLUNG (reiner Kern, getestet)
|
|
;; ============================================================
|
|
;; pts = Bereichskontur in LOKALEN Koordinaten: Reihen laufen entlang +X.
|
|
;; params = Alist ("gang" "tiefe" "reihen" "q_abstand" "q_breite"
|
|
;; "min_reihe" "min_gang"), Zahlen in mm.
|
|
;; Muster quer zu den Reihen (in +Y ab Unterkante der Kontur), je Modul:
|
|
;; 2 Reihen je Gang: Reihe | Gang | Reihe (benachbarte Module stossen
|
|
;; Ruecken an Ruecken)
|
|
;; 1 Reihe je Gang: Reihe | Gang
|
|
;; Es werden nur volle Module gelegt; der Rest quer zu den Reihen wird als
|
|
;; restbreite zurueckgegeben (Protokoll, Attribut RESTBREITE_mm).
|
|
;; Quergaenge (q_abstand > 0): Luecken der Breite q_breite nach jeweils
|
|
;; q_abstand Reihenlaenge, ueber alle Reihen ausgerichtet (gemessen ab
|
|
;; linker Konturkante). Hauptgaenge laufen durch die Quergaenge durch.
|
|
;; Ein Streifen gilt nur dort als belegbar, wo Unterkante, Mitte und
|
|
;; Oberkante innerhalb der Kontur liegen.
|
|
;; Optionale params:
|
|
;; "rand" = (("N" . mm) ("O" . mm) ("S" . mm) ("W" . mm)) Randgaenge
|
|
;; nach Himmelsrichtung (Nord = +Y Welt), entlang der echten
|
|
;; Konturkanten (auch L-Form), siehe lg-randgang-streifen
|
|
;; "richtung" = Drehung lokal -> Welt (Bogenmass), fuer die Himmelsrichtung
|
|
;; "sperr" = Sperrpolygone (lokal, z.B. manuelle Gaenge)
|
|
;; Randgaenge und Sperrpolygone werden aus Reihen, Haupt- und Quergaengen
|
|
;; ausgeschnitten (exakt ueber das Band jedes Streifens, ssg-poly-band-x).
|
|
;; Randgaenge an der Unter-/Oberkante verschieben den Modulstapel, an der
|
|
;; linken/rechten Kante den Bezug der Quergaenge.
|
|
;; Rueckgabe: (records restbreite module) mit
|
|
;; record = (typ p1 p2 breite), typ = "reihe" | "gang" | "quergang" |
|
|
;; "randgang", p1/p2 = Anfang/Ende der Mittellinie (lokal, 2D).
|
|
;; Randgaenge stehen am Ende der Liste.
|
|
|
|
;; Himmelsrichtung einer Aussennormalen (Weltwinkel, Bogenmass), Nord = +Y.
|
|
;; Genau diagonale Kanten (45 Grad) zaehlen zu N/S.
|
|
(defun lg-kompass (winkel / g)
|
|
(setq g (* (/ winkel pi) 180.0))
|
|
(while (< g 0.0) (setq g (+ g 360.0)))
|
|
(while (>= g 360.0) (setq g (- g 360.0)))
|
|
(cond
|
|
((and (>= g (- 45.0 1e-6)) (<= g (+ 135.0 1e-6))) "N")
|
|
((and (>= g (- 225.0 1e-6)) (<= g (+ 315.0 1e-6))) "S")
|
|
((and (> g 135.0) (< g 225.0)) "W")
|
|
(T "O")
|
|
)
|
|
)
|
|
|
|
;; Laengenkorrektur eines Randgangs an einer Ecke (+ verlaengern, - kuerzen).
|
|
;; N/S-Randgaenge besitzen die Ecken: an einer konvexen Ecke wird der O/W-
|
|
;; Randgang um die Breite des N/S-Nachbarn gekuerzt (keine Doppelflaeche),
|
|
;; an einer einspringenden Ecke der N/S-Randgang um die Breite des O/W-
|
|
;; Nachbarn verlaengert (sonst bliebe dort ein freies Quadrat, in das eine
|
|
;; Reihe passt, und der Gang waere unterbrochen).
|
|
(defun lg-randgang-ecke (eigen nachbar nb konvex / ns-eigen ns-nachbar)
|
|
(setq ns-eigen (if (member eigen '("N" "S")) T nil)
|
|
ns-nachbar (if (member nachbar '("N" "S")) T nil))
|
|
(cond
|
|
((or (<= nb 0.0) (= eigen nachbar)) 0.0)
|
|
((and konvex (not ns-eigen) ns-nachbar) (- nb))
|
|
((and (not konvex) ns-eigen (not ns-nachbar)) nb)
|
|
(T 0.0)
|
|
)
|
|
)
|
|
|
|
;; Kreuzprodukt der Kanten (a b) und (b c) - Vorzeichen = Knickrichtung.
|
|
(defun lg-knick (k1 k2 / a b c)
|
|
(setq a (car k1) b (cadr k1) c (cadr k2))
|
|
(- (* (- (car b) (car a)) (- (cadr c) (cadr b)))
|
|
(* (- (cadr b) (cadr a)) (- (car c) (car b))))
|
|
)
|
|
|
|
;; Randgang-Streifen entlang der Konturkanten (lokale Koordinaten).
|
|
;; w = Drehung lokal -> Welt (Bogenmass), rand = Breiten je Himmelsrichtung.
|
|
;; Jede Kante bekommt den Randgang ihrer Himmelsrichtung (Aussennormale),
|
|
;; als Rechteck von der Kante nach innen; Ecken nach lg-randgang-ecke.
|
|
;; Rueckgabe: ((kompass p1 p2 breite polygon kante) ...), p1/p2 = Mittellinie.
|
|
(defun lg-randgang-streifen (pts w rand min-g / s kanten n kompasse breiten erg i k b
|
|
p q a vor nach t0 t1 nin p1 p2)
|
|
(setq pts (mapcar '(lambda (p) (list (car p) (cadr p))) pts)
|
|
s (ssg-poly-flaeche-signiert pts)
|
|
kanten (ssg-poly-kanten pts)
|
|
n (length kanten)
|
|
erg nil)
|
|
(if (and rand (> n 2) (not (equal s 0.0 1e-9)))
|
|
(progn
|
|
(setq kompasse
|
|
(mapcar '(lambda (k / a)
|
|
(setq a (angle (car k) (cadr k)))
|
|
(lg-kompass (+ w (if (> s 0.0) (- a (/ pi 2.0)) (+ a (/ pi 2.0))))))
|
|
kanten))
|
|
(setq breiten (mapcar '(lambda (r) (cond ((lg-zahl (cdr (assoc r rand)))) (0.0))) kompasse))
|
|
(setq i 0)
|
|
(foreach k kanten
|
|
(setq b (nth i breiten))
|
|
(if (> b 0.0)
|
|
(progn
|
|
(setq vor (rem (+ i n -1) n)
|
|
nach (rem (1+ i) n)
|
|
p (car k) q (cadr k) a (angle p q)
|
|
nin (if (> s 0.0) (+ a (/ pi 2.0)) (- a (/ pi 2.0))))
|
|
(setq t0 (lg-randgang-ecke (nth i kompasse) (nth vor kompasse) (nth vor breiten)
|
|
(> (* s (lg-knick (nth vor kanten) k)) 0.0))
|
|
t1 (lg-randgang-ecke (nth i kompasse) (nth nach kompasse) (nth nach breiten)
|
|
(> (* s (lg-knick k (nth nach kanten))) 0.0)))
|
|
(setq p1 (polar p a (- t0))
|
|
p2 (polar q a t1))
|
|
(if (>= (+ (distance p q) t0 t1) min-g)
|
|
(setq erg (cons (list (nth i kompasse)
|
|
(polar p1 nin (/ b 2.0)) (polar p2 nin (/ b 2.0)) b
|
|
(list p1 p2 (polar p2 nin b) (polar p1 nin b))
|
|
k)
|
|
erg))))
|
|
)
|
|
(setq i (1+ i))
|
|
)
|
|
)
|
|
)
|
|
(reverse erg)
|
|
)
|
|
|
|
;; Gesperrte x-Intervalle eines Bandes y0..y1 (je Sperrpolygon eins).
|
|
(defun lg-sperr-intervalle (sperr y0 y1 / erg iv)
|
|
(setq erg nil)
|
|
(foreach s sperr
|
|
(if (setq iv (ssg-poly-band-x s y0 y1)) (setq erg (cons iv erg))))
|
|
erg
|
|
)
|
|
|
|
(defun lg-streifen-intervalle (pts y0 y1 / e)
|
|
(setq e (min 0.01 (/ (- y1 y0) 4.0)))
|
|
(ssg-intervalle-schnitt
|
|
(ssg-intervalle-schnitt (ssg-poly-schnitt-y pts (+ y0 e))
|
|
(ssg-poly-schnitt-y pts (/ (+ y0 y1) 2.0)))
|
|
(ssg-poly-schnitt-y pts (- y1 e)))
|
|
)
|
|
|
|
;; Quergang-Luecken entlang X. Eine Luecke entsteht nur, wenn dahinter noch
|
|
;; ein Reihenstueck von mindestens min-rest Platz hat - ein Quergang am
|
|
;; Reihenende waere sinnlos und kostete nur Regalflaeche.
|
|
(defun lg-quergang-luecken (xmin xmax q-abstand q-breite min-rest / erg x)
|
|
(setq erg nil)
|
|
(if (and q-abstand (> q-abstand 0.0) q-breite (> q-breite 0.0))
|
|
(progn
|
|
(setq x (+ xmin q-abstand))
|
|
(while (<= (+ x q-breite min-rest) xmax)
|
|
(setq erg (cons (list x (+ x q-breite)) erg)
|
|
x (+ x q-breite q-abstand)))))
|
|
(reverse erg)
|
|
)
|
|
|
|
;; Parameter mit Vorgabe (nil/fehlend -> vorgabe).
|
|
(defun lg-param (params k vorgabe)
|
|
(cond ((cdr (assoc k params))) (vorgabe))
|
|
)
|
|
|
|
(defun lg-fuellung-berechnen (pts params / bb xmin xmax ymin ymax g tf r muster pitch
|
|
y module recs luecken gang-y y-start iv yc b typ
|
|
pts-t xc m i l min-r min-g rand-str sperr sperr-t
|
|
unten oben links rechts k gesperrt)
|
|
(setq g (float (lg-param params "gang" 1000.0))
|
|
tf (float (lg-param params "tiefe" 700.0))
|
|
r (lg-param params "reihen" 2)
|
|
min-r (lg-param params "min_reihe" 500.0)
|
|
min-g (lg-param params "min_gang" 100.0))
|
|
(setq muster (if (= r 1)
|
|
(list (list "reihe" tf) (list "gang" g))
|
|
(list (list "reihe" tf) (list "gang" g) (list "reihe" tf))))
|
|
(setq pitch (apply '+ (mapcar 'cadr muster)))
|
|
(setq bb (ssg-poly-bbox pts)
|
|
xmin (car (car bb)) ymin (cadr (car bb))
|
|
xmax (car (cadr bb)) ymax (cadr (cadr bb)))
|
|
;; Randgaenge + Sperrpolygone
|
|
(setq rand-str (lg-randgang-streifen pts (lg-param params "richtung" 0.0)
|
|
(lg-param params "rand" nil) min-g))
|
|
(setq sperr (append (lg-param params "sperr" nil) (mapcar '(lambda (s) (nth 4 s)) rand-str)))
|
|
;; Randgaenge an den Aussenkanten der Huelle verschieben Stapel und Quergang-Bezug
|
|
(setq unten 0.0 oben 0.0 links 0.0 rechts 0.0)
|
|
(foreach s rand-str
|
|
(setq k (nth 5 s))
|
|
(cond
|
|
((equal (cadr (car k)) (cadr (cadr k)) 1e-6) ; waagrechte Kante
|
|
(cond ((equal (cadr (car k)) ymin 1e-3) (setq unten (max unten (nth 3 s))))
|
|
((equal (cadr (car k)) ymax 1e-3) (setq oben (max oben (nth 3 s))))))
|
|
((equal (car (car k)) (car (cadr k)) 1e-6) ; senkrechte Kante
|
|
(cond ((equal (car (car k)) xmin 1e-3) (setq links (max links (nth 3 s))))
|
|
((equal (car (car k)) xmax 1e-3) (setq rechts (max rechts (nth 3 s))))))
|
|
)
|
|
)
|
|
(setq luecken (lg-quergang-luecken (+ xmin links) (- xmax rechts) (lg-param params "q_abstand" 0.0)
|
|
(lg-param params "q_breite" 0.0) min-r))
|
|
(setq y (+ ymin unten) y-start y module 0 recs nil gang-y nil)
|
|
(while (<= (+ y pitch) (+ (- ymax oben) 1e-6))
|
|
(foreach m muster
|
|
(setq typ (car m) b (cadr m) yc (+ y (/ b 2.0)))
|
|
(setq iv (lg-streifen-intervalle pts y (+ y b))
|
|
gesperrt (lg-sperr-intervalle sperr y (+ y b)))
|
|
(if (= typ "reihe")
|
|
(progn
|
|
(setq iv (ssg-intervalle-minus (ssg-intervalle-minus iv luecken) gesperrt))
|
|
(foreach i iv
|
|
(if (>= (- (cadr i) (car i)) min-r)
|
|
(setq recs (cons (list "reihe" (list (car i) yc) (list (cadr i) yc) b) recs)))))
|
|
(progn
|
|
(setq gang-y (cons (list y (+ y b)) gang-y))
|
|
(foreach i (ssg-intervalle-minus iv gesperrt)
|
|
(if (>= (- (cadr i) (car i)) min-g)
|
|
(setq recs (cons (list "gang" (list (car i) yc) (list (cadr i) yc) b) recs))))))
|
|
(setq y (+ y b))
|
|
)
|
|
(setq module (1+ module))
|
|
)
|
|
;; Quergaenge: senkrechte Streifen in den Luecken, nur im belegten
|
|
;; Modulbereich und ohne die Hauptgaenge (die zaehlen schon als Gang).
|
|
(if (and luecken (> module 0))
|
|
(progn
|
|
(setq pts-t (mapcar '(lambda (q) (list (cadr q) (car q))) pts)
|
|
sperr-t (mapcar '(lambda (s) (mapcar '(lambda (q) (list (cadr q) (car q))) s)) sperr)
|
|
gang-y (reverse gang-y))
|
|
(foreach l luecken
|
|
(setq xc (/ (+ (car l) (cadr l)) 2.0))
|
|
(setq iv (ssg-intervalle-schnitt (lg-streifen-intervalle pts-t (car l) (cadr l))
|
|
(list (list y-start y))))
|
|
(setq iv (ssg-intervalle-minus (ssg-intervalle-minus iv gang-y)
|
|
(lg-sperr-intervalle sperr-t (car l) (cadr l))))
|
|
(foreach i iv
|
|
(if (>= (- (cadr i) (car i)) min-g)
|
|
(setq recs (cons (list "quergang" (list xc (car i)) (list xc (cadr i))
|
|
(- (cadr l) (car l)))
|
|
recs))))
|
|
)
|
|
)
|
|
)
|
|
(foreach s rand-str
|
|
(setq recs (cons (list "randgang" (cadr s) (caddr s) (cadddr s)) recs)))
|
|
(list (reverse recs) (- (- ymax oben) y) module)
|
|
)
|
|
|
|
;; Richtung der Reihen als Vorgabe: Winkel der laengsten Konturkante (Grad,
|
|
;; auf [0,180) normiert).
|
|
(defun lg-kontur-richtung (pts / best w l)
|
|
(setq best nil l 0.0)
|
|
(foreach k (ssg-poly-kanten pts)
|
|
(if (> (distance (list (car (car k)) (cadr (car k))) (list (car (cadr k)) (cadr (cadr k)))) l)
|
|
(setq l (distance (list (car (car k)) (cadr (car k))) (list (car (cadr k)) (cadr (cadr k))))
|
|
best k)))
|
|
(if best
|
|
(progn
|
|
(setq w (* (/ (angle (car best) (cadr best)) pi) 180.0))
|
|
(while (>= w 180.0) (setq w (- w 180.0)))
|
|
(if (equal w 180.0 1e-6) 0.0 w))
|
|
0.0)
|
|
)
|
|
|
|
;; ============================================================
|
|
;; LAGERBEREICHE
|
|
;; ============================================================
|
|
|
|
(defun lg-bereich-blockdef ( / )
|
|
(lg-blockdef "LG_BEREICH"
|
|
(append
|
|
(list (lg-geom-kreis '(0.0 0.0 0.0) 250.0)
|
|
;; Pfeil zeigt die Reihenrichtung (Einfuegedrehung = RICHTUNG)
|
|
(lg-geom-linie '(250.0 0.0 0.0) '(800.0 0.0 0.0))
|
|
(lg-geom-linie '(800.0 0.0 0.0) '(650.0 80.0 0.0))
|
|
(lg-geom-linie '(800.0 0.0 0.0) '(650.0 -80.0 0.0))
|
|
(lg-geom-attdef "NR" "" '(-100.0 -80.0 0.0) 160.0 T))
|
|
(lg-attdefs-unsichtbar (vl-remove-if '(lambda (p) (= (car p) "NR")) *lg-schema-bereich*))))
|
|
)
|
|
|
|
(defun lg-bereich-naechste-nr ( / nrs)
|
|
(setq nrs (mapcar '(lambda (e) (atoi (cond ((cdr (assoc "NR" (ssg-attrib-read e)))) ("0"))))
|
|
(lg-alle-bloecke "LG_BEREICH")))
|
|
(if nrs (1+ (apply 'max nrs)) 1)
|
|
)
|
|
|
|
(defun lg-bereich-vorgaben (pts / )
|
|
(list (cons "GANGBREITE_mm" (lg-mm-str (lg-zahl (lg-vorgabe '("bereich" "gangbreite_mm") 1000))))
|
|
(cons "REGALTIEFE_mm" (lg-mm-str (lg-zahl (lg-vorgabe '("bereich" "regaltiefe_mm") 700))))
|
|
(cons "REIHEN_JE_GANG" (itoa (fix (lg-zahl (lg-vorgabe '("bereich" "reihen_je_gang") 2)))))
|
|
(cons "SCHIENEN_JE_GANG" (itoa (fix (lg-zahl (lg-vorgabe '("bereich" "schienen_je_gang") 1)))))
|
|
(cons "QUERGANG_ABSTAND_mm" (lg-mm-str (lg-zahl (lg-vorgabe '("bereich" "quergang_abstand_mm") 0))))
|
|
(cons "QUERGANG_BREITE_mm" (lg-mm-str (lg-zahl (lg-vorgabe '("bereich" "quergang_breite_mm") 1200))))
|
|
(cons "RICHTUNG" (lg-mm-str (if pts (lg-kontur-richtung pts) 0.0)))
|
|
(cons "HAENGEEBENEN" (lg-vorgabe '("reihe" "haengeebenen") "2300/1200;1100/1100"))
|
|
(cons "BELAG" (lg-vorgabe '("bereich" "belag") "spanplatte"))
|
|
(cons "RANDGANG_N_mm" (lg-mm-str (lg-zahl (lg-vorgabe '("bereich" "randgang_mm" "n") 0))))
|
|
(cons "RANDGANG_O_mm" (lg-mm-str (lg-zahl (lg-vorgabe '("bereich" "randgang_mm" "o") 0))))
|
|
(cons "RANDGANG_S_mm" (lg-mm-str (lg-zahl (lg-vorgabe '("bereich" "randgang_mm" "s") 0))))
|
|
(cons "RANDGANG_W_mm" (lg-mm-str (lg-zahl (lg-vorgabe '("bereich" "randgang_mm" "w") 0)))))
|
|
)
|
|
|
|
;; Randgang-Breiten eines Bereichs (Attribute) fuer lg-fuellung-berechnen.
|
|
;; Fehlt ein Attribut (Altbestand), gilt 0.
|
|
(defun lg-bereich-rand (a)
|
|
(mapcar '(lambda (r) (cons r (cond ((lg-zahl (cdr (assoc (strcat "RANDGANG_" r "_mm") a)))) (0.0))))
|
|
'("N" "O" "S" "W"))
|
|
)
|
|
|
|
;; Lagerbereich, in dessen Kontur pt liegt (gleiches Geschoss), oder nil.
|
|
(defun lg-bereich-fuer-punkt (pt gs / )
|
|
(vl-some '(lambda (b / k)
|
|
(if (and (= (cdr (assoc "GESCHOSS" (ssg-attrib-read b))) (vl-princ-to-string gs))
|
|
(setq k (lg-ent-aus-handle (lg-xdata-wert b "kontur")))
|
|
(ssg-punkt-in-poly-p pt (ssg-lwpoly-punkte k)))
|
|
b))
|
|
(lg-alle-bloecke "LG_BEREICH"))
|
|
)
|
|
|
|
;; Grundriss einer Reihe/eines Gangs als Rechteck (WCS, 2D) aus
|
|
;; Einfuegepunkt, Drehung, LAENGE und Breite (Gang BREITE_mm, Reihe
|
|
;; TIEFE_mm) - beide liegen mittig auf ihrer Linie.
|
|
(defun lg-linie-polygon (ent / ed a p1 p2 rot l b n)
|
|
(setq ed (entget ent) a (ssg-attrib-read ent)
|
|
p1 (cdr (assoc 10 ed)) p1 (list (car p1) (cadr p1))
|
|
rot (cond ((cdr (assoc 50 ed))) (0.0))
|
|
l (cond ((lg-zahl (cdr (assoc "LAENGE" a)))) (0.0))
|
|
b (cond ((lg-zahl (cdr (assoc "BREITE_mm" a)))) ((lg-zahl (cdr (assoc "TIEFE_mm" a)))) (0.0))
|
|
p2 (polar p1 rot l)
|
|
n (+ rot (/ pi 2.0)))
|
|
(list (polar p1 n (/ b -2.0)) (polar p2 n (/ b -2.0)) (polar p2 n (/ b 2.0)) (polar p1 n (/ b 2.0)))
|
|
)
|
|
|
|
(defun lg-quelle (ent)
|
|
(cdr (assoc "QUELLE" (ssg-attrib-read ent)))
|
|
)
|
|
|
|
(defun lg-manuell-p (ent)
|
|
(= (lg-quelle ent) "manuell")
|
|
)
|
|
|
|
;; Von Hand gesetzt oder geaendert: bleibt bei jeder Neuberechnung stehen.
|
|
(defun lg-von-hand-p (ent)
|
|
(if (member (lg-quelle ent) '("manuell" "auto_geaendert")) T)
|
|
)
|
|
|
|
;; Rang einer QUELLE fuer das Ausschneiden: ein Objekt schneidet nur aus
|
|
;; rangniedrigeren heraus (auto < auto_geaendert < manuell). Rein, getestet.
|
|
(defun lg-quelle-rang (q)
|
|
(cond ((= q "manuell") 2) ((= q "auto_geaendert") 1) (T 0))
|
|
)
|
|
|
|
;; Reiner Kern: was von einer Reihe/einem Gang uebrig bleibt, wenn die
|
|
;; Sperrpolygone herausgeschnitten werden. Lokal: Linie von 0 bis laenge
|
|
;; entlang +X, Breite b mittig darauf; sperr = Polygone im selben System.
|
|
;; Stuecke unter min-l fallen weg. Rueckgabe ((x0 x1) ...) - leer = ganz
|
|
;; ueberdeckt - oder 'unveraendert, wenn kein Polygon die Flaeche schneidet.
|
|
(defun lg-linie-zuschnitt (laenge b sperr min-l / ganz rest)
|
|
(setq ganz (list (list 0.0 (float laenge)))
|
|
rest (ssg-intervalle-minus ganz (lg-sperr-intervalle sperr (/ b -2.0) (/ b 2.0))))
|
|
(if (equal rest ganz 1e-6)
|
|
'unveraendert
|
|
(vl-remove-if '(lambda (i) (< (- (cadr i) (car i)) min-l)) rest))
|
|
)
|
|
|
|
;; Sperrflaeche eines von Hand gesetzten oder geaenderten Objekts (Reihe/
|
|
;; Gang) auf die rangniedrigeren Reihen und Gaenge desselben Geschosses
|
|
;; anwenden (lg-quelle-rang: ein manuelles Objekt schneidet aus auto und
|
|
;; auto_geaendert, ein geaendertes nur aus auto): ueberdeckte Stuecke werden
|
|
;; herausgeschnitten, die Reste behalten ihre Attribute (QUELLE, BEREICH ...).
|
|
;; Bewusst KEINE Neuberechnung des Bereichs - sonst kaemen von Hand
|
|
;; geloeschte Objekte zurueck und von Hand geaenderte wuerden ersetzt.
|
|
;; Rueckgabe: Anzahl zugeschnittener Objekte.
|
|
(defun lg-sperre-anwenden (sperr-ent / gs rang poly n a ed p1 rot art l b min-l lok stuecke werte bereich)
|
|
(setq a (ssg-attrib-read sperr-ent)
|
|
gs (cdr (assoc "GESCHOSS" a))
|
|
rang (lg-quelle-rang (cdr (assoc "QUELLE" a)))
|
|
poly (lg-linie-polygon sperr-ent)
|
|
n 0)
|
|
(foreach k (append (lg-alle-bloecke "LG_REIHE_*") (lg-alle-bloecke "LG_GANG_*"))
|
|
(setq a (ssg-attrib-read k))
|
|
(if (and (not (equal k sperr-ent))
|
|
(= (cdr (assoc "GESCHOSS" a)) gs)
|
|
(< (lg-quelle-rang (cdr (assoc "QUELLE" a))) rang))
|
|
(progn
|
|
(setq ed (entget k)
|
|
p1 (cdr (assoc 10 ed))
|
|
rot (cond ((cdr (assoc 50 ed))) (0.0))
|
|
art (if (wcmatch (strcase (lg-blockname k)) "LG_REIHE_*") "reihe" "gang")
|
|
l (cond ((lg-zahl (cdr (assoc "LAENGE" a)))) (0.0))
|
|
b (cond ((lg-zahl (cdr (assoc (if (= art "reihe") "TIEFE_mm" "BREITE_mm") a)))) (0.0))
|
|
min-l (lg-zahl (if (= art "reihe")
|
|
(lg-vorgabe '("bereich" "min_reihenlaenge_mm") 500)
|
|
(lg-vorgabe '("bereich" "min_ganglaenge_mm") 100)))
|
|
lok (ssg-poly-drehen (mapcar '(lambda (q) (list (- (car q) (car p1)) (- (cadr q) (cadr p1)))) poly)
|
|
(- rot) '(0.0 0.0))
|
|
stuecke (lg-linie-zuschnitt l b (list lok) min-l))
|
|
(if (not (eq stuecke 'unveraendert))
|
|
(progn
|
|
(setq werte (vl-remove-if '(lambda (p) (member (car p) '("LAENGE" "LAYER" "ID"))) a)
|
|
bereich (lg-ent-aus-handle (lg-xdata-wert k "bereich")))
|
|
(foreach s stuecke
|
|
(lg-linie-einfuegen art (polar p1 rot (car s)) (polar p1 rot (cadr s)) werte bereich))
|
|
(entdel k)
|
|
(setq n (1+ n)))))))
|
|
n
|
|
)
|
|
|
|
;; Alle Kinder (Reihen/Gaenge) eines Bereichs.
|
|
(defun lg-bereich-kinder (bereich-ent / h)
|
|
(setq h (lg-handle bereich-ent))
|
|
(vl-remove-if-not '(lambda (e) (equal (lg-xdata-wert e "bereich") h))
|
|
(append (lg-alle-bloecke "LG_REIHE_*") (lg-alle-bloecke "LG_GANG_*")))
|
|
)
|
|
|
|
;; Von Hand gesetzte Reihen/Gaenge (QUELLE manuell) desselben Geschosses,
|
|
;; die nicht mit einem Bereich verknuepft sind, aber mit ihrer Mitte in der
|
|
;; Kontur pts liegen (z.B. Altbestand von LG_REIHE vor der Verknuepfung).
|
|
(defun lg-manuelle-in-kontur (gs pts / a p q)
|
|
(vl-remove-if-not
|
|
'(lambda (e)
|
|
(setq a (ssg-attrib-read e))
|
|
(if (and (= (cdr (assoc "GESCHOSS" a)) gs)
|
|
(= (cdr (assoc "QUELLE" a)) "manuell")
|
|
(null (lg-xdata-wert e "bereich")))
|
|
(progn
|
|
(setq p (lg-linie-polygon e)
|
|
q (list (/ (+ (car (car p)) (car (caddr p))) 2.0) (/ (+ (cadr (car p)) (cadr (caddr p))) 2.0)))
|
|
(ssg-punkt-in-poly-p q pts))))
|
|
(append (lg-alle-bloecke "LG_REIHE_*") (lg-alle-bloecke "LG_GANG_*")))
|
|
)
|
|
|
|
;; Reihen/Gaenge eines Bereichs aus seinen Attributen (neu) erzeugen.
|
|
;; Die automatisch erzeugten Kinder (QUELLE auto) werden vorher entfernt
|
|
;; (Sektions-Neuaufbau statt Feld-Splice). Von Hand gesetzte (manuell) und
|
|
;; von Hand geaenderte (auto_geaendert) Reihen und Gaenge bleiben stehen und
|
|
;; sparen ihre Flaeche aus - ebenso unverknuepfte manuelle Objekte in der
|
|
;; Kontur. Rueckgabe: (reihen gaenge restbreite).
|
|
(defun lg-bereich-fuellen (bereich-ent / a kontur pts w pts-l erg z gs
|
|
n-reihen n-gaenge werte-reihe werte-gang p1 p2 behalten)
|
|
(setq a (ssg-attrib-read bereich-ent)
|
|
kontur (lg-ent-aus-handle (lg-xdata-wert bereich-ent "kontur")))
|
|
(if (null kontur)
|
|
(progn (princ (ssg-text "lg-bereich-ohne-kontur")) nil)
|
|
(progn
|
|
(setq behalten nil)
|
|
(foreach k (lg-bereich-kinder bereich-ent)
|
|
(if (lg-von-hand-p k)
|
|
(setq behalten (cons k behalten))
|
|
(entdel k)))
|
|
(setq pts (ssg-lwpoly-punkte kontur)
|
|
behalten (append behalten (lg-manuelle-in-kontur (cdr (assoc "GESCHOSS" a)) pts)))
|
|
(if behalten
|
|
(princ (ssg-textf "lg-bereich-beibehalten" (list (itoa (length behalten)) (cdr (assoc "NR" a))))))
|
|
(setq z (if (caddr (car pts)) (caddr (car pts)) 0.0)
|
|
w (* (/ (cond ((lg-zahl (cdr (assoc "RICHTUNG" a)))) (0.0)) 180.0) pi)
|
|
pts-l (ssg-poly-drehen pts (- w) '(0.0 0.0)))
|
|
(setq erg (lg-fuellung-berechnen pts-l
|
|
(list (cons "gang" (lg-zahl (cdr (assoc "GANGBREITE_mm" a))))
|
|
(cons "tiefe" (lg-zahl (cdr (assoc "REGALTIEFE_mm" a))))
|
|
(cons "reihen" (atoi (cdr (assoc "REIHEN_JE_GANG" a))))
|
|
(cons "q_abstand" (lg-zahl (cdr (assoc "QUERGANG_ABSTAND_mm" a))))
|
|
(cons "q_breite" (lg-zahl (cdr (assoc "QUERGANG_BREITE_mm" a))))
|
|
(cons "min_reihe" (lg-zahl (lg-vorgabe '("bereich" "min_reihenlaenge_mm") 500)))
|
|
(cons "min_gang" (lg-zahl (lg-vorgabe '("bereich" "min_ganglaenge_mm") 100)))
|
|
(cons "rand" (lg-bereich-rand a))
|
|
(cons "richtung" w)
|
|
(cons "sperr" (mapcar '(lambda (g) (ssg-poly-drehen (lg-linie-polygon g) (- w) '(0.0 0.0)))
|
|
behalten)))))
|
|
(setq gs (cdr (assoc "GESCHOSS" a)) n-reihen 0 n-gaenge 0)
|
|
(setq werte-reihe
|
|
(list (cons "GESCHOSS" gs) (cons "TIEFE_mm" (cdr (assoc "REGALTIEFE_mm" a)))
|
|
(cons "HAENGEEBENEN" (cdr (assoc "HAENGEEBENEN" a)))
|
|
(cons "SCHIENEN" (cdr (assoc "SCHIENEN_JE_GANG" a)))
|
|
(cons "BEREICH" (cdr (assoc "NR" a))) (cons "QUELLE" "auto")))
|
|
(foreach r (car erg)
|
|
(setq p1 (ssg-punkt-drehen (cadr r) w '(0.0 0.0))
|
|
p2 (ssg-punkt-drehen (caddr r) w '(0.0 0.0))
|
|
p1 (list (car p1) (cadr p1) z)
|
|
p2 (list (car p2) (cadr p2) z))
|
|
(if (= (car r) "reihe")
|
|
(if (lg-linie-einfuegen "reihe" p1 p2 werte-reihe bereich-ent)
|
|
(setq n-reihen (1+ n-reihen)))
|
|
(progn
|
|
(setq werte-gang
|
|
(list (cons "GESCHOSS" gs) (cons "BREITE_mm" (lg-mm-str (cadddr r)))
|
|
(cons "ART" (car r)) (cons "BELAG" (cdr (assoc "BELAG" a)))
|
|
(cons "BEREICH" (cdr (assoc "NR" a))) (cons "QUELLE" "auto")))
|
|
(if (lg-linie-einfuegen "gang" p1 p2 werte-gang bereich-ent)
|
|
(setq n-gaenge (1+ n-gaenge)))))
|
|
)
|
|
(lg-attribute-setzen bereich-ent (list (cons "RESTBREITE_mm" (lg-mm-str (cadr erg)))))
|
|
(princ (ssg-textf "lg-bereich-gefuellt"
|
|
(list (cdr (assoc "NR" a)) (itoa n-reihen) (itoa n-gaenge) (lg-mm-str (cadr erg)))))
|
|
(list n-reihen n-gaenge (cadr erg))
|
|
)
|
|
)
|
|
)
|
|
|
|
;; Bereich zur Kontur anlegen und fuellen (nicht interaktiv).
|
|
;; werte = Bereichsparameter (lg-bereich-vorgaben + Dialog); GESCHOSS muss
|
|
;; gesetzt sein. Rueckgabe: ename des Bereich-Blocks oder nil.
|
|
(defun lg-bereich-anlegen (kontur werte / blk)
|
|
(if (setq blk (lg-bereich-block-anlegen kontur werte))
|
|
(progn (lg-bereich-fuellen blk) blk))
|
|
)
|
|
|
|
;; Nur den Bereich-Block zur Kontur anlegen und verknuepfen, ohne Fuellung
|
|
;; (Geschoss kopieren uebernimmt die Kinder 1:1). NR, LAYER und ID werden
|
|
;; neu vergeben. Rueckgabe: ename oder nil.
|
|
(defun lg-bereich-block-anlegen (kontur werte / gs nr lay pts bb pt blk)
|
|
(setq gs (cdr (assoc "GESCHOSS" werte))
|
|
nr (lg-bereich-naechste-nr)
|
|
lay (lg-layer "bereich" gs))
|
|
(setq kontur (lg-kontur-uebernehmen kontur lay))
|
|
(setq pts (ssg-lwpoly-punkte kontur)
|
|
bb (ssg-poly-bbox pts))
|
|
(setq pt (list (/ (+ (car (car bb)) (car (cadr bb))) 2.0)
|
|
(/ (+ (cadr (car bb)) (cadr (cadr bb))) 2.0)
|
|
(if (caddr (car pts)) (caddr (car pts)) 0.0)))
|
|
(if (not (ssg-punkt-in-poly-p pt pts)) (setq pt (car pts)))
|
|
(lg-bereich-blockdef)
|
|
;; vorne angefuegt: assoc findet die neuen Werte vor evtl. alten (Kopie)
|
|
(setq werte (append (list (cons "NR" (itoa nr)) (cons "LAYER" lay)
|
|
(cons "ID" (strcat "B" (itoa nr))))
|
|
werte))
|
|
(if (setq blk (lg-block-einfuegen "LG_BEREICH" pt
|
|
(* (/ (cond ((lg-zahl (cdr (assoc "RICHTUNG" werte)))) (0.0)) 180.0) pi)
|
|
lay werte))
|
|
(progn
|
|
(lg-xdata-setzen blk (list (cons "kontur" (cons 1005 (lg-handle kontur)))))
|
|
(lg-xdata-setzen kontur (list (cons "besitzer" (cons 1005 (lg-handle blk)))
|
|
(cons "rolle" (cons 1000 "bereich"))))
|
|
blk))
|
|
)
|
|
|
|
;; ============================================================
|
|
;; GOH_RACK-ERKENNUNG (lg-racks-sammeln, Befehl LG_REGALE)
|
|
;; ============================================================
|
|
;; goh_rack ist ein parametrischer BricsCAD-Block (MCAD-Parametrik), KEIN
|
|
;; AutoCAD-Dynamikblock: seine Referenzen tragen einen anonymen Namen
|
|
;; ("*U29"), IsDynamicBlock ist FALSE, und der echte Name sowie die
|
|
;; Parameter stehen nur in den Objekteigenschaften:
|
|
;; (getpropertyvalue ent "EffectiveName") -> "goh_rack"
|
|
;; (getpropertyvalue ent "Laenge~MCAD") -> "7187.52 mm"
|
|
;; Gefunden werden Racks direkt im Modellbereich, in assoziativen Arrays
|
|
;; (anonymer Block mit Referenzen), in MINSERT-Rastern und in beliebig
|
|
;; verschachtelten Bloecken (bis *lg-rack-max-tiefe*). Blockname und
|
|
;; Parameternamen aus lager.json "goh_rack".
|
|
;; Ergebnis je Rack: (name laenge-mm ebenen mitte top-ent), Zugriff ueber
|
|
;; lg-rk-*. top-ent = oberstes INSERT im Modellbereich, in dem das Rack
|
|
;; steckt (bei einem direkt eingefuegten Rack es selbst) - ueber dessen
|
|
;; Layer _G<nr> ordnet lg-rack-geschoss das Geschoss zu.
|
|
|
|
(setq *lg-rack-max-tiefe* 8)
|
|
|
|
(defun lg-rk-name (r) (nth 0 r))
|
|
(defun lg-rk-laenge (r) (nth 1 r))
|
|
(defun lg-rk-ebenen (r) (nth 2 r))
|
|
(defun lg-rk-mitte (r) (nth 3 r))
|
|
(defun lg-rk-top (r) (nth 4 r))
|
|
|
|
;; Reiner Kern: Zahl aus einem Parameterwert. MCAD-Parameter kommen als
|
|
;; Text mit Einheit ("700 mm", "71.8752 cm", "12.9 m") - auf mm umgerechnet;
|
|
;; ohne Einheit unveraendert. Unbekannte Einheit/kein Zahlanfang -> nil.
|
|
(defun lg-zahl-einheit (v / s i c ziffern zahl rest faktor)
|
|
(cond
|
|
((numberp v) (float v))
|
|
((= (type v) 'STR)
|
|
(setq s (vl-string-translate "," "." (vl-string-trim " \t\r\n" v))
|
|
i 1 ziffern "")
|
|
(while (and (<= i (strlen s))
|
|
(setq c (substr s i 1))
|
|
(or (wcmatch c "#") (member c '("." "-" "+"))))
|
|
(setq ziffern (strcat ziffern c) i (1+ i)))
|
|
(setq zahl (if (/= ziffern "") (distof ziffern 2))
|
|
rest (strcase (vl-string-trim " \t" (substr s i)))
|
|
faktor (cdr (assoc rest '(("" . 1.0) ("MM" . 1.0) ("CM" . 10.0) ("DM" . 100.0) ("M" . 1000.0)))))
|
|
(if (and zahl faktor) (* zahl faktor)))
|
|
(T nil))
|
|
)
|
|
|
|
;; Reiner Kern: ein echter Blockname (nicht leer, nicht anonym "*U..").
|
|
(defun lg-name-brauchbar-p (s)
|
|
(if (and (= (type s) 'STR) (/= s "") (/= (substr s 1 1) "*")) T)
|
|
)
|
|
|
|
;; Objekteigenschaft lesen, nil wenn es sie nicht gibt.
|
|
(defun lg-prop (ent name / r)
|
|
(setq r (vl-catch-all-apply 'getpropertyvalue (list ent name)))
|
|
(if (vl-catch-all-error-p r) nil r)
|
|
)
|
|
|
|
;; Name, unter dem eine Referenz gefuehrt wird: Objekteigenschaft
|
|
;; EffectiveName (auch fuer MCAD-Bloecke), sonst ActiveX-EffectiveName,
|
|
;; sonst DXF-Blockname.
|
|
(defun lg-rack-name (ent / n)
|
|
(cond
|
|
((lg-name-brauchbar-p (setq n (lg-prop ent "EffectiveName"))) n)
|
|
(T (lg-blockname ent)))
|
|
)
|
|
|
|
(defun lg-rack-p (ent / n)
|
|
(setq n (lg-rack-name ent))
|
|
(and n (= (strcase n) (strcase *lg-rack-suchname*)))
|
|
)
|
|
|
|
;; MCAD-Parameter (Kennung "<Name>~MCAD" in listallproperties, Gross-/
|
|
;; Kleinschreibung egal).
|
|
(defun lg-mcad-param (ent name / props id soll)
|
|
(setq props (vl-catch-all-apply 'listallproperties (list ent))
|
|
soll (strcase (strcat name "~MCAD")))
|
|
(if (and (not (vl-catch-all-error-p props)) (listp props)
|
|
(setq id (vl-some '(lambda (p / s)
|
|
(setq s (vl-princ-to-string p))
|
|
(if (= (strcase s) soll) s))
|
|
props)))
|
|
(lg-prop ent id))
|
|
)
|
|
|
|
;; Dynamische Blockeigenschaft (AutoCAD-Dynamikbloecke).
|
|
(defun lg-dyn-param (ent name / r)
|
|
(setq r (vl-catch-all-apply
|
|
'(lambda ( / obj)
|
|
(setq obj (vlax-ename->vla-object ent))
|
|
(if (and (vlax-property-available-p obj 'IsDynamicBlock)
|
|
(= :vlax-true (vla-get-IsDynamicBlock obj)))
|
|
(vl-some '(lambda (p)
|
|
(if (= (strcase (vla-get-PropertyName p)) (strcase name))
|
|
(vlax-variant-value (vla-get-Value p))))
|
|
(vlax-invoke obj 'GetDynamicBlockProperties))))))
|
|
(if (vl-catch-all-error-p r) nil r)
|
|
)
|
|
|
|
;; Parameterwert einer Referenz: MCAD-Parameter vor dynamischer
|
|
;; Eigenschaft vor Attribut vor konstanter ATTDEF-Vorgabe.
|
|
(defun lg-rack-param (ent name / w)
|
|
(cond
|
|
((setq w (lg-mcad-param ent name)) w)
|
|
((setq w (lg-dyn-param ent name)) w)
|
|
((setq w (lg-wert-fuer-tag name (ssg-attrib-read ent))) w)
|
|
((lg-wert-fuer-tag name
|
|
(mapcar '(lambda (ed) (cons (cdr (assoc 2 ed)) (cdr (assoc 1 ed))))
|
|
(vl-remove-if-not '(lambda (ed) (= (cdr (assoc 0 ed)) "ATTDEF"))
|
|
(lg-blockdef-objekte (cdr (assoc 2 (entget ent))))))))
|
|
)
|
|
)
|
|
|
|
;; --- Transformationen: tf = (ursprung x-achse y-achse z-achse), Achsen
|
|
;; mit Skalierung; p' = o + px*ax + py*ay + pz*az (rein, getestet) ---
|
|
(defun lg-v3 (p) (list (float (car p)) (float (cadr p)) (if (caddr p) (float (caddr p)) 0.0)))
|
|
(defun lg-v+ (a b) (mapcar '+ a b))
|
|
(defun lg-v* (v k) (mapcar '(lambda (x) (* x k)) v))
|
|
(defun lg-tf-id () '((0.0 0.0 0.0) (1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0)))
|
|
(defun lg-tf-vek (tf v / v3)
|
|
(setq v3 (lg-v3 v))
|
|
(lg-v+ (lg-v* (nth 1 tf) (car v3)) (lg-v+ (lg-v* (nth 2 tf) (cadr v3)) (lg-v* (nth 3 tf) (caddr v3))))
|
|
)
|
|
(defun lg-tf-pkt (tf p) (lg-v+ (car tf) (lg-tf-vek tf p)))
|
|
;; innen ist im System von aussen beschrieben -> Gesamttransformation
|
|
(defun lg-tf-verketten (aussen innen)
|
|
(list (lg-tf-pkt aussen (car innen)) (lg-tf-vek aussen (nth 1 innen))
|
|
(lg-tf-vek aussen (nth 2 innen)) (lg-tf-vek aussen (nth 3 innen)))
|
|
)
|
|
|
|
(defun lg-skal (s) (if (and s (not (equal s 0.0 1e-12))) s 1.0))
|
|
|
|
;; Transformation einer INSERT (entget-Liste) im System ihres Containers.
|
|
;; sp/zl = MINSERT-Spalte/-Zeile (0/0 = Basis). Beruecksichtigt Extrusion
|
|
;; (210), Drehung, Skalierung, Rasterabstaende (44/45, entlang der
|
|
;; gedrehten Achsen) und den Basispunkt der Blockdefinition.
|
|
(defun lg-insert-tf (ed sp zl / nor rot ax ay az xr yr o bp)
|
|
(setq nor (lg-v3 (cond ((cdr (assoc 210 ed))) ('(0.0 0.0 1.0))))
|
|
rot (cond ((cdr (assoc 50 ed))) (0.0)))
|
|
(if (equal nor '(0.0 0.0 1.0) 1e-12)
|
|
(setq ax '(1.0 0.0 0.0) ay '(0.0 1.0 0.0) az '(0.0 0.0 1.0))
|
|
(setq ax (lg-v3 (trans '(1.0 0.0 0.0) nor 0 T))
|
|
ay (lg-v3 (trans '(0.0 1.0 0.0) nor 0 T))
|
|
az (lg-v3 (trans '(0.0 0.0 1.0) nor 0 T))))
|
|
(setq xr (lg-v+ (lg-v* ax (cos rot)) (lg-v* ay (sin rot)))
|
|
yr (lg-v+ (lg-v* ax (- (sin rot))) (lg-v* ay (cos rot)))
|
|
o (lg-tf-pkt (list '(0.0 0.0 0.0) ax ay az) (cdr (assoc 10 ed)))
|
|
o (lg-v+ o (lg-v+ (lg-v* xr (* sp (cond ((cdr (assoc 44 ed))) (0.0))))
|
|
(lg-v* yr (* zl (cond ((cdr (assoc 45 ed))) (0.0)))))))
|
|
(setq xr (lg-v* xr (lg-skal (cdr (assoc 41 ed))))
|
|
yr (lg-v* yr (lg-skal (cdr (assoc 42 ed))))
|
|
az (lg-v* az (lg-skal (cdr (assoc 43 ed))))
|
|
bp (lg-v3 (cond ((cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 ed)))))) ('(0.0 0.0 0.0)))))
|
|
;; der Basispunkt der Definition liegt auf dem Einfuegepunkt
|
|
(list (lg-v+ o (lg-v* (lg-tf-vek (list nil xr yr az) bp) -1.0)) xr yr az)
|
|
)
|
|
|
|
;; Bounding-Box (min max) eines Objekts in den Koordinaten seines
|
|
;; Containers, nil wenn nicht ermittelbar.
|
|
(defun lg-bbox (ent / r)
|
|
(setq r (vl-catch-all-apply
|
|
'(lambda ( / ll ur)
|
|
(vla-GetBoundingBox (vlax-ename->vla-object ent) 'll 'ur)
|
|
(list (lg-v3 (vlax-safearray->list ll)) (lg-v3 (vlax-safearray->list ur))))))
|
|
(if (vl-catch-all-error-p r) nil r)
|
|
)
|
|
|
|
;; Enthaelt die Blockdefinition (rekursiv) ein Rack? Gemerkt in
|
|
;; *lg-rack-cache*, Zirkelschutz ueber *lg-rack-pfad*, XRefs ausgenommen.
|
|
(defun lg-rack-enthaelt-p (bname tiefe / k vorh def res)
|
|
(setq k (strcase bname))
|
|
(cond
|
|
((setq vorh (assoc k *lg-rack-cache*)) (cdr vorh))
|
|
((or (>= tiefe *lg-rack-max-tiefe*) (member k *lg-rack-pfad*)) nil)
|
|
(T
|
|
(setq def (tblsearch "BLOCK" bname) res nil)
|
|
(if (and def (= 0 (logand (cond ((cdr (assoc 70 def))) (0)) 4)))
|
|
(progn
|
|
(setq *lg-rack-pfad* (cons k *lg-rack-pfad*))
|
|
(setq res (vl-some '(lambda (ed)
|
|
(if (= (cdr (assoc 0 ed)) "INSERT")
|
|
(or (lg-rack-p (cdr (assoc -1 ed)))
|
|
(lg-rack-enthaelt-p (cdr (assoc 2 ed)) (1+ tiefe)))))
|
|
(lg-blockdef-objekte bname)))
|
|
(setq *lg-rack-pfad* (cdr *lg-rack-pfad*))))
|
|
(setq *lg-rack-cache* (cons (cons k res) *lg-rack-cache*))
|
|
res))
|
|
)
|
|
|
|
;; Eine INSERT pruefen (inkl. MINSERT-Raster) bzw. in ihre Definition
|
|
;; absteigen. ptf = Transformation des Containers nach Welt.
|
|
(defun lg-rack-insert (ent ptf tiefe top / ed spalten zeilen raster sp zl ctf bb name laenge ebenen)
|
|
(setq ed (entget ent)
|
|
spalten (max 1 (cond ((cdr (assoc 70 ed))) (1)))
|
|
zeilen (max 1 (cond ((cdr (assoc 71 ed))) (1)))
|
|
raster (> (* spalten zeilen) 1))
|
|
(cond
|
|
((lg-rack-p ent)
|
|
(setq name (lg-rack-name ent)
|
|
laenge (lg-zahl-einheit (lg-rack-param ent *lg-rack-param-laenge*))
|
|
ebenen (lg-zahl-einheit (lg-rack-param ent *lg-rack-param-ebenen*))
|
|
bb (if (not raster) (lg-bbox ent))
|
|
sp 0)
|
|
(repeat spalten
|
|
(setq zl 0)
|
|
(repeat zeilen
|
|
(setq *lg-racks*
|
|
(cons (list name laenge ebenen
|
|
(if bb
|
|
(lg-tf-pkt ptf (mapcar '(lambda (a b) (/ (+ a b) 2.0)) (car bb) (cadr bb)))
|
|
(car (lg-tf-verketten ptf (lg-insert-tf ed sp zl))))
|
|
top)
|
|
*lg-racks*)
|
|
zl (1+ zl)))
|
|
(setq sp (1+ sp))))
|
|
((and (< tiefe *lg-rack-max-tiefe*) (lg-rack-enthaelt-p (cdr (assoc 2 ed)) 0))
|
|
(setq sp 0)
|
|
(repeat spalten
|
|
(setq zl 0)
|
|
(repeat zeilen
|
|
(setq ctf (lg-tf-verketten ptf (lg-insert-tf ed sp zl)))
|
|
(foreach sub (lg-blockdef-objekte (cdr (assoc 2 ed)))
|
|
(if (= (cdr (assoc 0 sub)) "INSERT")
|
|
(lg-rack-insert (cdr (assoc -1 sub)) ctf (1+ tiefe) top)))
|
|
(setq zl (1+ zl)))
|
|
(setq sp (1+ sp))))
|
|
)
|
|
)
|
|
|
|
;; Alle goh_racks im Modellbereich (Blockname/Parameter aus lager.json).
|
|
;; Rueckgabe: Liste (name laenge-mm ebenen mitte top-ent), Fundreihenfolge.
|
|
(defun lg-racks-sammeln ( / )
|
|
(lg-racks-finden (lg-vorgabe '("goh_rack" "blockname") "goh_rack")
|
|
(lg-vorgabe '("goh_rack" "param_laenge") "Laenge")
|
|
(lg-vorgabe '("goh_rack" "param_ebenen") "Ebenen"))
|
|
)
|
|
|
|
;; Wie lg-racks-sammeln, Blockname und Parameternamen als Argument.
|
|
(defun lg-racks-finden (name p-laenge p-ebenen / ss i)
|
|
(setq *lg-rack-suchname* name
|
|
*lg-rack-param-laenge* p-laenge
|
|
*lg-rack-param-ebenen* p-ebenen
|
|
*lg-racks* nil *lg-rack-cache* nil *lg-rack-pfad* nil)
|
|
(if (setq ss (ssget "_X" '((0 . "INSERT") (410 . "Model"))))
|
|
(progn
|
|
(setq i 0)
|
|
(repeat (sslength ss)
|
|
(lg-rack-insert (ssname ss i) (lg-tf-id) 0 (ssname ss i))
|
|
(setq i (1+ i)))))
|
|
(reverse *lg-racks*)
|
|
)
|
|
|
|
;; Reiner Kern: Racks je Geschoss zusammenfassen. eintraege = ((geschoss
|
|
;; laenge-mm ebenen) ...), geschoss nil = nicht zuordenbar, fehlende Laenge/
|
|
;; Ebenen zaehlen 0. Rueckgabe ((geschoss anzahl summe-laenge
|
|
;; summe-laenge-x-ebenen) ...), nach Geschoss sortiert, nil zuletzt.
|
|
(defun lg-racks-auswerten (eintraege / erg vorh l k)
|
|
(setq erg nil)
|
|
(foreach x eintraege
|
|
(setq l (cond ((cadr x)) (0.0))
|
|
k (* l (cond ((caddr x)) (0.0)))
|
|
vorh (assoc (car x) erg))
|
|
(setq erg (if vorh
|
|
(subst (list (car x) (1+ (cadr vorh)) (+ (caddr vorh) l) (+ (cadddr vorh) k)) vorh erg)
|
|
(cons (list (car x) 1 l k) erg))))
|
|
(vl-sort erg '(lambda (a b) (cond ((null (car a)) nil) ((null (car b)) T) (T (< (car a) (car b))))))
|
|
)
|
|
|
|
;; Befehl LG_REGALE: goh_racks zaehlen, Anzahl, Laenge und Laenge x Ebenen
|
|
;; (Haengekapazitaet) je Geschoss in der Befehlszeile.
|
|
(defun c:LG_REGALE ( / kand racks zeilen ohne-laenge)
|
|
(setq kand (lg-geschoss-kandidaten)
|
|
racks (lg-racks-sammeln))
|
|
(if (null racks)
|
|
(princ (ssg-textf "lg-regale-keine" (list (lg-vorgabe '("goh_rack" "blockname") "goh_rack"))))
|
|
(progn
|
|
(setq zeilen (lg-racks-auswerten
|
|
(mapcar '(lambda (r) (list (lg-rack-geschoss (lg-ent-layer (lg-rk-top r)) (lg-rk-mitte r) kand)
|
|
(lg-rk-laenge r) (lg-rk-ebenen r)))
|
|
racks))
|
|
ohne-laenge (length (vl-remove-if 'lg-rk-laenge racks)))
|
|
(princ (ssg-text "lg-regale-kopf"))
|
|
(foreach z zeilen
|
|
(princ (ssg-textf "lg-regale-zeile"
|
|
(list (if (car z) (ssg-textf "lg-regale-geschoss" (list (itoa (car z))))
|
|
(ssg-text "lg-regale-ohne-geschoss"))
|
|
(itoa (cadr z)) (rtos (/ (caddr z) 1000.0) 2 2) (rtos (/ (cadddr z) 1000.0) 2 2)))))
|
|
(princ (ssg-textf "lg-regale-zeile"
|
|
(list (ssg-text "lg-regale-summe") (itoa (length racks))
|
|
(rtos (/ (apply '+ (mapcar 'caddr zeilen)) 1000.0) 2 2)
|
|
(rtos (/ (apply '+ (mapcar 'cadddr zeilen)) 1000.0) 2 2))))
|
|
(if (> ohne-laenge 0) (princ (ssg-textf "lg-regale-ohne-laenge" (list (itoa ohne-laenge)))))))
|
|
(princ)
|
|
)
|
|
|
|
;; ============================================================
|
|
;; GESCHOSS KOPIEREN (LG_GESCHOSS_KOPIEREN)
|
|
;; ============================================================
|
|
;; Obergeschosse haben meist dieselben Regale und Flaechen wie das Geschoss
|
|
;; darunter. Ein BricsCAD-KOPIEREN taugt dafuer nicht: die XDATA-Verweise
|
|
;; (kontur/besitzer/bereich) zeigten weiter auf die Originale, GESCHOSS,
|
|
;; Layer _G<nr> und IDs blieben die alten. Darum wird jedes Objekt ueber die
|
|
;; normalen Einfuegefunktionen NEU erzeugt (Layer, ID, Verknuepfung,
|
|
;; Blockname/Schraffur, ATTSYNC kommen von dort) - die Kinder 1:1 aus der
|
|
;; Quelle, ohne Neufuellen, damit Handaenderungen (auto_geaendert, manuelle
|
|
;; Reihen/Gaenge) erhalten bleiben. goh_rack-Bloecke (parametrisch) werden
|
|
;; per vla-Copy kopiert und auf den Regal-Layer des Zielgeschosses gelegt.
|
|
;; Die Kopie liegt deckungsgleich (2D uebereinander), optional je Kopie um
|
|
;; (dx dy) versetzt; in einer 3D-Zeichnung (Konturen auf Belagshoehe)
|
|
;; zusaetzlich in Z um den Hoehenabstand.
|
|
|
|
;; Layer eines Objekts oder nil.
|
|
(defun lg-ent-layer (ent / ed)
|
|
(if (and ent (setq ed (entget ent))) (cdr (assoc 8 ed)))
|
|
)
|
|
|
|
;; Reiner Kern: Geschossnummer aus einem Lager-Layer "LG_<x>_G<nr>"
|
|
;; (Muster wie lg-geschoss-aktivieren), sonst nil.
|
|
(defun lg-geschoss-aus-layer (name / s p rest)
|
|
(if (and (= (type name) 'STR) (wcmatch (setq s (strcase name)) "LG_*_G#*"))
|
|
(progn
|
|
(setq p (vl-string-position (ascii "_") s nil T)
|
|
rest (substr s (+ p 2)))
|
|
(if (and (> (strlen rest) 1) (= (substr rest 1 1) "G")
|
|
(vl-every '(lambda (c) (<= 48 c 57)) (vl-string->list (substr rest 2))))
|
|
(atoi (substr rest 2)))))
|
|
)
|
|
|
|
;; Reiner Kern: Geschoss eines goh_rack. Ein Lager-Layer _G<nr> eines
|
|
;; vorhandenen Geschosses entscheidet (eindeutig auch bei 2D-Geschossen
|
|
;; uebereinander), sonst die Kontur (lg-geschoss-fuer-punkt-kern).
|
|
;; kandidaten = ((nr hoehe-mm kontur-punkte) ...)
|
|
(defun lg-rack-geschoss (layer pt kandidaten / n)
|
|
(setq n (lg-geschoss-aus-layer layer))
|
|
(if (and n (assoc n kandidaten))
|
|
n
|
|
(lg-geschoss-fuer-punkt-kern pt kandidaten))
|
|
)
|
|
|
|
;; Reiner Kern: Belag eines kopierten Bereichs/Gangs. Entsprach er dem
|
|
;; Geschossbelag der Quelle, folgt er dem neuen Geschossbelag; bewusst
|
|
;; abweichende (z.B. Gitterrost-Gang auf Spanplatte-Buehne) bleiben.
|
|
(defun lg-kopie-belag (belag alt neu)
|
|
(if (and belag alt neu (= (strcase belag) (strcase alt))) neu belag)
|
|
)
|
|
|
|
;; Reiner Kern: Attributwerte einer kopierten Reihe/eines Gangs fuer
|
|
;; lg-linie-einfuegen. LAENGE/LAYER/ID entstehen dort neu; GESCHOSS und
|
|
;; BEREICH (nil = ohne Bereich -> "") werden ersetzt, BELAG folgt
|
|
;; lg-kopie-belag, alles uebrige (QUELLE!) bleibt.
|
|
(defun lg-kopie-werte (attribs gs-neu bereich-nr belag-alt belag-neu / w)
|
|
(setq w (vl-remove-if '(lambda (p) (member (strcase (car p)) '("LAENGE" "LAYER" "ID" "GESCHOSS" "BEREICH")))
|
|
attribs))
|
|
(if (assoc "BELAG" w)
|
|
(setq w (lg-wert-setzen w "BELAG" (lg-kopie-belag (cdr (assoc "BELAG" w)) belag-alt belag-neu))))
|
|
(append (list (cons "GESCHOSS" (vl-princ-to-string gs-neu))
|
|
(cons "BEREICH" (if bereich-nr (vl-princ-to-string bereich-nr) "")))
|
|
w)
|
|
)
|
|
|
|
;; Reiner Kern: Kopierplan ((i hoehe (vx vy vz)) ...) fuer n Kopien.
|
|
;; Kopie i liegt auf h-src + i*abstand und um i*(dx dy) versetzt; in Z nur
|
|
;; bei einer 3D-Zeichnung (z3d).
|
|
(defun lg-kopie-plan (h-src abstand n dx dy z3d / i erg)
|
|
(setq i 1 erg nil)
|
|
(while (<= i n)
|
|
(setq erg (cons (list i (+ h-src (* i abstand))
|
|
(list (* i dx) (* i dy) (if z3d (* i abstand) 0.0)))
|
|
erg)
|
|
i (1+ i)))
|
|
(reverse erg)
|
|
)
|
|
|
|
;; Reiner Kern: Vorgabe Hoehenabstand. Abstand zum Geschoss darunter, sonst
|
|
;; lichte Hoehe + Konstruktionshoehe der Quelle, sonst nil (Eingabe noetig).
|
|
(defun lg-kopie-abstand-vorgabe (h-src h-unter lichte konstr)
|
|
(cond
|
|
((and h-unter (> (- h-src h-unter) 1.0)) (- h-src h-unter))
|
|
((and lichte (> lichte 0.0)) (+ lichte (if konstr konstr 0.0)))
|
|
(T nil))
|
|
)
|
|
|
|
;; Reiner Kern: liegt die Zeichnung in 3D (mindestens ein Geschoss mit
|
|
;; Hoehe != 0, dessen Kontur auf seiner Belagshoehe liegt)?
|
|
(defun lg-kopie-3d-p (kandidaten)
|
|
(if (vl-some '(lambda (k) (and (caddr k) (> (abs (cadr k)) 1.0)
|
|
(equal (lg-kandidat-z k) (cadr k) 1.0)))
|
|
kandidaten)
|
|
T)
|
|
)
|
|
|
|
;; Dialog-Vorgaben: oberstes Geschoss als Quelle (Erweitern G3 -> G4).
|
|
(defun lg-kopie-vorgaben ( / gs top h-top unter a belag)
|
|
(setq gs (vl-sort (lg-geschosse) '(lambda (x y) (< (lg-geschoss-hoehe x) (lg-geschoss-hoehe y))))
|
|
top (last gs)
|
|
h-top (lg-geschoss-hoehe top)
|
|
unter (vl-remove-if-not '(lambda (g) (< (lg-geschoss-hoehe g) (- h-top 1.0))) gs)
|
|
a (caddr top)
|
|
belag (cdr (assoc "BELAG_ART" a)))
|
|
(if (or (null belag) (= belag "hallenboden"))
|
|
(setq belag (lg-vorgabe '("geschoss" "belag_art") "spanplatte")))
|
|
(list (cons "QUELLE" (itoa (cadr top)))
|
|
(cons "ANZAHL" "1")
|
|
(cons "ABSTAND_mm" (lg-mm-str (lg-kopie-abstand-vorgabe
|
|
h-top (if unter (lg-geschoss-hoehe (last unter)))
|
|
(lg-zahl (cdr (assoc "LICHTE_HOEHE_mm" a)))
|
|
(lg-zahl (cdr (assoc "KONSTR_HOEHE_mm" a))))))
|
|
(cons "BELAG_ART" belag)
|
|
(cons "VERSATZ_X_mm" "0")
|
|
(cons "VERSATZ_Y_mm" "0"))
|
|
)
|
|
|
|
(defun lg-ent-verschieben (ent v)
|
|
(vla-Move (vlax-ename->vla-object ent) (vlax-3d-point '(0.0 0.0 0.0)) (vlax-3d-point v))
|
|
ent
|
|
)
|
|
|
|
;; Kontur kopieren (ohne Handle/XDATA) und um v verschieben.
|
|
(defun lg-kontur-kopie (ent v / neu)
|
|
(if (setq neu (lg-kontur-kopieren ent)) (lg-ent-verschieben neu v))
|
|
)
|
|
|
|
;; goh_rack-Bloecke des Geschosses src als oberste INSERTs im Modellbereich
|
|
;; (ein Array mit Racks zaehlt als ein Objekt). Vor der ersten Kopie
|
|
;; aufrufen: danach waere die Kontur-Zuordnung deckungsgleicher Geschosse
|
|
;; mehrdeutig. Rueckgabe: (racks anzahl-mehrdeutig)
|
|
(defun lg-racks-der-quelle (src kandidaten / src-pts racks mehrdeutig top gs)
|
|
(setq racks nil mehrdeutig nil
|
|
src-pts (caddr (assoc src kandidaten)))
|
|
(foreach r (lg-racks-sammeln)
|
|
(setq top (lg-rk-top r)
|
|
gs (lg-rack-geschoss (lg-ent-layer top) (lg-rk-mitte r) kandidaten))
|
|
(cond
|
|
((and gs (= gs src))
|
|
(if (not (member top racks)) (setq racks (cons top racks))))
|
|
((and (null gs) src-pts (ssg-punkt-in-poly-p (lg-rk-mitte r) src-pts))
|
|
(if (not (member top mehrdeutig)) (setq mehrdeutig (cons top mehrdeutig))))))
|
|
(list (reverse racks)
|
|
(length (vl-remove-if '(lambda (m) (member m racks)) mehrdeutig)))
|
|
)
|
|
|
|
;; Racks der Quelle ohne Lager-Layer auf den Regal-Layer der Quelle legen -
|
|
;; nach der Kopie liegen sie deckungsgleich mit den Kopien, nur der Layer
|
|
;; trennt sie dann (Export, LG_GESCHOSS_AKTIV). Rueckgabe: Anzahl.
|
|
(defun lg-racks-umhaengen (racks src / lay n)
|
|
(setq n 0)
|
|
(foreach r racks
|
|
(if (null (lg-geschoss-aus-layer (lg-ent-layer r)))
|
|
(progn
|
|
(if (null lay) (setq lay (lg-layer "goh_rack" src)))
|
|
(vla-put-Layer (vlax-ename->vla-object r) lay)
|
|
(setq n (1+ n)))))
|
|
n
|
|
)
|
|
|
|
;; Racks per vla-Copy (MCAD-Parameter bleiben) um v versetzt ins Geschoss
|
|
;; nr kopieren. Rueckgabe: Anzahl.
|
|
(defun lg-racks-kopieren (racks nr v / lay n res)
|
|
(setq n 0 lay (if racks (lg-layer "goh_rack" nr)))
|
|
(foreach r racks
|
|
(setq res (vl-catch-all-apply
|
|
'(lambda ( / obj)
|
|
(setq obj (vla-Copy (vlax-ename->vla-object r)))
|
|
(vla-Move obj (vlax-3d-point '(0.0 0.0 0.0)) (vlax-3d-point v))
|
|
(vla-put-Layer obj lay)
|
|
T)))
|
|
(if (vl-catch-all-error-p res)
|
|
(princ (ssg-textf "lg-einfuegen-fehler" (list (lg-blockname r) (vl-catch-all-error-message res))))
|
|
(setq n (1+ n))))
|
|
n
|
|
)
|
|
|
|
;; Eine Kopie des Geschosses src-nr als Geschoss nr auf hoehe, um v versetzt.
|
|
;; Rueckgabe: (geschoss-ent reihen gaenge racks) oder nil.
|
|
(defun lg-geschoss-kopieren (src-nr nr hoehe belag-neu v racks
|
|
/ src a belag-alt k werte blk zuordnung kk nb ab ed p1 p2 rot
|
|
laenge nb-h art n-reihen n-gaenge s-gs)
|
|
(setq src (lg-geschoss-finden src-nr)
|
|
a (caddr src)
|
|
belag-alt (cdr (assoc "BELAG_ART" a))
|
|
s-gs (itoa src-nr)
|
|
k (if src (lg-ent-aus-handle (lg-xdata-wert (car src) "kontur"))))
|
|
(cond
|
|
((null src) (princ (ssg-textf "lg-geschoss-unbekannt" (list s-gs))) nil)
|
|
((null k) (princ (ssg-textf "lg-exp-geschoss-ohne-kontur" (list s-gs))) nil)
|
|
(T
|
|
;; 1. Geschoss: Attribute der Quelle, neu sind Nummer, Bezeichnung,
|
|
;; Belagshoehe und Belag (GESCHOSS/LAYER/ID setzt lg-geschoss-anlegen)
|
|
(setq werte (append
|
|
(list (cons "NR" (itoa nr))
|
|
(assoc "BEZEICHNUNG" (lg-geschoss-vorgaben nr))
|
|
(cons "HOEHE_BELAG_mm" (lg-mm-str hoehe))
|
|
(cons "BELAG_ART" belag-neu))
|
|
(vl-remove-if '(lambda (p) (member (strcase (car p))
|
|
'("NR" "BEZEICHNUNG" "HOEHE_BELAG_MM" "BELAG_ART"
|
|
"GESCHOSS" "LAYER" "ID")))
|
|
a)))
|
|
(setq kk (lg-kontur-kopie k v))
|
|
(if (null (setq blk (lg-geschoss-anlegen kk werte)))
|
|
(progn (if kk (entdel kk)) nil)
|
|
(progn
|
|
;; 2. Bereiche (ohne Fuellung), Zuordnung alter -> neuer Handle
|
|
(setq zuordnung nil)
|
|
(foreach b (lg-alle-bloecke "LG_BEREICH")
|
|
(setq ab (ssg-attrib-read b))
|
|
(if (and (= (cdr (assoc "GESCHOSS" ab)) s-gs)
|
|
(setq k (lg-ent-aus-handle (lg-xdata-wert b "kontur")))
|
|
(setq kk (lg-kontur-kopie k v)))
|
|
(progn
|
|
(setq werte (vl-remove-if '(lambda (p) (member (strcase (car p)) '("NR" "LAYER" "ID" "GESCHOSS")))
|
|
ab))
|
|
(if (assoc "BELAG" werte)
|
|
(setq werte (lg-wert-setzen werte "BELAG"
|
|
(lg-kopie-belag (cdr (assoc "BELAG" werte)) belag-alt belag-neu))))
|
|
(if (setq nb (lg-bereich-block-anlegen kk (cons (cons "GESCHOSS" (itoa nr)) werte)))
|
|
(setq zuordnung (cons (cons (lg-handle b) nb) zuordnung))
|
|
(entdel kk)))))
|
|
;; 3. Reihen und Gaenge 1:1 (auch ohne Bereich), kein Neufuellen
|
|
(setq n-reihen 0 n-gaenge 0)
|
|
(foreach e (append (lg-alle-bloecke "LG_REIHE_*") (lg-alle-bloecke "LG_GANG_*"))
|
|
(setq ab (ssg-attrib-read e))
|
|
(if (= (cdr (assoc "GESCHOSS" ab)) s-gs)
|
|
(progn
|
|
(setq ed (entget e)
|
|
p1 (mapcar '+ (cdr (assoc 10 ed)) v)
|
|
rot (cond ((cdr (assoc 50 ed))) (0.0))
|
|
laenge (cond ((lg-zahl (cdr (assoc "LAENGE" ab)))) (0.0))
|
|
p2 (polar p1 rot laenge)
|
|
p2 (list (car p2) (cadr p2) (caddr p1))
|
|
nb (cdr (assoc (lg-xdata-wert e "bereich") zuordnung))
|
|
art (if (wcmatch (strcase (lg-blockname e)) "LG_REIHE_*") "reihe" "gang"))
|
|
(if (lg-linie-einfuegen art p1 p2
|
|
(lg-kopie-werte ab nr (if nb (cdr (assoc "NR" (ssg-attrib-read nb))))
|
|
belag-alt belag-neu)
|
|
nb)
|
|
(if (= art "reihe") (setq n-reihen (1+ n-reihen)) (setq n-gaenge (1+ n-gaenge)))))))
|
|
;; 4. goh_rack
|
|
(list blk n-reihen n-gaenge (lg-racks-kopieren racks nr v))))
|
|
)
|
|
)
|
|
)
|
|
|
|
;; Geschoss kopieren nach Dialogwerten (QUELLE ANZAHL ABSTAND_mm BELAG_ART
|
|
;; VERSATZ_X_mm VERSATZ_Y_mm), nicht interaktiv - auch fuer Tests.
|
|
;; Rueckgabe: Liste der neuen Geschossnummern oder nil.
|
|
(defun lg-geschosse-kopieren (werte / src-nr src n abstand belag dx dy kandidaten
|
|
rq racks nr erg neu)
|
|
(setq src-nr (atoi (cond ((cdr (assoc "QUELLE" werte))) ("0")))
|
|
src (lg-geschoss-finden src-nr)
|
|
n (atoi (cond ((cdr (assoc "ANZAHL" werte))) ("1")))
|
|
abstand (lg-zahl (cdr (assoc "ABSTAND_mm" werte)))
|
|
belag (cdr (assoc "BELAG_ART" werte))
|
|
dx (cond ((lg-zahl (cdr (assoc "VERSATZ_X_mm" werte)))) (0.0))
|
|
dy (cond ((lg-zahl (cdr (assoc "VERSATZ_Y_mm" werte)))) (0.0)))
|
|
(cond
|
|
((null src) (princ (ssg-textf "lg-geschoss-unbekannt" (list (itoa src-nr)))) nil)
|
|
((or (null abstand) (<= abstand 0.0)) (princ (ssg-text "lg-kopie-abstand-ungueltig")) nil)
|
|
((< n 1) nil)
|
|
(T
|
|
(setq kandidaten (lg-geschoss-kandidaten))
|
|
;; Racks VOR der ersten Kopie bestimmen (danach waere die Kontur mehrdeutig)
|
|
(setq rq (lg-racks-der-quelle src-nr kandidaten)
|
|
racks (car rq))
|
|
(if (> (cadr rq) 0) (princ (ssg-textf "lg-kopie-racks-mehrdeutig" (list (itoa (cadr rq))))))
|
|
(if (> (setq neu (lg-racks-umhaengen racks src-nr)) 0)
|
|
(princ (ssg-textf "lg-kopie-racks-umgehaengt" (list (itoa neu) (itoa src-nr)))))
|
|
(setq erg nil)
|
|
(foreach p (lg-kopie-plan (lg-geschoss-hoehe src) abstand n dx dy (lg-kopie-3d-p kandidaten))
|
|
(if (vl-some '(lambda (k) (equal (cadr k) (cadr p) 1.0)) (lg-geschoss-kandidaten))
|
|
(princ (ssg-textf "lg-kopie-hoehe-belegt" (list (lg-mm-str (cadr p))))))
|
|
(setq nr (lg-geschoss-naechste-nr))
|
|
(if (setq neu (lg-geschoss-kopieren src-nr nr (cadr p) belag (caddr p) racks))
|
|
(progn
|
|
(setq erg (cons nr erg))
|
|
(princ (ssg-textf "lg-kopie-fertig"
|
|
(list (itoa src-nr) (itoa nr) (lg-mm-str (cadr p))
|
|
(itoa (cadr neu)) (itoa (caddr neu)) (itoa (cadddr neu))))))))
|
|
(if erg
|
|
(progn
|
|
(lg-ldata-setzen "GESCHOSS_AKTIV" (car erg))
|
|
(princ (ssg-text "lg-kopie-hinweis-aktiv"))))
|
|
(reverse erg))
|
|
)
|
|
)
|
|
|
|
;; ============================================================
|
|
;; BEFEHLE
|
|
;; ============================================================
|
|
|
|
(defun c:LG_GESCHOSS ( / kontur nr werte blk)
|
|
(ssg-start (ssg-text "lg-titel-geschoss") nil)
|
|
(setq kontur (lg-kontur-waehlen (ssg-text "lg-prompt-kontur-geschoss")))
|
|
(if kontur
|
|
(progn
|
|
(setq nr (lg-geschoss-naechste-nr))
|
|
(setq werte (lg-dialog "lg_geschoss" *lg-felder-geschoss* (lg-geschoss-vorgaben nr) nil))
|
|
(if (and werte (setq blk (lg-geschoss-anlegen kontur werte)))
|
|
(progn
|
|
(lg-ldata-setzen "GESCHOSS_AKTIV" (atoi (cdr (assoc "NR" werte))))
|
|
(princ (ssg-textf "lg-geschoss-angelegt" (list (cdr (assoc "NR" werte))
|
|
(cdr (assoc "HOEHE_BELAG_mm" werte)))))))))
|
|
(ssg-end)
|
|
(princ)
|
|
)
|
|
|
|
;; Geschoss aktivieren: Layer der uebrigen Geschosse frieren (0 = alle zeigen).
|
|
(defun lg-geschoss-aktivieren (nr / tab name suffix)
|
|
(if (and (> nr 0) (null (lg-geschoss-finden nr)))
|
|
(progn (princ (ssg-textf "lg-geschoss-unbekannt" (list (itoa nr)))) nil)
|
|
(progn
|
|
(lg-ldata-setzen "GESCHOSS_AKTIV" nr)
|
|
;; aktuellen Layer weg von evtl. zu frierenden Lager-Layern
|
|
(if (and (> nr 0) (wcmatch (strcase (getvar "CLAYER")) "LG_*_G#*")
|
|
(not (wcmatch (strcase (getvar "CLAYER")) (strcat "LG_*_G" (itoa nr)))))
|
|
(setvar "CLAYER" "0"))
|
|
(setq suffix (strcat "_G" (itoa nr)))
|
|
(setq tab (tblnext "LAYER" T))
|
|
(while tab
|
|
(setq name (cdr (assoc 2 tab)))
|
|
(if (wcmatch (strcase name) "LG_*_G#*")
|
|
(lg-layer-frieren name (and (> nr 0) (not (wcmatch (strcase name) (strcat "LG_*" suffix))))))
|
|
(setq tab (tblnext "LAYER")))
|
|
(princ (if (> nr 0) (ssg-textf "lg-geschoss-aktiv" (list (itoa nr))) (ssg-text "lg-geschoss-alle")))
|
|
nr)
|
|
)
|
|
)
|
|
|
|
(defun lg-layer-frieren (name frieren / e ed f)
|
|
(if (and (setq e (tblobjname "LAYER" name))
|
|
(not (and frieren (= (strcase name) (strcase (getvar "CLAYER"))))))
|
|
(progn
|
|
(setq ed (entget e) f (cdr (assoc 70 ed)))
|
|
(setq f (if frieren (logior f 1) (logand f (~ 1))))
|
|
(entmod (subst (cons 70 f) (assoc 70 ed) ed))))
|
|
)
|
|
|
|
;; Geschoss mit Belag, Bereichen, Reihen, Gaengen und goh_racks in ein oder
|
|
;; mehrere neue Geschosse kopieren (siehe lg-geschosse-kopieren).
|
|
(defun c:LG_GESCHOSS_KOPIEREN ( / werte)
|
|
(ssg-start (ssg-text "lg-titel-kopie") nil)
|
|
(if (null (lg-geschosse))
|
|
(princ (ssg-text "lg-kein-geschoss"))
|
|
(if (setq werte (lg-dialog "lg_geschoss_kopie" *lg-felder-kopie* (lg-kopie-vorgaben) nil))
|
|
(lg-geschosse-kopieren werte)))
|
|
(ssg-end)
|
|
(princ)
|
|
)
|
|
|
|
(defun c:LG_GESCHOSS_AKTIV ( / gs nr)
|
|
(setq gs (lg-geschosse))
|
|
(if (null gs)
|
|
(princ (ssg-text "lg-kein-geschoss"))
|
|
(progn
|
|
(princ (strcat "\n" (ssg-join (mapcar '(lambda (g) (strcat (itoa (cadr g)) " = "
|
|
(cond ((cdr (assoc "BEZEICHNUNG" (caddr g)))) ("")))) gs)
|
|
", ")))
|
|
(setq nr (ssg-in-int (ssg-text "lg-prompt-geschoss-aktiv")
|
|
(cond ((lg-geschoss-aktiv)) (0))))
|
|
(if nr (lg-geschoss-aktivieren nr))
|
|
(command "_.REGEN")))
|
|
(princ)
|
|
)
|
|
|
|
(defun c:LG_BEREICH ( / kontur pts gs werte blk)
|
|
(ssg-start (ssg-text "lg-titel-bereich") nil)
|
|
(setq kontur (lg-kontur-waehlen (ssg-text "lg-prompt-kontur-bereich")))
|
|
(if kontur
|
|
(progn
|
|
(setq pts (ssg-lwpoly-punkte kontur))
|
|
(if (ssg-lwpoly-boegen-p kontur) (princ (ssg-text "lg-kontur-boegen")))
|
|
(setq gs (lg-geschoss-ermitteln (car pts)))
|
|
(if gs
|
|
(progn
|
|
(setq werte (lg-dialog "lg_bereich" *lg-felder-bereich* (lg-bereich-vorgaben pts) nil))
|
|
(if werte
|
|
(setq blk (lg-bereich-anlegen kontur (cons (cons "GESCHOSS" (itoa gs)) werte))))))))
|
|
(ssg-end)
|
|
(princ)
|
|
)
|
|
|
|
;; Reiner Kern: Gang aus einem Rechteck. ecken = 4 Eckpunkte im Umlauf
|
|
;; (WCS), die erste = die zuerst gepickte Ecke. Die laengere Seite ist die
|
|
;; Gangrichtung, die kurze Seite die Breite (auf ganze mm). Die Rundung
|
|
;; verschiebt NUR die Laengsseite gegenueber der ersten Ecke: die Seite, an
|
|
;; der der Anwender angesetzt hat (z.B. buendig an einer Regalreihe), bleibt
|
|
;; exakt liegen - sonst wuerde der Gang die Reihe um Bruchteile eines mm
|
|
;; ueberdecken und sie beim Zuschnitt entfernen. Ebenso beginnt die Linie an
|
|
;; der Querseite der ersten Ecke (die Laengenrundung wirkt am anderen Ende).
|
|
;; Quadrat: Richtung der ersten Kante. Z = Z der ersten Ecke.
|
|
;; Rueckgabe: (p1 p2 breite) oder nil (entartet).
|
|
(defun lg-gang-aus-ecken (ecken / a b c d z l1 l2 w ende quer u)
|
|
(setq a (nth 0 ecken) b (nth 1 ecken) c (nth 2 ecken) d (nth 3 ecken)
|
|
z (cond ((caddr a)) (0.0))
|
|
l1 (distance (list (car a) (cadr a)) (list (car b) (cadr b)))
|
|
l2 (distance (list (car b) (cadr b)) (list (car c) (cadr c))))
|
|
(if (and (>= l1 1.0) (>= l2 1.0))
|
|
(progn
|
|
;; ende = Ecke am Ende der Laengsseite durch a, quer = Nachbar quer dazu
|
|
(if (>= l1 l2)
|
|
(setq ende b quer d w (lg-mm-runden l2))
|
|
(setq ende d quer b w (lg-mm-runden l1)))
|
|
;; halbe gerundete Breite von der Laengsseite durch a nach innen
|
|
(setq u (/ (/ w 2.0) (distance (list (car a) (cadr a)) (list (car quer) (cadr quer))))
|
|
u (list (* u (- (car quer) (car a))) (* u (- (cadr quer) (cadr a)))))
|
|
(list (list (+ (car a) (car u)) (+ (cadr a) (cadr u)) z)
|
|
(list (+ (car ende) (car u)) (+ (cadr ende) (cadr u)) z)
|
|
w)))
|
|
)
|
|
|
|
;; Rechteck mit dem BricsCAD-Befehl RECHTECK zeichnen lassen - mit allen
|
|
;; seinen Optionen (Abmessungen, Flaeche, Drehung, Objektfang ...). Die
|
|
;; entstandene Polylinie wird als 4 Eckpunkte (WCS) gelesen und wieder
|
|
;; geloescht. Rueckgabe: Eckpunkte, nil (nichts gezeichnet = Ende) oder
|
|
;; 'kein-rechteck (z.B. mit Fase/Rundung gezeichnet).
|
|
(defun lg-rechteck-zeichnen ( / marke echo e pts)
|
|
(setq marke (entlast) echo (getvar "CMDECHO"))
|
|
;; ohne CMDECHO zeigt RECHTECK seine Fragen und Optionen nicht an
|
|
(setvar "CMDECHO" 1)
|
|
(command "_.RECTANG")
|
|
(while (> (getvar "CMDACTIVE") 0) (command pause))
|
|
(setvar "CMDECHO" echo)
|
|
(setq e (entlast))
|
|
(if (and e (not (equal e marke)))
|
|
(progn
|
|
(setq pts (lg-rechteck-ecken-aus-poly e))
|
|
(entdel e)
|
|
pts))
|
|
)
|
|
|
|
;; Eckpunkte (WCS) einer mit RECHTECK gezeichneten Polylinie oder
|
|
;; 'kein-rechteck (anderes Objekt, Fase/Rundung, mehr als 4 Ecken).
|
|
(defun lg-rechteck-ecken-aus-poly (e / pts)
|
|
(if (and (= (cdr (assoc 0 (entget e))) "LWPOLYLINE")
|
|
(= (length (setq pts (ssg-lwpoly-punkte e))) 4)
|
|
(not (ssg-lwpoly-boegen-p e)))
|
|
pts
|
|
'kein-rechteck)
|
|
)
|
|
|
|
;; Punkteingabe fuer Linienobjekte (Reihe/Gang): Startpunkt, dann Endpunkt
|
|
;; ODER getippte Laenge (+ Richtung), bis ESC/Enter (Muster Geruest-Traeger).
|
|
;; einfuegen-fn bekommt je Punktpaar (p1 p2) in WCS und liefert nil bei
|
|
;; Misserfolg. rechteck-fn (nil = ohne): schaltet am Startpunkt das
|
|
;; Schluesselwort "Rechteck" frei (prompt-start nennt es ueber %1); danach
|
|
;; wird jede Flaeche mit dem BricsCAD-Befehl RECHTECK gezeichnet
|
|
;; (lg-rechteck-zeichnen) und rechteck-fn bekommt die 4 Eckpunkte (WCS).
|
|
;; Enter ohne Rechteck beendet. Rueckgabe: Anzahl erfolgreicher Aufrufe.
|
|
(defun lg-linien-schleife (prompt-start einfuegen-fn rechteck-fn / weiter modus k-rechteck
|
|
ecken p1 eingabe p2 laenge winkel n)
|
|
(setq weiter T n 0 modus "linie"
|
|
k-rechteck (ssg-text "lg-key-rechteck"))
|
|
(while weiter
|
|
(if (= modus "rechteck")
|
|
(progn
|
|
(princ (ssg-text "lg-rechteck-hinweis"))
|
|
(setq ecken (lg-rechteck-zeichnen))
|
|
(cond
|
|
((null ecken) (setq weiter nil))
|
|
((eq ecken 'kein-rechteck) (princ (ssg-text "lg-rechteck-kein-rechteck")))
|
|
((apply rechteck-fn (list ecken)) (setq n (1+ n)))))
|
|
(progn
|
|
(if rechteck-fn (initget k-rechteck))
|
|
(setq p1 (getpoint (if rechteck-fn (vl-string-subst k-rechteck "%1" prompt-start) prompt-start)))
|
|
(cond
|
|
((null p1) (setq weiter nil))
|
|
((= (type p1) 'STR) (setq modus "rechteck"))
|
|
(T
|
|
(initget 128)
|
|
(setq eingabe (getpoint p1 (ssg-text "lg-prompt-reihe-ende")))
|
|
(setq p2 nil)
|
|
(cond
|
|
((null eingabe) (setq weiter nil))
|
|
((listp eingabe) (setq p2 eingabe))
|
|
((= eingabe "") (setq weiter nil))
|
|
((setq laenge (lg-zahl eingabe))
|
|
(setq winkel (getangle p1 (ssg-text "lg-prompt-reihe-richtung")))
|
|
(setq p2 (polar p1 (if winkel winkel 0.0) laenge)))
|
|
(T (princ (ssg-text "lg-wert-ungueltig"))))
|
|
(if p2
|
|
(progn
|
|
;; Objekt liegt auf Z des Startpunkts; erst p2, dann p1
|
|
;; nach WCS (p2 braucht das UCS-Z von p1)
|
|
(setq p2 (trans (list (car p2) (cadr p2) (caddr p1)) 1 0)
|
|
p1 (trans p1 1 0))
|
|
(if (apply einfuegen-fn (list p1 p2))
|
|
(setq n (1+ n)))))))))
|
|
)
|
|
n
|
|
)
|
|
|
|
;; Einzelreihen per Linie.
|
|
(defun c:LG_REIHE ( / gs werte n)
|
|
(ssg-start (ssg-text "lg-titel-reihe") nil)
|
|
(setq gs (lg-geschoss-ermitteln '(0.0 0.0 0.0)))
|
|
(if gs
|
|
(progn
|
|
(setq werte (lg-dialog "lg_reihe" *lg-felder-reihe*
|
|
(list (cons "LAENGE" "0")
|
|
(cons "TIEFE_mm" (lg-mm-str (lg-zahl (lg-vorgabe '("bereich" "regaltiefe_mm") 700))))
|
|
(cons "HAENGEEBENEN" (lg-vorgabe '("reihe" "haengeebenen") "2300/1200;1100/1100"))
|
|
(cons "SCHIENEN" (itoa (fix (lg-zahl (lg-vorgabe '("reihe" "schienen") 1))))))
|
|
'("laenge")))
|
|
(if werte
|
|
(progn
|
|
(setq werte (append (list (cons "GESCHOSS" (itoa gs)) (cons "BEREICH" "") (cons "QUELLE" "manuell"))
|
|
(vl-remove-if '(lambda (p) (= (car p) "LAENGE")) werte)))
|
|
(setq n (lg-linien-schleife (ssg-text "lg-prompt-reihe-start")
|
|
'(lambda (p1 p2) (lg-manuell-einfuegen "reihe" p1 p2 werte))
|
|
nil))
|
|
(princ (ssg-textf "lg-reihen-eingefuegt" (list (itoa n))))))))
|
|
(ssg-end)
|
|
(princ)
|
|
)
|
|
|
|
(defun lg-gang-vorgaben ( / )
|
|
(list (cons "LAENGE" "0")
|
|
(cons "BREITE_mm" (lg-mm-str (lg-zahl (lg-vorgabe '("bereich" "gangbreite_mm") 1000))))
|
|
(cons "ART" "gang")
|
|
(cons "BELAG" (lg-vorgabe '("bereich" "belag") "spanplatte")))
|
|
)
|
|
|
|
;; Reihe/Gang von Hand von p1 nach p2 (WCS, mittig auf der Linie) einfuegen
|
|
;; (nicht interaktiv - auch fuer Tests). art = "reihe"|"gang"; werte wie
|
|
;; bei lg-linie-einfuegen mit GESCHOSS. Liegt die Mitte in einem
|
|
;; Lagerbereich, wird das Objekt mit ihm verknuepft. Danach schneidet es
|
|
;; seine Flaeche aus den automatisch erzeugten Reihen/Gaengen heraus
|
|
;; (lg-sperre-anwenden) - der Bereich wird NICHT neu berechnet, und bei
|
|
;; jeder spaeteren Neuberechnung bleibt das Objekt stehen.
|
|
;; Rueckgabe: ename oder nil.
|
|
(defun lg-manuell-einfuegen (art p1 p2 werte / mitte bereich ent)
|
|
(setq mitte (list (/ (+ (car p1) (car p2)) 2.0) (/ (+ (cadr p1) (cadr p2)) 2.0)
|
|
(cond ((caddr p1)) (0.0))))
|
|
(setq bereich (lg-bereich-fuer-punkt mitte (cdr (assoc "GESCHOSS" werte))))
|
|
(setq werte (lg-wert-setzen werte "QUELLE" "manuell"))
|
|
(setq werte (lg-wert-setzen werte "BEREICH"
|
|
(if bereich (cdr (assoc "NR" (ssg-attrib-read bereich))) "")))
|
|
(if (setq ent (lg-linie-einfuegen art p1 p2 werte bereich))
|
|
(progn
|
|
(lg-sperre-anwenden ent)
|
|
ent))
|
|
)
|
|
|
|
;; Manuellen Gang einfuegen; werte braucht GESCHOSS, BREITE_mm, ART, BELAG.
|
|
(defun lg-gang-einfuegen (p1 p2 werte)
|
|
(lg-manuell-einfuegen "gang" p1 p2 werte)
|
|
)
|
|
|
|
;; Manuellen Gang aus einem Rechteck (4 Eckpunkte WCS) einfuegen - Breite
|
|
;; und Lage kommen aus der Flaeche, BREITE_mm aus werte gilt dann nicht.
|
|
;; Rueckgabe: ename oder nil.
|
|
(defun lg-gang-rechteck-einfuegen (ecken werte / g)
|
|
(if (setq g (lg-gang-aus-ecken ecken))
|
|
(lg-gang-einfuegen (car g) (cadr g) (lg-wert-setzen werte "BREITE_mm" (lg-mm-str (caddr g))))
|
|
(progn (princ (ssg-text "lg-rechteck-zu-klein")) nil))
|
|
)
|
|
|
|
;; Einzelne Gaenge per Linie oder Rechteck (Randgang, Fluchtweg, Durchgang ...).
|
|
(defun c:LG_GANG ( / gs werte n)
|
|
(ssg-start (ssg-text "lg-titel-gang") nil)
|
|
(setq gs (lg-geschoss-ermitteln '(0.0 0.0 0.0)))
|
|
(if gs
|
|
(progn
|
|
(setq werte (lg-dialog "lg_gang" *lg-felder-gang* (lg-gang-vorgaben) '("laenge")))
|
|
(if werte
|
|
(progn
|
|
(setq werte (cons (cons "GESCHOSS" (itoa gs))
|
|
(vl-remove-if '(lambda (p) (= (car p) "LAENGE")) werte)))
|
|
(setq n (lg-linien-schleife (ssg-text "lg-prompt-gang-start")
|
|
'(lambda (p1 p2) (lg-gang-einfuegen p1 p2 werte))
|
|
'(lambda (ecken) (lg-gang-rechteck-einfuegen ecken werte))))
|
|
(princ (ssg-textf "lg-gaenge-eingefuegt" (list (itoa n))))))))
|
|
(ssg-end)
|
|
(princ)
|
|
)
|
|
|
|
;; Doppelklick-Ziel (SSG_BLOCKEDIT, Zweig LG_*) und Befehl LG_EDIT.
|
|
(defun lg-edit-ent (ent / name a neu)
|
|
(setq name (strcase (lg-blockname ent))
|
|
a (ssg-attrib-read ent))
|
|
(cond
|
|
((= name "LG_GESCHOSS")
|
|
;; Nummer bleibt fest - an ihr haengen Layer und GESCHOSS der Kinder
|
|
(if (setq neu (lg-dialog "lg_geschoss" *lg-felder-geschoss* a '("nr")))
|
|
(progn (lg-attribute-setzen ent neu) (princ (ssg-text "lg-geaendert")))))
|
|
((= name "LG_BEREICH")
|
|
(if (setq neu (lg-dialog "lg_bereich" *lg-felder-bereich* a nil))
|
|
(progn
|
|
(lg-attribute-setzen ent neu)
|
|
;; Pfeil des Symbols folgt der Reihenrichtung
|
|
(vla-put-Rotation (vlax-ename->vla-object ent)
|
|
(* (/ (cond ((lg-zahl (cdr (assoc "RICHTUNG" neu)))) (0.0)) 180.0) pi))
|
|
(lg-bereich-fuellen ent))))
|
|
((wcmatch name "LG_REIHE_*")
|
|
(if (setq neu (lg-dialog "lg_reihe" *lg-felder-reihe* a nil))
|
|
(progn
|
|
(if (= (cdr (assoc "QUELLE" neu)) "auto")
|
|
(setq neu (lg-wert-setzen neu "QUELLE" "auto_geaendert")))
|
|
(lg-linie-neu-aufbauen-sperre ent neu))))
|
|
((wcmatch name "LG_GANG_*")
|
|
(if (setq neu (lg-dialog "lg_gang" *lg-felder-gang* a nil))
|
|
(progn
|
|
(if (/= (cdr (assoc "QUELLE" neu)) "manuell")
|
|
(setq neu (lg-wert-setzen neu "QUELLE" "auto_geaendert")))
|
|
(lg-linie-neu-aufbauen-sperre ent neu))))
|
|
(T (command "_.EATTEDIT" ent))
|
|
)
|
|
(princ)
|
|
)
|
|
|
|
(defun c:LG_EDIT ( / ss)
|
|
(setq ss (ssget "_I"))
|
|
(if (or (null ss) (/= (sslength ss) 1))
|
|
(setq ss (ssget ":S" '((0 . "INSERT") (2 . "LG_*")))))
|
|
(if ss
|
|
(progn
|
|
(ssg-start (ssg-text "lg-titel-edit") nil)
|
|
(lg-edit-ent (ssname ss 0))
|
|
(ssg-end)))
|
|
(princ)
|
|
)
|
|
|
|
;; ============================================================
|
|
;; EXPORT (lager_raw.json)
|
|
;; ============================================================
|
|
|
|
;; --- JSON-Schreiber (rein, getestet) ---
|
|
;; Werte: nil -> null, T -> true, String, Ganz-/Fliesszahl, (ROH "json").
|
|
(defun lg-json-zahl (w / s)
|
|
(setq s (rtos w 2 3))
|
|
(if (vl-string-search "." s)
|
|
(progn
|
|
(setq s (vl-string-right-trim "0" s))
|
|
(if (= (substr s (strlen s)) ".") (setq s (substr s 1 (1- (strlen s)))))))
|
|
(if (= s "-0") "0" s)
|
|
)
|
|
|
|
(defun lg-json-wert (v)
|
|
(cond
|
|
((null v) "null")
|
|
((eq v T) "true")
|
|
((= (type v) 'STR) (strcat "\"" (ssg-json-escape v) "\""))
|
|
((= (type v) 'INT) (itoa v))
|
|
((= (type v) 'REAL) (lg-json-zahl v))
|
|
((and (listp v) (eq (car v) 'ROH)) (cadr v))
|
|
(T (strcat "\"" (ssg-json-escape (vl-princ-to-string v)) "\""))
|
|
)
|
|
)
|
|
|
|
(defun lg-json-obj (paare)
|
|
(strcat "{"
|
|
(ssg-join (mapcar '(lambda (p) (strcat "\"" (car p) "\": " (lg-json-wert (cdr p)))) paare)
|
|
", ")
|
|
"}")
|
|
)
|
|
|
|
;; Liste bereits gerenderter JSON-Texte als Array (ein Element je Zeile).
|
|
(defun lg-json-arr (texte einrueckung)
|
|
(if texte
|
|
(strcat "[\n" einrueckung (ssg-join texte (strcat ",\n" einrueckung)) "\n" (substr einrueckung 3) "]")
|
|
"[]")
|
|
)
|
|
|
|
(defun lg-json-zahlen (zahlen)
|
|
(list 'ROH (strcat "[" (ssg-join (mapcar 'lg-json-wert zahlen) ", ") "]"))
|
|
)
|
|
|
|
(defun lg-json-ebenen (s)
|
|
(list 'ROH
|
|
(strcat "["
|
|
(ssg-join (mapcar '(lambda (e) (lg-json-obj (list (cons "schienenhoehe_mm" (car e))
|
|
(cons "warenlaenge_mm" (cadr e)))))
|
|
(lg-haengeebenen-parse s))
|
|
", ")
|
|
"]"))
|
|
)
|
|
|
|
;; Attributwert als Zahl bzw. Ganzzahl (nil, wenn leer).
|
|
(defun lg-a-zahl (a tag) (lg-zahl (cdr (assoc tag a))))
|
|
(defun lg-a-int (a tag / w) (if (setq w (lg-zahl (cdr (assoc tag a)))) (fix w)))
|
|
|
|
(defun lg-export-geschoss (g / a k pts bb)
|
|
(setq a (caddr g) pts (cadddr g) bb (ssg-poly-bbox pts)
|
|
k (lg-xdata-wert (car g) "kontur"))
|
|
(lg-json-obj
|
|
(list (cons "nr" (cadr g))
|
|
(cons "bezeichnung" (cdr (assoc "BEZEICHNUNG" a)))
|
|
(cons "hoehe_belag_mm" (lg-a-zahl a "HOEHE_BELAG_mm"))
|
|
(cons "konstr_hoehe_mm" (lg-a-zahl a "KONSTR_HOEHE_mm"))
|
|
(cons "lichte_hoehe_mm" (lg-a-zahl a "LICHTE_HOEHE_mm"))
|
|
(cons "belag_art" (cdr (assoc "BELAG_ART" a)))
|
|
(cons "personen" (lg-a-int a "PERSONEN"))
|
|
(cons "brandgefaehrdung" (cdr (assoc "BRANDGEFAEHRDUNG" a)))
|
|
(cons "kontur_flaeche_mm2" (if pts (ssg-poly-flaeche pts)))
|
|
(cons "kontur_umfang_mm" (if pts (ssg-poly-umfang pts)))
|
|
(cons "kontur_bbox" (if bb (lg-json-zahlen (append (car bb) (cadr bb)))))
|
|
(cons "handle" (lg-handle (car g)))
|
|
(cons "kontur_handle" k)))
|
|
)
|
|
|
|
(defun lg-export-bereich (e / a k pts bb)
|
|
(setq a (ssg-attrib-read e)
|
|
k (lg-ent-aus-handle (lg-xdata-wert e "kontur"))
|
|
pts (if k (ssg-lwpoly-punkte k))
|
|
bb (ssg-poly-bbox pts))
|
|
(lg-json-obj
|
|
(list (cons "nr" (lg-a-int a "NR"))
|
|
(cons "geschoss" (lg-a-int a "GESCHOSS"))
|
|
(cons "gangbreite_mm" (lg-a-zahl a "GANGBREITE_mm"))
|
|
(cons "regaltiefe_mm" (lg-a-zahl a "REGALTIEFE_mm"))
|
|
(cons "reihen_je_gang" (lg-a-int a "REIHEN_JE_GANG"))
|
|
(cons "schienen_je_gang" (lg-a-int a "SCHIENEN_JE_GANG"))
|
|
(cons "quergang_abstand_mm" (lg-a-zahl a "QUERGANG_ABSTAND_mm"))
|
|
(cons "quergang_breite_mm" (lg-a-zahl a "QUERGANG_BREITE_mm"))
|
|
(cons "richtung_grad" (lg-a-zahl a "RICHTUNG"))
|
|
(cons "haengeebenen" (lg-json-ebenen (cdr (assoc "HAENGEEBENEN" a))))
|
|
(cons "belag" (cdr (assoc "BELAG" a)))
|
|
(cons "randgang_mm" (list 'ROH (lg-json-obj
|
|
(mapcar '(lambda (r) (cons (strcase (car r) T) (cdr r)))
|
|
(lg-bereich-rand a)))))
|
|
(cons "restbreite_mm" (lg-a-zahl a "RESTBREITE_mm"))
|
|
(cons "kontur_flaeche_mm2" (if pts (ssg-poly-flaeche pts)))
|
|
(cons "kontur_bbox" (if bb (lg-json-zahlen (append (car bb) (cadr bb)))))
|
|
(cons "handle" (lg-handle e))))
|
|
)
|
|
|
|
(defun lg-export-linie (e art / a ed)
|
|
(setq a (ssg-attrib-read e) ed (entget e))
|
|
(lg-json-obj
|
|
(append
|
|
(list (cons "geschoss" (lg-a-int a "GESCHOSS"))
|
|
(cons "laenge_mm" (lg-a-zahl a "LAENGE")))
|
|
(if (= art "reihe")
|
|
(list (cons "tiefe_mm" (lg-a-zahl a "TIEFE_mm"))
|
|
(cons "haengeebenen" (lg-json-ebenen (cdr (assoc "HAENGEEBENEN" a))))
|
|
(cons "schienen" (lg-a-int a "SCHIENEN"))
|
|
(cons "quelle" (cdr (assoc "QUELLE" a))))
|
|
(list (cons "breite_mm" (lg-a-zahl a "BREITE_mm"))
|
|
(cons "art" (cdr (assoc "ART" a)))
|
|
(cons "belag" (cdr (assoc "BELAG" a)))
|
|
(cons "quelle" (if (member (cdr (assoc "QUELLE" a)) '(nil "")) "auto"
|
|
(cdr (assoc "QUELLE" a))))))
|
|
(list (cons "bereich" (lg-a-int a "BEREICH"))
|
|
(cons "start" (lg-json-zahlen (cdr (assoc 10 ed))))
|
|
(cons "winkel_grad" (* (/ (cond ((cdr (assoc 50 ed))) (0.0)) pi) 180.0))
|
|
(cons "handle" (lg-handle e)))))
|
|
)
|
|
|
|
;; goh_rack-Bloecke sammeln (lg-racks-sammeln). Geschoss ueber den Layer
|
|
;; des obersten INSERTs (_G<nr>), sonst ueber die Kontur (lg-rack-geschoss).
|
|
;; Rueckgabe: (json-texte warnungen)
|
|
(defun lg-export-goh-racks (kandidaten / texte warn gs ebenen vorgabe)
|
|
(setq texte nil warn nil
|
|
vorgabe (lg-vorgabe '("reihe" "haengeebenen") "2300/1200;1100/1100"))
|
|
(foreach r (lg-racks-sammeln)
|
|
(setq gs (lg-rack-geschoss (lg-ent-layer (lg-rk-top r)) (lg-rk-mitte r) kandidaten))
|
|
(if (and (null gs) kandidaten)
|
|
(setq warn (cons (ssg-textf "lg-exp-rack-ohne-geschoss"
|
|
(list (rtos (car (lg-rk-mitte r)) 2 0) (rtos (cadr (lg-rk-mitte r)) 2 0)))
|
|
warn)))
|
|
(setq ebenen (if (lg-rk-ebenen r) (fix (lg-rk-ebenen r))))
|
|
(if (null (lg-rk-laenge r))
|
|
(setq warn (cons (ssg-textf "lg-exp-rack-ohne-laenge" (list (lg-rk-name r))) warn)))
|
|
(setq texte (cons
|
|
(lg-json-obj
|
|
(list (cons "geschoss" gs)
|
|
(cons "name" (lg-rk-name r))
|
|
(cons "laenge_mm" (lg-rk-laenge r))
|
|
(cons "ebenen" ebenen)
|
|
(cons "tiefe_mm" (lg-zahl (lg-vorgabe '("goh_rack" "tiefe_mm") 700)))
|
|
(cons "haengeebenen" (lg-json-ebenen (if ebenen (lg-haengeebenen-n vorgabe ebenen) vorgabe)))
|
|
(cons "haengeebenen_quelle" "vorgabe")
|
|
(cons "position" (lg-json-zahlen (lg-rk-mitte r)))))
|
|
texte)))
|
|
(list (reverse texte) (reverse warn))
|
|
)
|
|
|
|
;; Alle Daten als JSON-Text.
|
|
(defun lg-export-json ( / gs kandidaten racks warn gs-ohne)
|
|
(setq gs (lg-geschosse)
|
|
kandidaten (lg-geschoss-kandidaten)
|
|
racks (lg-export-goh-racks kandidaten)
|
|
warn (cadr racks))
|
|
(if (null gs) (setq warn (cons (ssg-text "lg-exp-keine-geschosse") warn)))
|
|
(foreach g gs
|
|
(if (null (cadddr g))
|
|
(setq warn (cons (ssg-textf "lg-exp-geschoss-ohne-kontur" (list (itoa (cadr g)))) warn))))
|
|
(strcat
|
|
"{\n"
|
|
" \"version\": 1,\n"
|
|
" \"zeichnung\": " (lg-json-wert (strcat (getvar "DWGPREFIX") (getvar "DWGNAME"))) ",\n"
|
|
" \"erzeugt\": " (lg-json-wert (ssg-timestamp)) ",\n"
|
|
" \"einheit\": \"mm\",\n"
|
|
" \"land\": " (lg-json-wert (lg-land)) ",\n"
|
|
" \"belag_yaml\": " (lg-json-obj (vl-remove-if '(lambda (p) (or (/= (type (cdr p)) 'STR)
|
|
(= (car p) "beschreibung")))
|
|
(lg-vorgabe '("belag_yaml") nil))) ",\n"
|
|
" \"reihen_als_gitterrost\": " (lg-json-wert (if (lg-vorgabe '("flaechen" "reihen_als_gitterrost") nil) T nil)) ",\n"
|
|
" \"geschosse\": " (lg-json-arr (mapcar 'lg-export-geschoss gs) " ") ",\n"
|
|
" \"bereiche\": " (lg-json-arr (mapcar 'lg-export-bereich (lg-alle-bloecke "LG_BEREICH")) " ") ",\n"
|
|
" \"reihen\": " (lg-json-arr (mapcar '(lambda (e) (lg-export-linie e "reihe")) (lg-alle-bloecke "LG_REIHE_*")) " ") ",\n"
|
|
" \"gaenge\": " (lg-json-arr (mapcar '(lambda (e) (lg-export-linie e "gang")) (lg-alle-bloecke "LG_GANG_*")) " ") ",\n"
|
|
" \"goh_racks\": " (lg-json-arr (car racks) " ") ",\n"
|
|
" \"warnungen\": " (lg-json-arr (mapcar 'lg-json-wert warn) " ") "\n"
|
|
"}\n")
|
|
)
|
|
|
|
(defun lg-ausgabe-verzeichnis ( / d)
|
|
(setq d (cond ((getenv "DXFM_RESULTS")) ((getvar "DWGPREFIX"))))
|
|
(setq d (vl-string-right-trim "/\\" (vl-string-translate "\\" "/" d)))
|
|
(if (not (vl-file-directory-p d)) (vl-mkdir d))
|
|
d
|
|
)
|
|
|
|
(defun lg-dwg-basis ( / )
|
|
(if (= (getvar "DWGTITLED") 1) (vl-filename-base (getvar "DWGNAME")) "lager")
|
|
)
|
|
|
|
;; JSON schreiben (pfad) -> pfad oder nil.
|
|
(defun lg-export-schreiben (pfad / fh)
|
|
(if (setq fh (open pfad "w"))
|
|
(progn (princ (lg-export-json) fh) (close fh) pfad)
|
|
(progn (princ (ssg-textf "lg-exp-datei-fehler" (list pfad))) nil))
|
|
)
|
|
|
|
;; Python-Skript lager_yaml_export.py aufrufen (nutzt die Interpreter-
|
|
;; Ermittlung aus export.lsp). Rueckgabe: Exitcode oder nil.
|
|
(defun lg-python-aufrufen (raw yaml html / skript hand log args rc)
|
|
(cond
|
|
((not (car (atoms-family 1 '("EXPORT:RUN-PYTHON"))))
|
|
(princ (ssg-text "lg-exp-ohne-python")) nil)
|
|
((null (getenv "DXFM_LIB")) (princ (ssg-text "lg-exp-ohne-python")) nil)
|
|
(T
|
|
(setq skript (strcat (vl-string-translate "\\" "/" (getenv "DXFM_LIB")) "/lager_yaml_export.py")
|
|
hand (lg-ldata-lesen "HAND_YAML")
|
|
log (strcat (lg-ausgabe-verzeichnis) "/lager_export_python.log"))
|
|
(setq args (list raw yaml "--nachweis" html))
|
|
(if (and hand (= (type hand) 'STR) (findfile hand))
|
|
(setq args (append args (list "--hand" hand))))
|
|
(setq rc (export:run-python (export:python-exe) skript args log))
|
|
(if (and rc (/= rc 0))
|
|
(princ (ssg-textf "lg-exp-python-fehler" (list (vl-princ-to-string rc) log))))
|
|
rc)
|
|
)
|
|
)
|
|
|
|
(defun c:LAGER_EXPORT ( / dir basis raw yaml html rc)
|
|
(setq dir (lg-ausgabe-verzeichnis) basis (lg-dwg-basis))
|
|
(setq raw (strcat dir "/" basis "_lager_raw.json")
|
|
yaml (strcat dir "/" basis "_drawing.yaml")
|
|
html (strcat dir "/" basis "_nachweis.html"))
|
|
(if (lg-export-schreiben raw)
|
|
(progn
|
|
(princ (ssg-textf "lg-exp-raw" (list raw)))
|
|
(setq rc (lg-python-aufrufen raw yaml html))
|
|
(if (and rc (= rc 0))
|
|
(princ (ssg-textf "lg-exp-yaml" (list yaml html))))))
|
|
(princ)
|
|
)
|
|
|
|
;; Hand-YAML fuer den Abgleich (Konfliktliste) festlegen; leer = keiner.
|
|
(defun c:LAGER_HAND_YAML ( / alt neu)
|
|
(setq alt (lg-ldata-lesen "HAND_YAML"))
|
|
(setq neu (if (ssg-gui-p)
|
|
(getfiled (ssg-text "lg-titel-hand-yaml") (if (= (type alt) 'STR) alt "") "yaml" 0)
|
|
(ssg-in-string (ssg-text "lg-titel-hand-yaml") (if (= (type alt) 'STR) alt ""))))
|
|
(lg-ldata-setzen "HAND_YAML" (if neu neu ""))
|
|
(princ (ssg-textf "lg-hand-yaml" (list (if (and neu (/= neu "")) neu "-"))))
|
|
(princ)
|
|
)
|
|
|
|
(princ)
|