Merge branch 'goh-storage'
This commit is contained in:
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,234 @@
|
||||
;; ============================================================
|
||||
;; LagerPruefung.lsp - Regelprofile der Lagerplanung (Phase 0)
|
||||
;;
|
||||
;; Laedt das Laenderprofil cfg/regelwerk/<LAND>.json, loest die Vererbung
|
||||
;; (erbt_von) auf und liefert je Regel den STRENGSTEN Wert aller Quellen,
|
||||
;; deren Bedingung zutrifft - mit Protokoll, welche Quelle gewonnen hat.
|
||||
;; Jede Pruefregel der Lagerplanung wird genau einmal hier implementiert
|
||||
;; (Python rendert nur, siehe doc/plan/lager_rfq.md).
|
||||
;;
|
||||
;; Spaetere Phasen (Treppen-/Leiterpruefung, Fluchtweg, Verstoss-Marker,
|
||||
;; LAGER_PRUEFEN) kommen in dieses Modul.
|
||||
;;
|
||||
;; Profil-Format (Auszug):
|
||||
;; {"land": "DE", "erbt_von": null, "gepflegt": true,
|
||||
;; "regeln": [{"id": "treppe.steigung_max", "art": "max", "einheit": "mm",
|
||||
;; "werte": [{"wert": 190, "quelle": "ASR A1.8", "abschnitt": "4.5",
|
||||
;; "fassung": "...", "bedingung": "...", "verifiziert": false}]}]}
|
||||
;; art = "min" -> Mindestwert, strengster = groesster
|
||||
;; "max" -> Hoechstwert, strengster = kleinster
|
||||
;; "wert" -> fester Wert, der erste zutreffende gilt
|
||||
;; Ein Eintrag mit "tabelle" [[bis, wert] ...] + "tabellen_schluessel" liefert
|
||||
;; den Wert der ersten Zeile, deren "bis" den Kontextwert abdeckt.
|
||||
;; "bedingung": "<schluessel> <op> <wert>", op = = <= >= < >. Fehlt der
|
||||
;; Schluessel im Kontext, wird der Eintrag KONSERVATIV mit einbezogen
|
||||
;; (Protokoll: "Bedingung nicht auswertbar").
|
||||
;; ============================================================
|
||||
|
||||
(if (not (boundp '*lg-profil-cache*)) (setq *lg-profil-cache* nil))
|
||||
|
||||
;; ------------------------------------------------------------
|
||||
;; Profil laden
|
||||
;; ------------------------------------------------------------
|
||||
|
||||
(defun lg-regelwerk-pfad (land / cfg)
|
||||
(setq cfg (getenv "DXFM_CFG"))
|
||||
(if cfg
|
||||
(strcat (vl-string-right-trim "/\\" (vl-string-translate "\\" "/" cfg))
|
||||
"/regelwerk/" (strcase land) ".json"))
|
||||
)
|
||||
|
||||
;; Zwei Profile mischen: Regeln von kind ersetzen gleichnamige (id) von
|
||||
;; basis vollstaendig, neue kommen hinzu. Kopf-Felder (land, gepflegt ...)
|
||||
;; kommen vom Kind. Reine Funktion.
|
||||
(defun lg-profil-mischen (basis kind / regeln r id alt)
|
||||
(setq regeln (ssg-json-get basis "regeln"))
|
||||
(foreach r (ssg-json-get kind "regeln")
|
||||
(setq id (ssg-json-get r "id"))
|
||||
(if (setq alt (vl-some '(lambda (x) (if (= (ssg-json-get x "id") id) x)) regeln))
|
||||
(setq regeln (subst r alt regeln))
|
||||
(setq regeln (append regeln (list r))))
|
||||
)
|
||||
(cons (cons "regeln" regeln)
|
||||
(vl-remove-if '(lambda (p) (= (car p) "regeln")) kind))
|
||||
)
|
||||
|
||||
;; Profil inkl. Vererbung laden (rekursiv, Zirkelschutz ueber besucht).
|
||||
;; Rueckgabe: gemischtes Profil (Alist) oder nil.
|
||||
(defun lg-profil-laden-roh (land besucht / pfad daten basis-land basis)
|
||||
(setq pfad (lg-regelwerk-pfad land))
|
||||
(if (and pfad (findfile pfad)
|
||||
(not (member (strcase land) besucht)))
|
||||
(progn
|
||||
(setq daten (ssg-json-laden pfad))
|
||||
(setq basis-land (ssg-json-get daten "erbt_von"))
|
||||
(if (and basis-land (= (type basis-land) 'STR) (/= basis-land ""))
|
||||
(progn
|
||||
(setq basis (lg-profil-laden-roh basis-land (cons (strcase land) besucht)))
|
||||
(if basis (lg-profil-mischen basis daten) daten))
|
||||
daten)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
;; Gecachtes Profil des Landes. Meldet ein nicht gepflegtes Profil einmalig.
|
||||
(defun lg-profil (land / eintrag profil)
|
||||
(if (null land) (setq land "DE"))
|
||||
(setq eintrag (assoc (strcase land) *lg-profil-cache*))
|
||||
(if eintrag
|
||||
(cdr eintrag)
|
||||
(progn
|
||||
(setq profil (lg-profil-laden-roh land nil))
|
||||
(if (null profil)
|
||||
(princ (ssg-textf "lg-regel-profil-fehlt" (list land (lg-regelwerk-pfad land))))
|
||||
(if (not (ssg-json-get profil "gepflegt"))
|
||||
(princ (ssg-textf "lg-regel-profil-ungepflegt" (list land)))))
|
||||
(setq *lg-profil-cache* (cons (cons (strcase land) profil) *lg-profil-cache*))
|
||||
profil
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(defun lg-profil-reset ( / ) (setq *lg-profil-cache* nil) (princ))
|
||||
|
||||
(defun lg-regel-finden (profil id)
|
||||
(vl-some '(lambda (r) (if (= (ssg-json-get r "id") id) r))
|
||||
(ssg-json-get profil "regeln"))
|
||||
)
|
||||
|
||||
;; ------------------------------------------------------------
|
||||
;; Aufloesung (reine Funktionen)
|
||||
;; ------------------------------------------------------------
|
||||
|
||||
;; Kontextwert als Zahl, falls moeglich (Strings wie "3100" werden gewandelt).
|
||||
(defun lg-kontext-zahl (v)
|
||||
(cond
|
||||
((numberp v) (float v))
|
||||
;; NICHT ((and (= (type v) 'STR) (distof v 2))) - and liefert T statt der Zahl
|
||||
((= (type v) 'STR) (distof v 2))
|
||||
(T nil)
|
||||
)
|
||||
)
|
||||
|
||||
;; Bedingung pruefen. Rueckgabe: 'ja, 'nein oder 'unbekannt (Schluessel fehlt
|
||||
;; im Kontext oder Bedingung nicht lesbar).
|
||||
(defun lg-bedingung-pruefen (bedingung kontext / ops op pos key wert ist a b)
|
||||
(if (or (null bedingung) (= bedingung ""))
|
||||
'ja
|
||||
(progn
|
||||
;; laengere Operatoren zuerst, sonst wird "<=" als "<" gelesen
|
||||
(setq ops '("<=" ">=" "=" "<" ">") op nil)
|
||||
(foreach o ops
|
||||
(if (and (null op) (setq pos (vl-string-search o bedingung)))
|
||||
(setq op o
|
||||
key (vl-string-trim " " (substr bedingung 1 pos))
|
||||
wert (vl-string-trim " " (substr bedingung (+ pos 1 (strlen o)))))))
|
||||
(cond
|
||||
((null op) 'unbekannt)
|
||||
((null (setq ist (cdr (assoc key kontext)))) 'unbekannt)
|
||||
((= op "=")
|
||||
(if (and (lg-kontext-zahl ist) (lg-kontext-zahl wert))
|
||||
(if (equal (lg-kontext-zahl ist) (lg-kontext-zahl wert) 1e-9) 'ja 'nein)
|
||||
(if (= (strcase (vl-princ-to-string ist)) (strcase wert)) 'ja 'nein)))
|
||||
((and (setq a (lg-kontext-zahl ist)) (setq b (lg-kontext-zahl wert)))
|
||||
(if (cond ((= op "<=") (<= a b)) ((= op ">=") (>= a b))
|
||||
((= op "<") (< a b)) ((= op ">") (> a b)))
|
||||
'ja 'nein))
|
||||
(T 'unbekannt)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
;; Wert eines Eintrags (fester Wert oder Tabellenzeile). nil, wenn der
|
||||
;; Tabellenschluessel im Kontext fehlt oder ueber der letzten Zeile liegt
|
||||
;; (dann die letzte Zeile = groesster Tabellenwert, konservativ).
|
||||
(defun lg-eintrag-wert (eintrag kontext / tab k n erg)
|
||||
(setq tab (ssg-json-get eintrag "tabelle"))
|
||||
(if (null tab)
|
||||
(ssg-json-get eintrag "wert")
|
||||
(progn
|
||||
(setq k (ssg-json-get eintrag "tabellen_schluessel")
|
||||
n (lg-kontext-zahl (cdr (assoc k kontext))))
|
||||
(if (null n)
|
||||
;; Schluessel fehlt -> konservativ der groesste Tabellenwert
|
||||
(apply 'max (mapcar 'cadr tab))
|
||||
(progn
|
||||
(setq erg (vl-some '(lambda (z) (if (<= n (car z)) (cadr z))) tab))
|
||||
(if erg erg (cadr (last tab))))))
|
||||
)
|
||||
)
|
||||
|
||||
;; Text "Quelle Abschnitt (Fassung)" eines Eintrags fuer das Protokoll.
|
||||
(defun lg-eintrag-quelle (eintrag / q a f)
|
||||
(setq q (cond ((ssg-json-get eintrag "quelle")) ("?"))
|
||||
a (ssg-json-get eintrag "abschnitt")
|
||||
f (ssg-json-get eintrag "fassung"))
|
||||
(strcat q (if a (strcat " " a) "") (if f (strcat " (" f ")") ""))
|
||||
)
|
||||
|
||||
;; Regel aufloesen. kontext = Alist (("brandgefaehrdung" . "normal") ...).
|
||||
;; Rueckgabe: (wert gewinner-eintrag protokoll) oder nil, wenn kein Eintrag
|
||||
;; zutrifft. protokoll = Liste von Strings (je Kandidat eine Zeile + Ergebnis).
|
||||
(defun lg-regel-aufloesen (regel kontext / art kandidaten prot status w best)
|
||||
(setq art (cond ((ssg-json-get regel "art")) ("wert"))
|
||||
kandidaten nil prot nil)
|
||||
(foreach e (ssg-json-get regel "werte")
|
||||
(setq status (lg-bedingung-pruefen (ssg-json-get e "bedingung") kontext)
|
||||
w (lg-eintrag-wert e kontext))
|
||||
(cond
|
||||
((eq status 'nein)
|
||||
(setq prot (cons (strcat "nicht anwendbar: " (lg-eintrag-quelle e)
|
||||
" [" (ssg-json-get e "bedingung") "]") prot)))
|
||||
((null w) nil)
|
||||
(T
|
||||
(setq kandidaten (append kandidaten (list (cons w e))))
|
||||
(setq prot (cons (strcat (vl-princ-to-string w) " " (lg-eintrag-quelle e)
|
||||
(if (eq status 'unbekannt)
|
||||
" [Bedingung nicht auswertbar - konservativ einbezogen]"
|
||||
""))
|
||||
prot)))
|
||||
)
|
||||
)
|
||||
(if kandidaten
|
||||
(progn
|
||||
(setq best (car kandidaten))
|
||||
(foreach k (cdr kandidaten)
|
||||
(cond
|
||||
((and (= art "min") (> (car k) (car best))) (setq best k))
|
||||
((and (= art "max") (< (car k) (car best))) (setq best k))
|
||||
)
|
||||
)
|
||||
(setq prot (cons (strcat "-> " (vl-princ-to-string (car best))
|
||||
" (" art ", strengster: " (lg-eintrag-quelle (cdr best)) ")")
|
||||
prot))
|
||||
(list (car best) (cdr best) (reverse prot))
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
;; Bequemer Zugriff: Wert der Regel id im Profil des Landes (nil = unbekannt).
|
||||
(defun lg-regel-wert (id kontext land / regel erg)
|
||||
(setq regel (lg-regel-finden (lg-profil land) id))
|
||||
(if regel
|
||||
(car (lg-regel-aufloesen regel kontext))
|
||||
(progn (princ (ssg-textf "lg-regel-unbekannt" (list id))) nil))
|
||||
)
|
||||
|
||||
;; Diagnose: alle Regeln des Landes mit Ergebnis und Protokoll in die Konsole.
|
||||
(defun c:LG_REGELN ( / land profil kontext erg)
|
||||
(setq land (if (car (atoms-family 1 '("LG-LAND"))) (lg-land) "DE"))
|
||||
(setq profil (lg-profil land))
|
||||
(setq kontext (list (cons "brandgefaehrdung" "erhoeht_ohne_loeschanlage")))
|
||||
(princ (ssg-textf "lg-regel-liste-kopf" (list land (itoa (length (ssg-json-get profil "regeln"))))))
|
||||
(foreach r (ssg-json-get profil "regeln")
|
||||
(setq erg (lg-regel-aufloesen r kontext))
|
||||
(princ (strcat "\n " (ssg-json-get r "id") " = "
|
||||
(if erg (vl-princ-to-string (car erg)) "-")
|
||||
" " (cond ((ssg-json-get r "einheit")) (""))))
|
||||
(foreach z (caddr erg) (princ (strcat "\n " z)))
|
||||
)
|
||||
(princ)
|
||||
)
|
||||
|
||||
(princ)
|
||||
@@ -867,6 +867,51 @@ Das fertige Raster (Linien + Zaehl-Texte) wird zu einem einzigen Block
|
||||
|
||||
---
|
||||
|
||||
### `LagerInsert.lsp` / `LagerPruefung.lsp` – Lagerplanung (GOH-Buehnenlager -> RFQ-YAML)
|
||||
|
||||
Parametrische Attributbloecke fuer ein mehrgeschossiges Haengewarenlager; die
|
||||
Mengen gehen ueber `LAGER_EXPORT` als Overlay-YAML an das RFQ-Programm
|
||||
(`lib/lager_yaml_export.py`). Konzept, Datenmodell und YAML-Zuordnung:
|
||||
[`doc/plan/lager_rfq.md`](../doc/plan/lager_rfq.md). Stand: Phase 0 + 1
|
||||
(Mengen, 2D).
|
||||
|
||||
| Befehl | Beschreibung |
|
||||
| --- | --- |
|
||||
| `c:LG_GESCHOSS` | Belagskontur waehlen/zeichnen, Dialog `lg_geschoss` (`dcl/lager.dcl`), Block `LG_GESCHOSS` + XDATA-Verknuepfung zur Kontur |
|
||||
| `c:LG_GESCHOSS_AKTIV` | Aktives Geschoss setzen, Layer `LG_*_G<n>` der anderen Geschosse frieren (0 = alle zeigen) |
|
||||
| `c:LG_GESCHOSS_KOPIEREN` | Geschoss mit Belagskontur, Bereichen, Reihen, Gaengen und goh_racks 1:1 in ein oder mehrere neue Geschosse kopieren (Dialog `lg_geschoss_kopie`: Quelle - Vorgabe oberstes Geschoss -, Anzahl, Geschosshoehe je Kopie, Belag, Versatz X/Y je Kopie, 0 = deckungsgleich). Belaege gleich dem Quell-Geschossbelag folgen dem neuen Belag; Verknuepfungen, Layer `_G<n>` und IDs sind neu |
|
||||
| `c:LG_BEREICH` | Lagerbereich-Kontur + Dialog `lg_bereich`; Auto-Fuellung mit `LG_REIHE_<L>_<T>` / `LG_GANG_<L>_<B>_<BELAG>`, optional Randgaenge Nord/Ost/Sued/West entlang der Konturkanten (auch L-Form) |
|
||||
| `c:LG_REIHE` | Einzelne Regalreihen per Start/Ende oder getippter Laenge; wie bei `LG_GANG` mit dem Bereich verknuepft und ausgeschnitten statt neu berechnet (`lg-manuell-einfuegen`) |
|
||||
| `c:LG_GANG` | Einzelne Gaenge (Dialog `lg_gang`: Breite, Art gang/randgang/quergang, Belag), mittig auf der Linie - oder ueber die Option `Rechteck` als Flaeche, gezeichnet mit dem BricsCAD-Befehl RECHTECK samt aller seiner Optionen (Abmessungen, Flaeche, Drehung ...; `lg-rechteck-zeichnen`, Auswertung `lg-rechteck-ecken-aus-poly`, Fase/Rundung wird abgelehnt) (Lage und Breite aus dem Rechteck, laengere Seite = Gangrichtung; Kern `lg-gang-aus-ecken`, `lg-gang-rechteck-einfuegen`, `Linie` schaltet zurueck); liegt die Mitte in einem Bereich, wird der Gang mit ihm verknuepft. Der Gang schneidet seine Flaeche aus den automatisch erzeugten Reihen/Gaengen heraus (`lg-sperre-anwenden`), OHNE den Bereich neu zu berechnen - von Hand geloeschte oder geaenderte Objekte bleiben, wie sie sind; bei jeder Neuberechnung bleibt er stehen (Sperrflaeche) |
|
||||
| `c:LG_EDIT` | Bearbeiten (auch per Doppelklick ueber `SSG_BLOCKEDIT`, Zweig `LG_*`): Bereich -> Neuberechnung (von Hand eingefuegte und geaenderte Reihen/Gaenge bleiben stehen und werden ausgespart), Reihe/Gang -> Neuaufbau, danach Zuschnitt der rangniedrigeren Objekte (`auto` < `auto_geaendert` < `manuell`, `lg-quelle-rang`) statt Neuberechnung des Bereichs |
|
||||
| `c:LG_REGALE` | goh_racks zaehlen (`lg-racks-sammeln`): Anzahl, Laenge und Laenge x Ebenen je Geschoss (Zuordnung wie beim Export) plus Gesamtsumme in der Befehlszeile |
|
||||
| `c:LAGER_EXPORT` | `<dwg>_lager_raw.json` + Python -> `<dwg>_drawing.yaml` und `<dwg>_nachweis.html` in `DXFM_RESULTS` |
|
||||
| `c:LAGER_HAND_YAML` | Hand-YAML fuer den Abgleich (Konfliktliste) festlegen |
|
||||
| `c:LG_REGELN` | Regelprofil (`cfg/regelwerk/<Land>.json`) mit aufgeloesten Werten und Quellen anzeigen |
|
||||
|
||||
Gangflaechen sind je Belag schraffiert (Schraffur in der Blockdefinition, Muster aus
|
||||
`data/json/lager.json` `belag_schraffur`: Spanplatte ANSI31, Gitterrost GRID,
|
||||
Hallenboden keine).
|
||||
|
||||
Reine Kerne (`lg-fuellung-berechnen`, `lg-randgang-streifen`, `lg-kompass`,
|
||||
`lg-schraffur-vorgabe`, `lg-geschoss-fuer-punkt-kern`, `lg-geschoss-aus-layer`,
|
||||
`lg-rack-geschoss`, `lg-kopie-*`, `lg-zahl-einheit`, `lg-insert-tf`/`lg-tf-verketten`,
|
||||
`lg-regel-aufloesen`, `lg-profil-mischen`, JSON-Schreiber, Feldpruefung) in
|
||||
`tests/test_unit.lsp` (`tu-tests-lager`); Zeichnungsablauf in
|
||||
`tests/test_lager.lsp` (`TEST_LAGER`, inkl. Rack-Erkennung mit Verschachtelung und
|
||||
MINSERT sowie goh_rack-Regression gegen `tests/testdata/goh_storage_test.dwg`).
|
||||
|
||||
`goh_rack`-Bloecke (parametrischer BricsCAD-Block) erkennt und zaehlt `LagerInsert.lsp`
|
||||
selbst (`lg-racks-sammeln`): Name ueber die Objekteigenschaft `EffectiveName`,
|
||||
Parameter `Laenge`/`Ebenen` (`lager.json` `goh_rack`) als MCAD-Eigenschaft, dynamische
|
||||
Eigenschaft, Attribut oder ATTDEF-Vorgabe, Einheiten auf mm umgerechnet; gefunden auch
|
||||
in assoziativen Arrays, MINSERT-Rastern und verschachtelten Bloecken. `LAGER_EXPORT`
|
||||
ordnet jedes goh_rack zuerst ueber den Layer `LG_*_G<n>` seines obersten INSERTs
|
||||
(`lg-rk-top`), erst dann ueber die Geschosskontur zu. `LG_REGALE` zeigt die Zaehlung
|
||||
je Geschoss in der Befehlszeile.
|
||||
|
||||
---
|
||||
|
||||
### `Jam_Edit.lsp` – Staubereiche (SPS)
|
||||
|
||||
Staubereiche zeichnet sps_skel (`tro_annotate.py --anlage`) als Block `JAM_AREA`
|
||||
|
||||
@@ -434,6 +434,16 @@
|
||||
(command "_.EATTEDIT")
|
||||
)
|
||||
|
||||
;; Lager-Bloecke (LG_GESCHOSS, LG_BEREICH, LG_REIHE_*, LG_GANG_*) ->
|
||||
;; eigener Editor in LagerInsert.lsp. Ebenfalls VOR dem Omniflo-Zweig,
|
||||
;; aus demselben Grund wie GR_* (Attribut-Bloecke).
|
||||
((wcmatch (strcase bname) "LG_*")
|
||||
(ssg-ensure "LagerInsert")
|
||||
(ssg-start nil nil)
|
||||
(lg-edit-ent ent)
|
||||
(ssg-end)
|
||||
)
|
||||
|
||||
;; Kettenfoerderer (KF_n, KettenFoerderer.lsp) -> KF_EDIT (DCL-Dialog mit
|
||||
;; Neuaufbau an derselben Stelle). MUSS - aus demselben Grund wie GR_* -
|
||||
;; vor dem Omniflo-Zweig stehen: traegt die Baugruppe ein TEILEART-
|
||||
|
||||
@@ -1629,6 +1629,210 @@
|
||||
)
|
||||
|
||||
|
||||
;; ------------------------------------------------------------
|
||||
;; POLYGON-HELFER (2D, reine Berechnung - ohne Zeichnung testbar)
|
||||
;; ------------------------------------------------------------
|
||||
;; Ein Polygon ist eine Liste von Punkten ((x y [z]) ...), implizit
|
||||
;; geschlossen (der letzte Punkt wird mit dem ersten verbunden; ein
|
||||
;; doppelter Schlusspunkt stoert nicht). Z wird ignoriert.
|
||||
;; Genutzt von LagerInsert.lsp (Geschoss-/Bereichskonturen, Auto-Fuellung),
|
||||
;; bewusst hier, weil nichts davon lagerspezifisch ist.
|
||||
|
||||
;; Vorzeichenbehaftete Flaeche (Gauss'sche Trapezformel): > 0 = Umlauf
|
||||
;; gegen den Uhrzeigersinn, < 0 = im Uhrzeigersinn.
|
||||
(defun ssg-poly-flaeche-signiert (pts / s p q rest)
|
||||
(setq s 0.0 rest pts)
|
||||
(while rest
|
||||
(setq p (car rest)
|
||||
q (if (cdr rest) (cadr rest) (car pts)))
|
||||
(setq s (+ s (- (* (car p) (cadr q)) (* (car q) (cadr p)))))
|
||||
(setq rest (cdr rest))
|
||||
)
|
||||
(/ s 2.0)
|
||||
)
|
||||
|
||||
;; Flaeche, immer >= 0.
|
||||
(defun ssg-poly-flaeche (pts)
|
||||
(abs (ssg-poly-flaeche-signiert pts))
|
||||
)
|
||||
|
||||
;; Kanten als Liste ((p1 p2) ...), inklusive Schlusskante. Kanten der
|
||||
;; Laenge 0 (doppelter Schlusspunkt) fallen weg.
|
||||
(defun ssg-poly-kanten (pts / erg rest p q)
|
||||
(setq erg nil rest pts)
|
||||
(while rest
|
||||
(setq p (car rest)
|
||||
q (if (cdr rest) (cadr rest) (car pts)))
|
||||
(if (> (distance (list (car p) (cadr p)) (list (car q) (cadr q))) 1e-9)
|
||||
(setq erg (cons (list p q) erg)))
|
||||
(setq rest (cdr rest))
|
||||
)
|
||||
(reverse erg)
|
||||
)
|
||||
|
||||
;; Umfang (Summe aller Kantenlaengen in XY).
|
||||
(defun ssg-poly-umfang (pts / s)
|
||||
(setq s 0.0)
|
||||
(foreach k (ssg-poly-kanten pts)
|
||||
(setq s (+ s (distance (list (car (car k)) (cadr (car k)))
|
||||
(list (car (cadr k)) (cadr (cadr k)))))))
|
||||
s
|
||||
)
|
||||
|
||||
;; Achsparallele Huelle -> ((xmin ymin) (xmax ymax)), nil fuer leere Liste.
|
||||
(defun ssg-poly-bbox (pts)
|
||||
(if pts
|
||||
(list (list (apply 'min (mapcar 'car pts)) (apply 'min (mapcar 'cadr pts)))
|
||||
(list (apply 'max (mapcar 'car pts)) (apply 'max (mapcar 'cadr pts))))
|
||||
)
|
||||
)
|
||||
|
||||
;; Punkt im Polygon? (Strahlverfahren, Punkte AUF dem Rand sind nicht
|
||||
;; eindeutig zugeordnet - fuer Zuordnungen mit Toleranz unkritisch.)
|
||||
(defun ssg-punkt-in-poly-p (pt pts / innen p q x y)
|
||||
(setq innen nil x (car pt) y (cadr pt))
|
||||
(foreach k (ssg-poly-kanten pts)
|
||||
(setq p (car k) q (cadr k))
|
||||
(if (and (not (eq (> (cadr p) y) (> (cadr q) y)))
|
||||
(< x (+ (car p) (/ (* (- (car q) (car p)) (- y (cadr p)))
|
||||
(- (cadr q) (cadr p))))))
|
||||
(setq innen (not innen)))
|
||||
)
|
||||
innen
|
||||
)
|
||||
|
||||
;; Punkt um zentrum (2D) um winkel (Bogenmass, gegen Uhrzeigersinn) drehen.
|
||||
;; Ein Z-Wert bleibt erhalten.
|
||||
(defun ssg-punkt-drehen (pt winkel zentrum / dx dy c s erg)
|
||||
(setq dx (- (car pt) (car zentrum))
|
||||
dy (- (cadr pt) (cadr zentrum))
|
||||
c (cos winkel)
|
||||
s (sin winkel))
|
||||
(setq erg (list (+ (car zentrum) (- (* dx c) (* dy s)))
|
||||
(+ (cadr zentrum) (+ (* dx s) (* dy c)))))
|
||||
(if (caddr pt) (append erg (list (caddr pt))) erg)
|
||||
)
|
||||
|
||||
(defun ssg-poly-drehen (pts winkel zentrum)
|
||||
(mapcar '(lambda (p) (ssg-punkt-drehen p winkel zentrum)) pts)
|
||||
)
|
||||
|
||||
;; Innere Abschnitte der waagrechten Geraden y im Polygon.
|
||||
;; Rueckgabe: aufsteigend sortierte Intervalle ((x1 x2) ...).
|
||||
;; Halboffene Kantenregel (ymin <= y < ymax): eine Gerade genau durch eine
|
||||
;; Ecke zaehlt die Kante nur einmal; waagrechte Kanten zaehlen nie.
|
||||
(defun ssg-poly-schnitt-y (pts y / xs p q erg)
|
||||
(setq xs nil)
|
||||
(foreach k (ssg-poly-kanten pts)
|
||||
(setq p (car k) q (cadr k))
|
||||
(if (or (and (<= (cadr p) y) (< y (cadr q)))
|
||||
(and (<= (cadr q) y) (< y (cadr p))))
|
||||
(setq xs (cons (+ (car p) (/ (* (- (car q) (car p)) (- y (cadr p)))
|
||||
(- (cadr q) (cadr p))))
|
||||
xs)))
|
||||
)
|
||||
(setq xs (vl-sort xs '<) erg nil)
|
||||
(while (cadr xs)
|
||||
(if (> (- (cadr xs) (car xs)) 1e-9)
|
||||
(setq erg (cons (list (car xs) (cadr xs)) erg)))
|
||||
(setq xs (cddr xs))
|
||||
)
|
||||
(reverse erg)
|
||||
)
|
||||
|
||||
;; Polygon an der Waagrechten y = grenze abschneiden (Sutherland-Hodgman,
|
||||
;; eine Kante). oben = T behaelt den Teil mit y >= grenze, sonst y <= grenze.
|
||||
;; Rueckgabe: Punktliste (2D), leer = nichts bleibt.
|
||||
(defun ssg-poly-clip-y (pts grenze oben / erg rest p q pin qin)
|
||||
(setq erg nil rest pts)
|
||||
(while rest
|
||||
(setq p (car rest)
|
||||
q (if (cdr rest) (cadr rest) (car pts)))
|
||||
(setq pin (if oben (>= (cadr p) grenze) (<= (cadr p) grenze))
|
||||
qin (if oben (>= (cadr q) grenze) (<= (cadr q) grenze)))
|
||||
(if pin (setq erg (cons (list (car p) (cadr p)) erg)))
|
||||
(if (not (eq pin qin))
|
||||
(setq erg (cons (list (+ (car p) (/ (* (- (car q) (car p)) (- grenze (cadr p)))
|
||||
(- (cadr q) (cadr p))))
|
||||
grenze)
|
||||
erg)))
|
||||
(setq rest (cdr rest))
|
||||
)
|
||||
(reverse erg)
|
||||
)
|
||||
|
||||
;; x-Ausdehnung des Polygonteils im Band y0 <= y <= y1: (xmin xmax) oder nil.
|
||||
;; Ein Polygon, das das Band nur an einer Kante beruehrt (Teil ohne Hoehe),
|
||||
;; zaehlt nicht - ein Gang direkt neben einer Reihe sperrt sie nicht.
|
||||
;; Exakt fuer konvexe Polygone (Gang-Rechtecke); bei konkaven die Huelle.
|
||||
(defun ssg-poly-band-x (pts y0 y1 / c ys xs)
|
||||
(setq c (ssg-poly-clip-y (ssg-poly-clip-y pts y0 T) y1 nil))
|
||||
(if c
|
||||
(progn
|
||||
(setq ys (mapcar 'cadr c) xs (mapcar 'car c))
|
||||
(if (and (> (- (apply 'max ys) (apply 'min ys)) 1e-6)
|
||||
(> (- (apply 'max xs) (apply 'min xs)) 1e-6))
|
||||
(list (apply 'min xs) (apply 'max xs)))))
|
||||
)
|
||||
|
||||
;; Schnittmenge zweier sortierter Intervall-Listen ((a1 a2) ...).
|
||||
(defun ssg-intervalle-schnitt (a b / erg lo hi)
|
||||
(setq erg nil)
|
||||
(while (and a b)
|
||||
(setq lo (max (car (car a)) (car (car b)))
|
||||
hi (min (cadr (car a)) (cadr (car b))))
|
||||
(if (> hi lo) (setq erg (cons (list lo hi) erg)))
|
||||
(if (< (cadr (car a)) (cadr (car b)))
|
||||
(setq a (cdr a))
|
||||
(setq b (cdr b)))
|
||||
)
|
||||
(reverse erg)
|
||||
)
|
||||
|
||||
;; Intervall-Liste a ohne die Intervalle aus b (beide sortiert).
|
||||
(defun ssg-intervalle-minus (a b / erg iv rest x1 x2 bb)
|
||||
(setq erg nil)
|
||||
(foreach iv a
|
||||
(setq rest (list iv))
|
||||
(foreach bb b
|
||||
(setq rest
|
||||
(apply 'append
|
||||
(mapcar
|
||||
'(lambda (r / x1 x2)
|
||||
(setq x1 (car r) x2 (cadr r))
|
||||
(cond
|
||||
((or (<= (cadr bb) x1) (>= (car bb) x2)) (list r))
|
||||
(T (append
|
||||
(if (> (car bb) x1) (list (list x1 (car bb))))
|
||||
(if (< (cadr bb) x2) (list (list (cadr bb) x2)))))))
|
||||
rest)))
|
||||
)
|
||||
(setq erg (append erg rest))
|
||||
)
|
||||
erg
|
||||
)
|
||||
|
||||
;; Eckpunkte einer LWPOLYLINE in Weltkoordinaten (Z aus der Erhebung, Code
|
||||
;; 38). Bogensegmente (Bulge /= 0) werden wie gerade Kanten behandelt; ob
|
||||
;; welche vorkommen, meldet ssg-lwpoly-boegen-p.
|
||||
(defun ssg-lwpoly-punkte (ent / ed z nrm erg)
|
||||
(setq ed (entget ent)
|
||||
z (cond ((cdr (assoc 38 ed))) (0.0))
|
||||
nrm (cond ((cdr (assoc 210 ed))) ('(0.0 0.0 1.0))))
|
||||
(setq erg nil)
|
||||
(foreach g ed
|
||||
(if (= (car g) 10)
|
||||
(setq erg (cons (trans (list (cadr g) (caddr g) z) nrm 0) erg)))
|
||||
)
|
||||
(reverse erg)
|
||||
)
|
||||
|
||||
(defun ssg-lwpoly-boegen-p (ent)
|
||||
(vl-some '(lambda (g) (and (= (car g) 42) (not (equal (cdr g) 0.0 1e-9))))
|
||||
(entget ent))
|
||||
)
|
||||
|
||||
|
||||
;; ------------------------------------------------------------
|
||||
;; DCL ZUR LAUFZEIT GENERIEREN
|
||||
;; ------------------------------------------------------------
|
||||
|
||||
+4
-1
@@ -45,7 +45,10 @@
|
||||
(load (strcat base-path "ssg_blocktools.lsp") "ssg_blocktools.lsp nicht gefunden")
|
||||
(load (strcat base-path "ssg_texttools.lsp") "ssg_texttools.lsp nicht gefunden")
|
||||
(load (strcat base-path "ssg_stueckliste.lsp") "ssg_stueckliste.lsp nicht gefunden")
|
||||
(prompt "\nSSG-Bibliotheken geladen: ssg_core, ssg_lang, ssg_dbg, ssg_dialog, ssg_layer, ssg_input, KreiselInsert, VarioFoerderer, Gefaellestrecke, export, OmniModulInsert, SSG_LIB_Commands, ssg_blocktools, ssg_texttools, ssg_stueckliste")
|
||||
;; Lagerplanung: Regelprofile VOR LagerInsert, das sie nutzt
|
||||
(load (strcat base-path "LagerPruefung.lsp") "LagerPruefung.lsp nicht gefunden")
|
||||
(load (strcat base-path "LagerInsert.lsp") "LagerInsert.lsp nicht gefunden")
|
||||
(prompt "\nSSG-Bibliotheken geladen: ssg_core, ssg_lang, ssg_dbg, ssg_dialog, ssg_layer, ssg_input, KreiselInsert, VarioFoerderer, Gefaellestrecke, export, OmniModulInsert, SSG_LIB_Commands, ssg_blocktools, ssg_texttools, ssg_stueckliste, LagerPruefung, LagerInsert")
|
||||
(princ)
|
||||
)
|
||||
|
||||
|
||||
Reference in New Issue
Block a user