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

Lisp/LagerPruefung.lsp

@@ -0,0 +1,234 @@
+;; ============================================================
+;; LagerPruefung.lsp - Regelprofile der Lagerplanung (Phase 0)
+;;
+;; Laedt das Laenderprofil cfg/regelwerk/<LAND>.json, loest die Vererbung
+;; (erbt_von) auf und liefert je Regel den STRENGSTEN Wert aller Quellen,
+;; deren Bedingung zutrifft - mit Protokoll, welche Quelle gewonnen hat.
+;; Jede Pruefregel der Lagerplanung wird genau einmal hier implementiert
+;; (Python rendert nur, siehe doc/plan/lager_rfq.md).
+;;
+;; Spaetere Phasen (Treppen-/Leiterpruefung, Fluchtweg, Verstoss-Marker,
+;; LAGER_PRUEFEN) kommen in dieses Modul.
+;;
+;; Profil-Format (Auszug):
+;;   {"land": "DE", "erbt_von": null, "gepflegt": true,
+;;    "regeln": [{"id": "treppe.steigung_max", "art": "max", "einheit": "mm",
+;;                "werte": [{"wert": 190, "quelle": "ASR A1.8", "abschnitt": "4.5",
+;;                           "fassung": "...", "bedingung": "...", "verifiziert": false}]}]}
+;;   art = "min"  -> Mindestwert, strengster = groesster
+;;         "max"  -> Hoechstwert, strengster = kleinster
+;;         "wert" -> fester Wert, der erste zutreffende gilt
+;;   Ein Eintrag mit "tabelle" [[bis, wert] ...] + "tabellen_schluessel" liefert
+;;   den Wert der ersten Zeile, deren "bis" den Kontextwert abdeckt.
+;;   "bedingung": "<schluessel> <op> <wert>", op = = <= >= < >. Fehlt der
+;;   Schluessel im Kontext, wird der Eintrag KONSERVATIV mit einbezogen
+;;   (Protokoll: "Bedingung nicht auswertbar").
+;; ============================================================
+
+(if (not (boundp '*lg-profil-cache*)) (setq *lg-profil-cache* nil))
+
+;; ------------------------------------------------------------
+;; Profil laden
+;; ------------------------------------------------------------
+
+(defun lg-regelwerk-pfad (land / cfg)
+  (setq cfg (getenv "DXFM_CFG"))
+  (if cfg
+    (strcat (vl-string-right-trim "/\\" (vl-string-translate "\\" "/" cfg))
+            "/regelwerk/" (strcase land) ".json"))
+)
+
+;; Zwei Profile mischen: Regeln von kind ersetzen gleichnamige (id) von
+;; basis vollstaendig, neue kommen hinzu. Kopf-Felder (land, gepflegt ...)
+;; kommen vom Kind. Reine Funktion.
+(defun lg-profil-mischen (basis kind / regeln r id alt)
+  (setq regeln (ssg-json-get basis "regeln"))
+  (foreach r (ssg-json-get kind "regeln")
+    (setq id (ssg-json-get r "id"))
+    (if (setq alt (vl-some '(lambda (x) (if (= (ssg-json-get x "id") id) x)) regeln))
+      (setq regeln (subst r alt regeln))
+      (setq regeln (append regeln (list r))))
+  )
+  (cons (cons "regeln" regeln)
+        (vl-remove-if '(lambda (p) (= (car p) "regeln")) kind))
+)
+
+;; Profil inkl. Vererbung laden (rekursiv, Zirkelschutz ueber besucht).
+;; Rueckgabe: gemischtes Profil (Alist) oder nil.
+(defun lg-profil-laden-roh (land besucht / pfad daten basis-land basis)
+  (setq pfad (lg-regelwerk-pfad land))
+  (if (and pfad (findfile pfad)
+           (not (member (strcase land) besucht)))
+    (progn
+      (setq daten (ssg-json-laden pfad))
+      (setq basis-land (ssg-json-get daten "erbt_von"))
+      (if (and basis-land (= (type basis-land) 'STR) (/= basis-land ""))
+        (progn
+          (setq basis (lg-profil-laden-roh basis-land (cons (strcase land) besucht)))
+          (if basis (lg-profil-mischen basis daten) daten))
+        daten)
+    )
+  )
+)
+
+;; Gecachtes Profil des Landes. Meldet ein nicht gepflegtes Profil einmalig.
+(defun lg-profil (land / eintrag profil)
+  (if (null land) (setq land "DE"))
+  (setq eintrag (assoc (strcase land) *lg-profil-cache*))
+  (if eintrag
+    (cdr eintrag)
+    (progn
+      (setq profil (lg-profil-laden-roh land nil))
+      (if (null profil)
+        (princ (ssg-textf "lg-regel-profil-fehlt" (list land (lg-regelwerk-pfad land))))
+        (if (not (ssg-json-get profil "gepflegt"))
+          (princ (ssg-textf "lg-regel-profil-ungepflegt" (list land)))))
+      (setq *lg-profil-cache* (cons (cons (strcase land) profil) *lg-profil-cache*))
+      profil
+    )
+  )
+)
+
+(defun lg-profil-reset ( / ) (setq *lg-profil-cache* nil) (princ))
+
+(defun lg-regel-finden (profil id)
+  (vl-some '(lambda (r) (if (= (ssg-json-get r "id") id) r))
+           (ssg-json-get profil "regeln"))
+)
+
+;; ------------------------------------------------------------
+;; Aufloesung (reine Funktionen)
+;; ------------------------------------------------------------
+
+;; Kontextwert als Zahl, falls moeglich (Strings wie "3100" werden gewandelt).
+(defun lg-kontext-zahl (v)
+  (cond
+    ((numberp v) (float v))
+    ;; NICHT ((and (= (type v) 'STR) (distof v 2))) - and liefert T statt der Zahl
+    ((= (type v) 'STR) (distof v 2))
+    (T nil)
+  )
+)
+
+;; Bedingung pruefen. Rueckgabe: 'ja, 'nein oder 'unbekannt (Schluessel fehlt
+;; im Kontext oder Bedingung nicht lesbar).
+(defun lg-bedingung-pruefen (bedingung kontext / ops op pos key wert ist a b)
+  (if (or (null bedingung) (= bedingung ""))
+    'ja
+    (progn
+      ;; laengere Operatoren zuerst, sonst wird "<=" als "<" gelesen
+      (setq ops '("<=" ">=" "=" "<" ">") op nil)
+      (foreach o ops
+        (if (and (null op) (setq pos (vl-string-search o bedingung)))
+          (setq op o
+                key  (vl-string-trim " " (substr bedingung 1 pos))
+                wert (vl-string-trim " " (substr bedingung (+ pos 1 (strlen o)))))))
+      (cond
+        ((null op) 'unbekannt)
+        ((null (setq ist (cdr (assoc key kontext)))) 'unbekannt)
+        ((= op "=")
+          (if (and (lg-kontext-zahl ist) (lg-kontext-zahl wert))
+            (if (equal (lg-kontext-zahl ist) (lg-kontext-zahl wert) 1e-9) 'ja 'nein)
+            (if (= (strcase (vl-princ-to-string ist)) (strcase wert)) 'ja 'nein)))
+        ((and (setq a (lg-kontext-zahl ist)) (setq b (lg-kontext-zahl wert)))
+          (if (cond ((= op "<=") (<= a b)) ((= op ">=") (>= a b))
+                    ((= op "<") (< a b))   ((= op ">") (> a b)))
+            'ja 'nein))
+        (T 'unbekannt)
+      )
+    )
+  )
+)
+
+;; Wert eines Eintrags (fester Wert oder Tabellenzeile). nil, wenn der
+;; Tabellenschluessel im Kontext fehlt oder ueber der letzten Zeile liegt
+;; (dann die letzte Zeile = groesster Tabellenwert, konservativ).
+(defun lg-eintrag-wert (eintrag kontext / tab k n erg)
+  (setq tab (ssg-json-get eintrag "tabelle"))
+  (if (null tab)
+    (ssg-json-get eintrag "wert")
+    (progn
+      (setq k (ssg-json-get eintrag "tabellen_schluessel")
+            n (lg-kontext-zahl (cdr (assoc k kontext))))
+      (if (null n)
+        ;; Schluessel fehlt -> konservativ der groesste Tabellenwert
+        (apply 'max (mapcar 'cadr tab))
+        (progn
+          (setq erg (vl-some '(lambda (z) (if (<= n (car z)) (cadr z))) tab))
+          (if erg erg (cadr (last tab))))))
+  )
+)
+
+;; Text "Quelle Abschnitt (Fassung)" eines Eintrags fuer das Protokoll.
+(defun lg-eintrag-quelle (eintrag / q a f)
+  (setq q (cond ((ssg-json-get eintrag "quelle")) ("?"))
+        a (ssg-json-get eintrag "abschnitt")
+        f (ssg-json-get eintrag "fassung"))
+  (strcat q (if a (strcat " " a) "") (if f (strcat " (" f ")") ""))
+)
+
+;; Regel aufloesen. kontext = Alist (("brandgefaehrdung" . "normal") ...).
+;; Rueckgabe: (wert gewinner-eintrag protokoll) oder nil, wenn kein Eintrag
+;; zutrifft. protokoll = Liste von Strings (je Kandidat eine Zeile + Ergebnis).
+(defun lg-regel-aufloesen (regel kontext / art kandidaten prot status w best)
+  (setq art (cond ((ssg-json-get regel "art")) ("wert"))
+        kandidaten nil prot nil)
+  (foreach e (ssg-json-get regel "werte")
+    (setq status (lg-bedingung-pruefen (ssg-json-get e "bedingung") kontext)
+          w      (lg-eintrag-wert e kontext))
+    (cond
+      ((eq status 'nein)
+        (setq prot (cons (strcat "nicht anwendbar: " (lg-eintrag-quelle e)
+                                 " [" (ssg-json-get e "bedingung") "]") prot)))
+      ((null w) nil)
+      (T
+        (setq kandidaten (append kandidaten (list (cons w e))))
+        (setq prot (cons (strcat (vl-princ-to-string w) " " (lg-eintrag-quelle e)
+                                 (if (eq status 'unbekannt)
+                                   " [Bedingung nicht auswertbar - konservativ einbezogen]"
+                                   ""))
+                         prot)))
+    )
+  )
+  (if kandidaten
+    (progn
+      (setq best (car kandidaten))
+      (foreach k (cdr kandidaten)
+        (cond
+          ((and (= art "min") (> (car k) (car best))) (setq best k))
+          ((and (= art "max") (< (car k) (car best))) (setq best k))
+        )
+      )
+      (setq prot (cons (strcat "-> " (vl-princ-to-string (car best))
+                               " (" art ", strengster: " (lg-eintrag-quelle (cdr best)) ")")
+                       prot))
+      (list (car best) (cdr best) (reverse prot))
+    )
+  )
+)
+
+;; Bequemer Zugriff: Wert der Regel id im Profil des Landes (nil = unbekannt).
+(defun lg-regel-wert (id kontext land / regel erg)
+  (setq regel (lg-regel-finden (lg-profil land) id))
+  (if regel
+    (car (lg-regel-aufloesen regel kontext))
+    (progn (princ (ssg-textf "lg-regel-unbekannt" (list id))) nil))
+)
+
+;; Diagnose: alle Regeln des Landes mit Ergebnis und Protokoll in die Konsole.
+(defun c:LG_REGELN ( / land profil kontext erg)
+  (setq land (if (car (atoms-family 1 '("LG-LAND"))) (lg-land) "DE"))
+  (setq profil (lg-profil land))
+  (setq kontext (list (cons "brandgefaehrdung" "erhoeht_ohne_loeschanlage")))
+  (princ (ssg-textf "lg-regel-liste-kopf" (list land (itoa (length (ssg-json-get profil "regeln"))))))
+  (foreach r (ssg-json-get profil "regeln")
+    (setq erg (lg-regel-aufloesen r kontext))
+    (princ (strcat "\n  " (ssg-json-get r "id") " = "
+                   (if erg (vl-princ-to-string (car erg)) "-")
+                   " " (cond ((ssg-json-get r "einheit")) (""))))
+    (foreach z (caddr erg) (princ (strcat "\n      " z)))
+  )
+  (princ)
+)
+
+(princ)