;; ============================================================ ;; 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)