dxfmakros/Lisp/LagerPruefung.lsp

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