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

[ADD] Modul zum Erstellen von Hängewarenlagerbereichen und Stockwerken mit Attributsdefinition für den Export in ein Anforderungsdokument für Ausschreibungen

Browse Source
This commit is contained in:
Simon Hensch
2026-10-30 11:11:20 +01:00
parent 4fdeaf831f
commit 473aeec5bf
26 changed files with 5921 additions and 175 deletions
Download Patch File Download Diff File Expand all files Collapse all files
tests/test_lager.lsp
+550
View File
@@ -0,0 +1,550 @@
;; ============================================================
;; test_lager.lsp - Szenario-Test Lagerplanung (LagerInsert.lsp)
;;
;; Baut in der aktuellen (leeren) Zeichnung ohne Dialoge auf:
;; - zwei Geschosse auf derselben 2D-Kontur (EG Hallenboden, OG 3100 mm)
;; - einen Lagerbereich 10000 x 6000 im OG mit Auto-Fuellung
;; und prueft Bloecke, Attribute, Layer, Neuberechnung (keine Verdopplung),
;; den Neuaufbau einer geaenderten Reihe und die Rohdaten von LAGER_EXPORT.
;; Zum Schluss Regression der goh_rack-Erkennung (lg-racks-sammeln) gegen
;; tests/testdata/goh_storage_test.dwg (Referenzwerte aus
;; goh_storage_test_regal_report.txt: 38946.39 mm / 77892.78 mm).
;;
;; Aufruf in BricsCAD:
;; (load (strcat (getenv "DXFMAKRO") "/tests/test_lager.lsp"))
;; TEST_LAGER
;;
;; Speichert tests/output/lager_results.json (Konvention test_run_all)
;; und tests/output/lager_tests_lager_raw.json (Eingabe fuer
;; lib/lager_yaml_export.py).
;; ============================================================
(setq *tlg-pass* 0 *tlg-fail* 0 *tlg-fails* '())
(defun tlg-eq (name erwartet ist)
(if (equal erwartet ist 1e-3)
(progn (setq *tlg-pass* (1+ *tlg-pass*))
(princ (strcat "\n [PASS] " name)))
(progn (setq *tlg-fail* (1+ *tlg-fail*))
(setq *tlg-fails* (cons name *tlg-fails*))
(princ (strcat "\n [FAIL] " name
"\n erwartet: " (vl-princ-to-string erwartet)
"\n ist: " (vl-princ-to-string ist))))))
(defun tlg-rechteck (x0 y0 x1 y1 / )
(entmakex (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 tlg-attr (ent tag) (cdr (assoc tag (ssg-attrib-read ent))))
(defun tlg-layer-gefroren-p (name / e)
(setq e (tblsearch "LAYER" name))
(and e (= 1 (logand 1 (cdr (assoc 70 e))))))
(defun tlg-summe (texte feld / s)
(setq s 0.0)
(foreach t1 texte (setq s (+ s (cond ((ssg-json-get (ssg-json-parse t1) feld)) (0.0)))))
s)
;; Bloecke einer Liste, deren Name auf muster passt.
(defun tlg-nur (ents muster)
(vl-remove-if-not '(lambda (e) (wcmatch (cdr (assoc 2 (entget e))) muster)) ents))
(defun tlg-anzahl-art (ents art)
(length (vl-remove-if-not '(lambda (e) (= (tlg-attr e "ART") art)) ents)))
(defun tlg-summe-attr (ents tag / s)
(setq s 0.0)
(foreach e ents (setq s (+ s (cond ((lg-zahl (tlg-attr e tag))) (0.0)))))
s)
;; Schraffurmuster der (ersten) HATCH einer Blockdefinition oder nil.
(defun tlg-schraffur (bname / h)
(if (tblsearch "BLOCK" bname)
(if (setq h (vl-some '(lambda (ed) (if (= (cdr (assoc 0 ed)) "HATCH") ed))
(lg-blockdef-objekte bname)))
(cdr (assoc 2 h)))))
;; Bloecke nach Muster, die zu Geschoss gs (Zahl) gehoeren.
(defun tlg-gs (muster gs)
(vl-remove-if-not '(lambda (e) (= (tlg-attr e "GESCHOSS") (itoa gs))) (lg-alle-bloecke muster)))
;; Kinderzahl je Bereich eines Geschosses, sortiert.
(defun tlg-kinderzahlen (gs)
(vl-sort (mapcar '(lambda (b) (length (lg-bereich-kinder b))) (tlg-gs "LG_BEREICH" gs)) '<))
(defun tlg-anzahl-attr (ents tag wert)
(length (vl-remove-if-not '(lambda (e) (= (tlg-attr e tag) wert)) ents)))
;; ATTDEF-Tags einer Blockdefinition als Alist (tag . T).
(defun tlg-attdef-tags (bname)
(mapcar '(lambda (ed) (cons (cdr (assoc 2 ed)) T))
(vl-remove-if-not '(lambda (ed) (= (cdr (assoc 0 ed)) "ATTDEF")) (lg-blockdef-objekte bname))))
(defun lager:tests ( / k0 k1 g0 g1 kb bereich reihen gaenge r0 neu raw daten pfad f
racks laengen kap tr kb2 b2 kinder mg mg2 hg alt eb
r1 gg1 n-alt g2 r2 gg2 ids b2k n-kinder bb gr rg grp rk kand zl
b3 rh3 mg3 ge3 ag3 n3 mr3 alt3)
(setvar "CMDECHO" 0)
(ssg-gui-aus)
;; --- Geschosse auf derselben Kontur (2D-Grundrisse uebereinander) ---
(setq k0 (tlg-rechteck 0.0 0.0 10000.0 6000.0))
(setq g0 (lg-geschoss-anlegen k0
(append (list (cons "HOEHE_BELAG_mm" "0") (cons "BELAG_ART" "hallenboden")
(cons "BEZEICHNUNG" "ground floor") (cons "KONSTR_HOEHE_mm" "0"))
(lg-geschoss-vorgaben 0))))
(setq g1 (lg-geschoss-anlegen k0
(append (list (cons "HOEHE_BELAG_mm" "3100") (cons "KONSTR_HOEHE_mm" "150"))
(lg-geschoss-vorgaben 1))))
(tlg-eq "geschoss 0 angelegt" "INSERT" (if g0 (cdr (assoc 0 (entget g0)))))
(tlg-eq "geschoss 1 angelegt" "INSERT" (if g1 (cdr (assoc 0 (entget g1)))))
(tlg-eq "geschosse gesamt" 2 (length (lg-geschosse)))
(tlg-eq "geschoss 1 layer" "LG_Geschoss_G1" (cdr (assoc 8 (entget g1))))
(tlg-eq "geschoss 1 hoehe" "3100" (tlg-attr g1 "HOEHE_BELAG_mm"))
;; die vergebene Kontur wurde fuer Geschoss 1 kopiert
(tlg-eq "kontur kopiert" T (not (equal (lg-xdata-wert g0 "kontur") (lg-xdata-wert g1 "kontur"))))
(tlg-eq "kontur besitzer" (lg-handle g1)
(lg-xdata-wert (lg-ent-aus-handle (lg-xdata-wert g1 "kontur")) "besitzer"))
(tlg-eq "doppelte nummer abgewiesen" nil
(lg-geschoss-anlegen (tlg-rechteck 0.0 0.0 10.0 10.0) (lg-geschoss-vorgaben 1)))
;; --- Aktives Geschoss friert die anderen ---
(lg-geschoss-aktivieren 1)
(tlg-eq "aktiv 1" 1 (lg-geschoss-aktiv))
(tlg-eq "G0 gefroren" T (tlg-layer-gefroren-p "LG_Geschoss_G0"))
(tlg-eq "G1 nicht gefroren" nil (tlg-layer-gefroren-p "LG_Geschoss_G1"))
(tlg-eq "ermitteln = aktiv" 1 (lg-geschoss-ermitteln '(5.0 5.0 0.0)))
(tlg-eq "gefrorene geschosse gefunden" 2 (length (lg-geschosse)))
;; --- Bereich mit Auto-Fuellung ---
(setq kb (tlg-rechteck 0.0 0.0 10000.0 6000.0))
(setq bereich (lg-bereich-anlegen kb (cons (cons "GESCHOSS" "1")
(lg-bereich-vorgaben (ssg-lwpoly-punkte kb)))))
(tlg-eq "bereich angelegt" "INSERT" (if bereich (cdr (assoc 0 (entget bereich)))))
(setq reihen (lg-alle-bloecke "LG_REIHE_*") gaenge (lg-alle-bloecke "LG_GANG_*"))
(tlg-eq "reihen" 4 (length reihen))
(tlg-eq "gaenge" 2 (length gaenge))
(tlg-eq "kinder des bereichs" 6 (length (lg-bereich-kinder bereich)))
(setq r0 (car reihen))
(tlg-eq "reihe laenge" "10000" (tlg-attr r0 "LAENGE"))
(tlg-eq "reihe tiefe" "700" (tlg-attr r0 "TIEFE_mm"))
(tlg-eq "reihe geschoss" "1" (tlg-attr r0 "GESCHOSS"))
(tlg-eq "reihe quelle" "auto" (tlg-attr r0 "QUELLE"))
(tlg-eq "reihe ebenen" "2300/1200;1100/1100" (tlg-attr r0 "HAENGEEBENEN"))
(tlg-eq "reihe layer" "LG_Reihe_G1" (cdr (assoc 8 (entget r0))))
(tlg-eq "reihe blockdef" "LG_REIHE_10000_700" (cdr (assoc 2 (entget r0))))
(tlg-eq "bereich rest" "1200" (tlg-attr bereich "RESTBREITE_mm"))
(tlg-eq "gang belag" "spanplatte" (tlg-attr (car gaenge) "BELAG"))
;; --- Neuberechnung ersetzt statt verdoppelt ---
(lg-bereich-fuellen bereich)
(tlg-eq "neu gefuellt: reihen" 4 (length (lg-alle-bloecke "LG_REIHE_*")))
(tlg-eq "neu gefuellt: gaenge" 2 (length (lg-alle-bloecke "LG_GANG_*")))
;; --- Bereichsparameter aendern: Gang 1200 -> Modul 2600, 2 Module ---
(lg-attribute-setzen bereich (list (cons "GANGBREITE_mm" "1200")
(cons "QUERGANG_ABSTAND_mm" "4000")))
(lg-bereich-fuellen bereich)
(tlg-eq "quergaenge: reihenstuecke" 8 (length (lg-alle-bloecke "LG_REIHE_*")))
(tlg-eq "bereich rest neu" "800" (tlg-attr bereich "RESTBREITE_mm"))
;; --- Einzelne Reihe aendern (Neuaufbau, Kennzeichnung) ---
(setq r0 (car (lg-alle-bloecke "LG_REIHE_*")))
(setq neu (lg-linie-neu-aufbauen r0 (list (cons "LAENGE" "2000") (cons "TIEFE_mm" "700")
(cons "HAENGEEBENEN" "2300/1200") (cons "SCHIENEN" "1")
(cons "GESCHOSS" "1") (cons "BEREICH" "1")
(cons "QUELLE" "auto_geaendert"))))
(tlg-eq "reihe neu aufgebaut" "LG_REIHE_2000_700" (if neu (cdr (assoc 2 (entget neu)))))
(tlg-eq "alte reihe weg" nil (entget r0))
(tlg-eq "reihenzahl gleich" 8 (length (lg-alle-bloecke "LG_REIHE_*")))
(tlg-eq "geaenderte reihe bleibt kind" T (if (member neu (lg-bereich-kinder bereich)) T nil))
;; --- Rohdaten fuer LAGER_EXPORT ---
(setq raw (lg-export-json))
(setq daten (ssg-json-parse raw))
(tlg-eq "export geschosse" 2 (length (ssg-json-get daten "geschosse")))
(tlg-eq "export bereiche" 1 (length (ssg-json-get daten "bereiche")))
(tlg-eq "export reihen" 8 (length (ssg-json-get daten "reihen")))
(tlg-eq "export land" "DE" (ssg-json-get daten "land"))
(tlg-eq "export konturflaeche" 6.0e7
(ssg-json-get (car (vl-remove-if-not '(lambda (g) (= (ssg-json-get g "nr") 1))
(ssg-json-get daten "geschosse")))
"kontur_flaeche_mm2"))
(tlg-eq "export haengeebenen"
'((("schienenhoehe_mm" . 2300) ("warenlaenge_mm" . 1200))
(("schienenhoehe_mm" . 1100) ("warenlaenge_mm" . 1100)))
(ssg-json-get (vl-some '(lambda (r) (if (= (ssg-json-get r "laenge_mm") 4000) r))
(ssg-json-get daten "reihen"))
"haengeebenen"))
;; --- Randgaenge Nord + Sued, Schraffur je Belag ---
(setq kb2 (tlg-rechteck 20000.0 0.0 30000.0 6000.0))
(setq b2 (lg-bereich-anlegen kb2 (append (list (cons "GESCHOSS" "1")
(cons "RANDGANG_N_mm" "1000")
(cons "RANDGANG_S_mm" "1000"))
(lg-bereich-vorgaben (ssg-lwpoly-punkte kb2)))))
(tlg-eq "randgang: attribut" "1000" (if b2 (tlg-attr b2 "RANDGANG_N_mm")))
(setq kinder (lg-bereich-kinder b2))
(tlg-eq "randgang: anzahl" 2 (tlg-anzahl-art kinder "randgang"))
(tlg-eq "randgang: reihen" 2 (length (tlg-nur kinder "LG_REIHE_*")))
;; Stapel 1000..5000 -> ein Modul, Rest 1600
(tlg-eq "randgang: rest" "1600" (tlg-attr b2 "RESTBREITE_mm"))
(tlg-eq "randgang: quelle auto" "auto" (tlg-attr (car (tlg-nur kinder "LG_GANG_*")) "QUELLE"))
(tlg-eq "schraffur spanplatte" "ANSI31" (tlg-schraffur "LG_GANG_10000_1000_SPANPLATTE"))
;; --- Manueller Gang quer durch den Bereich spart die Reihen aus ---
(setq mg (lg-gang-einfuegen '(25000.0 1000.0 0.0) '(25000.0 5000.0 0.0)
(list (cons "GESCHOSS" "1") (cons "BREITE_mm" "1000") (cons "ART" "gang")
(cons "BELAG" "gitterrost"))))
(tlg-eq "manuell: eingefuegt" "LG_GANG_4000_1000_GITTERROST" (if mg (cdr (assoc 2 (entget mg)))))
(tlg-eq "manuell: quelle" "manuell" (tlg-attr mg "QUELLE"))
(tlg-eq "manuell: bereich" (tlg-attr b2 "NR") (tlg-attr mg "BEREICH"))
(tlg-eq "schraffur gitterrost" "GRID" (tlg-schraffur "LG_GANG_4000_1000_GITTERROST"))
(setq kinder (lg-bereich-kinder b2))
(tlg-eq "manuell: reihen unterbrochen" 4 (length (tlg-nur kinder "LG_REIHE_*")))
(tlg-eq "manuell: reihenlaenge" 18000.0 (tlg-summe-attr (tlg-nur kinder "LG_REIHE_*") "LAENGE"))
;; Neuaufbau: manueller Gang bleibt, Reihen bleiben ausgespart
(lg-bereich-fuellen b2)
(setq kinder (lg-bereich-kinder b2))
(tlg-eq "manuell: bleibt beim neuaufbau" T (if (entget mg) T nil))
(tlg-eq "manuell: weiter ausgespart" 4 (length (tlg-nur kinder "LG_REIHE_*")))
;; Belag aendern -> neuer Blockname/neue Schraffur
(setq mg2 (lg-linie-neu-aufbauen mg (lg-wert-setzen (ssg-attrib-read mg) "BELAG" "spanplatte")))
(tlg-eq "manuell: belag geaendert" "LG_GANG_4000_1000_SPANPLATTE" (if mg2 (cdr (assoc 2 (entget mg2)))))
(tlg-eq "manuell: bleibt kind" T (if (member mg2 (lg-bereich-kinder b2)) T nil))
;; Hallenboden: keine Schraffur; ausserhalb jedes Bereichs: nicht verknuepft
(setq hg (lg-gang-einfuegen '(40000.0 0.0 0.0) '(42000.0 0.0 0.0)
(list (cons "GESCHOSS" "1") (cons "BREITE_mm" "1500") (cons "ART" "gang")
(cons "BELAG" "hallenboden"))))
(tlg-eq "hallenboden: ohne schraffur" nil (tlg-schraffur "LG_GANG_2000_1500_HALLENBODEN"))
(tlg-eq "hallenboden: kein bereich" "" (tlg-attr hg "BEREICH"))
;; --- Altbestand: Blockdefinition um ein neues ATTDEF ergaenzen ---
(lg-blockdef "TLG_ALT" (list (lg-geom-linie '(0.0 0.0 0.0) '(100.0 0.0 0.0))
(lg-geom-attdef "A" "" '(0.0 0.0 0.0) 50.0 nil)))
(setq alt (lg-block-einfuegen "TLG_ALT" '(0.0 -5000.0 0.0) 0.0 "0" '(("A" . "1"))))
(lg-blockdef "TLG_ALT" (list (lg-geom-linie '(0.0 0.0 0.0) '(100.0 0.0 0.0))
(lg-geom-attdef "A" "" '(0.0 0.0 0.0) 50.0 nil)
(lg-geom-attdef "B" "" '(0.0 -100.0 0.0) 50.0 nil)))
(tlg-eq "altbestand: neues ATTDEF" T (if (assoc "B" (tlg-attdef-tags "TLG_ALT")) T nil))
(tlg-eq "altbestand: referenz hat neuen tag" T (if (assoc "B" (ssg-attrib-read alt)) T nil))
(tlg-eq "altbestand: alter wert bleibt" "1" (tlg-attr alt "A"))
;; --- Export mit Randgaengen und manuellen Gaengen ---
(setq raw (lg-export-json) daten (ssg-json-parse raw))
(setq eb (vl-some '(lambda (b) (if (= (ssg-json-get b "nr") (atoi (tlg-attr b2 "NR"))) b))
(ssg-json-get daten "bereiche")))
(tlg-eq "export randgang_mm" '(("n" . 1000) ("o" . 0) ("s" . 1000) ("w" . 0))
(ssg-json-get eb "randgang_mm"))
(tlg-eq "export randgaenge" 2
(length (vl-remove-if-not '(lambda (g) (= (ssg-json-get g "art") "randgang"))
(ssg-json-get daten "gaenge"))))
(tlg-eq "export manuelle gaenge" 2
(length (vl-remove-if-not '(lambda (g) (= (ssg-json-get g "quelle") "manuell"))
(ssg-json-get daten "gaenge"))))
(setq pfad (strcat (getenv "DXFMAKRO") "/tests/output/lager_tests_lager_raw.json"))
(if (setq f (open pfad "w")) (progn (princ raw f) (close f)))
;; --- Geschoss kopieren: G1 (3100, Spanplatte) -> G2, G3 mit Gitterrost ---
(setq r1 (tlg-gs "LG_REIHE_*" 1) gg1 (tlg-gs "LG_GANG_*" 1)
n-alt (+ (length r1) (length gg1)))
(setq neu (lg-geschosse-kopieren
(list (cons "QUELLE" "1") (cons "ANZAHL" "2") (cons "ABSTAND_mm" "3000")
(cons "BELAG_ART" "gitterrost") (cons "VERSATZ_X_mm" "0") (cons "VERSATZ_Y_mm" "0"))))
(tlg-eq "kopie: neue geschosse" '(2 3) neu)
(tlg-eq "kopie: geschosse gesamt" 4 (length (lg-geschosse)))
(setq g2 (car (lg-geschoss-finden 2)))
(tlg-eq "kopie: G2 hoehe" "6100" (tlg-attr g2 "HOEHE_BELAG_mm"))
(tlg-eq "kopie: G3 hoehe" "9100" (tlg-attr (car (lg-geschoss-finden 3)) "HOEHE_BELAG_mm"))
(tlg-eq "kopie: G2 belag" "gitterrost" (tlg-attr g2 "BELAG_ART"))
(tlg-eq "kopie: G2 bezeichnung" "Level 2" (tlg-attr g2 "BEZEICHNUNG"))
(tlg-eq "kopie: G2 konstr. von quelle" "150" (tlg-attr g2 "KONSTR_HOEHE_mm"))
(tlg-eq "kopie: G2 layer" "LG_Geschoss_G2" (cdr (assoc 8 (entget g2))))
(tlg-eq "kopie: G2 eigene kontur" T
(and (lg-xdata-wert g2 "kontur")
(not (equal (lg-xdata-wert g2 "kontur") (lg-xdata-wert g1 "kontur")))))
(foreach nr '(2 3)
(tlg-eq (strcat "kopie: G" (itoa nr) " reihen") (length r1) (length (tlg-gs "LG_REIHE_*" nr)))
(tlg-eq (strcat "kopie: G" (itoa nr) " gaenge") (length gg1) (length (tlg-gs "LG_GANG_*" nr)))
(tlg-eq (strcat "kopie: G" (itoa nr) " reihenlaenge")
(tlg-summe-attr r1 "LAENGE") (tlg-summe-attr (tlg-gs "LG_REIHE_*" nr) "LAENGE"))
(tlg-eq (strcat "kopie: G" (itoa nr) " kinder je bereich") (tlg-kinderzahlen 1) (tlg-kinderzahlen nr)))
(tlg-eq "kopie: quelle unveraendert" n-alt
(+ (length (tlg-gs "LG_REIHE_*" 1)) (length (tlg-gs "LG_GANG_*" 1))))
(setq r2 (tlg-gs "LG_REIHE_*" 2) gg2 (tlg-gs "LG_GANG_*" 2))
(tlg-eq "kopie: reihen-layer G2" T
(vl-every '(lambda (e) (= (cdr (assoc 8 (entget e))) "LG_Reihe_G2")) r2))
(setq ids (mapcar '(lambda (e) (tlg-attr e "ID"))
(append (lg-alle-bloecke "LG_REIHE_*") (lg-alle-bloecke "LG_GANG_*"))))
(tlg-eq "kopie: IDs eindeutig" (length ids)
(length (vl-remove-if '(lambda (x) (member x (cdr (member x ids)))) ids)))
(tlg-eq "kopie: auto_geaendert bleibt" (tlg-anzahl-attr r1 "QUELLE" "auto_geaendert")
(tlg-anzahl-attr r2 "QUELLE" "auto_geaendert"))
(tlg-eq "kopie: manuelle gaenge" 2 (tlg-anzahl-attr gg2 "QUELLE" "manuell"))
;; Kinder zeigen auf den neuen Bereich (Nummer und XDATA)
(tlg-eq "kopie: kinder verknuepft" T
(vl-every '(lambda (b / nr)
(setq nr (tlg-attr b "NR"))
(vl-every '(lambda (k) (= (tlg-attr k "BEREICH") nr)) (lg-bereich-kinder b)))
(tlg-gs "LG_BEREICH" 2)))
;; Belag folgt dem Geschoss (Spanplatte -> Gitterrost), Hallenboden-Gang bleibt
(tlg-eq "kopie: belag folgt" 0 (tlg-anzahl-attr gg2 "BELAG" "spanplatte"))
(tlg-eq "kopie: manueller gang gitterrost" 1
(length (tlg-nur (vl-remove-if-not '(lambda (e) (= (tlg-attr e "QUELLE") "manuell")) gg2)
"LG_GANG_4000_1000_GITTERROST")))
(tlg-eq "kopie: hallenboden bleibt" 1 (length (tlg-nur gg2 "LG_GANG_2000_1500_HALLENBODEN")))
(tlg-eq "kopie: bereich belag" T
(vl-every '(lambda (b) (= (tlg-attr b "BELAG") "gitterrost")) (tlg-gs "LG_BEREICH" 2)))
;; Neufuellen einer Kopie laesst die Quelle in Ruhe, manueller Gang bleibt
(setq b2k (vl-some '(lambda (b) (if (= (tlg-attr b "RANDGANG_N_mm") "1000") b)) (tlg-gs "LG_BEREICH" 2)))
(setq n-kinder (length (lg-bereich-kinder b2k)))
(lg-bereich-fuellen b2k)
(tlg-eq "kopie neu gefuellt: kinder" n-kinder (length (lg-bereich-kinder b2k)))
(tlg-eq "kopie neu gefuellt: quelle unveraendert" n-alt
(+ (length (tlg-gs "LG_REIHE_*" 1)) (length (tlg-gs "LG_GANG_*" 1))))
;; Nachtraeglich erweitern: G3 -> G4
(tlg-eq "kopie: G3 -> G4" '(4)
(lg-geschosse-kopieren (list (cons "QUELLE" "3") (cons "ANZAHL" "1") (cons "ABSTAND_mm" "3000")
(cons "BELAG_ART" "gitterrost"))))
(tlg-eq "kopie: G4 hoehe" "12100" (tlg-attr (car (lg-geschoss-finden 4)) "HOEHE_BELAG_mm"))
;; Versatz in Y
(setq neu (lg-geschosse-kopieren (list (cons "QUELLE" "1") (cons "ANZAHL" "1") (cons "ABSTAND_mm" "3100")
(cons "BELAG_ART" "spanplatte") (cons "VERSATZ_Y_mm" "20000"))))
(tlg-eq "kopie versatz: G5" '(5) neu)
(tlg-eq "kopie versatz: kontur" '((0.0 20000.0) (10000.0 26000.0))
(mapcar '(lambda (p) (list (car p) (cadr p))) (ssg-poly-bbox (cadddr (lg-geschoss-finden 5)))))
(tlg-eq "kopie versatz: reihen verschoben" T
(vl-every '(lambda (e) (>= (cadr (cdr (assoc 10 (entget e)))) 20000.0)) (tlg-gs "LG_REIHE_*" 5)))
(tlg-eq "kopie: abstand 0 abgewiesen" nil
(lg-geschosse-kopieren (list (cons "QUELLE" "1") (cons "ANZAHL" "1") (cons "ABSTAND_mm" "0"))))
(setq daten (ssg-json-parse (lg-export-json)))
(tlg-eq "kopie: export geschosse" 6 (length (ssg-json-get daten "geschosse")))
;; --- Gang per Rechteck quer durch den kopierten Randgang-Bereich (G2) ---
(setq rg (lg-gang-rechteck-einfuegen
'((26500.0 0.0 0.0) (27500.0 0.0 0.0) (27500.0 6000.0 0.0) (26500.0 6000.0 0.0))
(list (cons "GESCHOSS" "2") (cons "BREITE_mm" "1000") (cons "ART" "gang")
(cons "BELAG" "gitterrost"))))
(tlg-eq "rechteck: blockname" "LG_GANG_6000_1000_GITTERROST" (if rg (cdr (assoc 2 (entget rg)))))
(tlg-eq "rechteck: mittellinie" '(27000.0 0.0) (if rg (list (car (cdr (assoc 10 (entget rg))))
(cadr (cdr (assoc 10 (entget rg)))))))
(tlg-eq "rechteck: quelle" "manuell" (tlg-attr rg "QUELLE"))
(tlg-eq "rechteck: bereich" (tlg-attr b2k "NR") (tlg-attr rg "BEREICH"))
(tlg-eq "rechteck: kind" T (if (member rg (lg-bereich-kinder b2k)) T nil))
;; Breite aus dem Rechteck, nicht aus werte
(setq rg (lg-gang-rechteck-einfuegen
'((40000.0 10000.0 0.0) (44000.0 10000.0 0.0) (44000.0 11500.0 0.0) (40000.0 11500.0 0.0))
(list (cons "GESCHOSS" "2") (cons "BREITE_mm" "1000") (cons "ART" "gang")
(cons "BELAG" "spanplatte"))))
(tlg-eq "rechteck: breite aus flaeche" "1500" (tlg-attr rg "BREITE_mm"))
(tlg-eq "rechteck: ohne bereich" "" (tlg-attr rg "BEREICH"))
(tlg-eq "rechteck: zu klein" nil
(lg-gang-rechteck-einfuegen '((0.0 0.0) (10.0 0.0) (10.0 0.0) (0.0 0.0))
(list (cons "GESCHOSS" "2") (cons "ART" "gang") (cons "BELAG" "spanplatte"))))
;; Polylinie aus dem BricsCAD-Befehl RECHTECK auswerten
(command "_.RECTANG" "_non" '(700000.0 0.0) "_non" '(704000.0 1200.0))
(setq rk (lg-rechteck-ecken-aus-poly (entlast)))
(entdel (entlast))
(tlg-eq "rechteck-befehl: 4 ecken" 4 (if (listp rk) (length rk)))
(tlg-eq "rechteck-befehl: gang" 1200.0 (caddr (lg-gang-aus-ecken rk)))
;; um 30 Grad gedrehtes Rechteck 5000 x 800 (wie RECHTECK mit Option Drehung)
(setq rk (mapcar '(lambda (p) (polar '(0.0 0.0) (+ (angle '(0.0 0.0) p) (/ pi 6.0)) (distance '(0.0 0.0) p)))
'((0.0 0.0) (5000.0 0.0) (5000.0 800.0) (0.0 800.0))))
(entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1))
(mapcar '(lambda (p) (cons 10 p)) rk)))
(setq rk (lg-rechteck-ecken-aus-poly (entlast)))
(entdel (entlast))
(tlg-eq "rechteck-befehl: gedreht breite" 800.0 (caddr (lg-gang-aus-ecken rk)))
(tlg-eq "rechteck-befehl: gedreht laenge" 5000.0
(distance (car (lg-gang-aus-ecken rk)) (cadr (lg-gang-aus-ecken rk))))
;; Fuenfeck (z.B. Fase) -> kein Rechteck
(entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 5) '(70 . 1))
(mapcar '(lambda (p) (cons 10 p)) '((0.0 0.0) (900.0 0.0) (1000.0 100.0) (1000.0 500.0) (0.0 500.0)))))
(tlg-eq "rechteck-befehl: fase abgelehnt" 'kein-rechteck (lg-rechteck-ecken-aus-poly (entlast)))
(entdel (entlast))
;; --- Rack-Erkennung: direkt, verschachtelt + gedreht, MINSERT ---
;; eigener Testblock (Parameter als Attribut bzw. ATTDEF-Vorgabe), damit
;; die Suche nach goh_rack davon unberuehrt bleibt
(lg-blockdef "TLG_RACK" (list (lg-geom-linie '(0.0 0.0 0.0) '(1000.0 0.0 0.0))
(lg-geom-attdef "Laenge" "500" '(0.0 0.0 0.0) 50.0 nil)
(lg-geom-attdef "Ebenen" "3" '(0.0 0.0 0.0) 50.0 nil)))
(lg-blockdef "TLG_GRUPPE" (list '((0 . "INSERT") (8 . "0") (2 . "TLG_RACK") (10 0.0 0.0 0.0))
'((0 . "INSERT") (8 . "0") (2 . "TLG_RACK") (10 0.0 2000.0 0.0))))
(lg-block-einfuegen "TLG_RACK" '(-100000.0 0.0 0.0) 0.0 "0" '(("Laenge" . "100 cm") ("Ebenen" . "2")))
(setq grp (lg-block-einfuegen "TLG_GRUPPE" '(-200000.0 0.0 0.0) (/ pi 2.0) "0" nil))
(vla-AddMInsertBlock (lg-modelspace) (vlax-3d-point '(-300000.0 0.0 0.0)) "TLG_RACK"
1.0 1.0 1.0 0.0 1 3 1000.0 3000.0)
(setq rk (lg-racks-finden "TLG_RACK" "Laenge" "Ebenen"))
(tlg-eq "racks: anzahl" 6 (length rk))
(tlg-eq "racks: laenge (attribut mit einheit + vorgaben)" 3500.0
(apply '+ (mapcar '(lambda (r) (cond ((lg-rk-laenge r)) (0.0))) rk)))
(tlg-eq "racks: ebenen" 17.0 (apply '+ (mapcar '(lambda (r) (cond ((lg-rk-ebenen r)) (0.0))) rk)))
(tlg-eq "racks: verschachtelt top" 2
(length (vl-remove-if-not '(lambda (r) (equal (lg-rk-top r) grp)) rk)))
;; Gruppe um 90 Grad gedreht: zweites Rack (lokal y = 2000) liegt bei x = -202000
(tlg-eq "racks: verschachtelt gedreht" T
(equal (vl-sort (mapcar '(lambda (r) (car (lg-rk-mitte r)))
(vl-remove-if-not '(lambda (r) (equal (lg-rk-top r) grp)) rk))
'<)
'(-202000.0 -200000.0) 100.0))
;; MINSERT 1 Zeile x 3 Spalten, Abstand 3000: Mitten = Einfuegepunkte
(tlg-eq "racks: minsert" '(-300000.0 -297000.0 -294000.0)
(vl-sort (mapcar '(lambda (r) (car (lg-rk-mitte r)))
(vl-remove-if-not '(lambda (r) (< (car (lg-rk-mitte r)) -250000.0)) rk))
'<))
;; --- goh_rack-Regression (Referenzwerte goh_storage_test_regal_report.txt) ---
(setq pfad (strcat (getenv "DXFMAKRO") "/tests/testdata/goh_storage_test.dwg"))
(if (findfile pfad)
(progn
;; "*" = aufgeloest einfuegen: die goh_rack-Bloecke liegen danach
;; direkt im Modellbereich wie in der Originalzeichnung
(command "_.-INSERT" (strcat "*" pfad) '(50000.0 0.0 0.0) 1 0)
(setq racks (lg-export-goh-racks nil))
(tlg-eq "goh_rack anzahl" 4 (length (car racks)))
(setq laengen (tlg-summe (car racks) "laenge_mm"))
(setq kap 0.0)
(foreach t1 (car racks)
(setq tr (ssg-json-parse t1))
(setq kap (+ kap (* (ssg-json-get tr "laenge_mm") (ssg-json-get tr "ebenen")))))
(tlg-eq "goh_rack laenge gesamt" T (equal laengen 38946.39 0.1))
(tlg-eq "goh_rack laenge x ebenen" T (equal kap 77892.78 0.1))
(princ (strcat "\n goh_rack: " (rtos laengen 2 2) " mm / " (rtos kap 2 2) " mm"))
;; --- Geschoss mit goh_racks kopieren (deckungsgleich, 2D) ---
;; Geschosskontur um die Racks legen (Mitten aus lg-racks-sammeln + Rand)
(setq bb (ssg-poly-bbox (mapcar '(lambda (p) (list (car p) (cadr p)))
(mapcar 'lg-rk-mitte (lg-racks-sammeln)))))
(setq gr (lg-geschoss-naechste-nr))
(lg-geschoss-anlegen (tlg-rechteck (- (car (car bb)) 20000.0) (- (cadr (car bb)) 20000.0)
(+ (car (cadr bb)) 20000.0) (+ (cadr (cadr bb)) 20000.0))
(append (list (cons "HOEHE_BELAG_mm" "20000")) (lg-geschoss-vorgaben gr)))
(setq neu (lg-geschosse-kopieren (list (cons "QUELLE" (itoa gr)) (cons "ANZAHL" "1")
(cons "ABSTAND_mm" "3000") (cons "BELAG_ART" "spanplatte"))))
(setq racks (lg-export-goh-racks (lg-geschoss-kandidaten)))
(tlg-eq "rack-kopie: anzahl" 8 (length (car racks)))
(tlg-eq "rack-kopie: quelle" 4
(length (vl-remove-if-not '(lambda (t1) (equal (ssg-json-get (ssg-json-parse t1) "geschoss") gr))
(car racks))))
(tlg-eq "rack-kopie: kopie" 4
(length (vl-remove-if-not '(lambda (t1) (equal (ssg-json-get (ssg-json-parse t1) "geschoss") (car neu)))
(car racks))))
(tlg-eq "rack-kopie: keine warnung" nil (cadr racks))
(tlg-eq "rack-kopie: laenge kopie" T
(equal (tlg-summe (car racks) "laenge_mm") (* 2 38946.39) 0.2))
(tlg-eq "rack-kopie: layer" T (if (tblsearch "LAYER" (strcat "LG_Regal_G" (itoa (car neu)))) T nil))
;; Auswertung je Geschoss wie LG_REGALE: je 4 Racks in Quelle und Kopie
(setq kand (lg-geschoss-kandidaten))
(setq zl (lg-racks-auswerten
(mapcar '(lambda (r) (list (lg-rack-geschoss (lg-ent-layer (lg-rk-top r)) (lg-rk-mitte r) kand)
(lg-rk-laenge r) (lg-rk-ebenen r)))
(lg-racks-sammeln))))
(tlg-eq "lg_regale: geschosse" (list gr (car neu)) (mapcar 'car zl))
(tlg-eq "lg_regale: anzahl" '(4 4) (mapcar 'cadr zl))
(tlg-eq "lg_regale: laenge x ebenen" T (equal (cadddr (car zl)) 77892.78 0.2))
(tlg-eq "lg_regale: befehl laeuft" nil (vl-catch-all-error-p (vl-catch-all-apply 'c:LG_REGALE nil))))
(tlg-eq "goh_storage_test.dwg vorhanden" T nil))
;; --- Von Hand Gesetztes bleibt: Einfuegen loest keine Neuberechnung aus ---
(setq kb (tlg-rechteck 600000.0 0.0 610000.0 6000.0))
(setq b3 (lg-bereich-anlegen kb (append (list (cons "GESCHOSS" "1"))
(lg-bereich-vorgaben (ssg-lwpoly-punkte kb)))))
(setq rh3 (tlg-nur (lg-bereich-kinder b3) "LG_REIHE_*"))
(tlg-eq "von hand: auto reihen" 4 (length rh3))
;; Anwender loescht eine automatisch erzeugte Reihe ...
(entdel (car rh3))
;; ... und setzt einen Gang quer durch den Bereich
(setq mg3 (lg-gang-einfuegen '(605000.0 0.0 0.0) '(605000.0 6000.0 0.0)
(list (cons "GESCHOSS" "1") (cons "BREITE_mm" "1000") (cons "ART" "gang")
(cons "BELAG" "spanplatte"))))
(setq rh3 (tlg-nur (lg-bereich-kinder b3) "LG_REIHE_*"))
(tlg-eq "von hand: geloeschte reihe bleibt weg" 6 (length rh3))
(tlg-eq "von hand: reihen zugeschnitten" 27000.0 (tlg-summe-attr rh3 "LAENGE"))
(tlg-eq "von hand: reste bleiben auto" 6 (tlg-anzahl-attr rh3 "QUELLE" "auto"))
;; Reihe von Hand aendern (auto -> auto_geaendert)
(setq ge3 (lg-linie-neu-aufbauen-sperre (car rh3)
(lg-wert-setzen (lg-wert-setzen (ssg-attrib-read (car rh3)) "QUELLE" "auto_geaendert")
"LAENGE" "3000")))
;; Regalreihe von Hand quer in einen automatisch erzeugten Gang setzen
(setq ag3 (vl-some '(lambda (g) (if (and (= (tlg-attr g "QUELLE") "auto") (= (tlg-attr g "ART") "gang")
(< (car (cdr (assoc 10 (entget g)))) 601000.0))
g))
(tlg-nur (lg-bereich-kinder b3) "LG_GANG_*")))
(setq n3 (length (tlg-nur (lg-bereich-kinder b3) "LG_GANG_*")))
(setq mr3 (lg-manuell-einfuegen "reihe"
(list 601000.0 (cadr (cdr (assoc 10 (entget ag3)))) 0.0)
(list 603000.0 (cadr (cdr (assoc 10 (entget ag3)))) 0.0)
(list (cons "GESCHOSS" "1") (cons "TIEFE_mm" "700") (cons "BEREICH" ""))))
(tlg-eq "von hand: reihe verknuepft" (tlg-attr b3 "NR") (tlg-attr mr3 "BEREICH"))
(tlg-eq "von hand: reihe quelle" "manuell" (tlg-attr mr3 "QUELLE"))
(tlg-eq "von hand: gang zerteilt" (1+ n3) (length (tlg-nur (lg-bereich-kinder b3) "LG_GANG_*")))
(tlg-eq "von hand: manueller gang unberuehrt" T (if (entget mg3) T nil))
;; unverknuepfte manuelle Reihe (Altbestand) in der Kontur, im Streifen
;; des manuellen Gangs (dort sicher frei von automatischen Objekten)
(setq alt3 (lg-linie-einfuegen "reihe" '(605000.0 500.0 0.0) '(605000.0 2500.0 0.0)
(list (cons "GESCHOSS" "1") (cons "TIEFE_mm" "700") (cons "QUELLE" "manuell")) nil))
;; ausdrueckliche Neuberechnung (Bereich bearbeiten): Handarbeit bleibt
(lg-bereich-fuellen b3)
(tlg-eq "neuberechnung: manueller gang bleibt" T (if (entget mg3) T nil))
(tlg-eq "neuberechnung: manuelle reihe bleibt" T (if (entget mr3) T nil))
(tlg-eq "neuberechnung: geaenderte reihe bleibt" T (if (and ge3 (entget ge3)) T nil))
(tlg-eq "neuberechnung: altbestand bleibt" T (if (entget alt3) T nil))
;; nichts Automatisches ueberdeckt mehr die Handarbeit
(tlg-eq "neuberechnung: nichts zu schneiden" '(0 0 0 0)
(mapcar 'lg-sperre-anwenden (list mg3 mr3 ge3 alt3)))
;; Gang-Rechteck buendig an eine Reihe gezeichnet, krumme Breite 999.6:
;; die Rundung darf die Ansetzkante nicht verschieben, die Reihe bleibt
(setq rh3 (vl-remove-if-not '(lambda (r) (= (tlg-attr r "QUELLE") "auto"))
(tlg-nur (lg-bereich-kinder b3) "LG_REIHE_*")))
(setq bb (lg-linie-polygon (car rh3))
kb (mapcar '(lambda (q p) (/ (- q p) (distance (car bb) (cadddr bb)))) (cadddr bb) (car bb)))
(setq rg (lg-gang-rechteck-einfuegen
(list (cadddr bb) (caddr bb)
(mapcar '+ (caddr bb) (mapcar '(lambda (x) (* x 999.6)) kb))
(mapcar '+ (cadddr bb) (mapcar '(lambda (x) (* x 999.6)) kb)))
(list (cons "GESCHOSS" "1") (cons "ART" "gang") (cons "BELAG" "spanplatte"))))
(tlg-eq "rechteck buendig: gang breite" "1000" (tlg-attr rg "BREITE_mm"))
(tlg-eq "rechteck buendig: reihe bleibt" T (if (entget (car rh3)) T nil))
(ssg-gui-an)
(princ))
(defun lager:export-results (out-dir / f pfad)
(setq pfad (strcat out-dir "/lager_results.json"))
(setq f (open pfad "w"))
(if f
(progn
(write-line "{" f)
(write-line (strcat " \"pass\": " (itoa *tlg-pass*) ",") f)
(write-line (strcat " \"fail\": " (itoa *tlg-fail*) ",") f)
(write-line (strcat " \"status\": \""
(if (= *tlg-fail* 0) "OK" "FEHLER") "\"") f)
(write-line "}" f)
(close f)
(princ (strcat "\n Ergebnis: " pfad))))
(princ))
(defun c:TEST_LAGER ( / )
(setq *tlg-pass* 0 *tlg-fail* 0 *tlg-fails* '())
(princ "\n================================================================")
(princ "\n TEST_LAGER - Lagerplanung (LagerInsert.lsp)")
(princ "\n================================================================")
(lager:tests)
(princ "\n\n----------------------------------------------------------------")
(princ (strcat "\n Ergebnis: " (itoa *tlg-pass*) " PASS, "
(itoa *tlg-fail*) " FAIL"))
(if (> *tlg-fail* 0)
(progn
(princ "\n Fehlgeschlagen:")
(foreach n (reverse *tlg-fails*) (princ (strcat "\n - " n)))))
(princ "\n================================================================")
(princ))
(princ "\nTEST_LAGER geladen. Aufruf: TEST_LAGER")
(princ)