;; ============================================================
;; LagerInsert.lsp - Lagerplanung GOH-Buehnenlager (Phase 1: Mengen, 2D)
;;
;; Erzeugt parametrische Attributbloecke fuer ein mehrgeschossiges
;; Haengewarenlager und sammelt daraus die Mengen fuer die RFQ-YAML
;; (Overlay, siehe doc/plan/lager_rfq.md):
;;
;;   LG_GESCHOSS          Geschoss-Kopfsymbol, verknuepft mit seiner Belagskontur
;;   LG_BEREICH           Lagerbereich (Kontur + Parameter), fuellt sich selbst
;;                        mit Regalreihen und Gaengen (Auto-Fuellung)
;;   LG_REIHE_<L>_<T>     Regalreihe (Rechteck L x T + Schienenlinie)
;;   LG_GANG_<L>_<B>_<BELAG>  Gang/Quergang/Randgang (Rechteck L x B, Schraffur
;;                        je Belag aus lager.json belag_schraffur)
;;   goh_rack             parametrischer BricsCAD-Block (Bestand), wird als
;;                        Regalreihe mitgezaehlt (lg-racks-sammeln)
;;
;; Befehle: LG_GESCHOSS, LG_GESCHOSS_AKTIV, LG_GESCHOSS_KOPIEREN, LG_BEREICH,
;;          LG_REIHE, LG_GANG, LG_EDIT, LG_REGALE, LAGER_EXPORT, LAGER_HAND_YAML
;;
;; Grundsaetze (CLAUDE.md):
;; - Alle Werte selbstbeschreibend in mm/Grad, keine Index-Codes.
;; - Verknuepfungen (Kontur <-> Block, Kind -> Bereich) als XDATA-Handles
;;   (App SSG_LG), nie in .dbg.
;; - Jeder Block traegt ID, GESCHOSS, LAYER.
;; - Layer je Geschoss: Basis aus cfg/layer.cfg [lager] + "_G<nr>", damit
;;   LG_GESCHOSS_AKTIV die uebrigen Geschosse frieren kann.
;; - Blockdefinitionen entstehen per entmake (BLOCK...ENDBLK), Einfuegen per
;;   vla-InsertBlock in Weltkoordinaten - kein _.-BLOCK/_.INSERT, damit weder
;;   BKS noch ATTREQ/ATTDIA dazwischenfunken.
;; ============================================================

(vl-load-com)

;; Regelprofile aus LagerPruefung. Guarded Nachlade-Load fuer das isolierte
;; Laden dieses Moduls; im Normalfall hat die MNL es schon geladen.
(if (and (not (car (atoms-family 1 '("LG-REGEL-AUFLOESEN"))))
         (ssg-lisp-datei-pfad "LagerPruefung.lsp"))
  (load (ssg-lisp-datei-pfad "LagerPruefung.lsp") nil))

(setq *lg-app* "SSG_LG")
(if (not (boundp '*lg-daten*)) (setq *lg-daten* nil))

;; ============================================================
;; DATEN (data/json/lager.json)
;; ============================================================

(defun lg-daten-pfad ( / basis)
  (setq basis (cond ((getenv "DXFM_DATA") (vl-string-translate "\\" "/" (getenv "DXFM_DATA")))
                    ((getenv "DXFMAKRO")
                      (strcat (vl-string-translate "\\" "/" (getenv "DXFMAKRO")) "/data"))))
  (if basis (strcat (vl-string-right-trim "/" basis) "/json/lager.json"))
)

(defun lg-daten ( / pfad)
  (if (null *lg-daten*)
    (progn
      (setq pfad (lg-daten-pfad))
      (if (and pfad (findfile pfad))
        (setq *lg-daten* (ssg-json-laden pfad))
        (princ (ssg-textf "lg-daten-fehlt" (list (if pfad pfad "lager.json"))))))
  )
  *lg-daten*
)

;; Wert unter einem Schluesselpfad, z.B. (lg-vorgabe '("bereich" "gangbreite_mm") 1000)
(defun lg-vorgabe (pfad vorgabe / obj)
  (setq obj (lg-daten))
  (foreach k pfad (setq obj (if (listp obj) (ssg-json-get obj k))))
  (if (null obj) vorgabe obj)
)

(defun lg-land ( / l)
  (setq l (lg-vorgabe '("land") "DE"))
  (if (= (type l) 'STR) l "DE")
)

;; ============================================================
;; ZAHL-/TEXT-HELFER (rein, getestet in tests/test_unit.lsp)
;; ============================================================

;; Zahl aus String/Zahl, Komma wie Punkt. nil bei leer/ungueltig.
(defun lg-zahl (v / s)
  (cond
    ((numberp v) (float v))
    ((= (type v) 'STR)
      (setq s (vl-string-translate "," "." (vl-string-trim " \t" v)))
      (if (/= s "") (distof s 2)))
    (T nil)
  )
)

;; mm-Wert als Attributtext: ganze Zahl ohne Nachkommastelle, sonst eine
;; Stelle (unabhaengig von DIMZIN).
(defun lg-mm-str (w / r s)
  (if (null w)
    ""
    (progn
      (setq w (float w)
            r (if (< w 0) (fix (- w 0.5)) (fix (+ w 0.5))))
      (if (equal w r 1e-6)
        (itoa r)
        (progn
          (setq s (rtos w 2 1))
          (if (not (vl-string-search "." s)) (setq s (strcat s ".0")))
          s)))
  )
)

;; Auf ganze mm runden (Blocknamen und Geometrie muessen uebereinstimmen).
(defun lg-mm-runden (w)
  (float (if (< w 0) (fix (- w 0.5)) (fix (+ w 0.5))))
)

;; Haengeebenen "2300/1200;1100/1100" -> ((2300.0 1200.0) (1100.0 1100.0)).
;; Ungueltige Teile fallen weg; fehlende Warenlaenge = 0.
(defun lg-haengeebenen-parse (s / erg teil ab h w)
  (setq erg nil)
  (if (and s (= (type s) 'STR))
    (foreach teil (ssg-sepliste-split-feld s ";")
      (setq ab (ssg-sepliste-split-feld teil "/")
            h  (lg-zahl (car ab))
            w  (lg-zahl (cadr ab)))
      (if h (setq erg (cons (list h (if w w 0.0)) erg)))
    )
  )
  (reverse erg)
)

(defun lg-haengeebenen-string (ebenen)
  (ssg-join (mapcar '(lambda (e) (strcat (lg-mm-str (car e)) "/" (lg-mm-str (cadr e))))
                    ebenen)
            ";")
)

;; Haengeebenen auf n Ebenen begrenzen (goh_rack kennt nur die Anzahl):
;; die obersten n der Vorgabe. Fehlen Ebenen in der Vorgabe, bleibt es bei
;; dem, was da ist.
(defun lg-haengeebenen-n (s n / ebenen erg i)
  (setq ebenen (lg-haengeebenen-parse s) erg nil i 0)
  (while (and ebenen (< i n))
    (setq erg (cons (car ebenen) erg) ebenen (cdr ebenen) i (1+ i)))
  (lg-haengeebenen-string (reverse erg))
)

;; Feldwert pruefen/normalisieren. art: "mm" (Zahl >= 0), "mm_leer" (wie mm,
;; leer erlaubt), "int" (ganze Zahl >= 1), "int0" (>= 0), "grad" (beliebige
;; Zahl), "mm_vz" (mm mit Vorzeichen, z.B. Versatz), "text", "ebenen"
;; (Haengeebenen-Liste, mind. eine Ebene).
;; Rueckgabe: normalisierter String oder nil (ungueltig).
(defun lg-feld-pruefen (art s / w)
  (if (null s) (setq s ""))
  (setq s (vl-string-trim " \t" s))
  (cond
    ((= art "text") s)
    ((and (= art "mm_leer") (= s "")) "")
    ((member art '("mm" "mm_leer"))
      (if (and (setq w (lg-zahl s)) (>= w 0.0)) (lg-mm-str w)))
    ((member art '("grad" "mm_vz"))
      (if (setq w (lg-zahl s)) (lg-mm-str w)))
    ((member art '("int" "int0"))
      (if (and (setq w (lg-zahl s)) (equal w (fix w) 1e-9)
               (>= w (if (= art "int") 1 0)))
        (itoa (fix w))))
    ((= art "ebenen")
      (if (lg-haengeebenen-parse s) (lg-haengeebenen-string (lg-haengeebenen-parse s))))
    (T s)
  )
)

;; ============================================================
;; LAYER JE GESCHOSS
;; ============================================================

;; Basis-Layername eines Lager-Schluessels aus cfg/layer.cfg [lager].
;; Rueckgabe: (name . farbe), Rueckfall "LG_<Schluessel>" / Farbe 7.
(defun lg-layer-basis (schluessel / e)
  (setq e (ssg-layer-cfg-eintrag (ssg-layer-cfg-load) "lager" schluessel))
  (if e e (cons (strcat "LG_" schluessel) "7"))
)

;; Reiner Kern: Layername fuer Geschoss nr (nil/"" -> ohne Suffix).
(defun lg-layer-name (basis nr)
  (if (and nr (/= (vl-princ-to-string nr) ""))
    (strcat basis "_G" (vl-princ-to-string nr))
    basis)
)

;; Layer anlegen (Farbe nur bei Neuanlage) und Namen liefern.
(defun lg-layer (schluessel nr / b name)
  (setq b (lg-layer-basis schluessel)
        name (lg-layer-name (car b) nr))
  (ssg-make-layer name (cdr b) nil)
  name
)

;; ============================================================
;; ZEICHNUNGSWEITE EINSTELLUNGEN (Dictionary per vlax-ldata)
;; ============================================================

(defun lg-ldata-lesen (key / r)
  (setq r (vl-catch-all-apply 'vlax-ldata-get (list "SSG_LAGER" key)))
  (if (vl-catch-all-error-p r) nil r)
)

(defun lg-ldata-setzen (key wert)
  (vl-catch-all-apply 'vlax-ldata-put (list "SSG_LAGER" key wert))
  wert
)

;; ============================================================
;; XDATA (App SSG_LG): Folge von (1000 . schluessel) + Wertgruppe
;; (1005 = Handle, 1000 = Text). Gelesen als Alist (schluessel . wert).
;; ============================================================

(defun lg-regapp ()
  (if (not (tblsearch "APPID" *lg-app*)) (regapp *lg-app*))
)

;; paare = (("kontur" 1005 . "2A") ("rolle" 1000 . "reihe") ...)
(defun lg-xdata-setzen (ent paare / ed gruppen)
  (lg-regapp)
  (setq gruppen nil)
  (foreach p paare
    (setq gruppen (append gruppen (list (cons 1000 (car p)) (cons (cadr p) (cddr p))))))
  (setq ed (vl-remove-if '(lambda (g) (= (car g) -3)) (entget ent)))
  (entmod (append ed (list (list -3 (cons *lg-app* gruppen)))))
  (entupd ent)
)

(defun lg-xdata-lesen (ent / xd gruppen erg)
  (setq xd (assoc -3 (entget ent (list *lg-app*))))
  (setq gruppen (if xd (cdr (assoc *lg-app* (cdr xd)))))
  (setq erg nil)
  (while (cadr gruppen)
    (if (= (car (car gruppen)) 1000)
      (setq erg (cons (cons (cdr (car gruppen)) (cdr (cadr gruppen))) erg)))
    (setq gruppen (cddr gruppen))
  )
  (reverse erg)
)

(defun lg-xdata-wert (ent key) (cdr (assoc key (lg-xdata-lesen ent))))

(defun lg-handle (ent) (cdr (assoc 5 (entget ent))))

(defun lg-ent-aus-handle (h / e)
  (if (and h (setq e (handent h)) (entget e)) e)
)

;; ============================================================
;; BLOCKBAU
;; ============================================================

(defun lg-geom-linie (p1 p2)
  (list '(0 . "LINE") '(8 . "0") (cons 10 p1) (cons 11 p2))
)

(defun lg-geom-rechteck (x0 y0 x1 y1)
  (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 lg-geom-kreis (pt r)
  (list '(0 . "CIRCLE") '(8 . "0") (cons 10 pt) (cons 40 r))
)

;; ATTDEF fuer eine Blockdefinition. sichtbar = nil -> unsichtbar.
(defun lg-geom-attdef (tag wert pt hoehe sichtbar)
  (list '(0 . "ATTDEF") '(8 . "0") (cons 10 pt) (cons 40 hoehe)
        (cons 1 wert) (cons 3 tag) (cons 2 tag)
        (cons 70 (if sichtbar 0 1)))
)

;; Unsichtbare ATTDEFs fuer alle Tags eines Schemas ((TAG . vorgabe) ...).
(defun lg-attdefs-unsichtbar (schema / y erg)
  (setq y 0.0 erg nil)
  (foreach p schema
    (setq erg (cons (lg-geom-attdef (car p) "" (list 0.0 y 0.0) 50.0 nil) erg)
          y (- y 100.0)))
  (reverse erg)
)

(defun lg-blockdef-anlegen (bname ents)
  (entmake (list '(0 . "BLOCK") (cons 2 bname) '(70 . 2) '(10 0.0 0.0 0.0)))
  (foreach e ents (entmake e))
  (entmake '((0 . "ENDBLK")))
)

;; Objekte einer vorhandenen Blockdefinition (entget-Listen).
(defun lg-blockdef-objekte (bname / e ed erg)
  (setq e (cdr (assoc -2 (tblsearch "BLOCK" bname))) erg nil)
  (while (and e (setq ed (entget e)) (/= (cdr (assoc 0 ed)) "ENDBLK"))
    (setq erg (cons ed erg) e (entnext e)))
  (reverse erg)
)

;; Blockdefinition anlegen, falls sie fehlt. ents = entmake-Listen.
;; Altbestand: fehlen einer vorhandenen Definition ATTDEFs aus ents (Schema
;; wurde erweitert), wird sie neu definiert und per ATTSYNC auf die
;; Referenzen uebertragen - sonst verschluckt lg-attribute-setzen die neuen
;; Tags still.
(defun lg-blockdef (bname ents / vorhanden fehlt)
  (if (not (tblsearch "BLOCK" bname))
    (lg-blockdef-anlegen bname ents)
    (progn
      (setq vorhanden (mapcar '(lambda (ed) (strcase (cdr (assoc 2 ed))))
                              (vl-remove-if-not '(lambda (ed) (= (cdr (assoc 0 ed)) "ATTDEF"))
                                                (lg-blockdef-objekte bname))))
      (setq fehlt (vl-remove-if '(lambda (tg) (member tg vorhanden))
                    (mapcar '(lambda (e) (strcase (cdr (assoc 2 e))))
                            (vl-remove-if-not '(lambda (e) (= (cdr (assoc 0 e)) "ATTDEF")) ents))))
      (if fehlt
        (progn
          (lg-blockdef-anlegen bname ents)
          (vl-catch-all-apply '(lambda () (command "_.ATTSYNC" "_N" bname)))
          (princ (ssg-textf "lg-blockdef-ergaenzt" (list bname (ssg-join fehlt ", "))))))
    )
  )
  bname
)

(defun lg-modelspace ()
  (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
)

;; Wert zu einem Attribut-Tag aus werte (("TAG" . "wert") ...), Gross-/
;; Kleinschreibung egal: die Tags tragen gemischte Schreibweise
;; (HOEHE_BELAG_mm), Attribut-Tags gelten aber case-insensitiv.
(defun lg-wert-fuer-tag (tag werte / g)
  (setq g (strcase tag))
  (cdr (vl-some '(lambda (p) (if (= (strcase (car p)) g) p)) werte))
)

;; Block bei pt (WCS) mit Drehung rot (Bogenmass) einfuegen, Layer setzen,
;; Attribute aus werte (("TAG" . "wert") ...) eintragen.
;; Rueckgabe: ename oder nil.
(defun lg-block-einfuegen (bname pt rot layer werte / obj res w)
  (setq res
    (vl-catch-all-apply
      '(lambda ()
         (setq obj (vla-InsertBlock (lg-modelspace) (vlax-3d-point pt) bname 1.0 1.0 1.0 rot))
         (if layer (vla-put-Layer obj layer))
         (foreach a (vlax-invoke obj 'GetAttributes)
           (if (setq w (lg-wert-fuer-tag (vla-get-TagString a) werte))
             (vla-put-TextString a w)))
         (vlax-vla-object->ename obj))))
  (if (vl-catch-all-error-p res)
    (progn (princ (ssg-textf "lg-einfuegen-fehler" (list bname (vl-catch-all-error-message res)))) nil)
    res)
)

;; Attribute eines vorhandenen Blocks setzen (nur bestehende Tags).
(defun lg-attribute-setzen (ent werte / obj w)
  (setq obj (vlax-ename->vla-object ent))
  (foreach a (vlax-invoke obj 'GetAttributes)
    (if (setq w (lg-wert-fuer-tag (vla-get-TagString a) werte))
      (vla-put-TextString a w)))
  ent
)

;; Effektiver Blockname (unsere Bloecke sind nie dynamisch, aber
;; Benutzerkopien koennten es sein).
(defun lg-blockname (ent / r)
  (setq r (vl-catch-all-apply 'vla-get-EffectiveName (list (vlax-ename->vla-object ent))))
  (if (vl-catch-all-error-p r) (cdr (assoc 2 (entget ent))) r)
)

(defun lg-alle-bloecke (muster / ss i erg)
  (setq erg nil)
  (if (setq ss (ssget "_X" (list '(0 . "INSERT") (cons 2 muster))))
    (progn
      (setq i 0)
      (repeat (sslength ss)
        (setq erg (cons (ssname ss i) erg) i (1+ i)))))
  (reverse erg)
)

;; ============================================================
;; ATTRIBUT-SCHEMATA (Tag . Vorgabe)
;; ============================================================

(setq *lg-schema-geschoss*
  '(("ID" . "") ("GESCHOSS" . "") ("LAYER" . "") ("NR" . "") ("BEZEICHNUNG" . "")
    ("HOEHE_BELAG_mm" . "0") ("KONSTR_HOEHE_mm" . "") ("LICHTE_HOEHE_mm" . "")
    ("BELAG_ART" . "") ("PERSONEN" . "") ("BRANDGEFAEHRDUNG" . "")))

(setq *lg-schema-bereich*
  '(("ID" . "") ("GESCHOSS" . "") ("LAYER" . "") ("NR" . "")
    ("GANGBREITE_mm" . "") ("REGALTIEFE_mm" . "") ("REIHEN_JE_GANG" . "")
    ("SCHIENEN_JE_GANG" . "") ("QUERGANG_ABSTAND_mm" . "") ("QUERGANG_BREITE_mm" . "")
    ("RICHTUNG" . "") ("HAENGEEBENEN" . "") ("BELAG" . "")
    ("RANDGANG_N_mm" . "0") ("RANDGANG_O_mm" . "0") ("RANDGANG_S_mm" . "0") ("RANDGANG_W_mm" . "0")
    ("RESTBREITE_mm" . "")))

(setq *lg-schema-reihe*
  '(("ID" . "") ("GESCHOSS" . "") ("LAYER" . "") ("LAENGE" . "") ("TIEFE_mm" . "")
    ("HAENGEEBENEN" . "") ("SCHIENEN" . "") ("BEREICH" . "") ("QUELLE" . "")))

(setq *lg-schema-gang*
  '(("ID" . "") ("GESCHOSS" . "") ("LAYER" . "") ("LAENGE" . "") ("BREITE_mm" . "")
    ("ART" . "") ("BELAG" . "") ("BEREICH" . "") ("QUELLE" . "")))

;; ============================================================
;; GESCHOSSE
;; ============================================================

(defun lg-geschoss-blockdef ( / )
  (lg-blockdef "LG_GESCHOSS"
    (append
      (list (lg-geom-kreis '(0.0 0.0 0.0) 300.0)
            (lg-geom-linie '(-300.0 0.0 0.0) '(300.0 0.0 0.0)))
      ;; sichtbar: Nummer, Bezeichnung, Belagshoehe
      (list (lg-geom-attdef "NR" "" '(-120.0 40.0 0.0) 180.0 T)
            (lg-geom-attdef "BEZEICHNUNG" "" '(400.0 60.0 0.0) 150.0 T)
            (lg-geom-attdef "HOEHE_BELAG_mm" "" '(400.0 -200.0 0.0) 150.0 T))
      (lg-attdefs-unsichtbar
        (vl-remove-if '(lambda (p) (member (car p) '("NR" "BEZEICHNUNG" "HOEHE_BELAG_mm")))
                      *lg-schema-geschoss*))))
)

;; Record eines Geschoss-Blocks: (ent nr attribs kontur-punkte)
(defun lg-geschoss-record (ent / attribs k)
  (setq attribs (ssg-attrib-read ent)
        k (lg-ent-aus-handle (lg-xdata-wert ent "kontur")))
  (list ent (atoi (cond ((cdr (assoc "NR" attribs))) ("0"))) attribs
        (if k (ssg-lwpoly-punkte k)))
)

(defun lg-geschosse ( / )
  (vl-sort (mapcar 'lg-geschoss-record (lg-alle-bloecke "LG_GESCHOSS"))
           '(lambda (a b) (< (cadr a) (cadr b))))
)

(defun lg-geschoss-finden (nr)
  (vl-some '(lambda (g) (if (= (cadr g) nr) g)) (lg-geschosse))
)

(defun lg-geschoss-hoehe (rec)
  (cond ((lg-zahl (cdr (assoc "HOEHE_BELAG_mm" (caddr rec))))) (0.0))
)

;; Z einer Kontur (Erhebung des ersten Punkts) eines Kandidaten.
(defun lg-kandidat-z (k)
  (cond ((caddr (car (caddr k)))) (0.0))
)

;; Reiner Kern der Geschosszuordnung.
;; kandidaten = ((nr hoehe-mm kontur-punkte) ...), pt = (x y z).
;; Liegt pt in genau einer Kontur -> deren nr. Liegt er in mehreren, hilft
;; nur Z: liegen die Konturen auf verschiedenen Hoehen (3D), gewinnt die
;; hoechste Kontur bis z + 50 mm. Liegen sie alle auf derselben Hoehe
;; (2D-Grundrisse uebereinander), ist die Zuordnung nicht eindeutig -> nil.
(defun lg-geschoss-fuer-punkt-kern (pt kandidaten / innen z z0 passend)
  (setq innen (vl-remove-if-not '(lambda (k) (and (caddr k) (ssg-punkt-in-poly-p pt (caddr k))))
                                kandidaten))
  (cond
    ((null innen) nil)
    ((null (cdr innen)) (car (car innen)))
    (T
      (setq z  (if (caddr pt) (caddr pt) 0.0)
            z0 (lg-kandidat-z (car innen)))
      (if (vl-every '(lambda (k) (equal (lg-kandidat-z k) z0 1.0)) innen)
        nil
        (progn
          (setq passend (vl-remove-if-not '(lambda (k) (<= (lg-kandidat-z k) (+ z 50.0))) innen))
          (if passend
            (car (car (vl-sort passend '(lambda (a b) (> (lg-kandidat-z a) (lg-kandidat-z b))))))))))
  )
)

(defun lg-geschoss-kandidaten ( / )
  (mapcar '(lambda (g) (list (cadr g) (lg-geschoss-hoehe g) (cadddr g))) (lg-geschosse))
)

;; Aktives Geschoss (Zahl) oder nil.
(defun lg-geschoss-aktiv ( / nr)
  (setq nr (lg-ldata-lesen "GESCHOSS_AKTIV"))
  (if (and (numberp nr) (> nr 0) (lg-geschoss-finden nr)) nr)
)

;; Geschoss fuer ein neues Objekt: aktives Geschoss, sonst Kontur-Zuordnung,
;; sonst Rueckfrage. nil = kein Geschoss vorhanden.
(defun lg-geschoss-ermitteln (pt / nr gs)
  (setq gs (lg-geschosse))
  (cond
    ((null gs) (princ (ssg-text "lg-kein-geschoss")) nil)
    ((setq nr (lg-geschoss-aktiv)) nr)
    ((setq nr (lg-geschoss-fuer-punkt-kern pt (lg-geschoss-kandidaten))) nr)
    ((null (cdr gs)) (cadr (car gs)))
    (T
      (setq nr (ssg-in-int (ssg-text "lg-prompt-geschoss-nr") (cadr (car gs))))
      (if (lg-geschoss-finden nr) nr
        (progn (princ (ssg-textf "lg-geschoss-unbekannt" (list (itoa nr)))) nil)))
  )
)

(defun lg-geschoss-naechste-nr ( / gs)
  (setq gs (lg-geschosse))
  (if gs (1+ (apply 'max (mapcar 'cadr gs))) 1)
)

;; ------------------------------------------------------------
;; Konturen
;; ------------------------------------------------------------

(defun lg-kontur-p (ent / ed)
  (setq ed (entget ent))
  (and (= (cdr (assoc 0 ed)) "LWPOLYLINE")
       (>= (length (ssg-lwpoly-punkte ent)) 3))
)

;; Kontur geschlossen setzen (Flag 1), Duplikat-Schlusspunkt stoert nicht.
(defun lg-kontur-schliessen (ent / ed f)
  (setq ed (entget ent) f (cdr (assoc 70 ed)))
  (if (= 0 (logand f 1))
    (progn (entmod (subst (cons 70 (logior f 1)) (assoc 70 ed) ed)) (entupd ent)))
  ent
)

;; Kopie einer Polylinie ohne Handle/Besitzer/XDATA (fuer eine Kontur, die
;; schon einem anderen Geschoss/Bereich gehoert - die 2D-Grundrisse liegen
;; uebereinander, jede Kontur gehoert genau einem Block).
(defun lg-kontur-kopieren (ent)
  (entmakex (vl-remove-if '(lambda (g) (member (car g) '(-1 5 330 102 360 -3)))
                          (entget ent)))
)

;; Kontur fuer einen neuen Block vorbereiten: kopieren, falls schon
;; vergeben, schliessen, auf layer legen. Rueckgabe: ename der Kontur.
(defun lg-kontur-uebernehmen (ent layer / ed)
  (if (lg-xdata-wert ent "besitzer") (setq ent (lg-kontur-kopieren ent)))
  (lg-kontur-schliessen ent)
  (setq ed (entget ent))
  (entmod (subst (cons 8 layer) (assoc 8 ed) ed))
  (entupd ent)
  ent
)

;; Interaktiv: geschlossene Polylinie waehlen, Enter = neu zeichnen.
(defun lg-kontur-waehlen (prompt / sel ent fertig)
  (while (not fertig)
    (setq sel (entsel prompt))
    (cond
      ((null sel)
        (if (= (getvar "ERRNO") 52)
          (progn
            ;; Enter: neue Kontur zeichnen
            (princ (ssg-text "lg-kontur-zeichnen"))
            (setq ent (entlast))
            (command "_.PLINE")
            (while (> (getvar "CMDACTIVE") 0) (command pause))
            (if (and (entlast) (not (eq ent (entlast))) (lg-kontur-p (entlast)))
              (setq ent (entlast))
              (setq ent nil))
            (setq fertig T))
          (setq fertig T ent nil)))
      ((lg-kontur-p (car sel)) (setq ent (car sel) fertig T))
      (T (princ (ssg-text "lg-keine-kontur")))
    )
  )
  ent
)

;; ------------------------------------------------------------
;; Geschoss anlegen / aendern
;; ------------------------------------------------------------

(defun lg-geschoss-vorgaben (nr / )
  (list (cons "NR" (itoa nr))
        (cons "GESCHOSS" (itoa nr))
        (cons "BEZEICHNUNG" (if (= nr 0) "ground floor" (strcat "Level " (itoa nr))))
        (cons "HOEHE_BELAG_mm" "0")
        (cons "KONSTR_HOEHE_mm" (lg-mm-str (lg-zahl (lg-vorgabe '("geschoss" "konstr_hoehe_mm") 250))))
        (cons "LICHTE_HOEHE_mm" "")
        (cons "BELAG_ART" (lg-vorgabe '("geschoss" "belag_art") "spanplatte"))
        (cons "PERSONEN" (itoa (fix (lg-zahl (lg-vorgabe '("geschoss" "personen") 20)))))
        (cons "BRANDGEFAEHRDUNG" (lg-vorgabe '("geschoss" "brandgefaehrdung") "erhoeht_ohne_loeschanlage")))
)

;; Geschoss-Block zur Kontur anlegen (nicht interaktiv - auch fuer Tests).
;; werte = vollstaendige Attributwerte (lg-geschoss-vorgaben + Dialog).
;; Rueckgabe: ename des Blocks oder nil.
(defun lg-geschoss-anlegen (kontur werte / nr lay pts bb pt blk)
  (setq nr (atoi (cdr (assoc "NR" werte))))
  (if (lg-geschoss-finden nr)
    (progn (princ (ssg-textf "lg-geschoss-existiert" (list (itoa nr)))) nil)
    (progn
      (setq lay (lg-layer "geschoss" nr))
      (setq kontur (lg-kontur-uebernehmen kontur lay))
      (setq pts (ssg-lwpoly-punkte kontur)
            bb  (ssg-poly-bbox pts))
      ;; Kopfsymbol unten links an der Kontur, auf deren Z
      (setq pt (list (car (car bb)) (cadr (car bb)) (if (caddr (car pts)) (caddr (car pts)) 0.0)))
      (lg-geschoss-blockdef)
      (setq werte (append (list (cons "GESCHOSS" (itoa nr)) (cons "LAYER" lay)
                                (cons "ID" (strcat "G" (itoa nr))))
                          werte))
      (if (setq blk (lg-block-einfuegen "LG_GESCHOSS" pt 0.0 lay werte))
        (progn
          (lg-xdata-setzen blk (list (cons "kontur" (cons 1005 (lg-handle kontur)))))
          (lg-xdata-setzen kontur (list (cons "besitzer" (cons 1005 (lg-handle blk)))
                                        (cons "rolle" (cons 1000 "geschoss"))))
          blk))
    )
  )
)

;; ============================================================
;; DIALOGE (generisch: Feldliste -> DCL bzw. Konsole)
;; ============================================================
;; feld = (tile-key attribut-tag art optionen)
;;   art siehe lg-feld-pruefen, zusaetzlich "wahl" (popup_list aus optionen)
;; Konsolen-Prompt: ssg-text "lg-feld-<tile-key>".

(setq *lg-felder-geschoss*
  '(("nr" "NR" "int0" nil)
    ("bezeichnung" "BEZEICHNUNG" "text" nil)
    ("hoehe" "HOEHE_BELAG_mm" "mm" nil)
    ("konstr" "KONSTR_HOEHE_mm" "mm" nil)
    ("lichte" "LICHTE_HOEHE_mm" "mm_leer" nil)
    ("belag" "BELAG_ART" "wahl" belag)
    ("personen" "PERSONEN" "int0" nil)
    ("brand" "BRANDGEFAEHRDUNG" "wahl" brand)))

(setq *lg-felder-bereich*
  '(("gang" "GANGBREITE_mm" "mm" nil)
    ("tiefe" "REGALTIEFE_mm" "mm" nil)
    ("reihen" "REIHEN_JE_GANG" "wahl" reihen)
    ("schienen" "SCHIENEN_JE_GANG" "int0" nil)
    ("q_abstand" "QUERGANG_ABSTAND_mm" "mm" nil)
    ("q_breite" "QUERGANG_BREITE_mm" "mm" nil)
    ("richtung" "RICHTUNG" "grad" nil)
    ("ebenen" "HAENGEEBENEN" "ebenen" nil)
    ("belag" "BELAG" "wahl" belag)
    ("rand_n" "RANDGANG_N_mm" "mm" nil)
    ("rand_o" "RANDGANG_O_mm" "mm" nil)
    ("rand_s" "RANDGANG_S_mm" "mm" nil)
    ("rand_w" "RANDGANG_W_mm" "mm" nil)))

(setq *lg-felder-gang*
  '(("laenge" "LAENGE" "mm" nil)
    ("breite" "BREITE_mm" "mm" nil)
    ("art" "ART" "wahl" gangart)
    ("belag" "BELAG" "wahl" belag)))

(setq *lg-felder-reihe*
  '(("laenge" "LAENGE" "mm" nil)
    ("tiefe" "TIEFE_mm" "mm" nil)
    ("ebenen" "HAENGEEBENEN" "ebenen" nil)
    ("schienen" "SCHIENEN" "int0" nil)))

;; LG_GESCHOSS_KOPIEREN - die Tags sind reine Dialogwerte, kein Block-Schema.
(setq *lg-felder-kopie*
  '(("quelle" "QUELLE" "wahl" geschosse)
    ("anzahl" "ANZAHL" "int" nil)
    ("abstand" "ABSTAND_mm" "mm" nil)
    ("belag" "BELAG_ART" "wahl" belag)
    ("versatz_x" "VERSATZ_X_mm" "mm_vz" nil)
    ("versatz_y" "VERSATZ_Y_mm" "mm_vz" nil)))

(defun lg-optionen (sym)
  (cond
    ((eq sym 'belag) (lg-vorgabe '("geschoss" "belag_arten") '("spanplatte" "gitterrost" "hallenboden")))
    ((eq sym 'brand) (lg-vorgabe '("brandgefaehrdungen") '("normal" "erhoeht_mit_loeschanlage" "erhoeht_ohne_loeschanlage")))
    ((eq sym 'reihen) '("1" "2"))
    ((eq sym 'gangart) '("gang" "randgang" "quergang"))
    ((eq sym 'geschosse) (mapcar '(lambda (g) (itoa (cadr g))) (lg-geschosse)))
  )
)

(defun lg-dcl-pfad ( / d)
  (setq d (getenv "DXFM_DCL"))
  (if d (strcat (vl-string-right-trim "/\\" (vl-string-translate "\\" "/" d)) "/lager.dcl"))
)

;; Dialog zeigen. gesperrt = Liste von tile-keys, die nicht editierbar sind.
;; Rueckgabe: aktualisierte werte oder nil (Abbruch). Faellt bei fehlender
;; GUI/DCL auf die Konsole zurueck.
(defun lg-dialog (dlg-name felder werte gesperrt / pfad dat erg)
  (setq pfad (lg-dcl-pfad))
  (cond
    ((not (ssg-gui-p)) werte)          ; Tests/Batch: Vorgaben uebernehmen
    ((or (null pfad) (not (findfile pfad)) (< (setq dat (load_dialog pfad)) 0))
      (princ (ssg-textf "lg-dialog-fehlt" (list (if pfad pfad "lager.dcl"))))
      (lg-konsole felder werte gesperrt))
    ((not (new_dialog dlg-name dat))
      (unload_dialog dat)
      (lg-konsole felder werte gesperrt))
    (T
      (setq *lg-dlg-werte* werte *lg-dlg-felder* felder *lg-dlg-ergebnis* nil)
      (foreach f felder
        (if (= (caddr f) "wahl")
          (progn
            (start_list (car f))
            (mapcar 'add_list (lg-optionen (cadddr f)))
            (end_list)
            (set_tile (car f)
              (itoa (cond ((vl-position (cdr (assoc (cadr f) werte)) (lg-optionen (cadddr f))))
                          (0)))))
          (set_tile (car f) (cond ((cdr (assoc (cadr f) werte))) (""))))
        (if (member (car f) gesperrt) (mode_tile (car f) 1))
      )
      (action_tile "accept" "(lg-dialog-ok)")
      (action_tile "cancel" "(done_dialog 0)")
      (setq erg (start_dialog))
      (unload_dialog dat)
      (if (= erg 1) *lg-dlg-ergebnis*)
    )
  )
)

;; OK-Knopf: alle Felder pruefen; bei Fehler Dialog offen lassen.
(defun lg-dialog-ok ( / werte fehler f s n)
  (setq werte *lg-dlg-werte* fehler nil)
  (foreach f *lg-dlg-felder*
    (setq s (get_tile (car f)))
    (if (= (caddr f) "wahl")
      (setq n (nth (atoi s) (lg-optionen (cadddr f))))
      (setq n (lg-feld-pruefen (caddr f) s)))
    (if (null n)
      (if (null fehler) (setq fehler (car f)))
      (setq werte (lg-wert-setzen werte (cadr f) n)))
  )
  (if fehler
    (progn (set_tile "error" (ssg-textf "lg-feld-ungueltig" (list (ssg-text (strcat "lg-feld-" fehler)))))
           (mode_tile fehler 2))
    (progn (setq *lg-dlg-ergebnis* werte) (done_dialog 1)))
)

(defun lg-wert-setzen (werte tag wert)
  (if (assoc tag werte)
    (subst (cons tag wert) (assoc tag werte) werte)
    (append werte (list (cons tag wert))))
)

;; Konsolen-Rueckfall: jedes Feld mit Vorgabe abfragen (Enter = Vorgabe).
(defun lg-konsole (felder werte gesperrt / f alt neu opts)
  (foreach f felder
    (if (not (member (car f) gesperrt))
      (progn
        (setq alt (cond ((cdr (assoc (cadr f) werte))) ("")))
        (setq neu nil)
        (while (null neu)
          (if (= (caddr f) "wahl")
            (progn
              (setq opts (lg-optionen (cadddr f)))
              (princ (strcat "\n  " (ssg-join opts " | ")))
              (setq neu (ssg-in-string (ssg-text (strcat "lg-feld-" (car f))) alt))
              (if (not (member neu opts)) (progn (princ (ssg-text "lg-wahl-ungueltig")) (setq neu nil))))
            (progn
              (setq neu (lg-feld-pruefen (caddr f)
                          (ssg-in-string (ssg-text (strcat "lg-feld-" (car f))) alt)))
              (if (null neu) (princ (ssg-text "lg-wert-ungueltig")))))
        )
        (setq werte (lg-wert-setzen werte (cadr f) neu))
      )
    )
  )
  werte
)

;; ============================================================
;; REGALREIHEN UND GAENGE
;; ============================================================

(defun lg-reihe-blockname (laenge tiefe)
  (strcat "LG_REIHE_" (lg-mm-str laenge) "_" (lg-mm-str tiefe))
)

;; Der Belag steht im Namen, weil die Definition seine Schraffur enthaelt
;; und je Geometrie wiederverwendet wird.
(defun lg-gang-blockname (laenge breite belag)
  (strcat "LG_GANG_" (lg-mm-str laenge) "_" (lg-mm-str breite)
          (if (and belag (= (type belag) 'STR) (/= belag ""))
            (strcat "_" (strcase (vl-string-translate " " "_" belag)))
            ""))
)

;; Reihe: Rechteck L x T um die Schienenlinie (0,0)-(L,0).
(defun lg-reihe-blockdef (laenge tiefe / h)
  (setq h (/ tiefe 2.0))
  (lg-blockdef (lg-reihe-blockname laenge tiefe)
    (append (list (lg-geom-rechteck 0.0 (- h) laenge h)
                  (lg-geom-linie '(0.0 0.0 0.0) (list laenge 0.0 0.0)))
            (lg-attdefs-unsichtbar *lg-schema-reihe*)))
)

;; Schraffur-Vorgabe eines Belags aus der Tabelle belag_schraffur
;; (lager.json). Rueckgabe: (muster massstab winkel-grad) oder nil (keine
;; Schraffur: Belag null, unbekannt oder ohne Muster). Rein, getestet.
(defun lg-schraffur-vorgabe (belag tabelle / e m)
  (if (and belag (= (type belag) 'STR))
    (progn
      (setq e (ssg-json-get tabelle belag))
      (if (and e (listp e))
        (progn
          (setq m (ssg-json-get e "muster"))
          (if (and m (= (type m) 'STR) (/= m ""))
            (list m
                  (float (cond ((ssg-json-get e "massstab")) (1.0)))
                  (float (cond ((ssg-json-get e "winkel")) (0.0)))))))))
)

(if (not (boundp '*lg-schraffur-gemeldet*)) (setq *lg-schraffur-gemeldet* nil))

;; Schraffur in eine vorhandene Blockdefinition einsetzen: umrandet die
;; erste Polylinie der Definition, Layer 0 + Farbe VONBLOCK (erbt den
;; Geschoss-Layer der Referenz). vorgabe = (muster massstab winkel-grad).
;; Rueckgabe: T oder nil (Muster unbekannt o.ae., Meldung).
(defun lg-schraffur-einsetzen (bname vorgabe / blk pl h res)
  (setq res
    (vl-catch-all-apply
      '(lambda ()
         (setq blk (vla-Item (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) bname))
         (vlax-for o blk
           (if (and (null pl) (= (vla-get-ObjectName o) "AcDbPolyline")) (setq pl o)))
         (setq h (vla-AddHatch blk 1 (car vorgabe) :vlax-false))   ; 1 = vordefiniert
         (vla-put-Layer h "0")
         (vla-put-Color h 0)                                       ; 0 = VONBLOCK
         (vla-put-PatternScale h (cadr vorgabe))
         (vla-put-PatternAngle h (* (/ (caddr vorgabe) 180.0) pi))
         (vlax-invoke h 'AppendOuterLoop (list pl))
         (vla-Evaluate h)
         T)))
  (if (vl-catch-all-error-p res)
    (progn
      (if h (vl-catch-all-apply 'vla-Delete (list h)))
      (princ (ssg-textf "lg-schraffur-fehler" (list (car vorgabe) bname (vl-catch-all-error-message res))))
      nil)
    res)
)

(defun lg-gang-blockdef (laenge breite belag / h bname tab vorgabe)
  (setq h (/ breite 2.0)
        bname (lg-gang-blockname laenge breite belag)
        tab (lg-vorgabe '("belag_schraffur") nil)
        vorgabe (lg-schraffur-vorgabe belag tab))
  (if (and belag (= (type belag) 'STR) (/= belag "")
           (not (assoc belag tab)) (not (member belag *lg-schraffur-gemeldet*)))
    (progn
      (setq *lg-schraffur-gemeldet* (cons belag *lg-schraffur-gemeldet*))
      (princ (ssg-textf "lg-schraffur-unbekannt" (list belag)))))
  (lg-blockdef bname
    (append (list (lg-geom-rechteck 0.0 (- h) laenge h))
            (lg-attdefs-unsichtbar *lg-schema-gang*)))
  ;; Schraffur nur einmal je Definition (auch nach einer Neudefinition)
  (if (and vorgabe
           (not (vl-some '(lambda (ed) (= (cdr (assoc 0 ed)) "HATCH")) (lg-blockdef-objekte bname))))
    (lg-schraffur-einsetzen bname vorgabe))
  bname
)

;; Linienobjekt (Reihe/Gang) von p1 nach p2 (WCS) einfuegen.
;; art = "reihe"|"gang", werte = Attribute ohne LAENGE/LAYER/ID.
;; Rueckgabe: ename oder nil (zu kurz).
(defun lg-linie-einfuegen (art p1 p2 werte bereich-ent / laenge quer gs lay bname ent)
  (setq laenge (lg-mm-runden (distance (list (car p1) (cadr p1)) (list (car p2) (cadr p2)))))
  (if (> laenge 0.0)
    (progn
      (setq gs (cdr (assoc "GESCHOSS" werte)))
      (if (= art "reihe")
        (setq quer (lg-zahl (cdr (assoc "TIEFE_mm" werte)))
              lay  (lg-layer "reihe" gs)
              bname (progn (lg-reihe-blockdef laenge quer) (lg-reihe-blockname laenge quer)))
        (setq quer (lg-zahl (cdr (assoc "BREITE_mm" werte)))
              lay  (lg-layer "gang" gs)
              bname (lg-gang-blockdef laenge quer (cdr (assoc "BELAG" werte)))))
      (setq werte (append (list (cons "LAENGE" (lg-mm-str laenge)) (cons "LAYER" lay)) werte))
      (if (setq ent (lg-block-einfuegen bname p1 (angle p1 p2) lay werte))
        (progn
          (lg-attribute-setzen ent (list (cons "ID" (lg-handle ent))))
          (if bereich-ent
            (lg-xdata-setzen ent (list (cons "bereich" (cons 1005 (lg-handle bereich-ent))))))
          ent))
    )
  )
)

;; Wie lg-linie-neu-aufbauen, danach schneidet das neue Objekt seine
;; Flaeche aus den rangniedrigeren Reihen/Gaengen heraus (lg-sperre-
;; anwenden) - fuer das Bearbeiten von Hand. Rueckgabe: neuer ename.
(defun lg-linie-neu-aufbauen-sperre (ent werte / neu)
  (if (setq neu (lg-linie-neu-aufbauen ent werte))
    (lg-sperre-anwenden neu))
  neu
)

;; Reihe/Gang mit neuen Werten (inkl. LAENGE) an derselben Stelle neu
;; aufbauen. Rueckgabe: neuer ename.
(defun lg-linie-neu-aufbauen (ent werte / ed p1 rot art laenge p2 bereich neu)
  (setq ed  (entget ent)
        p1  (cdr (assoc 10 ed))
        rot (cond ((cdr (assoc 50 ed))) (0.0))
        art (if (wcmatch (strcase (lg-blockname ent)) "LG_REIHE_*") "reihe" "gang")
        laenge (lg-zahl (cdr (assoc "LAENGE" werte)))
        bereich (lg-ent-aus-handle (lg-xdata-wert ent "bereich")))
  (setq p2 (polar p1 rot laenge))
  (setq werte (vl-remove-if '(lambda (p) (member (car p) '("LAENGE" "LAYER" "ID"))) werte))
  (if (setq neu (lg-linie-einfuegen art p1 (list (car p2) (cadr p2) (caddr p1)) werte bereich))
    (entdel ent))
  neu
)

;; ============================================================
;; AUTO-FUELLUNG (reiner Kern, getestet)
;; ============================================================
;; pts    = Bereichskontur in LOKALEN Koordinaten: Reihen laufen entlang +X.
;; params = Alist ("gang" "tiefe" "reihen" "q_abstand" "q_breite"
;;                 "min_reihe" "min_gang"), Zahlen in mm.
;; Muster quer zu den Reihen (in +Y ab Unterkante der Kontur), je Modul:
;;   2 Reihen je Gang: Reihe | Gang | Reihe  (benachbarte Module stossen
;;                     Ruecken an Ruecken)
;;   1 Reihe je Gang:  Reihe | Gang
;; Es werden nur volle Module gelegt; der Rest quer zu den Reihen wird als
;; restbreite zurueckgegeben (Protokoll, Attribut RESTBREITE_mm).
;; Quergaenge (q_abstand > 0): Luecken der Breite q_breite nach jeweils
;; q_abstand Reihenlaenge, ueber alle Reihen ausgerichtet (gemessen ab
;; linker Konturkante). Hauptgaenge laufen durch die Quergaenge durch.
;; Ein Streifen gilt nur dort als belegbar, wo Unterkante, Mitte und
;; Oberkante innerhalb der Kontur liegen.
;; Optionale params:
;;   "rand"     = (("N" . mm) ("O" . mm) ("S" . mm) ("W" . mm)) Randgaenge
;;                nach Himmelsrichtung (Nord = +Y Welt), entlang der echten
;;                Konturkanten (auch L-Form), siehe lg-randgang-streifen
;;   "richtung" = Drehung lokal -> Welt (Bogenmass), fuer die Himmelsrichtung
;;   "sperr"    = Sperrpolygone (lokal, z.B. manuelle Gaenge)
;; Randgaenge und Sperrpolygone werden aus Reihen, Haupt- und Quergaengen
;; ausgeschnitten (exakt ueber das Band jedes Streifens, ssg-poly-band-x).
;; Randgaenge an der Unter-/Oberkante verschieben den Modulstapel, an der
;; linken/rechten Kante den Bezug der Quergaenge.
;; Rueckgabe: (records restbreite module) mit
;;   record = (typ p1 p2 breite), typ = "reihe" | "gang" | "quergang" |
;;   "randgang", p1/p2 = Anfang/Ende der Mittellinie (lokal, 2D).
;;   Randgaenge stehen am Ende der Liste.

;; Himmelsrichtung einer Aussennormalen (Weltwinkel, Bogenmass), Nord = +Y.
;; Genau diagonale Kanten (45 Grad) zaehlen zu N/S.
(defun lg-kompass (winkel / g)
  (setq g (* (/ winkel pi) 180.0))
  (while (< g 0.0) (setq g (+ g 360.0)))
  (while (>= g 360.0) (setq g (- g 360.0)))
  (cond
    ((and (>= g (- 45.0 1e-6)) (<= g (+ 135.0 1e-6))) "N")
    ((and (>= g (- 225.0 1e-6)) (<= g (+ 315.0 1e-6))) "S")
    ((and (> g 135.0) (< g 225.0)) "W")
    (T "O")
  )
)

;; Laengenkorrektur eines Randgangs an einer Ecke (+ verlaengern, - kuerzen).
;; N/S-Randgaenge besitzen die Ecken: an einer konvexen Ecke wird der O/W-
;; Randgang um die Breite des N/S-Nachbarn gekuerzt (keine Doppelflaeche),
;; an einer einspringenden Ecke der N/S-Randgang um die Breite des O/W-
;; Nachbarn verlaengert (sonst bliebe dort ein freies Quadrat, in das eine
;; Reihe passt, und der Gang waere unterbrochen).
(defun lg-randgang-ecke (eigen nachbar nb konvex / ns-eigen ns-nachbar)
  (setq ns-eigen   (if (member eigen '("N" "S")) T nil)
        ns-nachbar (if (member nachbar '("N" "S")) T nil))
  (cond
    ((or (<= nb 0.0) (= eigen nachbar)) 0.0)
    ((and konvex (not ns-eigen) ns-nachbar) (- nb))
    ((and (not konvex) ns-eigen (not ns-nachbar)) nb)
    (T 0.0)
  )
)

;; Kreuzprodukt der Kanten (a b) und (b c) - Vorzeichen = Knickrichtung.
(defun lg-knick (k1 k2 / a b c)
  (setq a (car k1) b (cadr k1) c (cadr k2))
  (- (* (- (car b) (car a)) (- (cadr c) (cadr b)))
     (* (- (cadr b) (cadr a)) (- (car c) (car b))))
)

;; Randgang-Streifen entlang der Konturkanten (lokale Koordinaten).
;; w = Drehung lokal -> Welt (Bogenmass), rand = Breiten je Himmelsrichtung.
;; Jede Kante bekommt den Randgang ihrer Himmelsrichtung (Aussennormale),
;; als Rechteck von der Kante nach innen; Ecken nach lg-randgang-ecke.
;; Rueckgabe: ((kompass p1 p2 breite polygon kante) ...), p1/p2 = Mittellinie.
(defun lg-randgang-streifen (pts w rand min-g / s kanten n kompasse breiten erg i k b
                               p q a vor nach t0 t1 nin p1 p2)
  (setq pts (mapcar '(lambda (p) (list (car p) (cadr p))) pts)
        s (ssg-poly-flaeche-signiert pts)
        kanten (ssg-poly-kanten pts)
        n (length kanten)
        erg nil)
  (if (and rand (> n 2) (not (equal s 0.0 1e-9)))
    (progn
      (setq kompasse
        (mapcar '(lambda (k / a)
                   (setq a (angle (car k) (cadr k)))
                   (lg-kompass (+ w (if (> s 0.0) (- a (/ pi 2.0)) (+ a (/ pi 2.0))))))
                kanten))
      (setq breiten (mapcar '(lambda (r) (cond ((lg-zahl (cdr (assoc r rand)))) (0.0))) kompasse))
      (setq i 0)
      (foreach k kanten
        (setq b (nth i breiten))
        (if (> b 0.0)
          (progn
            (setq vor  (rem (+ i n -1) n)
                  nach (rem (1+ i) n)
                  p (car k) q (cadr k) a (angle p q)
                  nin (if (> s 0.0) (+ a (/ pi 2.0)) (- a (/ pi 2.0))))
            (setq t0 (lg-randgang-ecke (nth i kompasse) (nth vor kompasse) (nth vor breiten)
                                       (> (* s (lg-knick (nth vor kanten) k)) 0.0))
                  t1 (lg-randgang-ecke (nth i kompasse) (nth nach kompasse) (nth nach breiten)
                                       (> (* s (lg-knick k (nth nach kanten))) 0.0)))
            (setq p1 (polar p a (- t0))
                  p2 (polar q a t1))
            (if (>= (+ (distance p q) t0 t1) min-g)
              (setq erg (cons (list (nth i kompasse)
                                    (polar p1 nin (/ b 2.0)) (polar p2 nin (/ b 2.0)) b
                                    (list p1 p2 (polar p2 nin b) (polar p1 nin b))
                                    k)
                              erg))))
        )
        (setq i (1+ i))
      )
    )
  )
  (reverse erg)
)

;; Gesperrte x-Intervalle eines Bandes y0..y1 (je Sperrpolygon eins).
(defun lg-sperr-intervalle (sperr y0 y1 / erg iv)
  (setq erg nil)
  (foreach s sperr
    (if (setq iv (ssg-poly-band-x s y0 y1)) (setq erg (cons iv erg))))
  erg
)

(defun lg-streifen-intervalle (pts y0 y1 / e)
  (setq e (min 0.01 (/ (- y1 y0) 4.0)))
  (ssg-intervalle-schnitt
    (ssg-intervalle-schnitt (ssg-poly-schnitt-y pts (+ y0 e))
                            (ssg-poly-schnitt-y pts (/ (+ y0 y1) 2.0)))
    (ssg-poly-schnitt-y pts (- y1 e)))
)

;; Quergang-Luecken entlang X. Eine Luecke entsteht nur, wenn dahinter noch
;; ein Reihenstueck von mindestens min-rest Platz hat - ein Quergang am
;; Reihenende waere sinnlos und kostete nur Regalflaeche.
(defun lg-quergang-luecken (xmin xmax q-abstand q-breite min-rest / erg x)
  (setq erg nil)
  (if (and q-abstand (> q-abstand 0.0) q-breite (> q-breite 0.0))
    (progn
      (setq x (+ xmin q-abstand))
      (while (<= (+ x q-breite min-rest) xmax)
        (setq erg (cons (list x (+ x q-breite)) erg)
              x (+ x q-breite q-abstand)))))
  (reverse erg)
)

;; Parameter mit Vorgabe (nil/fehlend -> vorgabe).
(defun lg-param (params k vorgabe)
  (cond ((cdr (assoc k params))) (vorgabe))
)

(defun lg-fuellung-berechnen (pts params / bb xmin xmax ymin ymax g tf r muster pitch
                                y module recs luecken gang-y y-start iv yc b typ
                                pts-t xc m i l min-r min-g rand-str sperr sperr-t
                                unten oben links rechts k gesperrt)
  (setq g  (float (lg-param params "gang" 1000.0))
        tf (float (lg-param params "tiefe" 700.0))
        r  (lg-param params "reihen" 2)
        min-r (lg-param params "min_reihe" 500.0)
        min-g (lg-param params "min_gang" 100.0))
  (setq muster (if (= r 1)
                 (list (list "reihe" tf) (list "gang" g))
                 (list (list "reihe" tf) (list "gang" g) (list "reihe" tf))))
  (setq pitch (apply '+ (mapcar 'cadr muster)))
  (setq bb (ssg-poly-bbox pts)
        xmin (car (car bb)) ymin (cadr (car bb))
        xmax (car (cadr bb)) ymax (cadr (cadr bb)))
  ;; Randgaenge + Sperrpolygone
  (setq rand-str (lg-randgang-streifen pts (lg-param params "richtung" 0.0)
                                       (lg-param params "rand" nil) min-g))
  (setq sperr (append (lg-param params "sperr" nil) (mapcar '(lambda (s) (nth 4 s)) rand-str)))
  ;; Randgaenge an den Aussenkanten der Huelle verschieben Stapel und Quergang-Bezug
  (setq unten 0.0 oben 0.0 links 0.0 rechts 0.0)
  (foreach s rand-str
    (setq k (nth 5 s))
    (cond
      ((equal (cadr (car k)) (cadr (cadr k)) 1e-6)          ; waagrechte Kante
        (cond ((equal (cadr (car k)) ymin 1e-3) (setq unten (max unten (nth 3 s))))
              ((equal (cadr (car k)) ymax 1e-3) (setq oben (max oben (nth 3 s))))))
      ((equal (car (car k)) (car (cadr k)) 1e-6)            ; senkrechte Kante
        (cond ((equal (car (car k)) xmin 1e-3) (setq links (max links (nth 3 s))))
              ((equal (car (car k)) xmax 1e-3) (setq rechts (max rechts (nth 3 s))))))
    )
  )
  (setq luecken (lg-quergang-luecken (+ xmin links) (- xmax rechts) (lg-param params "q_abstand" 0.0)
                                     (lg-param params "q_breite" 0.0) min-r))
  (setq y (+ ymin unten) y-start y module 0 recs nil gang-y nil)
  (while (<= (+ y pitch) (+ (- ymax oben) 1e-6))
    (foreach m muster
      (setq typ (car m) b (cadr m) yc (+ y (/ b 2.0)))
      (setq iv (lg-streifen-intervalle pts y (+ y b))
            gesperrt (lg-sperr-intervalle sperr y (+ y b)))
      (if (= typ "reihe")
        (progn
          (setq iv (ssg-intervalle-minus (ssg-intervalle-minus iv luecken) gesperrt))
          (foreach i iv
            (if (>= (- (cadr i) (car i)) min-r)
              (setq recs (cons (list "reihe" (list (car i) yc) (list (cadr i) yc) b) recs)))))
        (progn
          (setq gang-y (cons (list y (+ y b)) gang-y))
          (foreach i (ssg-intervalle-minus iv gesperrt)
            (if (>= (- (cadr i) (car i)) min-g)
              (setq recs (cons (list "gang" (list (car i) yc) (list (cadr i) yc) b) recs))))))
      (setq y (+ y b))
    )
    (setq module (1+ module))
  )
  ;; Quergaenge: senkrechte Streifen in den Luecken, nur im belegten
  ;; Modulbereich und ohne die Hauptgaenge (die zaehlen schon als Gang).
  (if (and luecken (> module 0))
    (progn
      (setq pts-t (mapcar '(lambda (q) (list (cadr q) (car q))) pts)
            sperr-t (mapcar '(lambda (s) (mapcar '(lambda (q) (list (cadr q) (car q))) s)) sperr)
            gang-y (reverse gang-y))
      (foreach l luecken
        (setq xc (/ (+ (car l) (cadr l)) 2.0))
        (setq iv (ssg-intervalle-schnitt (lg-streifen-intervalle pts-t (car l) (cadr l))
                                         (list (list y-start y))))
        (setq iv (ssg-intervalle-minus (ssg-intervalle-minus iv gang-y)
                                       (lg-sperr-intervalle sperr-t (car l) (cadr l))))
        (foreach i iv
          (if (>= (- (cadr i) (car i)) min-g)
            (setq recs (cons (list "quergang" (list xc (car i)) (list xc (cadr i))
                                   (- (cadr l) (car l)))
                             recs))))
      )
    )
  )
  (foreach s rand-str
    (setq recs (cons (list "randgang" (cadr s) (caddr s) (cadddr s)) recs)))
  (list (reverse recs) (- (- ymax oben) y) module)
)

;; Richtung der Reihen als Vorgabe: Winkel der laengsten Konturkante (Grad,
;; auf [0,180) normiert).
(defun lg-kontur-richtung (pts / best w l)
  (setq best nil l 0.0)
  (foreach k (ssg-poly-kanten pts)
    (if (> (distance (list (car (car k)) (cadr (car k))) (list (car (cadr k)) (cadr (cadr k)))) l)
      (setq l (distance (list (car (car k)) (cadr (car k))) (list (car (cadr k)) (cadr (cadr k))))
            best k)))
  (if best
    (progn
      (setq w (* (/ (angle (car best) (cadr best)) pi) 180.0))
      (while (>= w 180.0) (setq w (- w 180.0)))
      (if (equal w 180.0 1e-6) 0.0 w))
    0.0)
)

;; ============================================================
;; LAGERBEREICHE
;; ============================================================

(defun lg-bereich-blockdef ( / )
  (lg-blockdef "LG_BEREICH"
    (append
      (list (lg-geom-kreis '(0.0 0.0 0.0) 250.0)
            ;; Pfeil zeigt die Reihenrichtung (Einfuegedrehung = RICHTUNG)
            (lg-geom-linie '(250.0 0.0 0.0) '(800.0 0.0 0.0))
            (lg-geom-linie '(800.0 0.0 0.0) '(650.0 80.0 0.0))
            (lg-geom-linie '(800.0 0.0 0.0) '(650.0 -80.0 0.0))
            (lg-geom-attdef "NR" "" '(-100.0 -80.0 0.0) 160.0 T))
      (lg-attdefs-unsichtbar (vl-remove-if '(lambda (p) (= (car p) "NR")) *lg-schema-bereich*))))
)

(defun lg-bereich-naechste-nr ( / nrs)
  (setq nrs (mapcar '(lambda (e) (atoi (cond ((cdr (assoc "NR" (ssg-attrib-read e)))) ("0"))))
                    (lg-alle-bloecke "LG_BEREICH")))
  (if nrs (1+ (apply 'max nrs)) 1)
)

(defun lg-bereich-vorgaben (pts / )
  (list (cons "GANGBREITE_mm" (lg-mm-str (lg-zahl (lg-vorgabe '("bereich" "gangbreite_mm") 1000))))
        (cons "REGALTIEFE_mm" (lg-mm-str (lg-zahl (lg-vorgabe '("bereich" "regaltiefe_mm") 700))))
        (cons "REIHEN_JE_GANG" (itoa (fix (lg-zahl (lg-vorgabe '("bereich" "reihen_je_gang") 2)))))
        (cons "SCHIENEN_JE_GANG" (itoa (fix (lg-zahl (lg-vorgabe '("bereich" "schienen_je_gang") 1)))))
        (cons "QUERGANG_ABSTAND_mm" (lg-mm-str (lg-zahl (lg-vorgabe '("bereich" "quergang_abstand_mm") 0))))
        (cons "QUERGANG_BREITE_mm" (lg-mm-str (lg-zahl (lg-vorgabe '("bereich" "quergang_breite_mm") 1200))))
        (cons "RICHTUNG" (lg-mm-str (if pts (lg-kontur-richtung pts) 0.0)))
        (cons "HAENGEEBENEN" (lg-vorgabe '("reihe" "haengeebenen") "2300/1200;1100/1100"))
        (cons "BELAG" (lg-vorgabe '("bereich" "belag") "spanplatte"))
        (cons "RANDGANG_N_mm" (lg-mm-str (lg-zahl (lg-vorgabe '("bereich" "randgang_mm" "n") 0))))
        (cons "RANDGANG_O_mm" (lg-mm-str (lg-zahl (lg-vorgabe '("bereich" "randgang_mm" "o") 0))))
        (cons "RANDGANG_S_mm" (lg-mm-str (lg-zahl (lg-vorgabe '("bereich" "randgang_mm" "s") 0))))
        (cons "RANDGANG_W_mm" (lg-mm-str (lg-zahl (lg-vorgabe '("bereich" "randgang_mm" "w") 0)))))
)

;; Randgang-Breiten eines Bereichs (Attribute) fuer lg-fuellung-berechnen.
;; Fehlt ein Attribut (Altbestand), gilt 0.
(defun lg-bereich-rand (a)
  (mapcar '(lambda (r) (cons r (cond ((lg-zahl (cdr (assoc (strcat "RANDGANG_" r "_mm") a)))) (0.0))))
          '("N" "O" "S" "W"))
)

;; Lagerbereich, in dessen Kontur pt liegt (gleiches Geschoss), oder nil.
(defun lg-bereich-fuer-punkt (pt gs / )
  (vl-some '(lambda (b / k)
              (if (and (= (cdr (assoc "GESCHOSS" (ssg-attrib-read b))) (vl-princ-to-string gs))
                       (setq k (lg-ent-aus-handle (lg-xdata-wert b "kontur")))
                       (ssg-punkt-in-poly-p pt (ssg-lwpoly-punkte k)))
                b))
           (lg-alle-bloecke "LG_BEREICH"))
)

;; Grundriss einer Reihe/eines Gangs als Rechteck (WCS, 2D) aus
;; Einfuegepunkt, Drehung, LAENGE und Breite (Gang BREITE_mm, Reihe
;; TIEFE_mm) - beide liegen mittig auf ihrer Linie.
(defun lg-linie-polygon (ent / ed a p1 p2 rot l b n)
  (setq ed (entget ent) a (ssg-attrib-read ent)
        p1 (cdr (assoc 10 ed)) p1 (list (car p1) (cadr p1))
        rot (cond ((cdr (assoc 50 ed))) (0.0))
        l (cond ((lg-zahl (cdr (assoc "LAENGE" a)))) (0.0))
        b (cond ((lg-zahl (cdr (assoc "BREITE_mm" a)))) ((lg-zahl (cdr (assoc "TIEFE_mm" a)))) (0.0))
        p2 (polar p1 rot l)
        n (+ rot (/ pi 2.0)))
  (list (polar p1 n (/ b -2.0)) (polar p2 n (/ b -2.0)) (polar p2 n (/ b 2.0)) (polar p1 n (/ b 2.0)))
)

(defun lg-quelle (ent)
  (cdr (assoc "QUELLE" (ssg-attrib-read ent)))
)

(defun lg-manuell-p (ent)
  (= (lg-quelle ent) "manuell")
)

;; Von Hand gesetzt oder geaendert: bleibt bei jeder Neuberechnung stehen.
(defun lg-von-hand-p (ent)
  (if (member (lg-quelle ent) '("manuell" "auto_geaendert")) T)
)

;; Rang einer QUELLE fuer das Ausschneiden: ein Objekt schneidet nur aus
;; rangniedrigeren heraus (auto < auto_geaendert < manuell). Rein, getestet.
(defun lg-quelle-rang (q)
  (cond ((= q "manuell") 2) ((= q "auto_geaendert") 1) (T 0))
)

;; Reiner Kern: was von einer Reihe/einem Gang uebrig bleibt, wenn die
;; Sperrpolygone herausgeschnitten werden. Lokal: Linie von 0 bis laenge
;; entlang +X, Breite b mittig darauf; sperr = Polygone im selben System.
;; Stuecke unter min-l fallen weg. Rueckgabe ((x0 x1) ...) - leer = ganz
;; ueberdeckt - oder 'unveraendert, wenn kein Polygon die Flaeche schneidet.
(defun lg-linie-zuschnitt (laenge b sperr min-l / ganz rest)
  (setq ganz (list (list 0.0 (float laenge)))
        rest (ssg-intervalle-minus ganz (lg-sperr-intervalle sperr (/ b -2.0) (/ b 2.0))))
  (if (equal rest ganz 1e-6)
    'unveraendert
    (vl-remove-if '(lambda (i) (< (- (cadr i) (car i)) min-l)) rest))
)

;; Sperrflaeche eines von Hand gesetzten oder geaenderten Objekts (Reihe/
;; Gang) auf die rangniedrigeren Reihen und Gaenge desselben Geschosses
;; anwenden (lg-quelle-rang: ein manuelles Objekt schneidet aus auto und
;; auto_geaendert, ein geaendertes nur aus auto): ueberdeckte Stuecke werden
;; herausgeschnitten, die Reste behalten ihre Attribute (QUELLE, BEREICH ...).
;; Bewusst KEINE Neuberechnung des Bereichs - sonst kaemen von Hand
;; geloeschte Objekte zurueck und von Hand geaenderte wuerden ersetzt.
;; Rueckgabe: Anzahl zugeschnittener Objekte.
(defun lg-sperre-anwenden (sperr-ent / gs rang poly n a ed p1 rot art l b min-l lok stuecke werte bereich)
  (setq a (ssg-attrib-read sperr-ent)
        gs (cdr (assoc "GESCHOSS" a))
        rang (lg-quelle-rang (cdr (assoc "QUELLE" a)))
        poly (lg-linie-polygon sperr-ent)
        n 0)
  (foreach k (append (lg-alle-bloecke "LG_REIHE_*") (lg-alle-bloecke "LG_GANG_*"))
    (setq a (ssg-attrib-read k))
    (if (and (not (equal k sperr-ent))
             (= (cdr (assoc "GESCHOSS" a)) gs)
             (< (lg-quelle-rang (cdr (assoc "QUELLE" a))) rang))
      (progn
        (setq ed  (entget k)
              p1  (cdr (assoc 10 ed))
              rot (cond ((cdr (assoc 50 ed))) (0.0))
              art (if (wcmatch (strcase (lg-blockname k)) "LG_REIHE_*") "reihe" "gang")
              l   (cond ((lg-zahl (cdr (assoc "LAENGE" a)))) (0.0))
              b   (cond ((lg-zahl (cdr (assoc (if (= art "reihe") "TIEFE_mm" "BREITE_mm") a)))) (0.0))
              min-l (lg-zahl (if (= art "reihe")
                               (lg-vorgabe '("bereich" "min_reihenlaenge_mm") 500)
                               (lg-vorgabe '("bereich" "min_ganglaenge_mm") 100)))
              lok (ssg-poly-drehen (mapcar '(lambda (q) (list (- (car q) (car p1)) (- (cadr q) (cadr p1)))) poly)
                                   (- rot) '(0.0 0.0))
              stuecke (lg-linie-zuschnitt l b (list lok) min-l))
        (if (not (eq stuecke 'unveraendert))
          (progn
            (setq werte (vl-remove-if '(lambda (p) (member (car p) '("LAENGE" "LAYER" "ID"))) a)
                  bereich (lg-ent-aus-handle (lg-xdata-wert k "bereich")))
            (foreach s stuecke
              (lg-linie-einfuegen art (polar p1 rot (car s)) (polar p1 rot (cadr s)) werte bereich))
            (entdel k)
            (setq n (1+ n)))))))
  n
)

;; Alle Kinder (Reihen/Gaenge) eines Bereichs.
(defun lg-bereich-kinder (bereich-ent / h)
  (setq h (lg-handle bereich-ent))
  (vl-remove-if-not '(lambda (e) (equal (lg-xdata-wert e "bereich") h))
                    (append (lg-alle-bloecke "LG_REIHE_*") (lg-alle-bloecke "LG_GANG_*")))
)

;; Von Hand gesetzte Reihen/Gaenge (QUELLE manuell) desselben Geschosses,
;; die nicht mit einem Bereich verknuepft sind, aber mit ihrer Mitte in der
;; Kontur pts liegen (z.B. Altbestand von LG_REIHE vor der Verknuepfung).
(defun lg-manuelle-in-kontur (gs pts / a p q)
  (vl-remove-if-not
    '(lambda (e)
       (setq a (ssg-attrib-read e))
       (if (and (= (cdr (assoc "GESCHOSS" a)) gs)
                (= (cdr (assoc "QUELLE" a)) "manuell")
                (null (lg-xdata-wert e "bereich")))
         (progn
           (setq p (lg-linie-polygon e)
                 q (list (/ (+ (car (car p)) (car (caddr p))) 2.0) (/ (+ (cadr (car p)) (cadr (caddr p))) 2.0)))
           (ssg-punkt-in-poly-p q pts))))
    (append (lg-alle-bloecke "LG_REIHE_*") (lg-alle-bloecke "LG_GANG_*")))
)

;; Reihen/Gaenge eines Bereichs aus seinen Attributen (neu) erzeugen.
;; Die automatisch erzeugten Kinder (QUELLE auto) werden vorher entfernt
;; (Sektions-Neuaufbau statt Feld-Splice). Von Hand gesetzte (manuell) und
;; von Hand geaenderte (auto_geaendert) Reihen und Gaenge bleiben stehen und
;; sparen ihre Flaeche aus - ebenso unverknuepfte manuelle Objekte in der
;; Kontur. Rueckgabe: (reihen gaenge restbreite).
(defun lg-bereich-fuellen (bereich-ent / a kontur pts w pts-l erg z gs
                              n-reihen n-gaenge werte-reihe werte-gang p1 p2 behalten)
  (setq a (ssg-attrib-read bereich-ent)
        kontur (lg-ent-aus-handle (lg-xdata-wert bereich-ent "kontur")))
  (if (null kontur)
    (progn (princ (ssg-text "lg-bereich-ohne-kontur")) nil)
    (progn
      (setq behalten nil)
      (foreach k (lg-bereich-kinder bereich-ent)
        (if (lg-von-hand-p k)
          (setq behalten (cons k behalten))
          (entdel k)))
      (setq pts (ssg-lwpoly-punkte kontur)
            behalten (append behalten (lg-manuelle-in-kontur (cdr (assoc "GESCHOSS" a)) pts)))
      (if behalten
        (princ (ssg-textf "lg-bereich-beibehalten" (list (itoa (length behalten)) (cdr (assoc "NR" a))))))
      (setq z   (if (caddr (car pts)) (caddr (car pts)) 0.0)
            w   (* (/ (cond ((lg-zahl (cdr (assoc "RICHTUNG" a)))) (0.0)) 180.0) pi)
            pts-l (ssg-poly-drehen pts (- w) '(0.0 0.0)))
      (setq erg (lg-fuellung-berechnen pts-l
                  (list (cons "gang"      (lg-zahl (cdr (assoc "GANGBREITE_mm" a))))
                        (cons "tiefe"     (lg-zahl (cdr (assoc "REGALTIEFE_mm" a))))
                        (cons "reihen"    (atoi (cdr (assoc "REIHEN_JE_GANG" a))))
                        (cons "q_abstand" (lg-zahl (cdr (assoc "QUERGANG_ABSTAND_mm" a))))
                        (cons "q_breite"  (lg-zahl (cdr (assoc "QUERGANG_BREITE_mm" a))))
                        (cons "min_reihe" (lg-zahl (lg-vorgabe '("bereich" "min_reihenlaenge_mm") 500)))
                        (cons "min_gang"  (lg-zahl (lg-vorgabe '("bereich" "min_ganglaenge_mm") 100)))
                        (cons "rand"      (lg-bereich-rand a))
                        (cons "richtung"  w)
                        (cons "sperr"     (mapcar '(lambda (g) (ssg-poly-drehen (lg-linie-polygon g) (- w) '(0.0 0.0)))
                                                  behalten)))))
      (setq gs (cdr (assoc "GESCHOSS" a)) n-reihen 0 n-gaenge 0)
      (setq werte-reihe
        (list (cons "GESCHOSS" gs) (cons "TIEFE_mm" (cdr (assoc "REGALTIEFE_mm" a)))
              (cons "HAENGEEBENEN" (cdr (assoc "HAENGEEBENEN" a)))
              (cons "SCHIENEN" (cdr (assoc "SCHIENEN_JE_GANG" a)))
              (cons "BEREICH" (cdr (assoc "NR" a))) (cons "QUELLE" "auto")))
      (foreach r (car erg)
        (setq p1 (ssg-punkt-drehen (cadr r) w '(0.0 0.0))
              p2 (ssg-punkt-drehen (caddr r) w '(0.0 0.0))
              p1 (list (car p1) (cadr p1) z)
              p2 (list (car p2) (cadr p2) z))
        (if (= (car r) "reihe")
          (if (lg-linie-einfuegen "reihe" p1 p2 werte-reihe bereich-ent)
            (setq n-reihen (1+ n-reihen)))
          (progn
            (setq werte-gang
              (list (cons "GESCHOSS" gs) (cons "BREITE_mm" (lg-mm-str (cadddr r)))
                    (cons "ART" (car r)) (cons "BELAG" (cdr (assoc "BELAG" a)))
                    (cons "BEREICH" (cdr (assoc "NR" a))) (cons "QUELLE" "auto")))
            (if (lg-linie-einfuegen "gang" p1 p2 werte-gang bereich-ent)
              (setq n-gaenge (1+ n-gaenge)))))
      )
      (lg-attribute-setzen bereich-ent (list (cons "RESTBREITE_mm" (lg-mm-str (cadr erg)))))
      (princ (ssg-textf "lg-bereich-gefuellt"
               (list (cdr (assoc "NR" a)) (itoa n-reihen) (itoa n-gaenge) (lg-mm-str (cadr erg)))))
      (list n-reihen n-gaenge (cadr erg))
    )
  )
)

;; Bereich zur Kontur anlegen und fuellen (nicht interaktiv).
;; werte = Bereichsparameter (lg-bereich-vorgaben + Dialog); GESCHOSS muss
;; gesetzt sein. Rueckgabe: ename des Bereich-Blocks oder nil.
(defun lg-bereich-anlegen (kontur werte / blk)
  (if (setq blk (lg-bereich-block-anlegen kontur werte))
    (progn (lg-bereich-fuellen blk) blk))
)

;; Nur den Bereich-Block zur Kontur anlegen und verknuepfen, ohne Fuellung
;; (Geschoss kopieren uebernimmt die Kinder 1:1). NR, LAYER und ID werden
;; neu vergeben. Rueckgabe: ename oder nil.
(defun lg-bereich-block-anlegen (kontur werte / gs nr lay pts bb pt blk)
  (setq gs (cdr (assoc "GESCHOSS" werte))
        nr (lg-bereich-naechste-nr)
        lay (lg-layer "bereich" gs))
  (setq kontur (lg-kontur-uebernehmen kontur lay))
  (setq pts (ssg-lwpoly-punkte kontur)
        bb  (ssg-poly-bbox pts))
  (setq pt (list (/ (+ (car (car bb)) (car (cadr bb))) 2.0)
                 (/ (+ (cadr (car bb)) (cadr (cadr bb))) 2.0)
                 (if (caddr (car pts)) (caddr (car pts)) 0.0)))
  (if (not (ssg-punkt-in-poly-p pt pts)) (setq pt (car pts)))
  (lg-bereich-blockdef)
  ;; vorne angefuegt: assoc findet die neuen Werte vor evtl. alten (Kopie)
  (setq werte (append (list (cons "NR" (itoa nr)) (cons "LAYER" lay)
                            (cons "ID" (strcat "B" (itoa nr))))
                      werte))
  (if (setq blk (lg-block-einfuegen "LG_BEREICH" pt
                  (* (/ (cond ((lg-zahl (cdr (assoc "RICHTUNG" werte)))) (0.0)) 180.0) pi)
                  lay werte))
    (progn
      (lg-xdata-setzen blk (list (cons "kontur" (cons 1005 (lg-handle kontur)))))
      (lg-xdata-setzen kontur (list (cons "besitzer" (cons 1005 (lg-handle blk)))
                                    (cons "rolle" (cons 1000 "bereich"))))
      blk))
)

;; ============================================================
;; GOH_RACK-ERKENNUNG (lg-racks-sammeln, Befehl LG_REGALE)
;; ============================================================
;; goh_rack ist ein parametrischer BricsCAD-Block (MCAD-Parametrik), KEIN
;; AutoCAD-Dynamikblock: seine Referenzen tragen einen anonymen Namen
;; ("*U29"), IsDynamicBlock ist FALSE, und der echte Name sowie die
;; Parameter stehen nur in den Objekteigenschaften:
;;   (getpropertyvalue ent "EffectiveName") -> "goh_rack"
;;   (getpropertyvalue ent "Laenge~MCAD")   -> "7187.52 mm"
;; Gefunden werden Racks direkt im Modellbereich, in assoziativen Arrays
;; (anonymer Block mit Referenzen), in MINSERT-Rastern und in beliebig
;; verschachtelten Bloecken (bis *lg-rack-max-tiefe*). Blockname und
;; Parameternamen aus lager.json "goh_rack".
;; Ergebnis je Rack: (name laenge-mm ebenen mitte top-ent), Zugriff ueber
;; lg-rk-*. top-ent = oberstes INSERT im Modellbereich, in dem das Rack
;; steckt (bei einem direkt eingefuegten Rack es selbst) - ueber dessen
;; Layer _G<nr> ordnet lg-rack-geschoss das Geschoss zu.

(setq *lg-rack-max-tiefe* 8)

(defun lg-rk-name   (r) (nth 0 r))
(defun lg-rk-laenge (r) (nth 1 r))
(defun lg-rk-ebenen (r) (nth 2 r))
(defun lg-rk-mitte  (r) (nth 3 r))
(defun lg-rk-top    (r) (nth 4 r))

;; Reiner Kern: Zahl aus einem Parameterwert. MCAD-Parameter kommen als
;; Text mit Einheit ("700 mm", "71.8752 cm", "12.9 m") - auf mm umgerechnet;
;; ohne Einheit unveraendert. Unbekannte Einheit/kein Zahlanfang -> nil.
(defun lg-zahl-einheit (v / s i c ziffern zahl rest faktor)
  (cond
    ((numberp v) (float v))
    ((= (type v) 'STR)
      (setq s (vl-string-translate "," "." (vl-string-trim " \t\r\n" v))
            i 1 ziffern "")
      (while (and (<= i (strlen s))
                  (setq c (substr s i 1))
                  (or (wcmatch c "#") (member c '("." "-" "+"))))
        (setq ziffern (strcat ziffern c) i (1+ i)))
      (setq zahl (if (/= ziffern "") (distof ziffern 2))
            rest (strcase (vl-string-trim " \t" (substr s i)))
            faktor (cdr (assoc rest '(("" . 1.0) ("MM" . 1.0) ("CM" . 10.0) ("DM" . 100.0) ("M" . 1000.0)))))
      (if (and zahl faktor) (* zahl faktor)))
    (T nil))
)

;; Reiner Kern: ein echter Blockname (nicht leer, nicht anonym "*U..").
(defun lg-name-brauchbar-p (s)
  (if (and (= (type s) 'STR) (/= s "") (/= (substr s 1 1) "*")) T)
)

;; Objekteigenschaft lesen, nil wenn es sie nicht gibt.
(defun lg-prop (ent name / r)
  (setq r (vl-catch-all-apply 'getpropertyvalue (list ent name)))
  (if (vl-catch-all-error-p r) nil r)
)

;; Name, unter dem eine Referenz gefuehrt wird: Objekteigenschaft
;; EffectiveName (auch fuer MCAD-Bloecke), sonst ActiveX-EffectiveName,
;; sonst DXF-Blockname.
(defun lg-rack-name (ent / n)
  (cond
    ((lg-name-brauchbar-p (setq n (lg-prop ent "EffectiveName"))) n)
    (T (lg-blockname ent)))
)

(defun lg-rack-p (ent / n)
  (setq n (lg-rack-name ent))
  (and n (= (strcase n) (strcase *lg-rack-suchname*)))
)

;; MCAD-Parameter (Kennung "<Name>~MCAD" in listallproperties, Gross-/
;; Kleinschreibung egal).
(defun lg-mcad-param (ent name / props id soll)
  (setq props (vl-catch-all-apply 'listallproperties (list ent))
        soll (strcase (strcat name "~MCAD")))
  (if (and (not (vl-catch-all-error-p props)) (listp props)
           (setq id (vl-some '(lambda (p / s)
                                (setq s (vl-princ-to-string p))
                                (if (= (strcase s) soll) s))
                             props)))
    (lg-prop ent id))
)

;; Dynamische Blockeigenschaft (AutoCAD-Dynamikbloecke).
(defun lg-dyn-param (ent name / r)
  (setq r (vl-catch-all-apply
            '(lambda ( / obj)
               (setq obj (vlax-ename->vla-object ent))
               (if (and (vlax-property-available-p obj 'IsDynamicBlock)
                        (= :vlax-true (vla-get-IsDynamicBlock obj)))
                 (vl-some '(lambda (p)
                             (if (= (strcase (vla-get-PropertyName p)) (strcase name))
                               (vlax-variant-value (vla-get-Value p))))
                          (vlax-invoke obj 'GetDynamicBlockProperties))))))
  (if (vl-catch-all-error-p r) nil r)
)

;; Parameterwert einer Referenz: MCAD-Parameter vor dynamischer
;; Eigenschaft vor Attribut vor konstanter ATTDEF-Vorgabe.
(defun lg-rack-param (ent name / w)
  (cond
    ((setq w (lg-mcad-param ent name)) w)
    ((setq w (lg-dyn-param ent name)) w)
    ((setq w (lg-wert-fuer-tag name (ssg-attrib-read ent))) w)
    ((lg-wert-fuer-tag name
       (mapcar '(lambda (ed) (cons (cdr (assoc 2 ed)) (cdr (assoc 1 ed))))
               (vl-remove-if-not '(lambda (ed) (= (cdr (assoc 0 ed)) "ATTDEF"))
                                 (lg-blockdef-objekte (cdr (assoc 2 (entget ent))))))))
  )
)

;; --- Transformationen: tf = (ursprung x-achse y-achse z-achse), Achsen
;; mit Skalierung; p' = o + px*ax + py*ay + pz*az (rein, getestet) ---
(defun lg-v3 (p) (list (float (car p)) (float (cadr p)) (if (caddr p) (float (caddr p)) 0.0)))
(defun lg-v+ (a b) (mapcar '+ a b))
(defun lg-v* (v k) (mapcar '(lambda (x) (* x k)) v))
(defun lg-tf-id () '((0.0 0.0 0.0) (1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0)))
(defun lg-tf-vek (tf v / v3)
  (setq v3 (lg-v3 v))
  (lg-v+ (lg-v* (nth 1 tf) (car v3)) (lg-v+ (lg-v* (nth 2 tf) (cadr v3)) (lg-v* (nth 3 tf) (caddr v3))))
)
(defun lg-tf-pkt (tf p) (lg-v+ (car tf) (lg-tf-vek tf p)))
;; innen ist im System von aussen beschrieben -> Gesamttransformation
(defun lg-tf-verketten (aussen innen)
  (list (lg-tf-pkt aussen (car innen)) (lg-tf-vek aussen (nth 1 innen))
        (lg-tf-vek aussen (nth 2 innen)) (lg-tf-vek aussen (nth 3 innen)))
)

(defun lg-skal (s) (if (and s (not (equal s 0.0 1e-12))) s 1.0))

;; Transformation einer INSERT (entget-Liste) im System ihres Containers.
;; sp/zl = MINSERT-Spalte/-Zeile (0/0 = Basis). Beruecksichtigt Extrusion
;; (210), Drehung, Skalierung, Rasterabstaende (44/45, entlang der
;; gedrehten Achsen) und den Basispunkt der Blockdefinition.
(defun lg-insert-tf (ed sp zl / nor rot ax ay az xr yr o bp)
  (setq nor (lg-v3 (cond ((cdr (assoc 210 ed))) ('(0.0 0.0 1.0))))
        rot (cond ((cdr (assoc 50 ed))) (0.0)))
  (if (equal nor '(0.0 0.0 1.0) 1e-12)
    (setq ax '(1.0 0.0 0.0) ay '(0.0 1.0 0.0) az '(0.0 0.0 1.0))
    (setq ax (lg-v3 (trans '(1.0 0.0 0.0) nor 0 T))
          ay (lg-v3 (trans '(0.0 1.0 0.0) nor 0 T))
          az (lg-v3 (trans '(0.0 0.0 1.0) nor 0 T))))
  (setq xr (lg-v+ (lg-v* ax (cos rot)) (lg-v* ay (sin rot)))
        yr (lg-v+ (lg-v* ax (- (sin rot))) (lg-v* ay (cos rot)))
        o  (lg-tf-pkt (list '(0.0 0.0 0.0) ax ay az) (cdr (assoc 10 ed)))
        o  (lg-v+ o (lg-v+ (lg-v* xr (* sp (cond ((cdr (assoc 44 ed))) (0.0))))
                           (lg-v* yr (* zl (cond ((cdr (assoc 45 ed))) (0.0)))))))
  (setq xr (lg-v* xr (lg-skal (cdr (assoc 41 ed))))
        yr (lg-v* yr (lg-skal (cdr (assoc 42 ed))))
        az (lg-v* az (lg-skal (cdr (assoc 43 ed))))
        bp (lg-v3 (cond ((cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 ed)))))) ('(0.0 0.0 0.0)))))
  ;; der Basispunkt der Definition liegt auf dem Einfuegepunkt
  (list (lg-v+ o (lg-v* (lg-tf-vek (list nil xr yr az) bp) -1.0)) xr yr az)
)

;; Bounding-Box (min max) eines Objekts in den Koordinaten seines
;; Containers, nil wenn nicht ermittelbar.
(defun lg-bbox (ent / r)
  (setq r (vl-catch-all-apply
            '(lambda ( / ll ur)
               (vla-GetBoundingBox (vlax-ename->vla-object ent) 'll 'ur)
               (list (lg-v3 (vlax-safearray->list ll)) (lg-v3 (vlax-safearray->list ur))))))
  (if (vl-catch-all-error-p r) nil r)
)

;; Enthaelt die Blockdefinition (rekursiv) ein Rack? Gemerkt in
;; *lg-rack-cache*, Zirkelschutz ueber *lg-rack-pfad*, XRefs ausgenommen.
(defun lg-rack-enthaelt-p (bname tiefe / k vorh def res)
  (setq k (strcase bname))
  (cond
    ((setq vorh (assoc k *lg-rack-cache*)) (cdr vorh))
    ((or (>= tiefe *lg-rack-max-tiefe*) (member k *lg-rack-pfad*)) nil)
    (T
      (setq def (tblsearch "BLOCK" bname) res nil)
      (if (and def (= 0 (logand (cond ((cdr (assoc 70 def))) (0)) 4)))
        (progn
          (setq *lg-rack-pfad* (cons k *lg-rack-pfad*))
          (setq res (vl-some '(lambda (ed)
                                (if (= (cdr (assoc 0 ed)) "INSERT")
                                  (or (lg-rack-p (cdr (assoc -1 ed)))
                                      (lg-rack-enthaelt-p (cdr (assoc 2 ed)) (1+ tiefe)))))
                             (lg-blockdef-objekte bname)))
          (setq *lg-rack-pfad* (cdr *lg-rack-pfad*))))
      (setq *lg-rack-cache* (cons (cons k res) *lg-rack-cache*))
      res))
)

;; Eine INSERT pruefen (inkl. MINSERT-Raster) bzw. in ihre Definition
;; absteigen. ptf = Transformation des Containers nach Welt.
(defun lg-rack-insert (ent ptf tiefe top / ed spalten zeilen raster sp zl ctf bb name laenge ebenen)
  (setq ed (entget ent)
        spalten (max 1 (cond ((cdr (assoc 70 ed))) (1)))
        zeilen  (max 1 (cond ((cdr (assoc 71 ed))) (1)))
        raster  (> (* spalten zeilen) 1))
  (cond
    ((lg-rack-p ent)
      (setq name (lg-rack-name ent)
            laenge (lg-zahl-einheit (lg-rack-param ent *lg-rack-param-laenge*))
            ebenen (lg-zahl-einheit (lg-rack-param ent *lg-rack-param-ebenen*))
            bb (if (not raster) (lg-bbox ent))
            sp 0)
      (repeat spalten
        (setq zl 0)
        (repeat zeilen
          (setq *lg-racks*
            (cons (list name laenge ebenen
                        (if bb
                          (lg-tf-pkt ptf (mapcar '(lambda (a b) (/ (+ a b) 2.0)) (car bb) (cadr bb)))
                          (car (lg-tf-verketten ptf (lg-insert-tf ed sp zl))))
                        top)
                  *lg-racks*)
                zl (1+ zl)))
        (setq sp (1+ sp))))
    ((and (< tiefe *lg-rack-max-tiefe*) (lg-rack-enthaelt-p (cdr (assoc 2 ed)) 0))
      (setq sp 0)
      (repeat spalten
        (setq zl 0)
        (repeat zeilen
          (setq ctf (lg-tf-verketten ptf (lg-insert-tf ed sp zl)))
          (foreach sub (lg-blockdef-objekte (cdr (assoc 2 ed)))
            (if (= (cdr (assoc 0 sub)) "INSERT")
              (lg-rack-insert (cdr (assoc -1 sub)) ctf (1+ tiefe) top)))
          (setq zl (1+ zl)))
        (setq sp (1+ sp))))
  )
)

;; Alle goh_racks im Modellbereich (Blockname/Parameter aus lager.json).
;; Rueckgabe: Liste (name laenge-mm ebenen mitte top-ent), Fundreihenfolge.
(defun lg-racks-sammeln ( / )
  (lg-racks-finden (lg-vorgabe '("goh_rack" "blockname") "goh_rack")
                   (lg-vorgabe '("goh_rack" "param_laenge") "Laenge")
                   (lg-vorgabe '("goh_rack" "param_ebenen") "Ebenen"))
)

;; Wie lg-racks-sammeln, Blockname und Parameternamen als Argument.
(defun lg-racks-finden (name p-laenge p-ebenen / ss i)
  (setq *lg-rack-suchname* name
        *lg-rack-param-laenge* p-laenge
        *lg-rack-param-ebenen* p-ebenen
        *lg-racks* nil *lg-rack-cache* nil *lg-rack-pfad* nil)
  (if (setq ss (ssget "_X" '((0 . "INSERT") (410 . "Model"))))
    (progn
      (setq i 0)
      (repeat (sslength ss)
        (lg-rack-insert (ssname ss i) (lg-tf-id) 0 (ssname ss i))
        (setq i (1+ i)))))
  (reverse *lg-racks*)
)

;; Reiner Kern: Racks je Geschoss zusammenfassen. eintraege = ((geschoss
;; laenge-mm ebenen) ...), geschoss nil = nicht zuordenbar, fehlende Laenge/
;; Ebenen zaehlen 0. Rueckgabe ((geschoss anzahl summe-laenge
;; summe-laenge-x-ebenen) ...), nach Geschoss sortiert, nil zuletzt.
(defun lg-racks-auswerten (eintraege / erg vorh l k)
  (setq erg nil)
  (foreach x eintraege
    (setq l (cond ((cadr x)) (0.0))
          k (* l (cond ((caddr x)) (0.0)))
          vorh (assoc (car x) erg))
    (setq erg (if vorh
                (subst (list (car x) (1+ (cadr vorh)) (+ (caddr vorh) l) (+ (cadddr vorh) k)) vorh erg)
                (cons (list (car x) 1 l k) erg))))
  (vl-sort erg '(lambda (a b) (cond ((null (car a)) nil) ((null (car b)) T) (T (< (car a) (car b))))))
)

;; Befehl LG_REGALE: goh_racks zaehlen, Anzahl, Laenge und Laenge x Ebenen
;; (Haengekapazitaet) je Geschoss in der Befehlszeile.
(defun c:LG_REGALE ( / kand racks zeilen ohne-laenge)
  (setq kand (lg-geschoss-kandidaten)
        racks (lg-racks-sammeln))
  (if (null racks)
    (princ (ssg-textf "lg-regale-keine" (list (lg-vorgabe '("goh_rack" "blockname") "goh_rack"))))
    (progn
      (setq zeilen (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)))
                             racks))
            ohne-laenge (length (vl-remove-if 'lg-rk-laenge racks)))
      (princ (ssg-text "lg-regale-kopf"))
      (foreach z zeilen
        (princ (ssg-textf "lg-regale-zeile"
                 (list (if (car z) (ssg-textf "lg-regale-geschoss" (list (itoa (car z))))
                                   (ssg-text "lg-regale-ohne-geschoss"))
                       (itoa (cadr z)) (rtos (/ (caddr z) 1000.0) 2 2) (rtos (/ (cadddr z) 1000.0) 2 2)))))
      (princ (ssg-textf "lg-regale-zeile"
               (list (ssg-text "lg-regale-summe") (itoa (length racks))
                     (rtos (/ (apply '+ (mapcar 'caddr zeilen)) 1000.0) 2 2)
                     (rtos (/ (apply '+ (mapcar 'cadddr zeilen)) 1000.0) 2 2))))
      (if (> ohne-laenge 0) (princ (ssg-textf "lg-regale-ohne-laenge" (list (itoa ohne-laenge)))))))
  (princ)
)

;; ============================================================
;; GESCHOSS KOPIEREN (LG_GESCHOSS_KOPIEREN)
;; ============================================================
;; Obergeschosse haben meist dieselben Regale und Flaechen wie das Geschoss
;; darunter. Ein BricsCAD-KOPIEREN taugt dafuer nicht: die XDATA-Verweise
;; (kontur/besitzer/bereich) zeigten weiter auf die Originale, GESCHOSS,
;; Layer _G<nr> und IDs blieben die alten. Darum wird jedes Objekt ueber die
;; normalen Einfuegefunktionen NEU erzeugt (Layer, ID, Verknuepfung,
;; Blockname/Schraffur, ATTSYNC kommen von dort) - die Kinder 1:1 aus der
;; Quelle, ohne Neufuellen, damit Handaenderungen (auto_geaendert, manuelle
;; Reihen/Gaenge) erhalten bleiben. goh_rack-Bloecke (parametrisch) werden
;; per vla-Copy kopiert und auf den Regal-Layer des Zielgeschosses gelegt.
;; Die Kopie liegt deckungsgleich (2D uebereinander), optional je Kopie um
;; (dx dy) versetzt; in einer 3D-Zeichnung (Konturen auf Belagshoehe)
;; zusaetzlich in Z um den Hoehenabstand.

;; Layer eines Objekts oder nil.
(defun lg-ent-layer (ent / ed)
  (if (and ent (setq ed (entget ent))) (cdr (assoc 8 ed)))
)

;; Reiner Kern: Geschossnummer aus einem Lager-Layer "LG_<x>_G<nr>"
;; (Muster wie lg-geschoss-aktivieren), sonst nil.
(defun lg-geschoss-aus-layer (name / s p rest)
  (if (and (= (type name) 'STR) (wcmatch (setq s (strcase name)) "LG_*_G#*"))
    (progn
      (setq p (vl-string-position (ascii "_") s nil T)
            rest (substr s (+ p 2)))
      (if (and (> (strlen rest) 1) (= (substr rest 1 1) "G")
               (vl-every '(lambda (c) (<= 48 c 57)) (vl-string->list (substr rest 2))))
        (atoi (substr rest 2)))))
)

;; Reiner Kern: Geschoss eines goh_rack. Ein Lager-Layer _G<nr> eines
;; vorhandenen Geschosses entscheidet (eindeutig auch bei 2D-Geschossen
;; uebereinander), sonst die Kontur (lg-geschoss-fuer-punkt-kern).
;; kandidaten = ((nr hoehe-mm kontur-punkte) ...)
(defun lg-rack-geschoss (layer pt kandidaten / n)
  (setq n (lg-geschoss-aus-layer layer))
  (if (and n (assoc n kandidaten))
    n
    (lg-geschoss-fuer-punkt-kern pt kandidaten))
)

;; Reiner Kern: Belag eines kopierten Bereichs/Gangs. Entsprach er dem
;; Geschossbelag der Quelle, folgt er dem neuen Geschossbelag; bewusst
;; abweichende (z.B. Gitterrost-Gang auf Spanplatte-Buehne) bleiben.
(defun lg-kopie-belag (belag alt neu)
  (if (and belag alt neu (= (strcase belag) (strcase alt))) neu belag)
)

;; Reiner Kern: Attributwerte einer kopierten Reihe/eines Gangs fuer
;; lg-linie-einfuegen. LAENGE/LAYER/ID entstehen dort neu; GESCHOSS und
;; BEREICH (nil = ohne Bereich -> "") werden ersetzt, BELAG folgt
;; lg-kopie-belag, alles uebrige (QUELLE!) bleibt.
(defun lg-kopie-werte (attribs gs-neu bereich-nr belag-alt belag-neu / w)
  (setq w (vl-remove-if '(lambda (p) (member (strcase (car p)) '("LAENGE" "LAYER" "ID" "GESCHOSS" "BEREICH")))
                        attribs))
  (if (assoc "BELAG" w)
    (setq w (lg-wert-setzen w "BELAG" (lg-kopie-belag (cdr (assoc "BELAG" w)) belag-alt belag-neu))))
  (append (list (cons "GESCHOSS" (vl-princ-to-string gs-neu))
                (cons "BEREICH" (if bereich-nr (vl-princ-to-string bereich-nr) "")))
          w)
)

;; Reiner Kern: Kopierplan ((i hoehe (vx vy vz)) ...) fuer n Kopien.
;; Kopie i liegt auf h-src + i*abstand und um i*(dx dy) versetzt; in Z nur
;; bei einer 3D-Zeichnung (z3d).
(defun lg-kopie-plan (h-src abstand n dx dy z3d / i erg)
  (setq i 1 erg nil)
  (while (<= i n)
    (setq erg (cons (list i (+ h-src (* i abstand))
                          (list (* i dx) (* i dy) (if z3d (* i abstand) 0.0)))
                    erg)
          i (1+ i)))
  (reverse erg)
)

;; Reiner Kern: Vorgabe Hoehenabstand. Abstand zum Geschoss darunter, sonst
;; lichte Hoehe + Konstruktionshoehe der Quelle, sonst nil (Eingabe noetig).
(defun lg-kopie-abstand-vorgabe (h-src h-unter lichte konstr)
  (cond
    ((and h-unter (> (- h-src h-unter) 1.0)) (- h-src h-unter))
    ((and lichte (> lichte 0.0)) (+ lichte (if konstr konstr 0.0)))
    (T nil))
)

;; Reiner Kern: liegt die Zeichnung in 3D (mindestens ein Geschoss mit
;; Hoehe != 0, dessen Kontur auf seiner Belagshoehe liegt)?
(defun lg-kopie-3d-p (kandidaten)
  (if (vl-some '(lambda (k) (and (caddr k) (> (abs (cadr k)) 1.0)
                                 (equal (lg-kandidat-z k) (cadr k) 1.0)))
               kandidaten)
    T)
)

;; Dialog-Vorgaben: oberstes Geschoss als Quelle (Erweitern G3 -> G4).
(defun lg-kopie-vorgaben ( / gs top h-top unter a belag)
  (setq gs (vl-sort (lg-geschosse) '(lambda (x y) (< (lg-geschoss-hoehe x) (lg-geschoss-hoehe y))))
        top (last gs)
        h-top (lg-geschoss-hoehe top)
        unter (vl-remove-if-not '(lambda (g) (< (lg-geschoss-hoehe g) (- h-top 1.0))) gs)
        a (caddr top)
        belag (cdr (assoc "BELAG_ART" a)))
  (if (or (null belag) (= belag "hallenboden"))
    (setq belag (lg-vorgabe '("geschoss" "belag_art") "spanplatte")))
  (list (cons "QUELLE" (itoa (cadr top)))
        (cons "ANZAHL" "1")
        (cons "ABSTAND_mm" (lg-mm-str (lg-kopie-abstand-vorgabe
                                        h-top (if unter (lg-geschoss-hoehe (last unter)))
                                        (lg-zahl (cdr (assoc "LICHTE_HOEHE_mm" a)))
                                        (lg-zahl (cdr (assoc "KONSTR_HOEHE_mm" a))))))
        (cons "BELAG_ART" belag)
        (cons "VERSATZ_X_mm" "0")
        (cons "VERSATZ_Y_mm" "0"))
)

(defun lg-ent-verschieben (ent v)
  (vla-Move (vlax-ename->vla-object ent) (vlax-3d-point '(0.0 0.0 0.0)) (vlax-3d-point v))
  ent
)

;; Kontur kopieren (ohne Handle/XDATA) und um v verschieben.
(defun lg-kontur-kopie (ent v / neu)
  (if (setq neu (lg-kontur-kopieren ent)) (lg-ent-verschieben neu v))
)

;; goh_rack-Bloecke des Geschosses src als oberste INSERTs im Modellbereich
;; (ein Array mit Racks zaehlt als ein Objekt). Vor der ersten Kopie
;; aufrufen: danach waere die Kontur-Zuordnung deckungsgleicher Geschosse
;; mehrdeutig. Rueckgabe: (racks anzahl-mehrdeutig)
(defun lg-racks-der-quelle (src kandidaten / src-pts racks mehrdeutig top gs)
  (setq racks nil mehrdeutig nil
        src-pts (caddr (assoc src kandidaten)))
  (foreach r (lg-racks-sammeln)
    (setq top (lg-rk-top r)
          gs (lg-rack-geschoss (lg-ent-layer top) (lg-rk-mitte r) kandidaten))
    (cond
      ((and gs (= gs src))
        (if (not (member top racks)) (setq racks (cons top racks))))
      ((and (null gs) src-pts (ssg-punkt-in-poly-p (lg-rk-mitte r) src-pts))
        (if (not (member top mehrdeutig)) (setq mehrdeutig (cons top mehrdeutig))))))
  (list (reverse racks)
        (length (vl-remove-if '(lambda (m) (member m racks)) mehrdeutig)))
)

;; Racks der Quelle ohne Lager-Layer auf den Regal-Layer der Quelle legen -
;; nach der Kopie liegen sie deckungsgleich mit den Kopien, nur der Layer
;; trennt sie dann (Export, LG_GESCHOSS_AKTIV). Rueckgabe: Anzahl.
(defun lg-racks-umhaengen (racks src / lay n)
  (setq n 0)
  (foreach r racks
    (if (null (lg-geschoss-aus-layer (lg-ent-layer r)))
      (progn
        (if (null lay) (setq lay (lg-layer "goh_rack" src)))
        (vla-put-Layer (vlax-ename->vla-object r) lay)
        (setq n (1+ n)))))
  n
)

;; Racks per vla-Copy (MCAD-Parameter bleiben) um v versetzt ins Geschoss
;; nr kopieren. Rueckgabe: Anzahl.
(defun lg-racks-kopieren (racks nr v / lay n res)
  (setq n 0 lay (if racks (lg-layer "goh_rack" nr)))
  (foreach r racks
    (setq res (vl-catch-all-apply
                '(lambda ( / obj)
                   (setq obj (vla-Copy (vlax-ename->vla-object r)))
                   (vla-Move obj (vlax-3d-point '(0.0 0.0 0.0)) (vlax-3d-point v))
                   (vla-put-Layer obj lay)
                   T)))
    (if (vl-catch-all-error-p res)
      (princ (ssg-textf "lg-einfuegen-fehler" (list (lg-blockname r) (vl-catch-all-error-message res))))
      (setq n (1+ n))))
  n
)

;; Eine Kopie des Geschosses src-nr als Geschoss nr auf hoehe, um v versetzt.
;; Rueckgabe: (geschoss-ent reihen gaenge racks) oder nil.
(defun lg-geschoss-kopieren (src-nr nr hoehe belag-neu v racks
                             / src a belag-alt k werte blk zuordnung kk nb ab ed p1 p2 rot
                               laenge nb-h art n-reihen n-gaenge s-gs)
  (setq src (lg-geschoss-finden src-nr)
        a (caddr src)
        belag-alt (cdr (assoc "BELAG_ART" a))
        s-gs (itoa src-nr)
        k (if src (lg-ent-aus-handle (lg-xdata-wert (car src) "kontur"))))
  (cond
    ((null src) (princ (ssg-textf "lg-geschoss-unbekannt" (list s-gs))) nil)
    ((null k) (princ (ssg-textf "lg-exp-geschoss-ohne-kontur" (list s-gs))) nil)
    (T
      ;; 1. Geschoss: Attribute der Quelle, neu sind Nummer, Bezeichnung,
      ;;    Belagshoehe und Belag (GESCHOSS/LAYER/ID setzt lg-geschoss-anlegen)
      (setq werte (append
                    (list (cons "NR" (itoa nr))
                          (assoc "BEZEICHNUNG" (lg-geschoss-vorgaben nr))
                          (cons "HOEHE_BELAG_mm" (lg-mm-str hoehe))
                          (cons "BELAG_ART" belag-neu))
                    (vl-remove-if '(lambda (p) (member (strcase (car p))
                                                 '("NR" "BEZEICHNUNG" "HOEHE_BELAG_MM" "BELAG_ART"
                                                   "GESCHOSS" "LAYER" "ID")))
                                  a)))
      (setq kk (lg-kontur-kopie k v))
      (if (null (setq blk (lg-geschoss-anlegen kk werte)))
        (progn (if kk (entdel kk)) nil)
        (progn
          ;; 2. Bereiche (ohne Fuellung), Zuordnung alter -> neuer Handle
          (setq zuordnung nil)
          (foreach b (lg-alle-bloecke "LG_BEREICH")
            (setq ab (ssg-attrib-read b))
            (if (and (= (cdr (assoc "GESCHOSS" ab)) s-gs)
                     (setq k (lg-ent-aus-handle (lg-xdata-wert b "kontur")))
                     (setq kk (lg-kontur-kopie k v)))
              (progn
                (setq werte (vl-remove-if '(lambda (p) (member (strcase (car p)) '("NR" "LAYER" "ID" "GESCHOSS")))
                                          ab))
                (if (assoc "BELAG" werte)
                  (setq werte (lg-wert-setzen werte "BELAG"
                                (lg-kopie-belag (cdr (assoc "BELAG" werte)) belag-alt belag-neu))))
                (if (setq nb (lg-bereich-block-anlegen kk (cons (cons "GESCHOSS" (itoa nr)) werte)))
                  (setq zuordnung (cons (cons (lg-handle b) nb) zuordnung))
                  (entdel kk)))))
          ;; 3. Reihen und Gaenge 1:1 (auch ohne Bereich), kein Neufuellen
          (setq n-reihen 0 n-gaenge 0)
          (foreach e (append (lg-alle-bloecke "LG_REIHE_*") (lg-alle-bloecke "LG_GANG_*"))
            (setq ab (ssg-attrib-read e))
            (if (= (cdr (assoc "GESCHOSS" ab)) s-gs)
              (progn
                (setq ed (entget e)
                      p1 (mapcar '+ (cdr (assoc 10 ed)) v)
                      rot (cond ((cdr (assoc 50 ed))) (0.0))
                      laenge (cond ((lg-zahl (cdr (assoc "LAENGE" ab)))) (0.0))
                      p2 (polar p1 rot laenge)
                      p2 (list (car p2) (cadr p2) (caddr p1))
                      nb (cdr (assoc (lg-xdata-wert e "bereich") zuordnung))
                      art (if (wcmatch (strcase (lg-blockname e)) "LG_REIHE_*") "reihe" "gang"))
                (if (lg-linie-einfuegen art p1 p2
                      (lg-kopie-werte ab nr (if nb (cdr (assoc "NR" (ssg-attrib-read nb))))
                                      belag-alt belag-neu)
                      nb)
                  (if (= art "reihe") (setq n-reihen (1+ n-reihen)) (setq n-gaenge (1+ n-gaenge)))))))
          ;; 4. goh_rack
          (list blk n-reihen n-gaenge (lg-racks-kopieren racks nr v))))
    )
  )
)

;; Geschoss kopieren nach Dialogwerten (QUELLE ANZAHL ABSTAND_mm BELAG_ART
;; VERSATZ_X_mm VERSATZ_Y_mm), nicht interaktiv - auch fuer Tests.
;; Rueckgabe: Liste der neuen Geschossnummern oder nil.
(defun lg-geschosse-kopieren (werte / src-nr src n abstand belag dx dy kandidaten
                              rq racks nr erg neu)
  (setq src-nr (atoi (cond ((cdr (assoc "QUELLE" werte))) ("0")))
        src (lg-geschoss-finden src-nr)
        n (atoi (cond ((cdr (assoc "ANZAHL" werte))) ("1")))
        abstand (lg-zahl (cdr (assoc "ABSTAND_mm" werte)))
        belag (cdr (assoc "BELAG_ART" werte))
        dx (cond ((lg-zahl (cdr (assoc "VERSATZ_X_mm" werte)))) (0.0))
        dy (cond ((lg-zahl (cdr (assoc "VERSATZ_Y_mm" werte)))) (0.0)))
  (cond
    ((null src) (princ (ssg-textf "lg-geschoss-unbekannt" (list (itoa src-nr)))) nil)
    ((or (null abstand) (<= abstand 0.0)) (princ (ssg-text "lg-kopie-abstand-ungueltig")) nil)
    ((< n 1) nil)
    (T
      (setq kandidaten (lg-geschoss-kandidaten))
      ;; Racks VOR der ersten Kopie bestimmen (danach waere die Kontur mehrdeutig)
      (setq rq (lg-racks-der-quelle src-nr kandidaten)
            racks (car rq))
      (if (> (cadr rq) 0) (princ (ssg-textf "lg-kopie-racks-mehrdeutig" (list (itoa (cadr rq))))))
      (if (> (setq neu (lg-racks-umhaengen racks src-nr)) 0)
        (princ (ssg-textf "lg-kopie-racks-umgehaengt" (list (itoa neu) (itoa src-nr)))))
      (setq erg nil)
      (foreach p (lg-kopie-plan (lg-geschoss-hoehe src) abstand n dx dy (lg-kopie-3d-p kandidaten))
        (if (vl-some '(lambda (k) (equal (cadr k) (cadr p) 1.0)) (lg-geschoss-kandidaten))
          (princ (ssg-textf "lg-kopie-hoehe-belegt" (list (lg-mm-str (cadr p))))))
        (setq nr (lg-geschoss-naechste-nr))
        (if (setq neu (lg-geschoss-kopieren src-nr nr (cadr p) belag (caddr p) racks))
          (progn
            (setq erg (cons nr erg))
            (princ (ssg-textf "lg-kopie-fertig"
                     (list (itoa src-nr) (itoa nr) (lg-mm-str (cadr p))
                           (itoa (cadr neu)) (itoa (caddr neu)) (itoa (cadddr neu))))))))
      (if erg
        (progn
          (lg-ldata-setzen "GESCHOSS_AKTIV" (car erg))
          (princ (ssg-text "lg-kopie-hinweis-aktiv"))))
      (reverse erg))
  )
)

;; ============================================================
;; BEFEHLE
;; ============================================================

(defun c:LG_GESCHOSS ( / kontur nr werte blk)
  (ssg-start (ssg-text "lg-titel-geschoss") nil)
  (setq kontur (lg-kontur-waehlen (ssg-text "lg-prompt-kontur-geschoss")))
  (if kontur
    (progn
      (setq nr (lg-geschoss-naechste-nr))
      (setq werte (lg-dialog "lg_geschoss" *lg-felder-geschoss* (lg-geschoss-vorgaben nr) nil))
      (if (and werte (setq blk (lg-geschoss-anlegen kontur werte)))
        (progn
          (lg-ldata-setzen "GESCHOSS_AKTIV" (atoi (cdr (assoc "NR" werte))))
          (princ (ssg-textf "lg-geschoss-angelegt" (list (cdr (assoc "NR" werte))
                                                         (cdr (assoc "HOEHE_BELAG_mm" werte)))))))))
  (ssg-end)
  (princ)
)

;; Geschoss aktivieren: Layer der uebrigen Geschosse frieren (0 = alle zeigen).
(defun lg-geschoss-aktivieren (nr / tab name suffix)
  (if (and (> nr 0) (null (lg-geschoss-finden nr)))
    (progn (princ (ssg-textf "lg-geschoss-unbekannt" (list (itoa nr)))) nil)
    (progn
      (lg-ldata-setzen "GESCHOSS_AKTIV" nr)
      ;; aktuellen Layer weg von evtl. zu frierenden Lager-Layern
      (if (and (> nr 0) (wcmatch (strcase (getvar "CLAYER")) "LG_*_G#*")
               (not (wcmatch (strcase (getvar "CLAYER")) (strcat "LG_*_G" (itoa nr)))))
        (setvar "CLAYER" "0"))
      (setq suffix (strcat "_G" (itoa nr)))
      (setq tab (tblnext "LAYER" T))
      (while tab
        (setq name (cdr (assoc 2 tab)))
        (if (wcmatch (strcase name) "LG_*_G#*")
          (lg-layer-frieren name (and (> nr 0) (not (wcmatch (strcase name) (strcat "LG_*" suffix))))))
        (setq tab (tblnext "LAYER")))
      (princ (if (> nr 0) (ssg-textf "lg-geschoss-aktiv" (list (itoa nr))) (ssg-text "lg-geschoss-alle")))
      nr)
  )
)

(defun lg-layer-frieren (name frieren / e ed f)
  (if (and (setq e (tblobjname "LAYER" name))
           (not (and frieren (= (strcase name) (strcase (getvar "CLAYER"))))))
    (progn
      (setq ed (entget e) f (cdr (assoc 70 ed)))
      (setq f (if frieren (logior f 1) (logand f (~ 1))))
      (entmod (subst (cons 70 f) (assoc 70 ed) ed))))
)

;; Geschoss mit Belag, Bereichen, Reihen, Gaengen und goh_racks in ein oder
;; mehrere neue Geschosse kopieren (siehe lg-geschosse-kopieren).
(defun c:LG_GESCHOSS_KOPIEREN ( / werte)
  (ssg-start (ssg-text "lg-titel-kopie") nil)
  (if (null (lg-geschosse))
    (princ (ssg-text "lg-kein-geschoss"))
    (if (setq werte (lg-dialog "lg_geschoss_kopie" *lg-felder-kopie* (lg-kopie-vorgaben) nil))
      (lg-geschosse-kopieren werte)))
  (ssg-end)
  (princ)
)

(defun c:LG_GESCHOSS_AKTIV ( / gs nr)
  (setq gs (lg-geschosse))
  (if (null gs)
    (princ (ssg-text "lg-kein-geschoss"))
    (progn
      (princ (strcat "\n" (ssg-join (mapcar '(lambda (g) (strcat (itoa (cadr g)) " = "
                                                  (cond ((cdr (assoc "BEZEICHNUNG" (caddr g)))) ("")))) gs)
                             ", ")))
      (setq nr (ssg-in-int (ssg-text "lg-prompt-geschoss-aktiv")
                           (cond ((lg-geschoss-aktiv)) (0))))
      (if nr (lg-geschoss-aktivieren nr))
      (command "_.REGEN")))
  (princ)
)

(defun c:LG_BEREICH ( / kontur pts gs werte blk)
  (ssg-start (ssg-text "lg-titel-bereich") nil)
  (setq kontur (lg-kontur-waehlen (ssg-text "lg-prompt-kontur-bereich")))
  (if kontur
    (progn
      (setq pts (ssg-lwpoly-punkte kontur))
      (if (ssg-lwpoly-boegen-p kontur) (princ (ssg-text "lg-kontur-boegen")))
      (setq gs (lg-geschoss-ermitteln (car pts)))
      (if gs
        (progn
          (setq werte (lg-dialog "lg_bereich" *lg-felder-bereich* (lg-bereich-vorgaben pts) nil))
          (if werte
            (setq blk (lg-bereich-anlegen kontur (cons (cons "GESCHOSS" (itoa gs)) werte))))))))
  (ssg-end)
  (princ)
)

;; Reiner Kern: Gang aus einem Rechteck. ecken = 4 Eckpunkte im Umlauf
;; (WCS), die erste = die zuerst gepickte Ecke. Die laengere Seite ist die
;; Gangrichtung, die kurze Seite die Breite (auf ganze mm). Die Rundung
;; verschiebt NUR die Laengsseite gegenueber der ersten Ecke: die Seite, an
;; der der Anwender angesetzt hat (z.B. buendig an einer Regalreihe), bleibt
;; exakt liegen - sonst wuerde der Gang die Reihe um Bruchteile eines mm
;; ueberdecken und sie beim Zuschnitt entfernen. Ebenso beginnt die Linie an
;; der Querseite der ersten Ecke (die Laengenrundung wirkt am anderen Ende).
;; Quadrat: Richtung der ersten Kante. Z = Z der ersten Ecke.
;; Rueckgabe: (p1 p2 breite) oder nil (entartet).
(defun lg-gang-aus-ecken (ecken / a b c d z l1 l2 w ende quer u)
  (setq a (nth 0 ecken) b (nth 1 ecken) c (nth 2 ecken) d (nth 3 ecken)
        z (cond ((caddr a)) (0.0))
        l1 (distance (list (car a) (cadr a)) (list (car b) (cadr b)))
        l2 (distance (list (car b) (cadr b)) (list (car c) (cadr c))))
  (if (and (>= l1 1.0) (>= l2 1.0))
    (progn
      ;; ende = Ecke am Ende der Laengsseite durch a, quer = Nachbar quer dazu
      (if (>= l1 l2)
        (setq ende b quer d w (lg-mm-runden l2))
        (setq ende d quer b w (lg-mm-runden l1)))
      ;; halbe gerundete Breite von der Laengsseite durch a nach innen
      (setq u (/ (/ w 2.0) (distance (list (car a) (cadr a)) (list (car quer) (cadr quer))))
            u (list (* u (- (car quer) (car a))) (* u (- (cadr quer) (cadr a)))))
      (list (list (+ (car a) (car u)) (+ (cadr a) (cadr u)) z)
            (list (+ (car ende) (car u)) (+ (cadr ende) (cadr u)) z)
            w)))
)

;; Rechteck mit dem BricsCAD-Befehl RECHTECK zeichnen lassen - mit allen
;; seinen Optionen (Abmessungen, Flaeche, Drehung, Objektfang ...). Die
;; entstandene Polylinie wird als 4 Eckpunkte (WCS) gelesen und wieder
;; geloescht. Rueckgabe: Eckpunkte, nil (nichts gezeichnet = Ende) oder
;; 'kein-rechteck (z.B. mit Fase/Rundung gezeichnet).
(defun lg-rechteck-zeichnen ( / marke echo e pts)
  (setq marke (entlast) echo (getvar "CMDECHO"))
  ;; ohne CMDECHO zeigt RECHTECK seine Fragen und Optionen nicht an
  (setvar "CMDECHO" 1)
  (command "_.RECTANG")
  (while (> (getvar "CMDACTIVE") 0) (command pause))
  (setvar "CMDECHO" echo)
  (setq e (entlast))
  (if (and e (not (equal e marke)))
    (progn
      (setq pts (lg-rechteck-ecken-aus-poly e))
      (entdel e)
      pts))
)

;; Eckpunkte (WCS) einer mit RECHTECK gezeichneten Polylinie oder
;; 'kein-rechteck (anderes Objekt, Fase/Rundung, mehr als 4 Ecken).
(defun lg-rechteck-ecken-aus-poly (e / pts)
  (if (and (= (cdr (assoc 0 (entget e))) "LWPOLYLINE")
           (= (length (setq pts (ssg-lwpoly-punkte e))) 4)
           (not (ssg-lwpoly-boegen-p e)))
    pts
    'kein-rechteck)
)

;; Punkteingabe fuer Linienobjekte (Reihe/Gang): Startpunkt, dann Endpunkt
;; ODER getippte Laenge (+ Richtung), bis ESC/Enter (Muster Geruest-Traeger).
;; einfuegen-fn bekommt je Punktpaar (p1 p2) in WCS und liefert nil bei
;; Misserfolg. rechteck-fn (nil = ohne): schaltet am Startpunkt das
;; Schluesselwort "Rechteck" frei (prompt-start nennt es ueber %1); danach
;; wird jede Flaeche mit dem BricsCAD-Befehl RECHTECK gezeichnet
;; (lg-rechteck-zeichnen) und rechteck-fn bekommt die 4 Eckpunkte (WCS).
;; Enter ohne Rechteck beendet. Rueckgabe: Anzahl erfolgreicher Aufrufe.
(defun lg-linien-schleife (prompt-start einfuegen-fn rechteck-fn / weiter modus k-rechteck
                           ecken p1 eingabe p2 laenge winkel n)
  (setq weiter T n 0 modus "linie"
        k-rechteck (ssg-text "lg-key-rechteck"))
  (while weiter
    (if (= modus "rechteck")
      (progn
        (princ (ssg-text "lg-rechteck-hinweis"))
        (setq ecken (lg-rechteck-zeichnen))
        (cond
          ((null ecken) (setq weiter nil))
          ((eq ecken 'kein-rechteck) (princ (ssg-text "lg-rechteck-kein-rechteck")))
          ((apply rechteck-fn (list ecken)) (setq n (1+ n)))))
      (progn
        (if rechteck-fn (initget k-rechteck))
        (setq p1 (getpoint (if rechteck-fn (vl-string-subst k-rechteck "%1" prompt-start) prompt-start)))
        (cond
          ((null p1) (setq weiter nil))
          ((= (type p1) 'STR) (setq modus "rechteck"))
          (T
            (initget 128)
            (setq eingabe (getpoint p1 (ssg-text "lg-prompt-reihe-ende")))
            (setq p2 nil)
            (cond
              ((null eingabe) (setq weiter nil))
              ((listp eingabe) (setq p2 eingabe))
              ((= eingabe "") (setq weiter nil))
              ((setq laenge (lg-zahl eingabe))
                (setq winkel (getangle p1 (ssg-text "lg-prompt-reihe-richtung")))
                (setq p2 (polar p1 (if winkel winkel 0.0) laenge)))
              (T (princ (ssg-text "lg-wert-ungueltig"))))
            (if p2
              (progn
                ;; Objekt liegt auf Z des Startpunkts; erst p2, dann p1
                ;; nach WCS (p2 braucht das UCS-Z von p1)
                (setq p2 (trans (list (car p2) (cadr p2) (caddr p1)) 1 0)
                      p1 (trans p1 1 0))
                (if (apply einfuegen-fn (list p1 p2))
                  (setq n (1+ n)))))))))
  )
  n
)

;; Einzelreihen per Linie.
(defun c:LG_REIHE ( / gs werte n)
  (ssg-start (ssg-text "lg-titel-reihe") nil)
  (setq gs (lg-geschoss-ermitteln '(0.0 0.0 0.0)))
  (if gs
    (progn
      (setq werte (lg-dialog "lg_reihe" *lg-felder-reihe*
                    (list (cons "LAENGE" "0")
                          (cons "TIEFE_mm" (lg-mm-str (lg-zahl (lg-vorgabe '("bereich" "regaltiefe_mm") 700))))
                          (cons "HAENGEEBENEN" (lg-vorgabe '("reihe" "haengeebenen") "2300/1200;1100/1100"))
                          (cons "SCHIENEN" (itoa (fix (lg-zahl (lg-vorgabe '("reihe" "schienen") 1))))))
                    '("laenge")))
      (if werte
        (progn
          (setq werte (append (list (cons "GESCHOSS" (itoa gs)) (cons "BEREICH" "") (cons "QUELLE" "manuell"))
                              (vl-remove-if '(lambda (p) (= (car p) "LAENGE")) werte)))
          (setq n (lg-linien-schleife (ssg-text "lg-prompt-reihe-start")
                    '(lambda (p1 p2) (lg-manuell-einfuegen "reihe" p1 p2 werte))
                    nil))
          (princ (ssg-textf "lg-reihen-eingefuegt" (list (itoa n))))))))
  (ssg-end)
  (princ)
)

(defun lg-gang-vorgaben ( / )
  (list (cons "LAENGE" "0")
        (cons "BREITE_mm" (lg-mm-str (lg-zahl (lg-vorgabe '("bereich" "gangbreite_mm") 1000))))
        (cons "ART" "gang")
        (cons "BELAG" (lg-vorgabe '("bereich" "belag") "spanplatte")))
)

;; Reihe/Gang von Hand von p1 nach p2 (WCS, mittig auf der Linie) einfuegen
;; (nicht interaktiv - auch fuer Tests). art = "reihe"|"gang"; werte wie
;; bei lg-linie-einfuegen mit GESCHOSS. Liegt die Mitte in einem
;; Lagerbereich, wird das Objekt mit ihm verknuepft. Danach schneidet es
;; seine Flaeche aus den automatisch erzeugten Reihen/Gaengen heraus
;; (lg-sperre-anwenden) - der Bereich wird NICHT neu berechnet, und bei
;; jeder spaeteren Neuberechnung bleibt das Objekt stehen.
;; Rueckgabe: ename oder nil.
(defun lg-manuell-einfuegen (art p1 p2 werte / mitte bereich ent)
  (setq mitte (list (/ (+ (car p1) (car p2)) 2.0) (/ (+ (cadr p1) (cadr p2)) 2.0)
                    (cond ((caddr p1)) (0.0))))
  (setq bereich (lg-bereich-fuer-punkt mitte (cdr (assoc "GESCHOSS" werte))))
  (setq werte (lg-wert-setzen werte "QUELLE" "manuell"))
  (setq werte (lg-wert-setzen werte "BEREICH"
                (if bereich (cdr (assoc "NR" (ssg-attrib-read bereich))) "")))
  (if (setq ent (lg-linie-einfuegen art p1 p2 werte bereich))
    (progn
      (lg-sperre-anwenden ent)
      ent))
)

;; Manuellen Gang einfuegen; werte braucht GESCHOSS, BREITE_mm, ART, BELAG.
(defun lg-gang-einfuegen (p1 p2 werte)
  (lg-manuell-einfuegen "gang" p1 p2 werte)
)

;; Manuellen Gang aus einem Rechteck (4 Eckpunkte WCS) einfuegen - Breite
;; und Lage kommen aus der Flaeche, BREITE_mm aus werte gilt dann nicht.
;; Rueckgabe: ename oder nil.
(defun lg-gang-rechteck-einfuegen (ecken werte / g)
  (if (setq g (lg-gang-aus-ecken ecken))
    (lg-gang-einfuegen (car g) (cadr g) (lg-wert-setzen werte "BREITE_mm" (lg-mm-str (caddr g))))
    (progn (princ (ssg-text "lg-rechteck-zu-klein")) nil))
)

;; Einzelne Gaenge per Linie oder Rechteck (Randgang, Fluchtweg, Durchgang ...).
(defun c:LG_GANG ( / gs werte n)
  (ssg-start (ssg-text "lg-titel-gang") nil)
  (setq gs (lg-geschoss-ermitteln '(0.0 0.0 0.0)))
  (if gs
    (progn
      (setq werte (lg-dialog "lg_gang" *lg-felder-gang* (lg-gang-vorgaben) '("laenge")))
      (if werte
        (progn
          (setq werte (cons (cons "GESCHOSS" (itoa gs))
                            (vl-remove-if '(lambda (p) (= (car p) "LAENGE")) werte)))
          (setq n (lg-linien-schleife (ssg-text "lg-prompt-gang-start")
                    '(lambda (p1 p2) (lg-gang-einfuegen p1 p2 werte))
                    '(lambda (ecken) (lg-gang-rechteck-einfuegen ecken werte))))
          (princ (ssg-textf "lg-gaenge-eingefuegt" (list (itoa n))))))))
  (ssg-end)
  (princ)
)

;; Doppelklick-Ziel (SSG_BLOCKEDIT, Zweig LG_*) und Befehl LG_EDIT.
(defun lg-edit-ent (ent / name a neu)
  (setq name (strcase (lg-blockname ent))
        a    (ssg-attrib-read ent))
  (cond
    ((= name "LG_GESCHOSS")
      ;; Nummer bleibt fest - an ihr haengen Layer und GESCHOSS der Kinder
      (if (setq neu (lg-dialog "lg_geschoss" *lg-felder-geschoss* a '("nr")))
        (progn (lg-attribute-setzen ent neu) (princ (ssg-text "lg-geaendert")))))
    ((= name "LG_BEREICH")
      (if (setq neu (lg-dialog "lg_bereich" *lg-felder-bereich* a nil))
        (progn
          (lg-attribute-setzen ent neu)
          ;; Pfeil des Symbols folgt der Reihenrichtung
          (vla-put-Rotation (vlax-ename->vla-object ent)
                            (* (/ (cond ((lg-zahl (cdr (assoc "RICHTUNG" neu)))) (0.0)) 180.0) pi))
          (lg-bereich-fuellen ent))))
    ((wcmatch name "LG_REIHE_*")
      (if (setq neu (lg-dialog "lg_reihe" *lg-felder-reihe* a nil))
        (progn
          (if (= (cdr (assoc "QUELLE" neu)) "auto")
            (setq neu (lg-wert-setzen neu "QUELLE" "auto_geaendert")))
          (lg-linie-neu-aufbauen-sperre ent neu))))
    ((wcmatch name "LG_GANG_*")
      (if (setq neu (lg-dialog "lg_gang" *lg-felder-gang* a nil))
        (progn
          (if (/= (cdr (assoc "QUELLE" neu)) "manuell")
            (setq neu (lg-wert-setzen neu "QUELLE" "auto_geaendert")))
          (lg-linie-neu-aufbauen-sperre ent neu))))
    (T (command "_.EATTEDIT" ent))
  )
  (princ)
)

(defun c:LG_EDIT ( / ss)
  (setq ss (ssget "_I"))
  (if (or (null ss) (/= (sslength ss) 1))
    (setq ss (ssget ":S" '((0 . "INSERT") (2 . "LG_*")))))
  (if ss
    (progn
      (ssg-start (ssg-text "lg-titel-edit") nil)
      (lg-edit-ent (ssname ss 0))
      (ssg-end)))
  (princ)
)

;; ============================================================
;; EXPORT (lager_raw.json)
;; ============================================================

;; --- JSON-Schreiber (rein, getestet) ---
;; Werte: nil -> null, T -> true, String, Ganz-/Fliesszahl, (ROH "json").
(defun lg-json-zahl (w / s)
  (setq s (rtos w 2 3))
  (if (vl-string-search "." s)
    (progn
      (setq s (vl-string-right-trim "0" s))
      (if (= (substr s (strlen s)) ".") (setq s (substr s 1 (1- (strlen s)))))))
  (if (= s "-0") "0" s)
)

(defun lg-json-wert (v)
  (cond
    ((null v) "null")
    ((eq v T) "true")
    ((= (type v) 'STR) (strcat "\"" (ssg-json-escape v) "\""))
    ((= (type v) 'INT) (itoa v))
    ((= (type v) 'REAL) (lg-json-zahl v))
    ((and (listp v) (eq (car v) 'ROH)) (cadr v))
    (T (strcat "\"" (ssg-json-escape (vl-princ-to-string v)) "\""))
  )
)

(defun lg-json-obj (paare)
  (strcat "{"
          (ssg-join (mapcar '(lambda (p) (strcat "\"" (car p) "\": " (lg-json-wert (cdr p)))) paare)
                    ", ")
          "}")
)

;; Liste bereits gerenderter JSON-Texte als Array (ein Element je Zeile).
(defun lg-json-arr (texte einrueckung)
  (if texte
    (strcat "[\n" einrueckung (ssg-join texte (strcat ",\n" einrueckung)) "\n" (substr einrueckung 3) "]")
    "[]")
)

(defun lg-json-zahlen (zahlen)
  (list 'ROH (strcat "[" (ssg-join (mapcar 'lg-json-wert zahlen) ", ") "]"))
)

(defun lg-json-ebenen (s)
  (list 'ROH
    (strcat "["
      (ssg-join (mapcar '(lambda (e) (lg-json-obj (list (cons "schienenhoehe_mm" (car e))
                                                         (cons "warenlaenge_mm" (cadr e)))))
                        (lg-haengeebenen-parse s))
                ", ")
      "]"))
)

;; Attributwert als Zahl bzw. Ganzzahl (nil, wenn leer).
(defun lg-a-zahl (a tag) (lg-zahl (cdr (assoc tag a))))
(defun lg-a-int (a tag / w) (if (setq w (lg-zahl (cdr (assoc tag a)))) (fix w)))

(defun lg-export-geschoss (g / a k pts bb)
  (setq a (caddr g) pts (cadddr g) bb (ssg-poly-bbox pts)
        k (lg-xdata-wert (car g) "kontur"))
  (lg-json-obj
    (list (cons "nr" (cadr g))
          (cons "bezeichnung" (cdr (assoc "BEZEICHNUNG" a)))
          (cons "hoehe_belag_mm" (lg-a-zahl a "HOEHE_BELAG_mm"))
          (cons "konstr_hoehe_mm" (lg-a-zahl a "KONSTR_HOEHE_mm"))
          (cons "lichte_hoehe_mm" (lg-a-zahl a "LICHTE_HOEHE_mm"))
          (cons "belag_art" (cdr (assoc "BELAG_ART" a)))
          (cons "personen" (lg-a-int a "PERSONEN"))
          (cons "brandgefaehrdung" (cdr (assoc "BRANDGEFAEHRDUNG" a)))
          (cons "kontur_flaeche_mm2" (if pts (ssg-poly-flaeche pts)))
          (cons "kontur_umfang_mm" (if pts (ssg-poly-umfang pts)))
          (cons "kontur_bbox" (if bb (lg-json-zahlen (append (car bb) (cadr bb)))))
          (cons "handle" (lg-handle (car g)))
          (cons "kontur_handle" k)))
)

(defun lg-export-bereich (e / a k pts bb)
  (setq a (ssg-attrib-read e)
        k (lg-ent-aus-handle (lg-xdata-wert e "kontur"))
        pts (if k (ssg-lwpoly-punkte k))
        bb (ssg-poly-bbox pts))
  (lg-json-obj
    (list (cons "nr" (lg-a-int a "NR"))
          (cons "geschoss" (lg-a-int a "GESCHOSS"))
          (cons "gangbreite_mm" (lg-a-zahl a "GANGBREITE_mm"))
          (cons "regaltiefe_mm" (lg-a-zahl a "REGALTIEFE_mm"))
          (cons "reihen_je_gang" (lg-a-int a "REIHEN_JE_GANG"))
          (cons "schienen_je_gang" (lg-a-int a "SCHIENEN_JE_GANG"))
          (cons "quergang_abstand_mm" (lg-a-zahl a "QUERGANG_ABSTAND_mm"))
          (cons "quergang_breite_mm" (lg-a-zahl a "QUERGANG_BREITE_mm"))
          (cons "richtung_grad" (lg-a-zahl a "RICHTUNG"))
          (cons "haengeebenen" (lg-json-ebenen (cdr (assoc "HAENGEEBENEN" a))))
          (cons "belag" (cdr (assoc "BELAG" a)))
          (cons "randgang_mm" (list 'ROH (lg-json-obj
                                (mapcar '(lambda (r) (cons (strcase (car r) T) (cdr r)))
                                        (lg-bereich-rand a)))))
          (cons "restbreite_mm" (lg-a-zahl a "RESTBREITE_mm"))
          (cons "kontur_flaeche_mm2" (if pts (ssg-poly-flaeche pts)))
          (cons "kontur_bbox" (if bb (lg-json-zahlen (append (car bb) (cadr bb)))))
          (cons "handle" (lg-handle e))))
)

(defun lg-export-linie (e art / a ed)
  (setq a (ssg-attrib-read e) ed (entget e))
  (lg-json-obj
    (append
      (list (cons "geschoss" (lg-a-int a "GESCHOSS"))
            (cons "laenge_mm" (lg-a-zahl a "LAENGE")))
      (if (= art "reihe")
        (list (cons "tiefe_mm" (lg-a-zahl a "TIEFE_mm"))
              (cons "haengeebenen" (lg-json-ebenen (cdr (assoc "HAENGEEBENEN" a))))
              (cons "schienen" (lg-a-int a "SCHIENEN"))
              (cons "quelle" (cdr (assoc "QUELLE" a))))
        (list (cons "breite_mm" (lg-a-zahl a "BREITE_mm"))
              (cons "art" (cdr (assoc "ART" a)))
              (cons "belag" (cdr (assoc "BELAG" a)))
              (cons "quelle" (if (member (cdr (assoc "QUELLE" a)) '(nil "")) "auto"
                               (cdr (assoc "QUELLE" a))))))
      (list (cons "bereich" (lg-a-int a "BEREICH"))
            (cons "start" (lg-json-zahlen (cdr (assoc 10 ed))))
            (cons "winkel_grad" (* (/ (cond ((cdr (assoc 50 ed))) (0.0)) pi) 180.0))
            (cons "handle" (lg-handle e)))))
)

;; goh_rack-Bloecke sammeln (lg-racks-sammeln). Geschoss ueber den Layer
;; des obersten INSERTs (_G<nr>), sonst ueber die Kontur (lg-rack-geschoss).
;; Rueckgabe: (json-texte warnungen)
(defun lg-export-goh-racks (kandidaten / texte warn gs ebenen vorgabe)
  (setq texte nil warn nil
        vorgabe (lg-vorgabe '("reihe" "haengeebenen") "2300/1200;1100/1100"))
  (foreach r (lg-racks-sammeln)
    (setq gs (lg-rack-geschoss (lg-ent-layer (lg-rk-top r)) (lg-rk-mitte r) kandidaten))
    (if (and (null gs) kandidaten)
      (setq warn (cons (ssg-textf "lg-exp-rack-ohne-geschoss"
                         (list (rtos (car (lg-rk-mitte r)) 2 0) (rtos (cadr (lg-rk-mitte r)) 2 0)))
                       warn)))
    (setq ebenen (if (lg-rk-ebenen r) (fix (lg-rk-ebenen r))))
    (if (null (lg-rk-laenge r))
      (setq warn (cons (ssg-textf "lg-exp-rack-ohne-laenge" (list (lg-rk-name r))) warn)))
    (setq texte (cons
      (lg-json-obj
        (list (cons "geschoss" gs)
              (cons "name" (lg-rk-name r))
              (cons "laenge_mm" (lg-rk-laenge r))
              (cons "ebenen" ebenen)
              (cons "tiefe_mm" (lg-zahl (lg-vorgabe '("goh_rack" "tiefe_mm") 700)))
              (cons "haengeebenen" (lg-json-ebenen (if ebenen (lg-haengeebenen-n vorgabe ebenen) vorgabe)))
              (cons "haengeebenen_quelle" "vorgabe")
              (cons "position" (lg-json-zahlen (lg-rk-mitte r)))))
      texte)))
  (list (reverse texte) (reverse warn))
)

;; Alle Daten als JSON-Text.
(defun lg-export-json ( / gs kandidaten racks warn gs-ohne)
  (setq gs (lg-geschosse)
        kandidaten (lg-geschoss-kandidaten)
        racks (lg-export-goh-racks kandidaten)
        warn (cadr racks))
  (if (null gs) (setq warn (cons (ssg-text "lg-exp-keine-geschosse") warn)))
  (foreach g gs
    (if (null (cadddr g))
      (setq warn (cons (ssg-textf "lg-exp-geschoss-ohne-kontur" (list (itoa (cadr g)))) warn))))
  (strcat
    "{\n"
    "  \"version\": 1,\n"
    "  \"zeichnung\": " (lg-json-wert (strcat (getvar "DWGPREFIX") (getvar "DWGNAME"))) ",\n"
    "  \"erzeugt\": " (lg-json-wert (ssg-timestamp)) ",\n"
    "  \"einheit\": \"mm\",\n"
    "  \"land\": " (lg-json-wert (lg-land)) ",\n"
    "  \"belag_yaml\": " (lg-json-obj (vl-remove-if '(lambda (p) (or (/= (type (cdr p)) 'STR)
                                                                    (= (car p) "beschreibung")))
                                         (lg-vorgabe '("belag_yaml") nil))) ",\n"
    "  \"reihen_als_gitterrost\": " (lg-json-wert (if (lg-vorgabe '("flaechen" "reihen_als_gitterrost") nil) T nil)) ",\n"
    "  \"geschosse\": " (lg-json-arr (mapcar 'lg-export-geschoss gs) "    ") ",\n"
    "  \"bereiche\": " (lg-json-arr (mapcar 'lg-export-bereich (lg-alle-bloecke "LG_BEREICH")) "    ") ",\n"
    "  \"reihen\": " (lg-json-arr (mapcar '(lambda (e) (lg-export-linie e "reihe")) (lg-alle-bloecke "LG_REIHE_*")) "    ") ",\n"
    "  \"gaenge\": " (lg-json-arr (mapcar '(lambda (e) (lg-export-linie e "gang")) (lg-alle-bloecke "LG_GANG_*")) "    ") ",\n"
    "  \"goh_racks\": " (lg-json-arr (car racks) "    ") ",\n"
    "  \"warnungen\": " (lg-json-arr (mapcar 'lg-json-wert warn) "    ") "\n"
    "}\n")
)

(defun lg-ausgabe-verzeichnis ( / d)
  (setq d (cond ((getenv "DXFM_RESULTS")) ((getvar "DWGPREFIX"))))
  (setq d (vl-string-right-trim "/\\" (vl-string-translate "\\" "/" d)))
  (if (not (vl-file-directory-p d)) (vl-mkdir d))
  d
)

(defun lg-dwg-basis ( / )
  (if (= (getvar "DWGTITLED") 1) (vl-filename-base (getvar "DWGNAME")) "lager")
)

;; JSON schreiben (pfad) -> pfad oder nil.
(defun lg-export-schreiben (pfad / fh)
  (if (setq fh (open pfad "w"))
    (progn (princ (lg-export-json) fh) (close fh) pfad)
    (progn (princ (ssg-textf "lg-exp-datei-fehler" (list pfad))) nil))
)

;; Python-Skript lager_yaml_export.py aufrufen (nutzt die Interpreter-
;; Ermittlung aus export.lsp). Rueckgabe: Exitcode oder nil.
(defun lg-python-aufrufen (raw yaml html / skript hand log args rc)
  (cond
    ((not (car (atoms-family 1 '("EXPORT:RUN-PYTHON"))))
      (princ (ssg-text "lg-exp-ohne-python")) nil)
    ((null (getenv "DXFM_LIB")) (princ (ssg-text "lg-exp-ohne-python")) nil)
    (T
      (setq skript (strcat (vl-string-translate "\\" "/" (getenv "DXFM_LIB")) "/lager_yaml_export.py")
            hand (lg-ldata-lesen "HAND_YAML")
            log (strcat (lg-ausgabe-verzeichnis) "/lager_export_python.log"))
      (setq args (list raw yaml "--nachweis" html))
      (if (and hand (= (type hand) 'STR) (findfile hand))
        (setq args (append args (list "--hand" hand))))
      (setq rc (export:run-python (export:python-exe) skript args log))
      (if (and rc (/= rc 0))
        (princ (ssg-textf "lg-exp-python-fehler" (list (vl-princ-to-string rc) log))))
      rc)
  )
)

(defun c:LAGER_EXPORT ( / dir basis raw yaml html rc)
  (setq dir (lg-ausgabe-verzeichnis) basis (lg-dwg-basis))
  (setq raw  (strcat dir "/" basis "_lager_raw.json")
        yaml (strcat dir "/" basis "_drawing.yaml")
        html (strcat dir "/" basis "_nachweis.html"))
  (if (lg-export-schreiben raw)
    (progn
      (princ (ssg-textf "lg-exp-raw" (list raw)))
      (setq rc (lg-python-aufrufen raw yaml html))
      (if (and rc (= rc 0))
        (princ (ssg-textf "lg-exp-yaml" (list yaml html))))))
  (princ)
)

;; Hand-YAML fuer den Abgleich (Konfliktliste) festlegen; leer = keiner.
(defun c:LAGER_HAND_YAML ( / alt neu)
  (setq alt (lg-ldata-lesen "HAND_YAML"))
  (setq neu (if (ssg-gui-p)
              (getfiled (ssg-text "lg-titel-hand-yaml") (if (= (type alt) 'STR) alt "") "yaml" 0)
              (ssg-in-string (ssg-text "lg-titel-hand-yaml") (if (= (type alt) 'STR) alt ""))))
  (lg-ldata-setzen "HAND_YAML" (if neu neu ""))
  (princ (ssg-textf "lg-hand-yaml" (list (if (and neu (/= neu "")) neu "-"))))
  (princ)
)

(princ)