mistangl/dxfmakros
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
dbc6c585bf894522d65dacafe095afcb074df26e
dxfmakros/tests/test_unit.lsp
T
Michael StanglandClaude Opus 4.8 dbc6c585bf cs-zuordnung-lauf zerlegen + LISP-Testarchitektur vereinheitlichen 
cs-zuordnung-lauf (~230 Zeilen, ~26 Locals) in sieben benannte
Routinen zerlegt (cs-sammle-bloecke, cs-scanner-zuordnen,
cs-separatoren-zuordnen, cs-korrektur-vermerken, cs-scanner-distanz-
melden, cs-anzahl-schreiben, cs-bericht-ausgeben); die Engine ist
jetzt ein schlanker Orchestrator. Verhalten unveraendert.

Dadurch ist die rein geometrische Zuordnungslogik von den Entity-
Zugriffen getrennt und unittest-faehig: neuer Block tu-tests-sepscan
mit 30 Tests fuer cs-in-box/cs-bump/cs-carrier-by-id/cs-assign/
cs-nearest-two/cs-resolve-sensor (Carrier-Records als plain Listen,
keine Zeichnung noetig).

Testarchitektur (Laden) vereinheitlicht: lazy Feature-Module
(GeruestInsert, count_sep_scan) werden AUSSCHLIESSLICH in test_unit.scr
auf .scr-Top-Level geladen. Grund: in BricsCAD werden per load
definierte Funktionen erst nach Rueckkehr zum Top-Level sichtbar - ein
load in c:TEST_UNIT oder einem gecatchten Testblock bindet sie im
selben Durchlauf nicht. Die Testbloecke laden nichts mehr, sie pruefen
nur per atoms-family. Runner gehaertet (tu-run-block faengt harte
Fehler je Block ab -> FAIL statt Suite-Abbruch, Report immer da).

Nebenbei aufgeraeumt: tote tests.lsp-Referenz in ssg_load.lsp entfernt
(Datei laengst geloescht, blockierte headless den kompletten Testlauf).

Voller LISP-Unit-Lauf jetzt 226/226 gruen.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-09-18 14:31:35 +02:00

901 lines
40 KiB
Common Lisp
Raw Blame History

;; ============================================================
;; test_unit.lsp - Unit-Tests fuer einfache LISP-Standardfunktionen
;;
;; Testet reine Hilfsfunktionen (String, Zahl, Vektor, Liste,
;; Alist), die OHNE Zeichnungsdatenbank, Auswahlsaetze, Dialoge
;; oder Blockdateien auskommen - analog zu den Python-Unittests,
;; nur direkt in AutoLISP formuliert. Jeder Testfall vergleicht
;; einen Funktionsaufruf gegen ein erwartetes Ergebnis.
;;
;; Aufruf in BricsCAD (SSG_LIB muss geladen sein):
;; (load (strcat (getenv "DXFMAKRO") "/tests/test_unit.lsp"))
;; TEST_UNIT
;;
;; Ueber die Kommandozeile:
;; bin\run_tests.bat --lisp
;; (startet BricsCAD mit tests/output/_unit_run.scr, laedt SSG_LIB,
;; fuehrt TEST_UNIT aus und schreibt tests/output/unit_results.txt)
;;
;; Ergebnis:
;; Konsole: PASS/FAIL je Test + Zusammenfassung
;; Datei: tests/output/unit_results.txt (von run_tests.bat gelesen)
;;
;; Ladearchitektur (EINHEITLICH):
;; Das Laden der zu testenden Module passiert AUSSCHLIESSLICH auf .scr-
;; Top-Level in tests/test_unit.scr - die Core-Module ueber ssg_load.lsp,
;; die lazy Feature-Module (GeruestInsert, count_sep_scan) per explizitem
;; load. Die Testbloecke hier laden NICHTS nach; sie pruefen nur per
;; atoms-family, ob ihr Modul vorhanden ist, und ueberspringen sich sonst
;; mit einer FAIL-Meldung.
;; Grund: In BricsCAD werden per load definierte Funktionen erst nach
;; Rueckkehr zum Top-Level sichtbar. Ein load INNERHALB von c:TEST_UNIT
;; oder eines per vl-catch-all-apply gecatchten Testblocks bindet die
;; frisch definierten Funktionen im laufenden Durchlauf NICHT (beobachtet:
;; geruest-id-string/cs-in-box blieben ungebunden). Darum gehoert alles
;; Laden vor den (c:TEST_UNIT)-Aufruf ins .scr.
;; ============================================================
;; ------------------------------------------------------------
;; MINI-TEST-FRAMEWORK
;; ------------------------------------------------------------
(setq *tu-results* nil) ;; Liste von (pass-p name detail)
(setq *tu-pass* 0)
(setq *tu-fail* 0)
(defun tu-reset ()
(setq *tu-results* nil *tu-pass* 0 *tu-fail* 0)
)
(defun tu-str (v) (vl-princ-to-string v))
;; Ergebnis eines Testfalls erfassen
(defun tu-record (pass-p name detail)
(if pass-p
(setq *tu-pass* (1+ *tu-pass*))
(setq *tu-fail* (1+ *tu-fail*))
)
(setq *tu-results* (cons (list pass-p name detail) *tu-results*))
(princ (strcat "\n " (if pass-p "PASS" "FAIL") ": " name))
(if (not pass-p) (princ (strcat " | " detail)))
pass-p
)
;; Exakter Vergleich (Strings, Ganzzahlen, Listen von Strings/Ints)
(defun tu-eq (name expected actual)
(tu-record (equal expected actual) name
(strcat "erwartet=" (tu-str expected) " tatsaechlich=" (tu-str actual)))
)
;; Numerischer Vergleich mit Toleranz (Fliesskomma, auch verschachtelte Listen)
(defun tu-eqf (name expected actual)
(tu-record (equal expected actual 1e-6) name
(strcat "erwartet=" (tu-str expected) " tatsaechlich=" (tu-str actual)))
)
(defun tu-true (name actual)
(tu-record (not (null actual)) name (strcat "tatsaechlich=" (tu-str actual)))
)
(defun tu-nil (name actual)
(tu-record (null actual) name (strcat "tatsaechlich=" (tu-str actual)))
)
;; ------------------------------------------------------------
;; TESTS: ssg_core.lsp - String-/JSON-/Alist-Helfer
;; ------------------------------------------------------------
(defun tu-tests-core ()
(princ "\n[ssg_core]")
;; ssg-cfg-trim: Whitespace + abschliessendes Komma entfernen
(tu-eq "ssg-cfg-trim/spaces+komma" "hello" (ssg-cfg-trim " hello, "))
(tu-eq "ssg-cfg-trim/nur-spaces" "abc" (ssg-cfg-trim "\tabc\r\n"))
;; ssg-cfg-parse-value: JSON-Skalar erkennen
(tu-eq "ssg-cfg-parse-value/string" "text" (ssg-cfg-parse-value "\"text\""))
(tu-eq "ssg-cfg-parse-value/int" 42 (ssg-cfg-parse-value "42"))
(tu-eqf "ssg-cfg-parse-value/real" 3.5 (ssg-cfg-parse-value "3.5"))
(tu-true "ssg-cfg-parse-value/true" (ssg-cfg-parse-value "true"))
(tu-nil "ssg-cfg-parse-value/false" (ssg-cfg-parse-value "false"))
(tu-nil "ssg-cfg-parse-value/null" (ssg-cfg-parse-value "null"))
;; ssg-cfg-split-comma: an Kommas aufteilen
(tu-eq "ssg-cfg-split-comma" '("a" "b" "c") (ssg-cfg-split-comma "a,b,c"))
;; ssg-cfg-parse-array: JSON-Array parsen
(tu-eq "ssg-cfg-parse-array" '(1 2 3) (ssg-cfg-parse-array "[1, 2, 3]"))
;; ssg-cfg-parse-kv: "key": wert -> ("key" . wert)
(tu-eq "ssg-cfg-parse-kv" '("key" . 42) (ssg-cfg-parse-kv "\"key\": 42"))
;; ssg-val: Wert aus Alist lesen
(tu-eq "ssg-val/vorhanden" 2 (ssg-val '(("a" . 1) ("b" . 2)) "b"))
(tu-nil "ssg-val/fehlt" (ssg-val '(("a" . 1)) "x"))
;; ssg-attrib-defaults: (TAG DEFAULT) -> (TAG . DEFAULT)
(tu-eq "ssg-attrib-defaults"
'(("TYP" . "A") ("NR" . "0"))
(ssg-attrib-defaults '(("TYP" "A") ("NR" "0"))))
;; ssg-attrib-merge: gegebene Werte ueberschreiben Defaults
(tu-eq "ssg-attrib-merge/override"
'(("TYP" . "A") ("NR" . "5"))
(ssg-attrib-merge '(("NR" . "5")) '(("TYP" "A") ("NR" "0"))))
(tu-eq "ssg-attrib-merge/nil-given"
'(("TYP" . "A") ("NR" . "0"))
(ssg-attrib-merge nil '(("TYP" "A") ("NR" "0"))))
;; ssg-attrib-alist-to-defs: (TAG . Wert) -> (TAG Wert)
(tu-eq "ssg-attrib-alist-to-defs"
'(("TYP" "A") ("NR" "0"))
(ssg-attrib-alist-to-defs '(("TYP" . "A") ("NR" . "0"))))
;; ssg-geruest-typ-to-idx / idx-to-typ (Combobox-Zuordnung)
(tu-eq "ssg-geruest-typ-to-idx/bekannt" 2 (ssg-geruest-typ-to-idx "Schoenenberger Geruest"))
(tu-eq "ssg-geruest-typ-to-idx/erst" 0 (ssg-geruest-typ-to-idx "IPE-Geruest abgestuft"))
(tu-eq "ssg-geruest-typ-to-idx/unbekannt" 2 (ssg-geruest-typ-to-idx "gibtsnicht"))
(tu-eq "ssg-geruest-idx-to-typ" "Schoenenberger Geruest" (ssg-geruest-idx-to-typ 2))
;; ssg-ini-* : INI-Parser (Eingabe = Zeilenliste, kein Datei-IO)
(setq _ini (ssg-ini-parse-lines
'("# Kommentar" "[sek]" "key = wert" "liste = a, b ,c")))
(tu-eq "ssg-ini-get/vorhanden" "wert" (ssg-ini-get _ini "sek" "key" "def"))
(tu-eq "ssg-ini-get/default" "def" (ssg-ini-get _ini "sek" "fehlt" "def"))
(tu-eq "ssg-ini-list/normalisiert" "a,b,c" (ssg-ini-list _ini "sek" "liste" "x"))
;; ssg-parse-json-array: flaches JSON-Array -> Liste von Alists
(tu-eq "ssg-parse-json-array"
'((("a" . 1) ("b" . 2)))
(ssg-parse-json-array '("[" "{" "\"a\": 1," "\"b\": 2" "}" "]")))
;; ssg-layer-cfg-eintrag: "Layername, Farbe" -> (layer . farbe)
;; Reine Funktion, ini-Daten als Parameter - kein Datei-IO, keine Zeichnung.
(setq _lay (ssg-ini-parse-lines
'("# Kommentar"
"[ils_2d]"
"variofoerderer = ILS_Fingerfoerderer, 4"
"ohne_farbe = ILS_SP"
"leer ="
"[ils_3d]"
"variofoerderer = _3D_ILS_Fingerfoerderer, 4"
"[allgemein]"
"vf_beschriftung = VF_Beschriftung, 7")))
(tu-eq "ssg-layer-cfg-eintrag/layer-und-farbe"
'("ILS_Fingerfoerderer" . "4")
(ssg-layer-cfg-eintrag _lay "ils_2d" "variofoerderer"))
(tu-eq "ssg-layer-cfg-eintrag/ohne-farbe-default-7"
'("ILS_SP" . "7")
(ssg-layer-cfg-eintrag _lay "ils_2d" "ohne_farbe"))
(tu-nil "ssg-layer-cfg-eintrag/leerer-wert"
(ssg-layer-cfg-eintrag _lay "ils_2d" "leer"))
(tu-nil "ssg-layer-cfg-eintrag/key-fehlt"
(ssg-layer-cfg-eintrag _lay "ils_2d" "gibtsnicht"))
(tu-nil "ssg-layer-cfg-eintrag/sektion-fehlt"
(ssg-layer-cfg-eintrag _lay "gibtsnicht" "variofoerderer"))
;; ssg-layer-eintrag: Aufloesung [ils_<dim>] -> [allgemein].
;; Dimension und cfg werden hier injiziert (kein Datei-IO); der gemerkte
;; Ladeversuch verhindert, dass ssg-layer-cfg-load die echte Datei liest.
(setq _lay-cfg-alt *ssg-layer-cfg*
_lay-vers-alt *ssg-layer-cfg-versucht*
_lay-dim-alt (if (boundp '*ssg-ils-dim*) *ssg-ils-dim*))
(setq *ssg-layer-cfg* _lay *ssg-layer-cfg-versucht* T)
(setq *ssg-ils-dim* "2D")
(tu-eq "ssg-layer-eintrag/dim-2d"
'("ILS_Fingerfoerderer" . "4") (ssg-layer-eintrag "variofoerderer"))
(tu-eq "ssg-layer-eintrag/fallback-allgemein"
'("VF_Beschriftung" . "7") (ssg-layer-eintrag "vf_beschriftung"))
(setq *ssg-ils-dim* "3D")
(tu-eq "ssg-layer-eintrag/dim-3d"
'("_3D_ILS_Fingerfoerderer" . "4") (ssg-layer-eintrag "variofoerderer"))
(tu-nil "ssg-layer-eintrag/unbekannte-baugruppe"
(ssg-layer-eintrag "gibtsnicht"))
;; ssg-layer-farbe-fuer-name: Farbe zu einem LAYERNAMEN (nicht Baugruppe).
;; Wird gebraucht, weil Layer aus dem LAYER-Attribut oft VOR dem Wrapper
;; angelegt werden und ssg-make-layer die Farbe nur bei Neuanlage setzt.
(setq *ssg-layer-cfg* (ssg-ini-parse-lines
'("[ils_3d]"
"gefaellestrecke = _3D_ILS_SP, 3"
"[allgemein]"
"vf_beschriftung = VF_Beschriftung, 7"
"[farben]"
"ILS_SEP-SP = 82")))
(tu-eq "ssg-layer-farbe-fuer-name/abschnitt-farben"
"82" (ssg-layer-farbe-fuer-name "ILS_SEP-SP"))
(tu-eq "ssg-layer-farbe-fuer-name/aus-baugruppen-wert"
"3" (ssg-layer-farbe-fuer-name "_3D_ILS_SP"))
(tu-eq "ssg-layer-farbe-fuer-name/case-insensitiv"
"3" (ssg-layer-farbe-fuer-name "_3d_ils_sp"))
(tu-eq "ssg-layer-farbe-fuer-name/unbekannt-default-7"
"7" (ssg-layer-farbe-fuer-name "GibtsNicht"))
(tu-eq "ssg-layer-farbe-fuer-name/leerer-name"
"7" (ssg-layer-farbe-fuer-name ""))
;; Globale Zustaende wieder herstellen
(setq *ssg-ils-dim* _lay-dim-alt
*ssg-layer-cfg* _lay-cfg-alt
*ssg-layer-cfg-versucht* _lay-vers-alt)
)
;; ------------------------------------------------------------
;; TESTS: ssg_lang.lsp - Textersetzung
;; ------------------------------------------------------------
(defun tu-tests-lang ()
(princ "\n[ssg_lang]")
;; ssg-str-replace-all: (neu alt str)
(tu-eq "ssg-str-replace-all/alle" "fXX" (ssg-str-replace-all "X" "o" "foo"))
(tu-eq "ssg-str-replace-all/mehrfach" "a-b-c" (ssg-str-replace-all "-" "." "a.b.c"))
(tu-eq "ssg-str-replace-all/keins" "abc" (ssg-str-replace-all "X" "z" "abc"))
;; ssg-lang-unescape: literales \n (Backslash+n) -> echter Zeilenumbruch
(setq _u (ssg-lang-unescape (strcat "a" "\\n" "b")))
(tu-eq "ssg-lang-unescape/laenge" 3 (strlen _u))
(tu-eq "ssg-lang-unescape/newline" (chr 10) (substr _u 2 1))
)
;; ------------------------------------------------------------
;; TESTS: ssg_id.lsp - ID-Formatierung
;; ------------------------------------------------------------
(defun tu-tests-id ()
(princ "\n[ssg_id]")
(tu-eq "ssg-id-format/1" "0001" (ssg-id-format 1))
(tu-eq "ssg-id-format/42" "0042" (ssg-id-format 42))
(tu-eq "ssg-id-format/1000" "1000" (ssg-id-format 1000))
(tu-eq "ssg-id-format/12345" "12345" (ssg-id-format 12345))
)
;; ------------------------------------------------------------
;; TESTS: vf_core.lsp - Vektor-/Frame-Mathematik
;; ------------------------------------------------------------
(defun tu-tests-vfcore ()
(princ "\n[vf_core]")
(tu-eqf "vec-length/3-4-0" 5.0 (vec-length '(3.0 4.0 0.0)))
(tu-eqf "vec3-cross/x-cross-y" '(0.0 0.0 1.0) (vec3-cross '(1.0 0.0 0.0) '(0.0 1.0 0.0)))
(tu-eqf "vec3-cross/z-cross-x" '(0.0 1.0 0.0) (vec3-cross '(0.0 0.0 1.0) '(1.0 0.0 0.0)))
(tu-eqf "vec3-normalize/z5" '(0.0 0.0 1.0) (vec3-normalize '(0.0 0.0 5.0)))
(tu-eqf "mat3-mul-vec3/identitaet"
'(2.0 3.0 4.0)
(mat3-mul-vec3 '((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0)) '(2.0 3.0 4.0)))
(tu-eqf "punkt-differenz" '(3.0 4.0 5.0) (punkt-differenz '(1.0 1.0 1.0) '(4.0 5.0 6.0)))
(tu-eq "ks-normalize-name/ksys-ein" "KS_EIN" (ks-normalize-name "KSYS_EIN"))
(tu-eq "ks-normalize-name/ks-aus" "KS_AUS" (ks-normalize-name "KS_AUS"))
(tu-nil "ks-normalize-name/kein-ks" (ks-normalize-name "IRGENDWAS"))
(tu-eq "ks-line-axis/X-1" "X" (ks-line-axis 1.0))
(tu-eq "ks-line-axis/X-100" "X" (ks-line-axis 100.0))
(tu-eq "ks-line-axis/Y" "Y" (ks-line-axis 2.0))
(tu-eq "ks-line-axis/Z" "Z" (ks-line-axis 3.0))
(tu-eq "fmt/zahl" "3.14" (fmt 3.14159))
(tu-eq "fmt/nil" "---" (fmt nil))
;; hz-winkel->xu: Richtungsvektor aus Horizontal-/Vertikalwinkel
(tu-eqf "hz-winkel->xu/0-0" '(1.0 0.0 0.0) (hz-winkel->xu 0 0))
(tu-eqf "hz-winkel->xu/90-0" '(0.0 1.0 0.0) (hz-winkel->xu 90 0))
;; Roundtrip frame -> (hz winkel)
(tu-eqf "frame->hz-winkel/roundtrip"
'(30.0 10.0)
(frame->hz-winkel (punkt-hz-winkel->frame '(0.0 0.0 0.0) 30 10)))
;; ks-relativize / ks-absolutize sind zueinander invers
(setq _ks '(("KS_EIN" ((100.0 200.0 300.0) (101.0 200.0 300.0)))))
(tu-eqf "ks-relativize+absolutize/invers"
_ks
(ks-absolutize (ks-relativize _ks '(10.0 20.0 30.0)) '(10.0 20.0 30.0)))
)
;; ------------------------------------------------------------
;; TESTS: export.lsp - CSV/KOS-Kodierung
;; ------------------------------------------------------------
(defun tu-tests-export ()
(princ "\n[export]")
(tu-eq "csv:clamp/innen" 5 (csv:clamp 5 0 10))
(tu-eq "csv:clamp/unten" 0 (csv:clamp -3 0 10))
(tu-eq "csv:clamp/oben" 10 (csv:clamp 20 0 10))
(tu-eqf "csv:z-angle-to-quat/0" '(0.0 0.0 0.0 1.0) (csv:z-angle-to-quat 0))
(tu-eqf "csv:z-angle-to-quat/180" '(0.0 0.0 1.0 0.0) (csv:z-angle-to-quat 180))
(tu-eq "csv:b64-encode-ints/0" "AAAA" (csv:b64-encode-ints '(0)))
(tu-eq "csv:trans-encode/0-0-0" "AAAAAAAAAAAA" (csv:trans-encode 0.0 0.0 0.0))
;; local-to-world: reine Z-Drehung um den Elternpunkt
(tu-eqf "csv:local-to-world/keine-drehung"
'(1.0 0.0 0.0) (csv:local-to-world '(0.0 0.0 0.0) 0.0 '(1.0 0.0 0.0)))
(tu-eqf "csv:local-to-world/90-grad"
'(0.0 1.0 0.0) (csv:local-to-world '(0.0 0.0 0.0) (/ pi 2.0) '(1.0 0.0 0.0)))
;; json-escape: Anfuehrungszeichen maskieren
(tu-eq "csv:json-escape/quote" "a\\\"b" (csv:json-escape "a\"b"))
)
;; ------------------------------------------------------------
;; TESTS: Gefaellestrecke.lsp - Geometrie-/Listen-Helfer
;; ------------------------------------------------------------
(defun tu-tests-gf ()
(princ "\n[Gefaellestrecke]")
(tu-eq "gf-snap-bogenwinkel/30" 30 (gf-snap-bogenwinkel 30))
(tu-eq "gf-snap-bogenwinkel/44" 30 (gf-snap-bogenwinkel 44))
(tu-eq "gf-snap-bogenwinkel/60" 60 (gf-snap-bogenwinkel 60))
(tu-eq "gf-snap-bogenwinkel/90" 90 (gf-snap-bogenwinkel 90))
(tu-eq "gf-bogen-blockname"
"Gefaellebogen_links_90_R500" (gf-bogen-blockname 90 "links"))
(tu-eqf "gf-abstand-2d/3-4" 5.0 (gf-abstand-2d '(0.0 0.0) '(3.0 4.0)))
(tu-eqf "gf-hz-winkel/rechts" 0.0 (gf-hz-winkel '(0.0 0.0) '(1.0 0.0)))
(tu-eqf "gf-hz-winkel/oben" 90.0 (gf-hz-winkel '(0.0 0.0) '(0.0 1.0)))
(tu-eq "gf-replace-nth" '(a x c) (gf-replace-nth '(a b c) 1 'x))
;; gf-exit-hz: Ausgangsrichtung nach letztem Segment
(tu-eqf "gf-exit-hz/linie" 45.0 (gf-exit-hz '(("Linie" 45.0))))
(tu-eqf "gf-exit-hz/bogen-links"
90.0 (gf-exit-hz '(("Linie" 0.0) ("Bogen" 0.0 nil 90 "links"))))
)
;; ------------------------------------------------------------
;; TESTS: OmniModulInsert.lsp - Datensatz-Helfer
;; ------------------------------------------------------------
(defun tu-tests-omni ()
(princ "\n[OmniModulInsert]")
(tu-eq "omni:sivasid-to-str/int" "42" (omni:sivasid-to-str 42))
(tu-eq "omni:sivasid-to-str/str" "abc" (omni:sivasid-to-str "abc"))
(tu-eq "omni:sivasid-to-str/real" "3" (omni:sivasid-to-str 3.0))
;; Mock-Datensatz (Struktur wie ssg-load-json liefern wuerde)
(setq _lst
'((("Sivasnr" . 100) ("KurvenWinkel" . 45) ("Radius" . 550))
(("Sivasnr" . 200) ("KurvenWinkel" . 90) ("Radius" . 400))
(("Sivasnr" . 300) ("KurvenWinkel" . 45) ("Radius" . 750))))
(tu-eq "omni:val" 400 (omni:val (omni:get-by-sivasid _lst 200) "Radius"))
(tu-nil "omni:get-by-sivasid/fehlt" (omni:get-by-sivasid _lst 999))
(tu-eq "omni:filter/anzahl" 2 (length (omni:filter _lst "KurvenWinkel" 45)))
(tu-eq "omni:filter/wert"
100 (cdr (assoc "Sivasnr" (car (omni:filter _lst "KurvenWinkel" 45)))))
)
;; ------------------------------------------------------------
;; TESTS: KreiselInsert.lsp - Geometrie-Helfer
;; ------------------------------------------------------------
(defun tu-tests-kreisel ()
(princ "\n[KreiselInsert]")
;; Projektion eines Punktes auf eine Gerade
(tu-eqf "kreisel-project-point/lot"
'(0.0 0.0) (kreisel-project-point '(0.0 5.0) '(0.0 0.0) '(10.0 0.0)))
(tu-eqf "kreisel-project-point/mitte"
'(5.0 0.0) (kreisel-project-point '(5.0 5.0) '(0.0 0.0) '(10.0 0.0)))
;; Parallelitaet zweier Richtungsvektoren
(tu-true "kreisel-parallel-p/parallel" (kreisel-parallel-p '(1.0 0.0) '(2.0 0.0)))
(tu-nil "kreisel-parallel-p/senkrecht" (kreisel-parallel-p '(1.0 0.0) '(0.0 1.0)))
;; Ausrichtung <-> Index
(tu-eqf "kreisel-idx-to-rotation/0" 0.0 (kreisel-idx-to-rotation 0))
(tu-eqf "kreisel-idx-to-rotation/2" 90.0 (kreisel-idx-to-rotation 2))
(tu-eq "kreisel-rotation-to-idx/90" 2 (kreisel-rotation-to-idx 90.0))
(tu-eq "kreisel-rotation-to-idx/180" 1 (kreisel-rotation-to-idx 180.0))
)
;; ------------------------------------------------------------
;; TESTS: ssg_ks_insert.lsp - Sepliste-Serialisierung
;; ------------------------------------------------------------
(defun tu-tests-sepliste ()
(princ "\n[ssg_ks_insert/sepliste]")
;; ssg-sepliste-chunk-string: Stuecke <= n, nichts verloren
(tu-eq "ssg-sepliste-chunk-string/glatt" '("ab" "cd") (ssg-sepliste-chunk-string "abcd" 2))
(tu-eq "ssg-sepliste-chunk-string/rest" '("ab" "cd" "e") (ssg-sepliste-chunk-string "abcde" 2))
(tu-eq "ssg-sepliste-chunk-string/kuerzer" '("abc") (ssg-sepliste-chunk-string "abc" 10))
;; ssg-sepliste-split-feld: Trenner-Aufteilung, inkl. leeres Feld
(tu-eq "ssg-sepliste-split-feld/normal" '("SEP" "1" "10.00" "20.00")
(ssg-sepliste-split-feld "SEP:1:10.00:20.00" ":"))
;; ssg-sepliste-fmt-koord: GENAU 2 Nachkommastellen, DIMZIN-unabhaengig.
;; Ersetzt rtos (das bei DIMZIN=8 abschliessende Nullen verschluckt und die
;; XDATA-Serialisierung zeichnungsprofilabhaengig gemacht hat).
(tu-eq "sepliste-fmt/ganz" "10.00" (ssg-sepliste-fmt-koord 10.0))
(tu-eq "sepliste-fmt/eine-stelle" "30.50" (ssg-sepliste-fmt-koord 30.5))
(tu-eq "sepliste-fmt/rundung-ab" "5.01" (ssg-sepliste-fmt-koord 5.007))
(tu-eq "sepliste-fmt/uebertrag" "10.00" (ssg-sepliste-fmt-koord 9.999))
(tu-eq "sepliste-fmt/negativ" "-5.00" (ssg-sepliste-fmt-koord -5.0))
(tu-eq "sepliste-fmt/negativ-rund" "-5.01" (ssg-sepliste-fmt-koord -5.007))
(tu-eq "sepliste-fmt/null" "0.00" (ssg-sepliste-fmt-koord 0.0))
;; ssg-sepliste->string: Serialisierung eines Eintrags
(tu-eq "ssg-sepliste->string/ein-eintrag"
"SEP:1:10.00:20.00"
(ssg-sepliste->string '(("SEP" 1 10.0 20.0))))
(tu-eq "ssg-sepliste->string/mehrere"
"SEP:1:10.00:20.00,AS:2:30.00:40.00"
(ssg-sepliste->string '(("SEP" 1 10.0 20.0) ("AS" 2 30.0 40.0))))
;; ssg-sepliste-string->liste: Gegenstueck zu ssg-sepliste->string
(tu-eq "ssg-sepliste-string->liste/leer" nil (ssg-sepliste-string->liste ""))
(tu-eq "ssg-sepliste-string->liste/ein-eintrag"
'(("SEP" 1 10.0 20.0))
(ssg-sepliste-string->liste "SEP:1:10.00:20.00"))
;; Roundtrip ->string->liste: entscheidend, da der Export genau diesen
;; Weg (XDATA schreiben/lesen) fuer die Separator-Reihenfolge nutzt.
(setq _sep '(("SEP" 1 10.0 20.0) ("AS" 2 30.5 40.5) ("ES" 3 -5.0 0.0)))
(tu-eqf "sepliste-roundtrip/mehrere-typen"
_sep
(ssg-sepliste-string->liste (ssg-sepliste->string _sep)))
)
;; ------------------------------------------------------------
;; TESTS: ssg_core.lsp - rekursiver JSON-Parser + ssg-join
;; ------------------------------------------------------------
(defun tu-tests-json ( / _p _datei _daten _bg _var _anb)
(princ "\n[ssg_core/json]")
;; ssg-join
(tu-eq "ssg-join/leer" "" (ssg-join '() ","))
(tu-eq "ssg-join/eins" "a" (ssg-join '("a") ","))
(tu-eq "ssg-join/drei" "a,b,c" (ssg-join '("a" "b" "c") ","))
(tu-eq "ssg-join/plus" "a + b" (ssg-join '("a" "b") " + "))
;; Skalare und flaches Objekt
(tu-eq "json/objekt-flach" '(("a" . 1)) (ssg-json-parse "{\"a\": 1}"))
(tu-eq "json/zwei-keys" '(("a" . 1) ("b" . 2))
(ssg-json-parse "{\"a\": 1, \"b\": 2}"))
(tu-eq "json/string" "hallo" (ssg-json-get (ssg-json-parse "{\"a\": \"hallo\"}") "a"))
(tu-eq "json/int" 6000 (ssg-json-get (ssg-json-parse "{\"a\": 6000}") "a"))
(tu-eqf "json/real" 1.5 (ssg-json-get (ssg-json-parse "{\"a\": 1.5}") "a"))
(tu-eq "json/true" T (ssg-json-get (ssg-json-parse "{\"a\": true}") "a"))
(tu-eq "json/false" nil (ssg-json-get (ssg-json-parse "{\"a\": false}") "a"))
(tu-eq "json/null" nil (ssg-json-get (ssg-json-parse "{\"a\": null}") "a"))
;; Verschachtelung - genau das, was die alten Zeilen-Parser nicht koennen
(tu-eq "json/objekt-verschachtelt" '(("a" ("b" . 2)))
(ssg-json-parse "{\"a\": {\"b\": 2}}"))
(tu-eq "json/array" '(("a" 1 2 3))
(ssg-json-parse "{\"a\": [1, 2, 3]}"))
(tu-eq "json/array-objekte" '(("a" (("b" . 1)) (("b" . 2))))
(ssg-json-parse "{\"a\": [{\"b\": 1}, {\"b\": 2}]}"))
(tu-eq "json/array-leer" '(("a")) (ssg-json-parse "{\"a\": []}"))
;; Mehrzeilig (alte Parser verlangen Arrays in EINER Zeile)
(tu-eq "json/mehrzeilig" '(("a" "x" "y"))
(ssg-json-parse "{\n \"a\": [\n \"x\",\n \"y\"\n ]\n}"))
;; Maskiertes Anfuehrungszeichen und Komma im String - beides kommt in den
;; Geruest-Artikelbezeichnungen real vor ("ROHR R 1\" 33,7 x 2,6")
(tu-eq "json/escape-quote" "R 1\" x"
(ssg-json-get (ssg-json-parse "{\"a\": \"R 1\\\" x\"}") "a"))
(tu-eq "json/komma-im-string" "33,7 x 2,6"
(ssg-json-get (ssg-json-parse "{\"a\": \"33,7 x 2,6\"}") "a"))
(tu-eq "json/escape-backslash" "a\\b"
(ssg-json-get (ssg-json-parse "{\"a\": \"a\\\\b\"}") "a"))
(tu-eq "json/escape-newline" (chr 10)
(ssg-json-get (ssg-json-parse "{\"a\": \"\\n\"}") "a"))
;; ssg-json-escape: Gegenstueck zum Parser
(tu-eq "json-escape/quote" "a\\\"b" (ssg-json-escape "a\"b"))
(tu-eq "json-escape/backslash" "a\\\\b" (ssg-json-escape "a\\b"))
(tu-eq "json-escape/newline" "a\\nb" (ssg-json-escape (strcat "a" (chr 10) "b")))
(tu-eq "json-escape/leer" "" (ssg-json-escape nil))
;; Rundlauf: maskieren -> parsen ergibt den Originaltext zurueck
(tu-eq "json-escape/rundlauf" "ROHRKLAMMER 1\" KPL. VERTIKAL"
(ssg-json-get
(ssg-json-parse
(strcat "{\"a\": \""
(ssg-json-escape "ROHRKLAMMER 1\" KPL. VERTIKAL") "\"}"))
"a"))
;; Echte Datendatei: der eigentliche Praxisfall
(setq _datei (strcat (getenv "DXFMAKRO") "/data/json/geruest.json"))
(if (findfile _datei)
(progn
(setq _daten (ssg-json-laden _datei))
;; Drei Bereiche: Rohrabhaenger, Saeulen (1 und 2 Zoll zusammengefuehrt),
;; Wandbefestigung
(tu-eq "json/geruest-baugruppen" 3 (length _daten))
;; Baugruppe ueber das ASCII-Feld "id" finden (aeusserer Schluessel
;; traegt Umlaute bzw. Anfuehrungszeichen)
(setq _bg nil)
(foreach _e _daten
(if (and (null _bg) (= (ssg-json-get (cdr _e) "id") "Rohrabhaenger"))
(setq _bg (cdr _e))))
(tu-eq "json/geruest-id-gefunden" T (if _bg T nil))
(if _bg
(progn
(setq _var (ssg-json-get _bg "geometrie_varianten"))
(setq _anb (ssg-json-get _bg "anbaugruppen"))
(tu-eq "json/geruest-varianten" 3 (length _var))
(tu-eq "json/geruest-teileart" "Geruest Rohrabhaenger"
(ssg-json-get _bg "teileart"))
(tu-eq "json/geruest-dummy" "Rohrabhaenger_dummy.dwg"
(ssg-json-get _bg "dummy"))
;; Sivas-ID als Zahl geparst, Laengengrenze aus dem attribute-Block
(tu-eq "json/geruest-sivas" 821006026
(ssg-json-get (car (ssg-json-get (car _var) "teile")) "sivas_id"))
(tu-eq "json/geruest-max" 6000
(ssg-json-get (ssg-json-get (ssg-json-get _bg "attribute") "Laenge") "max"))
)
)
)
(tu-record nil "json/geruest-datei" (strcat "nicht gefunden: " _datei))
)
)
;; ------------------------------------------------------------
;; TESTS: GeruestInsert.lsp - reine Hilfsfunktionen
;; ------------------------------------------------------------
(defun tu-tests-geruest ( / _eintrag _gruppe _teile _konfig _rec _pfad _f
_zurueck _bgtest _saeulen)
(princ "\n[GeruestInsert]")
;; GeruestInsert ist ein lazy Feature-Modul (nicht in der Core-Ladeliste).
;; Geladen wird es zentral in test_unit.scr auf .scr-Top-Level; hier nur
;; pruefen, ob es da ist (siehe Kopfkommentar zur Ladearchitektur).
(if (null (atoms-family 1 '("GERUEST-ARTIKELNUMMERN")))
(tu-record nil "geruest/modul" "GeruestInsert.lsp nicht geladen")
(progn
(tu-eq "geruest-id-string/int" "821006026" (geruest-id-string 821006026))
(tu-eq "geruest-id-string/str" "0_B10071" (geruest-id-string "0_B10071"))
(tu-eq "geruest-id-string/nil" nil (geruest-id-string nil))
;; Einzelteil mit menge 2 -> Artikelnummer zweimal (ARTINR-Regel)
(setq _eintrag (ssg-json-parse
"{\"artikel\": \"X\", \"sivas_id\": 825002019, \"menge\": 2}"))
(tu-eq "geruest-artnr/menge2" '("825002019" "825002019")
(geruest-artikelnummern _eintrag))
(tu-eq "geruest-name/artikel" "X" (geruest-eintrag-name _eintrag))
;; Benannte Gruppe -> teile rekursiv aufloesen, Mengen beachten
(setq _gruppe (ssg-json-parse
(strcat "{\"name\": \"Schraubenset\", \"teile\": ["
"{\"artikel\": \"A\", \"sivas_id\": 111, \"menge\": 1},"
"{\"artikel\": \"B\", \"sivas_id\": 222, \"menge\": 2}]}")))
(tu-eq "geruest-artnr/gruppe" '("111" "222" "222")
(geruest-artikelnummern _gruppe))
(tu-eq "geruest-name/gruppe" "Schraubenset" (geruest-eintrag-name _gruppe))
;; Fehlendes menge-Feld -> 1
(tu-eq "geruest-artnr/ohne-menge" '("333")
(geruest-artikelnummern
(ssg-json-parse "{\"artikel\": \"C\", \"sivas_id\": 333}")))
;; --- Mengenfeld ---
(tu-eq "geruest-zahl-p/ziffern" T (geruest-zahl-p "12"))
(tu-eq "geruest-zahl-p/text" nil (geruest-zahl-p "1a"))
(tu-eq "geruest-zahl-p/leer" nil (geruest-zahl-p ""))
;; Leeres Feld uebernimmt die JSON-Vorgabe, ungueltiges liefert nil
(tu-eq "geruest-menge-wert/leer" 2 (geruest-menge-wert "" 2))
(tu-eq "geruest-menge-wert/zahl" 5 (geruest-menge-wert "5" 2))
(tu-eq "geruest-menge-wert/null" nil (geruest-menge-wert "0" 2))
(tu-eq "geruest-menge-wert/text" nil (geruest-menge-wert "abc" 2))
(tu-eq "geruest-menge-wert/negativ" nil (geruest-menge-wert "-3" 2))
;; --- Stueckzahl ersetzt die JSON-Menge (Einzelteil) ---
(tu-eq "geruest-artnr-n/einzelteil" '("825002019" "825002019" "825002019")
(geruest-artikelnummern-n _eintrag 3))
;; --- Gruppe: ganzes Set n-mal, Mengen INNERHALB bleiben erhalten ---
(tu-eq "geruest-artnr-n/gruppe" '("111" "222" "222" "111" "222" "222")
(geruest-artikelnummern-n _gruppe 2))
;; --- DCL-Label: Anfuehrungszeichen wuerde die Datei zerstoeren ---
(tu-eq "geruest-dcl-label/quote" "ROHRKLAMMER 1'' KPL. VERTIKAL"
(geruest-dcl-label "ROHRKLAMMER 1\" KPL. VERTIKAL"))
(tu-eq "geruest-dcl-label/ohne" "WINKEL 60X60X6X60"
(geruest-dcl-label "WINKEL 60X60X6X60"))
;; --- Hilfslisten ---
(tu-eq "geruest-nil-liste" '(nil nil nil) (geruest-nil-liste 3))
(tu-eq "geruest-liste-setzen" '(nil 7 nil)
(geruest-liste-setzen (geruest-nil-liste 3) 1 7))
(tu-eq "geruest-alist-setzen/neu" '(("a" . 1))
(geruest-alist-setzen nil "a" 1))
(tu-eq "geruest-alist-setzen/ersetzt" '(("a" . 2))
(geruest-alist-setzen '(("a" . 1)) "a" 2))
(tu-eq "geruest-zahl-string/int" "2000" (geruest-zahl-string 2000))
(tu-eq "geruest-zahl-string/leer" "" (geruest-zahl-string nil))
;; --- Konfiguration auf Anbauteile abbilden ---
(setq _teile (list _eintrag _gruppe))
(tu-eq "geruest-name-index/treffer" 1
(geruest-name-index "Schraubenset" _teile))
(tu-eq "geruest-name-index/fehlt" nil
(geruest-name-index "gibt es nicht" _teile))
;; Bekanntes Teil wird uebernommen, unbekanntes uebersprungen (nicht
;; die ganze Konfiguration verworfen)
(setq _konfig (ssg-json-parse
(strcat "{\"name\": \"K1\", \"oben\": ["
"{\"artikel\": \"Schraubenset\", \"menge\": 3},"
"{\"artikel\": \"unbekannt\", \"menge\": 1}]}")))
(tu-eq "geruest-konfig-position" '(nil 3)
(geruest-konfig-position _konfig "oben" _teile))
;; --- Variante gewinnt vor Baugruppe (TEILEART/dummy) ---
;; Die zusammengefuehrte Saeulen-Baugruppe unterscheidet 1 Zoll und
;; 2 Zoll nur noch ueber das teileart-Feld der Variante.
(setq _bgtest (ssg-json-parse
"{\"teileart\": \"Basis\", \"dummy\": \"basis.dwg\"}"))
(tu-eq "geruest-variante-wert/variante-gewinnt" "Speziell"
(geruest-variante-wert
(ssg-json-parse "{\"teileart\": \"Speziell\"}") _bgtest "teileart"))
(tu-eq "geruest-variante-wert/rueckfall" "Basis"
(geruest-variante-wert
(ssg-json-parse "{\"name\": \"X\"}") _bgtest "teileart"))
(tu-eq "geruest-variante-wert/ohne-variante" "basis.dwg"
(geruest-variante-wert nil _bgtest "dummy"))
;; --- Zusammengefuehrte Saeulen-Baugruppe ---
(setq _saeulen nil)
(foreach _e (geruest-baugruppen-liste)
(if (equal (car _e) "Saeulen") (setq _saeulen (cdr _e))))
(tu-eq "geruest/saeulen-vorhanden" T (if _saeulen T nil))
(if _saeulen
(progn
(tu-eq "geruest/saeulen-varianten" 6
(length (ssg-json-get _saeulen "geometrie_varianten")))
(tu-eq "geruest/saeulen-anbauteile" 7
(length (ssg-json-get _saeulen "anbaugruppen")))
(tu-eq "geruest/saeulen-titel" "Saeulen" (geruest-titel _saeulen))
;; R 1" ist die erste Variante und traegt die eigene TEILEART
(tu-eq "geruest/saeulen-1zoll-teileart" "Geruest Saeule 1 Zoll"
(geruest-variante-wert
(car (ssg-json-get _saeulen "geometrie_varianten"))
_saeulen "teileart"))
)
)
;; --- Rundlauf Schreiber -> Parser ---
;; Prueft den Konfigurations-Schreiber ohne BricsCAD-Dialog. Bewusst in
;; eine temporaere Datei: ein Test darf cfg/geruest_user.json nicht
;; ueberschreiben. Die Testdaten enthalten absichtlich Anfuehrungs-
;; zeichen - genau daran wuerde eine fehlende Maskierung scheitern.
(setq _rec
(list (cons "name" "Mein \"Satz\"")
(cons "variante" "ROHR R 1\" 33,7 x 2,6")
(cons "laenge" "2000")
(cons "teilefarbe" "RAL 7035 Lichtgrau")
(cons "oben" (list (list (cons "artikel" "ROHRKLAMMER 1\" KPL. VERTIKAL")
(cons "menge" 2))))
(cons "unten" nil)))
(setq _pfad (vl-filename-mktemp "grtest" nil ".json"))
(setq _f (open _pfad "w"))
(write-line "{ \"Test\": [" _f)
(geruest-konfig-liste-schreiben _f (list _rec))
(write-line "] }" _f)
(close _f)
(setq _zurueck (car (ssg-json-get (ssg-json-laden _pfad) "Test")))
(vl-file-delete _pfad)
(tu-eq "geruest-schreiber/name" "Mein \"Satz\""
(ssg-json-get _zurueck "name"))
(tu-eq "geruest-schreiber/variante" "ROHR R 1\" 33,7 x 2,6"
(ssg-json-get _zurueck "variante"))
(tu-eq "geruest-schreiber/laenge" "2000"
(ssg-json-get _zurueck "laenge"))
(tu-eq "geruest-schreiber/farbe" "RAL 7035 Lichtgrau"
(ssg-json-get _zurueck "teilefarbe"))
(tu-eq "geruest-schreiber/oben-artikel" "ROHRKLAMMER 1\" KPL. VERTIKAL"
(ssg-json-get (car (ssg-json-get _zurueck "oben")) "artikel"))
(tu-eq "geruest-schreiber/oben-menge" 2
(ssg-json-get (car (ssg-json-get _zurueck "oben")) "menge"))
(tu-eq "geruest-schreiber/unten-leer" nil
(ssg-json-get _zurueck "unten"))
)
)
)
;; ------------------------------------------------------------
;; TESTS: count_sep_scan.lsp - geometrische Sensor-Zuordnung
;;
;; Testet die durch die Zerlegung von cs-zuordnung-lauf isolierte,
;; rein funktionale Kernlogik: Carrier-Records sind plain Listen
;; (ename tagS tagP minx miny maxx maxy cx cy id label), Sensoren
;; sind Punkte (x y). Kein ssget/entget/entmod - der ename an
;; Position 0 wird von den Geometrie-Routinen nie dereferenziert,
;; darum genuegt ein Symbol-Platzhalter. *senstol* wird fuer
;; deterministische Ergebnisse explizit gesetzt (sonst cfg-abhaengig).
;; ------------------------------------------------------------
;; Record-Konstruktor fuers Testen: baut einen Carrier-Record so, wie
;; ihn cs-sammle-bloecke liefert - nur die Box-/Zentrum-/ID-Felder
;; (Index 3-9), die die Geometrie-Routinen lesen, sind relevant; ename
;; und label sind reine Platzhalter.
;; (name minx miny maxx maxy id) -> voller Carrier-Record
(defun tu-mk-carr (name minx miny maxx maxy id)
(list name "ANZAHL_SCANNER" "ANZAHL_SEPARATOR"
minx miny maxx maxy
(/ (+ minx maxx) 2.0) (/ (+ miny maxy) 2.0)
id (strcat "L-" name)))
(defun tu-tests-sepscan ( / _senstol-alt _a _b _c _carr _grid _res)
(princ "\n[count_sep_scan]")
;; count_sep_scan ist ein lazy Feature-Modul (nicht in der Core-Ladeliste).
;; Geladen wird es zentral in test_unit.scr auf .scr-Top-Level; hier nur
;; pruefen, ob es da ist (siehe Kopfkommentar zur Ladearchitektur).
(if (null (atoms-family 1 '("CS-RESOLVE-SENSOR")))
(tu-record nil "sepscan/modul" "count_sep_scan.lsp nicht geladen")
(progn
(setq _senstol-alt (if (boundp '*senstol*) *senstol*))
(setq *senstol* 0.0)
;; --- cs-in-box: Punkt in Carrier-Box (X/Y, Z ignoriert) ---
(setq _a (tu-mk-carr "A" 0.0 0.0 100.0 100.0 "0001"))
(tu-true "cs-in-box/mitte" (cs-in-box '(50.0 50.0) _a))
(tu-true "cs-in-box/rand" (cs-in-box '(0.0 0.0) _a))
(tu-nil "cs-in-box/ausserhalb-x" (cs-in-box '(150.0 50.0) _a))
(tu-nil "cs-in-box/ausserhalb-y" (cs-in-box '(50.0 -1.0) _a))
;; --- *senstol* vergroessert die Box ---
(setq *senstol* 10.0)
(tu-true "cs-in-box/toleranz-innen" (cs-in-box '(105.0 50.0) _a))
(tu-nil "cs-in-box/toleranz-aussen" (cs-in-box '(111.0 50.0) _a))
(setq *senstol* 0.0)
;; --- cs-bump: Zaehler je ename hochzaehlen ---
(tu-eq "cs-bump/neu" '(("k" . 1)) (cs-bump nil "k"))
(tu-eq "cs-bump/erhoeht" '(("k" . 2)) (cs-bump '(("k" . 1)) "k"))
(tu-eq "cs-bump/zweiter-key"
'(("m" . 1) ("k" . 1)) (cs-bump '(("k" . 1)) "m"))
;; --- cs-carrier-by-id: Record ueber ID (Feld 9) finden ---
(setq _b (tu-mk-carr "B" 200.0 0.0 300.0 100.0 "0002"))
(setq _carr (list _a _b))
(tu-eq "cs-carrier-by-id/treffer" _b (cs-carrier-by-id "0002" _carr))
(tu-nil "cs-carrier-by-id/fehlt" (cs-carrier-by-id "9999" _carr))
(tu-nil "cs-carrier-by-id/leer" (cs-carrier-by-id "" _carr))
(tu-nil "cs-carrier-by-id/nil" (cs-carrier-by-id nil _carr))
;; --- cs-assign: BBox-Zuordnung ueber das Grid ---
;; Zwei getrennte Boxen: Punkt in genau einer -> diese.
(setq _grid (cs-grid-build _carr))
(tu-eq "cs-assign/box-a" _a (cs-assign '(50.0 50.0) _grid))
(tu-eq "cs-assign/box-b" _b (cs-assign '(250.0 50.0) _grid))
(tu-nil "cs-assign/keine-box" (cs-assign '(1000.0 1000.0) _grid))
;; Ueberlappende Boxen -> naechstes Box-Zentrum gewinnt (Tiebreak).
;; C: 0..100, D: 40..200; Punkt (45,50) liegt in beiden,
;; C-Zentrum (50,50) ist naeher als D-Zentrum (120,50).
(setq _a (tu-mk-carr "C" 0.0 0.0 100.0 100.0 "0003"))
(setq _b (tu-mk-carr "D" 40.0 0.0 200.0 100.0 "0004"))
(setq _grid (cs-grid-build (list _a _b)))
(tu-eq "cs-assign/overlap-naechstes-zentrum"
_a (cs-assign '(45.0 50.0) _grid))
;; --- cs-nearest-two: die zwei naechsten Carrier nach Zentrum ---
;; Zentren: A(50,50) B(250,50) C(50,250). Punkt (60,60):
;; naechster A, zweiter B (dx 190 < dy 190? -> Abstand B=~194, C=~190).
(setq _a (tu-mk-carr "A" 0.0 0.0 100.0 100.0 "0001"))
(setq _b (tu-mk-carr "B" 200.0 0.0 300.0 100.0 "0002"))
(setq _c (tu-mk-carr "C" 0.0 200.0 100.0 300.0 "0003"))
(setq _res (cs-nearest-two '(60.0 60.0) (list _a _b _c)))
(tu-eq "cs-nearest-two/naechster" _a (nth 0 _res))
(tu-true "cs-nearest-two/zweiter-vorhanden" (nth 2 _res))
;; Abstand zum naechsten (A-Zentrum 50,50) = sqrt(10^2+10^2) ~ 14.14
(tu-eqf "cs-nearest-two/best-dist"
(distance '(60.0 60.0) '(50.0 50.0)) (nth 1 _res))
;; Nur ein Carrier -> zweiter ist nil.
(setq _res (cs-nearest-two '(60.0 60.0) (list _a)))
(tu-eq "cs-nearest-two/einzeln-best" _a (nth 0 _res))
(tu-nil "cs-nearest-two/einzeln-kein-zweiter" (nth 2 _res))
;; --- cs-resolve-sensor: der Entscheider bbox/distance/none ---
;; Punkt in einer Box -> modus 'bbox, kein Distanzfeld.
(setq _grid (cs-grid-build (list _a _b _c)))
(setq _res (cs-resolve-sensor '(50.0 50.0) (list _a _b _c) _grid))
(tu-eq "cs-resolve/bbox-modus" 'bbox (nth 0 _res))
(tu-eq "cs-resolve/bbox-rec" _a (nth 1 _res))
(tu-nil "cs-resolve/bbox-kein-dist" (nth 2 _res))
;; Punkt ausserhalb aller Boxen, aber Carrier vorhanden -> 'distance.
(setq _res (cs-resolve-sensor '(1000.0 1000.0) (list _a _b _c) _grid))
(tu-eq "cs-resolve/distance-modus" 'distance (nth 0 _res))
(tu-true "cs-resolve/distance-rec" (nth 1 _res))
(tu-true "cs-resolve/distance-dist" (nth 2 _res))
;; Gar keine Carrier -> 'none.
(setq _grid (cs-grid-build nil))
(setq _res (cs-resolve-sensor '(50.0 50.0) nil _grid))
(tu-eq "cs-resolve/none-modus" 'none (nth 0 _res))
(tu-nil "cs-resolve/none-rec" (nth 1 _res))
;; *senstol* wieder herstellen
(setq *senstol* _senstol-alt)
)
)
)
;; ------------------------------------------------------------
;; REPORT SCHREIBEN
;; ------------------------------------------------------------
(defun tu-write-report (pfad / f res)
(setq f (open pfad "w"))
(if f
(progn
(write-line "# SSG_LIB LISP Unit-Test Report" f)
(foreach res (reverse *tu-results*)
(write-line
(strcat (if (car res) "PASS: " "FAIL: ") (cadr res)
(if (car res) "" (strcat " | " (caddr res))))
f))
(write-line (strcat "SUMMARY: total=" (itoa (+ *tu-pass* *tu-fail*))
" passed=" (itoa *tu-pass*)
" failed=" (itoa *tu-fail*)) f)
(write-line (if (= *tu-fail* 0) "RESULT: OK" "RESULT: FAIL") f)
(close f)
T
)
nil
)
)
;; ------------------------------------------------------------
;; BEFEHL: TEST_UNIT
;; ------------------------------------------------------------
;; Testblock geschuetzt aufrufen: ein harter LISP-Fehler in einem Block
;; wird als FAIL erfasst, statt c:TEST_UNIT abzubrechen und damit den
;; Report zu verhindern. Der Blockname (String) wird per read zur Funktion.
(defun tu-run-block (fn / res)
(setq res (vl-catch-all-apply (read fn) nil))
(if (vl-catch-all-error-p res)
(tu-record nil (strcat fn "/ausfuehrung")
(strcat "harter Fehler: " (vl-catch-all-error-message res))))
)
(defun c:TEST_UNIT ( / out-dir report)
(tu-reset)
(princ "\n================================================================")
(princ "\n TEST_UNIT - LISP-Standardfunktionen")
(princ "\n================================================================")
(foreach fn '("tu-tests-core" "tu-tests-lang" "tu-tests-id" "tu-tests-vfcore"
"tu-tests-export" "tu-tests-gf" "tu-tests-omni" "tu-tests-kreisel"
"tu-tests-sepliste" "tu-tests-json" "tu-tests-geruest"
"tu-tests-sepscan")
(tu-run-block fn))
(princ "\n\n----------------------------------------------------------------")
(princ (strcat "\n Gesamt: " (itoa (+ *tu-pass* *tu-fail*))
" | PASS: " (itoa *tu-pass*)
" | FAIL: " (itoa *tu-fail*)))
(princ (if (= *tu-fail* 0) "\n ERGEBNIS: ALLE TESTS BESTANDEN" "\n ERGEBNIS: TESTS FEHLGESCHLAGEN"))
(princ "\n----------------------------------------------------------------")
;; Report-Datei schreiben (fuer run_tests.bat --lisp)
(setq out-dir (strcat (getenv "DXFMAKRO") "/tests/output"))
(vl-mkdir out-dir)
(setq report (strcat out-dir "/unit_results.txt"))
(if (tu-write-report report)
(princ (strcat "\n Report: " report))
(princ "\n WARNUNG: Report konnte nicht geschrieben werden.")
)
(princ)
)
(princ "\ntest_unit.lsp geladen. Befehl: TEST_UNIT")
(princ)
Reference in New Issue View Git Blame Copy Permalink