2653 lines
115 KiB
Common Lisp
2653 lines
115 KiB
Common Lisp
;; ============================================================
|
|
;; LagerInsert.lsp - Lagerplanung GOH-Buehnenlager (Phase 1: Mengen, 2D)
|
|
;;
|
|
;; Erzeugt parametrische Attributbloecke fuer ein mehrgeschossiges
|
|
;; Haengewarenlager und exportiert daraus die technischen Daten als JSON
|
|
;; fuer die RFQ-Dokumentation (LAGER_EXPORT, 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)
|
|
;;
|
|
;; Befehle: LG_GESCHOSS, LG_GESCHOSS_AKTIV, LG_GESCHOSS_KOPIEREN, LG_BEREICH,
|
|
;; LG_REIHE, LG_GANG, LG_EDIT, LG_REGALE, LAGER_EXPORT
|
|
;;
|
|
;; 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)
|
|
";")
|
|
)
|
|
|
|
;; 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")
|
|
("UNTER_REIHE" . "") ("GITTERKORB_HOEHE_mm" . "")
|
|
("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)
|
|
("unter" "UNTER_REIHE" "wahl" unter)
|
|
("korbhoehe" "GITTERKORB_HOEHE_mm" "mm" nil)
|
|
("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 'unter) *lg-unter-reihe-werte*)
|
|
((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 "UNTER_REIHE" (lg-unter-reihe-vorgabe))
|
|
(cons "GITTERKORB_HOEHE_mm" (lg-mm-str (lg-zahl (lg-vorgabe '("bereich" "gitterkorb_hoehe_mm") 500))))
|
|
(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)))))
|
|
)
|
|
|
|
;; Absturzsicherung unter den Regalreihen (Attribut UNTER_REIHE am Bereich):
|
|
;; gitterrost = Grundflaeche der Reihe als Gitterrost, gitterkorb = Korb mit
|
|
;; Boden UND Seitenwaenden zum Geschoss darunter, keine = offen.
|
|
(setq *lg-unter-reihe-werte* '("gitterrost" "gitterkorb" "keine"))
|
|
|
|
(defun lg-unter-reihe-vorgabe ( / v)
|
|
(setq v (lg-vorgabe '("bereich" "unter_reihe") "gitterrost"))
|
|
(if (member v *lg-unter-reihe-werte*) v "gitterrost")
|
|
)
|
|
|
|
;; Reiner Kern: wirksamer Wert unter einer Reihe. wert = UNTER_REIHE des
|
|
;; Bereichs (nil/leer/unbekannt -> vorgabe), buehne-p = nil auf Hallenboden
|
|
;; (dort gibt es nichts abzusichern -> "keine").
|
|
(defun lg-unter-reihe-wert (wert vorgabe buehne-p)
|
|
(cond
|
|
((not buehne-p) "keine")
|
|
((member wert *lg-unter-reihe-werte*) wert)
|
|
((member vorgabe *lg-unter-reihe-werte*) vorgabe)
|
|
(T "gitterrost")
|
|
)
|
|
)
|
|
|
|
;; 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))
|
|
)
|
|
|
|
;; ============================================================
|
|
;; REGALE ZAEHLEN (LG_REGALE)
|
|
;; ============================================================
|
|
|
|
;; Reiner Kern: Regalreihen 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-reihen-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))))))
|
|
)
|
|
|
|
;; Reiner Kern: Eintrag (geschoss laenge-mm ebenen) einer Regalreihe
|
|
;; (LG_REIHE_*) fuer lg-reihen-auswerten, aus ihren Attributen. Ebenen =
|
|
;; Anzahl der Haengeebenen in HAENGEEBENEN, Geschoss nil wenn nicht lesbar.
|
|
(defun lg-reihe-eintrag (a / gs)
|
|
(setq gs (lg-zahl (cdr (assoc "GESCHOSS" a))))
|
|
(list (if gs (fix gs))
|
|
(lg-zahl (cdr (assoc "LAENGE" a)))
|
|
(float (length (lg-haengeebenen-parse (cdr (assoc "HAENGEEBENEN" a))))))
|
|
)
|
|
|
|
;; Zeilen von lg-reihen-auswerten in der Befehlszeile ausgeben (Kopf, je
|
|
;; Geschoss eine Zeile, Summe). zeile-key: Textschluessel mit %1..%4.
|
|
(defun lg-regale-ausgeben (kopf-key zeile-key zeilen)
|
|
(princ (ssg-text kopf-key))
|
|
(foreach z zeilen
|
|
(princ (ssg-textf zeile-key
|
|
(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 zeile-key
|
|
(list (ssg-text "lg-regale-summe") (itoa (apply '+ (mapcar 'cadr zeilen)))
|
|
(rtos (/ (apply '+ (mapcar 'caddr zeilen)) 1000.0) 2 2)
|
|
(rtos (/ (apply '+ (mapcar 'cadddr zeilen)) 1000.0) 2 2))))
|
|
)
|
|
|
|
;; Befehl LG_REGALE: Regalreihen (LG_REIHE_* aus LG_BEREICH/LG_REIHE)
|
|
;; zaehlen - je Geschoss Anzahl, Laenge und Laenge x Ebenen
|
|
;; (Haengekapazitaet) in der Befehlszeile.
|
|
(defun c:LG_REGALE ( / reihen)
|
|
(if (setq reihen (lg-alle-bloecke "LG_REIHE_*"))
|
|
(lg-regale-ausgeben "lg-regale-kopf" "lg-regale-zeile"
|
|
(lg-reihen-auswerten (mapcar '(lambda (e) (lg-reihe-eintrag (ssg-attrib-read e))) reihen)))
|
|
(princ (ssg-text "lg-regale-keine")))
|
|
(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.
|
|
;; 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.
|
|
|
|
;; 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))
|
|
)
|
|
|
|
;; Eine Kopie des Geschosses src-nr als Geschoss nr auf hoehe, um v versetzt.
|
|
;; Rueckgabe: (geschoss-ent reihen gaenge) oder nil.
|
|
(defun lg-geschoss-kopieren (src-nr nr hoehe belag-neu v
|
|
/ 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)))))))
|
|
(list blk n-reihen n-gaenge)))
|
|
)
|
|
)
|
|
)
|
|
|
|
;; 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
|
|
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))
|
|
(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)))
|
|
(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))))))))
|
|
(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 und Gaengen 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 (<dwg>_lager.json)
|
|
;; ============================================================
|
|
;; Eine JSON-Datei mit den technischen Daten des Lagers fuer die
|
|
;; RFQ-Dokumentation (eigenes Projekt): alle Objekte mit Attributen und
|
|
;; voller Geometrie (WCS, mm) plus Kennwerte je Geschoss und fuer das ganze
|
|
;; Lager, jeder Geschoss-Kennwert mit Formel und Quelle (herkunft).
|
|
;; Schema und Formeln: doc/plan/lager_rfq.md. Die Kennwerte entstehen hier
|
|
;; in reinen Kernen (getestet) - fachliche Regeln leben in LISP.
|
|
;;
|
|
;; Datenform: Objekte als (OBJ (schluessel . wert) ...), Arrays als
|
|
;; (ARR wert ...); lg-j liest ein Feld, lg-j-setzen setzt es.
|
|
|
|
;; --- JSON-Schreiber (rein, getestet) ---
|
|
;; Werte: nil -> null, T -> true, FALSE -> false, String, Ganz-/Fliesszahl,
|
|
;; (ROH "json"), (OBJ ...) -> Objekt, (ARR ...) -> Array.
|
|
(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-hex4 (n / h erg)
|
|
(setq h "0123456789abcdef" erg "")
|
|
(repeat 4
|
|
(setq erg (strcat (substr h (1+ (rem n 16)) 1) erg) n (/ n 16)))
|
|
erg
|
|
)
|
|
|
|
;; String als JSON-Text. Zeichen ausserhalb ASCII (Umlaute in einer
|
|
;; Bezeichnung) als \uXXXX, damit die Datei unabhaengig von der Codepage
|
|
;; gueltiges UTF-8 bleibt.
|
|
(defun lg-json-str (s / roh i c erg)
|
|
(setq roh (ssg-json-escape s) erg "" i 1)
|
|
(while (<= i (strlen roh))
|
|
(setq c (substr roh i 1))
|
|
(setq erg (strcat erg (if (> (ascii c) 127) (strcat "\\u" (lg-hex4 (ascii c))) c))
|
|
i (1+ i)))
|
|
(strcat "\"" erg "\"")
|
|
)
|
|
|
|
(defun lg-json-wert (v)
|
|
(cond
|
|
((null v) "null")
|
|
((eq v T) "true")
|
|
((eq v 'FALSE) "false")
|
|
((= (type v) 'STR) (lg-json-str v))
|
|
((= (type v) 'INT) (itoa v))
|
|
((= (type v) 'REAL) (lg-json-zahl v))
|
|
((and (listp v) (eq (car v) 'ROH)) (cadr v))
|
|
((and (listp v) (eq (car v) 'OBJ)) (lg-json-obj (cdr v)))
|
|
((and (listp v) (eq (car v) 'ARR))
|
|
(strcat "[" (ssg-join (mapcar 'lg-json-wert (cdr v)) ", ") "]"))
|
|
(T (lg-json-str (vl-princ-to-string v)))
|
|
)
|
|
)
|
|
|
|
(defun lg-json-obj (paare)
|
|
(strcat "{"
|
|
(ssg-join (mapcar '(lambda (p) (strcat (lg-json-str (car p)) ": " (lg-json-wert (cdr p)))) paare)
|
|
", ")
|
|
"}")
|
|
)
|
|
|
|
(defun lg-json-container-p (v)
|
|
(and v (listp v) (member (car v) '(OBJ ARR)))
|
|
)
|
|
|
|
;; Anzahl Blattwerte eines Werts (Mass fuer "passt in eine Zeile").
|
|
(defun lg-json-blaetter (v)
|
|
(cond
|
|
((not (lg-json-container-p v)) 1)
|
|
((eq (car v) 'OBJ) (apply '+ (cons 0 (mapcar '(lambda (p) (lg-json-blaetter (cdr p))) (cdr v)))))
|
|
(T (apply '+ (cons 0 (mapcar 'lg-json-blaetter (cdr v)))))
|
|
)
|
|
)
|
|
|
|
;; Zahl, null oder Array nur daraus (Punkte, Punktlisten, bbox).
|
|
(defun lg-json-zahlen-p (v)
|
|
(cond
|
|
((or (null v) (numberp v)) T)
|
|
((and (listp v) (eq (car v) 'ARR)) (vl-every 'lg-json-zahlen-p (cdr v)))
|
|
(T nil)
|
|
)
|
|
)
|
|
|
|
;; Eingerueckter JSON-Text. Zahlenreihen (Punkte, Konturen) und kleine
|
|
;; Container (bis *lg-json-inline-max* Blattwerte) bleiben einzeilig, alles
|
|
;; andere bekommt je Eintrag eine Zeile.
|
|
(setq *lg-json-inline-max* 12)
|
|
|
|
(defun lg-json-text (v einr / innen zeilen obj-p)
|
|
(if (or (not (lg-json-container-p v))
|
|
(lg-json-zahlen-p v)
|
|
(<= (lg-json-blaetter v) *lg-json-inline-max*))
|
|
(lg-json-wert v)
|
|
(progn
|
|
(setq innen (strcat einr " ") obj-p (eq (car v) 'OBJ))
|
|
(setq zeilen
|
|
(if obj-p
|
|
(mapcar '(lambda (p) (strcat innen (lg-json-str (car p)) ": " (lg-json-text (cdr p) innen))) (cdr v))
|
|
(mapcar '(lambda (x) (strcat innen (lg-json-text x innen))) (cdr v))))
|
|
(if zeilen
|
|
(strcat (if obj-p "{" "[") "\n" (ssg-join zeilen ",\n") "\n" einr (if obj-p "}" "]"))
|
|
(if obj-p "{}" "[]")))
|
|
)
|
|
)
|
|
|
|
;; --- Zugriff auf OBJ-Records ---
|
|
(defun lg-j (obj key) (cdr (assoc key (cdr obj))))
|
|
|
|
(defun lg-j-setzen (obj key wert / alt)
|
|
(if (setq alt (assoc key (cdr obj)))
|
|
(cons 'OBJ (subst (cons key wert) alt (cdr obj)))
|
|
(cons 'OBJ (append (cdr obj) (list (cons key wert)))))
|
|
)
|
|
|
|
(defun lg-j-pkte (pts) (cons 'ARR (mapcar '(lambda (p) (cons 'ARR p)) pts)))
|
|
(defun lg-j-bbox (bb) (if bb (cons 'ARR (append (car bb) (cadr bb)))))
|
|
(defun lg-n (v) (if (numberp v) (float v) 0.0))
|
|
|
|
(defun lg-j-ebenen (s)
|
|
(cons 'ARR
|
|
(mapcar '(lambda (e) (list 'OBJ (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)))
|
|
|
|
;; Buehne = Belag vorhanden und kein Hallenboden. Rein.
|
|
(defun lg-buehne-p (belag)
|
|
(and (= (type belag) 'STR) (/= belag "") (/= (strcase belag T) "hallenboden"))
|
|
)
|
|
|
|
;; --- Reine Kerne der Kennwerte (getestet) ---
|
|
|
|
;; Regallaenge je Haengeebene. reihen = Reihen-Records mit laenge_mm und
|
|
;; haengeebenen; jede Reihe traegt ihre Laenge in jede ihrer Ebenen ein.
|
|
;; Rueckgabe (ARR (OBJ schienenhoehe_mm warenlaenge_mm reihen regallaenge_mm)
|
|
;; ...), nach Schienenhoehe absteigend.
|
|
(defun lg-haengeebenen-summen (reihen / erg key alt l)
|
|
(setq erg nil)
|
|
(foreach r reihen
|
|
(setq l (lg-n (lg-j r "laenge_mm")))
|
|
(foreach e (cdr (lg-j r "haengeebenen"))
|
|
(setq key (list (lg-n (lg-j e "schienenhoehe_mm")) (lg-n (lg-j e "warenlaenge_mm")))
|
|
alt (assoc key erg))
|
|
(setq erg (if alt
|
|
(subst (list key (1+ (cadr alt)) (+ (caddr alt) l)) alt erg)
|
|
(cons (list key 1 l) erg)))))
|
|
(cons 'ARR
|
|
(mapcar '(lambda (x) (list 'OBJ (cons "schienenhoehe_mm" (car (car x)))
|
|
(cons "warenlaenge_mm" (cadr (car x)))
|
|
(cons "reihen" (cadr x))
|
|
(cons "regallaenge_mm" (caddr x))))
|
|
(vl-sort erg '(lambda (a b) (if (equal (car (car a)) (car (car b)) 1e-6)
|
|
(> (cadr (car a)) (cadr (car b)))
|
|
(> (car (car a)) (car (car b))))))))
|
|
)
|
|
|
|
;; Gaenge je ART: (OBJ ("gang" . (OBJ anzahl laenge_mm flaeche_mm2)) ...),
|
|
;; gang/quergang/randgang immer vorhanden, weitere Arten dahinter.
|
|
(defun lg-gaenge-je-art (gaenge / erg art x l f)
|
|
(setq erg (mapcar '(lambda (a) (list a 0 0.0 0.0)) '("gang" "quergang" "randgang")))
|
|
(foreach g gaenge
|
|
(setq art (cond ((lg-j g "art")) ("unbekannt"))
|
|
x (assoc art erg)
|
|
l (lg-n (lg-j g "laenge_mm"))
|
|
f (* l (lg-n (lg-j g "breite_mm"))))
|
|
(setq erg (if x
|
|
(subst (list art (1+ (cadr x)) (+ (caddr x) l) (+ (cadddr x) f)) x erg)
|
|
(append erg (list (list art 1 l f))))))
|
|
(cons 'OBJ
|
|
(mapcar '(lambda (x) (cons (car x) (list 'OBJ (cons "anzahl" (cadr x))
|
|
(cons "laenge_mm" (caddr x))
|
|
(cons "flaeche_mm2" (cadddr x)))))
|
|
erg))
|
|
)
|
|
|
|
;; Die vier Kanten eines Rechtecks aus lg-linie-polygon, in fester
|
|
;; Reihenfolge: 1-2 laengs, 2-3 stirn, 3-4 laengs, 4-1 stirn.
|
|
(defun lg-rechteck-kanten (ecken)
|
|
(list (list (nth 0 ecken) (nth 1 ecken)) (list (nth 1 ecken) (nth 2 ecken))
|
|
(list (nth 2 ecken) (nth 3 ecken)) (list (nth 3 ecken) (nth 0 ecken)))
|
|
)
|
|
|
|
(defun lg-bbox-beruehrt-p (a b tol)
|
|
(and a b
|
|
(<= (car (car b)) (+ (car (cadr a)) tol)) (<= (car (car a)) (+ (car (cadr b)) tol))
|
|
(<= (cadr (car b)) (+ (cadr (cadr a)) tol)) (<= (cadr (car a)) (+ (cadr (cadr b)) tol)))
|
|
)
|
|
|
|
;; Offener Teil der Kante (p q): Laenge minus die Abschnitte, auf denen eine
|
|
;; Kante eines Nachbar-Rechtecks kollinear (Abstand < tol) aufliegt.
|
|
(defun lg-kante-offen (kante nachbarn tol / p q len ux uy zu c d dx dy dl t1 t2 lo hi)
|
|
(setq p (car kante) q (cadr kante) zu nil
|
|
len (distance (list (car p) (cadr p)) (list (car q) (cadr q))))
|
|
(if (< len 1e-9)
|
|
0.0
|
|
(progn
|
|
(setq ux (/ (- (car q) (car p)) len) uy (/ (- (cadr q) (cadr p)) len))
|
|
(foreach f nachbarn
|
|
(foreach k (lg-rechteck-kanten f)
|
|
(setq c (car k) d (cadr k)
|
|
dx (- (car d) (car c)) dy (- (cadr d) (cadr c))
|
|
dl (sqrt (+ (* dx dx) (* dy dy))))
|
|
(if (and (> dl 1e-9)
|
|
(< (abs (- (* ux dy) (* uy dx))) (* 1e-4 dl)) ; parallel
|
|
(< (abs (- (* ux (- (cadr c) (cadr p))) (* uy (- (car c) (car p))))) tol)) ; gleiche Linie
|
|
(progn
|
|
(setq t1 (+ (* ux (- (car c) (car p))) (* uy (- (cadr c) (cadr p))))
|
|
t2 (+ (* ux (- (car d) (car p))) (* uy (- (cadr d) (cadr p))))
|
|
lo (max 0.0 (min t1 t2))
|
|
hi (min len (max t1 t2)))
|
|
(if (> (- hi lo) tol) (setq zu (cons (list lo hi) zu)))))))
|
|
(apply '+ (cons 0.0 (mapcar '(lambda (i) (- (cadr i) (car i)))
|
|
(ssg-intervalle-minus (list (list 0.0 len)) zu))))))
|
|
)
|
|
|
|
;; Offene Kantenlaenge je Reihe. ecken-liste = je Reihe die 4 Ecken (2D)
|
|
;; aus lg-linie-polygon. Eine Kante ist dort zu, wo eine Kante einer ANDEREN
|
|
;; Reihe kollinear darauf liegt (z.B. Ruecken an Ruecken). Rueckgabe je
|
|
;; Reihe (offen-laengs offen-stirn) in mm.
|
|
(defun lg-reihen-offene-kanten (ecken-liste tol / bbs erg i j k bb nachbarn l s o)
|
|
(setq bbs (mapcar 'ssg-poly-bbox ecken-liste) erg nil i 0)
|
|
(foreach e ecken-liste
|
|
(setq bb (nth i bbs) nachbarn nil j 0 l 0.0 s 0.0 k 0)
|
|
(foreach f ecken-liste
|
|
(if (and (/= i j) (lg-bbox-beruehrt-p bb (nth j bbs) tol))
|
|
(setq nachbarn (cons f nachbarn)))
|
|
(setq j (1+ j)))
|
|
(foreach kante (lg-rechteck-kanten e)
|
|
(setq o (lg-kante-offen kante nachbarn tol))
|
|
(if (= 0 (rem k 2)) (setq l (+ l o)) (setq s (+ s o)))
|
|
(setq k (1+ k)))
|
|
(setq erg (cons (list l s) erg) i (1+ i)))
|
|
(reverse erg)
|
|
)
|
|
|
|
;; Gitterkorb der Reihen EINES Geschosses vervollstaendigen: Reihen mit
|
|
;; gitterkorb (OBJ hoehe_mm) bekommen Boden (Laenge x Tiefe), offene Kanten
|
|
;; (gegen alle Reihen des Geschosses) und Seitenflaeche (offen x Hoehe).
|
|
(defun lg-reihen-gitterkorb-berechnen (reihen tol / offen)
|
|
(if (vl-some '(lambda (r) (lg-j r "gitterkorb")) reihen)
|
|
(progn
|
|
(setq offen (lg-reihen-offene-kanten
|
|
(mapcar '(lambda (r) (mapcar 'cdr (cdr (lg-j r "ecken")))) reihen) tol))
|
|
(mapcar '(lambda (r o / gk h l b)
|
|
(if (setq gk (lg-j r "gitterkorb"))
|
|
(progn
|
|
(setq h (lg-n (lg-j gk "hoehe_mm"))
|
|
l (lg-n (lg-j r "laenge_mm"))
|
|
b (lg-n (lg-j r "tiefe_mm")))
|
|
(lg-j-setzen r "gitterkorb"
|
|
(list 'OBJ (cons "hoehe_mm" (lg-j gk "hoehe_mm"))
|
|
(cons "bodenflaeche_mm2" (* l b))
|
|
(cons "offen_laengs_mm" (car o))
|
|
(cons "offen_stirn_mm" (cadr o))
|
|
(cons "seitenflaeche_mm2" (* h (+ (car o) (cadr o)))))))
|
|
r))
|
|
reihen offen))
|
|
reihen)
|
|
)
|
|
|
|
(defun lg-herkunft (key formel quelle)
|
|
(cons key (list 'OBJ (cons "formel" formel) (cons "quelle" quelle)))
|
|
)
|
|
|
|
;; Kennwerte eines Geschosses. g = Geschoss-Record, nx = Record des
|
|
;; naechsthoeheren Geschosses (nil = oberstes), reihen/gaenge = Records
|
|
;; dieses Geschosses (Reihen mit unter_reihe/gitterkorb), n-bereiche =
|
|
;; Anzahl Bereiche. Rueckgabe (kennwerte herkunft), beide OBJ.
|
|
(defun lg-kennwerte-geschoss (g nx reihen gaenge n-bereiche / nrs q qr buehne hk lichte regal grund
|
|
schienen gitter-r korb gk l f belag-g gitter-g belag gitter)
|
|
(setq nrs (vl-princ-to-string (lg-j g "nr"))
|
|
q (strcat "LG_GESCHOSS " nrs)
|
|
qr (strcat (itoa (length reihen)) " Regalreihe(n) LG_REIHE_* Geschoss " nrs)
|
|
buehne (lg-buehne-p (lg-j g "belag_art"))
|
|
hk nil)
|
|
;; lichte Hoehe: Vorgabe am Geschoss, sonst aus dem Geschoss darueber
|
|
(cond
|
|
((numberp (lg-j g "lichte_hoehe_mm"))
|
|
(setq lichte (lg-j g "lichte_hoehe_mm")
|
|
hk (cons (lg-herkunft "lichte_hoehe_mm" "LICHTE_HOEHE_mm (Vorgabe am Geschoss)" q) hk)))
|
|
(nx
|
|
(setq lichte (- (lg-n (lg-j nx "hoehe_belag_mm")) (lg-n (lg-j nx "konstr_hoehe_mm"))
|
|
(lg-n (lg-j g "hoehe_belag_mm")))
|
|
hk (cons (lg-herkunft "lichte_hoehe_mm"
|
|
"HOEHE_BELAG_mm darueber - KONSTR_HOEHE_mm darueber - eigene HOEHE_BELAG_mm"
|
|
(strcat q " / " (vl-princ-to-string (lg-j nx "nr"))))
|
|
hk)))
|
|
(T (setq lichte nil))
|
|
)
|
|
;; Regalreihen
|
|
(setq regal 0.0 grund 0.0 schienen 0.0 gitter-r 0.0 korb (list 0 0.0 0.0 0.0 0.0))
|
|
(foreach r reihen
|
|
(setq l (lg-n (lg-j r "laenge_mm"))
|
|
f (* l (lg-n (lg-j r "tiefe_mm"))))
|
|
(setq regal (+ regal l) grund (+ grund f)
|
|
schienen (+ schienen (* l (if (numberp (lg-j r "schienen")) (lg-j r "schienen") 1))))
|
|
(cond
|
|
((equal (lg-j r "unter_reihe") "gitterrost") (setq gitter-r (+ gitter-r f)))
|
|
((setq gk (lg-j r "gitterkorb"))
|
|
(setq korb (list (1+ (nth 0 korb))
|
|
(+ (nth 1 korb) (lg-n (lg-j gk "bodenflaeche_mm2")))
|
|
(+ (nth 2 korb) (lg-n (lg-j gk "seitenflaeche_mm2")))
|
|
(+ (nth 3 korb) (lg-n (lg-j gk "offen_laengs_mm")))
|
|
(+ (nth 4 korb) (lg-n (lg-j gk "offen_stirn_mm")))))))
|
|
)
|
|
(setq hk (append (reverse
|
|
(list (lg-herkunft "regallaenge_mm" "Summe LAENGE der Regalreihen" qr)
|
|
(lg-herkunft "regalgrundflaeche_mm2" "Summe LAENGE x TIEFE_mm der Regalreihen" qr)
|
|
(lg-herkunft "schienenlaenge_mm" "Summe LAENGE x SCHIENEN der Regalreihen" qr)
|
|
(lg-herkunft "haengeebenen" "je Schienenhoehe/Warenlaenge: Summe LAENGE aller Reihen mit dieser Haengeebene" qr)
|
|
(lg-herkunft "gaenge" "je ART: Anzahl, Summe LAENGE, Summe LAENGE x BREITE_mm"
|
|
(strcat (itoa (length gaenge)) " Flaeche(n) LG_GANG_* Geschoss " nrs))))
|
|
hk))
|
|
;; Belag und Gitterrost (nur Buehne)
|
|
(setq belag-g 0.0 gitter-g 0.0)
|
|
(foreach x gaenge
|
|
(setq f (* (lg-n (lg-j x "laenge_mm")) (lg-n (lg-j x "breite_mm"))))
|
|
(if (equal (lg-j x "belag") "gitterrost")
|
|
(setq gitter-g (+ gitter-g f))
|
|
(setq belag-g (+ belag-g f))))
|
|
(if buehne
|
|
(progn
|
|
(if gaenge
|
|
(setq belag belag-g
|
|
hk (cons (lg-herkunft "belagsflaeche_mm2"
|
|
"Summe LAENGE x BREITE_mm der Gaenge mit BELAG ungleich gitterrost"
|
|
(strcat "LG_GANG_* Geschoss " nrs)) hk))
|
|
(setq belag (- (lg-n (lg-j (lg-j g "kontur") "flaeche_mm2")) grund)
|
|
hk (cons (lg-herkunft "belagsflaeche_mm2"
|
|
"Konturflaeche - Grundflaeche der Regalreihen (keine LG_GANG-Flaechen)"
|
|
(strcat "Belagskontur Geschoss " nrs)) hk)))
|
|
(setq gitter (+ gitter-g gitter-r)
|
|
hk (cons (lg-herkunft "gitterrostflaeche_mm2"
|
|
(strcat "Summe LAENGE x BREITE_mm der Gaenge mit BELAG gitterrost"
|
|
" + LAENGE x TIEFE_mm der Reihen mit UNTER_REIHE gitterrost")
|
|
(strcat "LG_GANG_*/LG_REIHE_* Geschoss " nrs)) hk))
|
|
(setq hk (cons (lg-herkunft "gitterkorb"
|
|
(strcat "Reihen mit UNTER_REIHE gitterkorb: Boden = LAENGE x TIEFE_mm,"
|
|
" Seiten = offene Kantenlaenge x GITTERKORB_HOEHE_mm"
|
|
" (Kanten an einer direkt anliegenden Nachbarreihe zaehlen nicht)")
|
|
qr) hk)))
|
|
(setq belag nil gitter nil
|
|
hk (cons (lg-herkunft "buehne" "BELAG_ART hallenboden (oder leer): keine Buehne, kein Belag/Gitterrost/Gitterkorb" q) hk))
|
|
)
|
|
(list
|
|
(list 'OBJ
|
|
(cons "lichte_hoehe_mm" lichte)
|
|
(cons "buehne" (if buehne T 'FALSE))
|
|
(cons "bereiche" n-bereiche)
|
|
(cons "reihen" (length reihen))
|
|
(cons "regallaenge_mm" regal)
|
|
(cons "regalgrundflaeche_mm2" grund)
|
|
(cons "schienenlaenge_mm" schienen)
|
|
(cons "haengeebenen" (lg-haengeebenen-summen reihen))
|
|
(cons "gaenge" (lg-gaenge-je-art gaenge))
|
|
(cons "belagsflaeche_mm2" belag)
|
|
(cons "gitterrostflaeche_mm2" gitter)
|
|
(cons "gitterkorb" (list 'OBJ (cons "reihen" (nth 0 korb))
|
|
(cons "bodenflaeche_mm2" (nth 1 korb))
|
|
(cons "seitenflaeche_mm2" (nth 2 korb))
|
|
(cons "offen_laengs_mm" (nth 3 korb))
|
|
(cons "offen_stirn_mm" (nth 4 korb)))))
|
|
(cons 'OBJ (reverse hk)))
|
|
)
|
|
|
|
(defun lg-summe-feld (objs key)
|
|
(apply '+ (cons 0.0 (mapcar '(lambda (o) (lg-n (lg-j o key))) objs)))
|
|
)
|
|
|
|
;; Kennwerte des ganzen Lagers. geschosse = Geschoss-Records mit kennwerte
|
|
;; und kontur, reihen/gaenge = alle einem Geschoss zugeordneten Records.
|
|
(defun lg-kennwerte-lager (geschosse reihen gaenge n-bereiche / kws korb bbs xmin ymin xmax ymax dx dy)
|
|
(setq kws (mapcar '(lambda (g) (lg-j g "kennwerte")) geschosse)
|
|
korb (mapcar '(lambda (k) (lg-j k "gitterkorb")) kws)
|
|
bbs (vl-remove nil (mapcar '(lambda (g) (cdr (lg-j (lg-j g "kontur") "bbox"))) geschosse)))
|
|
(if bbs
|
|
(setq xmin (apply 'min (mapcar 'car bbs)) ymin (apply 'min (mapcar 'cadr bbs))
|
|
xmax (apply 'max (mapcar 'caddr bbs)) ymax (apply 'max (mapcar 'cadddr bbs))
|
|
dx (- xmax xmin) dy (- ymax ymin)))
|
|
(list 'OBJ
|
|
(cons "geschosse" (length geschosse))
|
|
(cons "bereiche" n-bereiche)
|
|
(cons "reihen" (length reihen))
|
|
(cons "regallaenge_mm" (lg-summe-feld kws "regallaenge_mm"))
|
|
(cons "regalgrundflaeche_mm2" (lg-summe-feld kws "regalgrundflaeche_mm2"))
|
|
(cons "schienenlaenge_mm" (lg-summe-feld kws "schienenlaenge_mm"))
|
|
(cons "haengeebenen" (lg-haengeebenen-summen reihen))
|
|
(cons "gaenge" (lg-gaenge-je-art gaenge))
|
|
(cons "belagsflaeche_mm2" (lg-summe-feld kws "belagsflaeche_mm2"))
|
|
(cons "gitterrostflaeche_mm2" (lg-summe-feld kws "gitterrostflaeche_mm2"))
|
|
(cons "gitterkorb" (list 'OBJ (cons "reihen" (fix (lg-summe-feld korb "reihen")))
|
|
(cons "bodenflaeche_mm2" (lg-summe-feld korb "bodenflaeche_mm2"))
|
|
(cons "seitenflaeche_mm2" (lg-summe-feld korb "seitenflaeche_mm2"))
|
|
(cons "offen_laengs_mm" (lg-summe-feld korb "offen_laengs_mm"))
|
|
(cons "offen_stirn_mm" (lg-summe-feld korb "offen_stirn_mm"))))
|
|
(cons "huelle" (if bbs
|
|
(list 'OBJ (cons "bbox" (list 'ARR xmin ymin xmax ymax))
|
|
(cons "laenge_mm" (max dx dy))
|
|
(cons "breite_mm" (min dx dy))))))
|
|
)
|
|
|
|
;; --- Records aus der Zeichnung ---
|
|
|
|
(defun lg-ent-layer (e) (cdr (assoc 8 (entget e))))
|
|
|
|
(defun lg-export-kontur (k / pts)
|
|
(if (and k (setq pts (ssg-lwpoly-punkte k)))
|
|
(list 'OBJ
|
|
(cons "handle" (lg-handle k))
|
|
(cons "z" (cond ((caddr (car pts))) (0.0)))
|
|
(cons "punkte" (lg-j-pkte (mapcar '(lambda (p) (list (car p) (cadr p))) pts)))
|
|
(cons "flaeche_mm2" (ssg-poly-flaeche pts))
|
|
(cons "umfang_mm" (ssg-poly-umfang pts))
|
|
(cons "bbox" (lg-j-bbox (ssg-poly-bbox pts)))))
|
|
)
|
|
|
|
(defun lg-export-geschoss-rec (g / a)
|
|
(setq a (caddr g))
|
|
(list 'OBJ
|
|
(cons "nr" (cadr g))
|
|
(cons "bezeichnung" (cdr (assoc "BEZEICHNUNG" a)))
|
|
(cons "id" (cdr (assoc "ID" a)))
|
|
(cons "handle" (lg-handle (car g)))
|
|
(cons "layer" (lg-ent-layer (car g)))
|
|
(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" (lg-export-kontur (lg-ent-aus-handle (lg-xdata-wert (car g) "kontur"))))))
|
|
|
|
(defun lg-export-bereich-rec (e / a kinder)
|
|
(setq a (ssg-attrib-read e) kinder (lg-bereich-kinder e))
|
|
(list 'OBJ
|
|
(cons "nr" (lg-a-int a "NR"))
|
|
(cons "id" (cdr (assoc "ID" a)))
|
|
(cons "handle" (lg-handle e))
|
|
(cons "layer" (lg-ent-layer e))
|
|
(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-j-ebenen (cdr (assoc "HAENGEEBENEN" a))))
|
|
(cons "belag" (cdr (assoc "BELAG" a)))
|
|
(cons "unter_reihe" (lg-unter-reihe-wert (cdr (assoc "UNTER_REIHE" a)) (lg-unter-reihe-vorgabe) T))
|
|
(cons "gitterkorb_hoehe_mm" (cond ((lg-a-zahl a "GITTERKORB_HOEHE_mm"))
|
|
((lg-zahl (lg-vorgabe '("bereich" "gitterkorb_hoehe_mm") nil)))))
|
|
(cons "randgang_mm" (cons '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 "anzahl_reihen" (length (vl-remove-if-not '(lambda (k) (wcmatch (strcase (lg-blockname k)) "LG_REIHE_*")) kinder)))
|
|
(cons "anzahl_gaenge" (length (vl-remove-if-not '(lambda (k) (wcmatch (strcase (lg-blockname k)) "LG_GANG_*")) kinder)))
|
|
(cons "kontur" (lg-export-kontur (lg-ent-aus-handle (lg-xdata-wert e "kontur"))))))
|
|
|
|
;; Reihe oder Gang: Attribute plus Geometrie (Start/Ende/Mitte in WCS mit Z,
|
|
;; Ecken des Grundrisses 2D aus lg-linie-polygon).
|
|
(defun lg-export-linie-rec (e art / a ed p1 z rot l b p2 quelle)
|
|
(setq a (ssg-attrib-read e) ed (entget e)
|
|
p1 (cdr (assoc 10 ed)) z (cond ((caddr p1)) (0.0))
|
|
rot (cond ((cdr (assoc 50 ed))) (0.0))
|
|
l (lg-a-zahl a "LAENGE")
|
|
b (lg-a-zahl a (if (= art "reihe") "TIEFE_mm" "BREITE_mm"))
|
|
p2 (polar (list (car p1) (cadr p1)) rot (lg-n l))
|
|
quelle (cdr (assoc "QUELLE" a)))
|
|
(if (member quelle '(nil "")) (setq quelle "auto"))
|
|
(cons 'OBJ
|
|
(append
|
|
(list (cons "id" (cdr (assoc "ID" a)))
|
|
(cons "handle" (lg-handle e))
|
|
(cons "layer" (lg-ent-layer e))
|
|
(cons "geschoss" (lg-a-int a "GESCHOSS"))
|
|
(cons "bereich" (lg-a-int a "BEREICH"))
|
|
(cons "bereich_handle" (lg-xdata-wert e "bereich"))
|
|
(cons "quelle" quelle)
|
|
(cons "laenge_mm" l))
|
|
(if (= art "reihe")
|
|
(list (cons "tiefe_mm" b)
|
|
(cons "schienen" (lg-a-int a "SCHIENEN"))
|
|
(cons "haengeebenen" (lg-j-ebenen (cdr (assoc "HAENGEEBENEN" a)))))
|
|
(list (cons "breite_mm" b)
|
|
(cons "art" (cdr (assoc "ART" a)))
|
|
(cons "belag" (cdr (assoc "BELAG" a)))))
|
|
(list (cons "start" (list 'ARR (car p1) (cadr p1) z))
|
|
(cons "ende" (list 'ARR (car p2) (cadr p2) z))
|
|
(cons "mitte" (list 'ARR (/ (+ (car p1) (car p2)) 2.0) (/ (+ (cadr p1) (cadr p2)) 2.0) z))
|
|
(cons "winkel_grad" (* (/ rot pi) 180.0))
|
|
(cons "ecken" (lg-j-pkte (lg-linie-polygon e)))
|
|
(cons "flaeche_mm2" (* (lg-n l) (lg-n b))))))
|
|
)
|
|
|
|
;; unter_reihe je Reihe aus ihrem Bereich (sonst Vorgabe), auf Hallenboden
|
|
;; "keine"; Reihen mit Gitterkorb bekommen (OBJ hoehe_mm) als Startwert.
|
|
(defun lg-reihen-unter-setzen (reihen bereiche geschosse vorgabe / br gr u)
|
|
(mapcar
|
|
'(lambda (r / br gr u)
|
|
(setq br (if (lg-j r "bereich_handle")
|
|
(vl-some '(lambda (b) (if (equal (lg-j b "handle") (lg-j r "bereich_handle")) b)) bereiche))
|
|
gr (vl-some '(lambda (g) (if (equal (lg-j g "nr") (lg-j r "geschoss")) g)) geschosse)
|
|
u (lg-unter-reihe-wert (lg-j br "unter_reihe") vorgabe (lg-buehne-p (lg-j gr "belag_art"))))
|
|
(lg-j-setzen
|
|
(lg-j-setzen r "unter_reihe" u)
|
|
"gitterkorb"
|
|
(if (= u "gitterkorb")
|
|
(list 'OBJ (cons "hoehe_mm" (cond ((lg-j br "gitterkorb_hoehe_mm"))
|
|
((lg-zahl (lg-vorgabe '("bereich" "gitterkorb_hoehe_mm") nil)))))))))
|
|
reihen)
|
|
)
|
|
|
|
;; Alle Daten des Lagers als OBJ (Grundlage von lg-export-json).
|
|
(defun lg-export-daten ( / warn gs bereiche reihen gaenge g-recs vorgabe g-neu r-neu r-gs g-gs i g nx nr nrs kw)
|
|
(setq gs (lg-geschosse) warn nil vorgabe (lg-unter-reihe-vorgabe))
|
|
(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))))
|
|
(setq bereiche (mapcar 'lg-export-bereich-rec (lg-alle-bloecke "LG_BEREICH"))
|
|
reihen (mapcar '(lambda (e) (lg-export-linie-rec e "reihe")) (lg-alle-bloecke "LG_REIHE_*"))
|
|
gaenge (mapcar '(lambda (e) (lg-export-linie-rec e "gang")) (lg-alle-bloecke "LG_GANG_*"))
|
|
;; Geschosse von unten nach oben (Belagshoehe, dann Nr)
|
|
g-recs (vl-sort (mapcar 'lg-export-geschoss-rec gs)
|
|
'(lambda (a b / ha hb)
|
|
(setq ha (lg-n (lg-j a "hoehe_belag_mm")) hb (lg-n (lg-j b "hoehe_belag_mm")))
|
|
(if (equal ha hb 1e-6) (< (lg-j a "nr") (lg-j b "nr")) (< ha hb)))))
|
|
(setq reihen (lg-reihen-unter-setzen reihen bereiche g-recs vorgabe))
|
|
(setq g-neu nil r-neu nil r-gs nil g-gs nil i 0)
|
|
(foreach g g-recs
|
|
(setq nr (lg-j g "nr")
|
|
nx (nth (1+ i) g-recs)
|
|
r-gs (lg-reihen-gitterkorb-berechnen
|
|
(vl-remove-if-not '(lambda (r) (equal (lg-j r "geschoss") nr)) reihen) 1.0)
|
|
g-gs (vl-remove-if-not '(lambda (x) (equal (lg-j x "geschoss") nr)) gaenge)
|
|
kw (lg-kennwerte-geschoss g nx r-gs g-gs
|
|
(length (vl-remove-if-not '(lambda (b) (equal (lg-j b "geschoss") nr)) bereiche))))
|
|
(if (null (lg-j (car kw) "lichte_hoehe_mm"))
|
|
(setq warn (cons (ssg-textf "lg-exp-lichte-hoehe-oben" (list (itoa nr))) warn)))
|
|
(if (not (lg-buehne-p (lg-j g "belag_art")))
|
|
(foreach b bereiche
|
|
(if (and (equal (lg-j b "geschoss") nr) (= (lg-j b "unter_reihe") "gitterkorb"))
|
|
(setq warn (cons (ssg-textf "lg-exp-korb-hallenboden"
|
|
(list (vl-princ-to-string (lg-j b "nr")) (itoa nr))) warn)))))
|
|
(setq g-neu (cons (lg-j-setzen (lg-j-setzen g "kennwerte" (car kw)) "herkunft" (cadr kw)) g-neu)
|
|
r-neu (append r-neu r-gs)
|
|
i (1+ i)))
|
|
(setq g-neu (reverse g-neu)
|
|
nrs (mapcar '(lambda (g) (lg-j g "nr")) g-recs)
|
|
r-gs (vl-remove-if '(lambda (r) (member (lg-j r "geschoss") nrs)) reihen))
|
|
(if r-gs
|
|
(setq warn (cons (ssg-textf "lg-exp-reihen-ohne-geschoss" (list (itoa (length r-gs)))) warn)))
|
|
(list 'OBJ
|
|
(cons "format" "ssg-lager")
|
|
(cons "version" 2)
|
|
(cons "zeichnung" (strcat (getvar "DWGPREFIX") (getvar "DWGNAME")))
|
|
(cons "erzeugt" (ssg-timestamp))
|
|
(cons "land" (lg-land))
|
|
(cons "einheiten" (list 'OBJ (cons "laenge" "mm") (cons "flaeche" "mm2") (cons "winkel" "grad")))
|
|
(cons "koordinaten" "WCS, Nord = +Y")
|
|
(cons "lager" (lg-kennwerte-lager g-neu r-neu
|
|
(vl-remove-if-not '(lambda (x) (member (lg-j x "geschoss") nrs)) gaenge)
|
|
(length bereiche)))
|
|
(cons "geschosse" (cons 'ARR g-neu))
|
|
(cons "bereiche" (cons 'ARR bereiche))
|
|
(cons "reihen" (cons 'ARR (append r-neu r-gs)))
|
|
(cons "gaenge" (cons 'ARR gaenge))
|
|
(cons "warnungen" (cons 'ARR (reverse warn))))
|
|
)
|
|
|
|
;; Alle Daten als JSON-Text.
|
|
(defun lg-export-json ( / )
|
|
(strcat (lg-json-text (lg-export-daten) "") "\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))
|
|
)
|
|
|
|
;; Technische Daten des Lagers als <dwg>_lager.json nach DXFM_RESULTS.
|
|
(defun c:LAGER_EXPORT ( / pfad)
|
|
(setq pfad (strcat (lg-ausgabe-verzeichnis) "/" (lg-dwg-basis) "_lager.json"))
|
|
(if (lg-export-schreiben pfad)
|
|
(princ (ssg-textf "lg-exp-json" (list pfad))))
|
|
(princ)
|
|
)
|
|
|
|
(princ)
|