;|; --==©==-- --==©==-- --==©==-- --==©==-- --==©==-- --==©==-- --==©==-- --=={©ABBS©}==-- --==©==-- --==©==-- --==©==-- --==©==-- --==©==-- --==©==-- --==©==-- ;|;
;|;	Copyright© 2025 Archäologische Bodenforschung Basel-Stadt.												 ;|;
;|; Alle Rechte am Code und der Zusammenstellung sind vorbehalten. Die Nutzung der Software geschieht auf eigenes Risiko.					 ;|;
;|; Die Archäologische Bodenforschung Basel-Stadt schliesst eine Haftung für Probleme, Fehler und Schäden, die bei der Nutzung der				 ;|;
;|; Software an Hardware, Software oder damit erstellten Softwareprodukten und -dateien, aus. Es besteht kein Anspruch auf Support.				 ;|;
;|; Eine Weitergabe der Software ist nicht gestattet. Interessenten können sich bei Interesse melden bei: Fabian Bubendorf, fabian.bubendorf@bs.ch		 ;|;
;|; --==©==-- --==©==-- --==©==-- --==©==-- --==©==-- --==©==-- --==©==-- --=={©ABBS©}==-- --==©==-- --==©==-- --==©==-- --==©==-- --==©==-- --==©==-- --==©==-- ;|;

;;; --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --=={ ABBS }==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- ;;;
;|;								     Böschungslinien generieren									 ;|;
;;; --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --=={ ABBS }==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- ;;;
;;;  Befehl:     L-Boeschung																	 ;;;
;;;  Zweck:      Zum automatischen Erstellen von Böschungslinien zwischen zwei Linien nach Dynamischem- oder Fixem-Wert						 ;;;
;;;  Funktionen: (*ERROR* . 1)																	 ;;;
;;;              (CLSTPT . 2)																	 ;;;
;;;              (LSTN . 2)																	 ;;;
;;;              (SFTT . 3)																	 ;;;
;;;              (MBBOX . 2)																	 ;;;
;;;              (CRVL . 2)																	 ;;;
;;;              (CRVS . 1)																	 ;;;
;;;              |->(MRGCRV . 2)																 ;;;
;;;                 |->(CRVSTART . 2)																 ;;;
;;;                    |->(LSTR . 2)																 ;;;
;;;                 |->(BRK3DP . 2)																 ;;;
;;;              (LM:POPUP . 3)																	 ;;;
;;;              (DIALOG . 6)																	 ;;;
;;;              |->(WRITEFILE . 3)																 ;;;
;;;              |->(LAY? . 1)																	 ;;;
;;;              |->(REVCRV . 1)																 ;;;
;;;              |->(DIR? . 2)																	 ;;;
;;;                 |->(CW? . 1)																 ;;;
;;;              |->(DST<>% . 3)																 ;;;
;;;              |->(DST<>PT . 2)																 ;;;
;;;              |->(SLPL . 7)																	 ;;;
;;;                 |->(2DDST . 2)																 ;;;
;;;                 |->(ONCRV . 3)																 ;;;
;;;                 |->(OVRCRV . 3)																 ;;;
;;;                 |->(3DANG . 2)																 ;;;
;;;              |->(DRWVECIMG . 8)																 ;;;
;;;                 |->(SPLV . 2)																 ;;;
;;;  Dialog:     Ja - DBoesch																	 ;;;
;;;  Fehler:     Je nach Grössenverhältnissen bei Bögen zwischen der Oberen- und Unteren-Linie werden die Böschungen nicht akkurat gesetzt.			 ;;;
;;;              Wenn ACAD keinen Schnittpunkt berechnen kann, kann die Mehrfachauswahl auch keinen Schnittpunkt erkennen und die Linie so nicht erstellt werden ;;;
;;;  Autor:      Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt											 ;;;
;;;  URL:        Ursprünglich Inspiriert durch: https://www.cadwiesel.de/index.php?hp=downloads&anzeigedatei=downloads&download_id=136				 ;;;
;;;  Version:    1.0 -> 2021/August																 ;;;
;;;              	Erstellung und Erstversion														 ;;;
;;;              1.1 -> 2021/Oktober																 ;;;
;;;              	Einbau Linien drehen bei Ungleichheit													 ;;;
;;;              2.0 -> 2023/Januar																 ;;;
;;;              	Generalüberarbeitung, Benutzung von Splines, geschlossener Linien und Gliederung in einzelne Unterfunktionen				 ;;;
;;;              	Umstellung Nutzereingaben als Argumente und Einführung Vorschaufenster (Dialog)								 ;;;
;;;              3.0 -> 2023/März																 ;;;
;;;              	Einbau Mehrfachauswahl Ober/Unterkannte	und Berechnung neuer zusammenhängender Linie, Anpassung Dialog auf Mehrfachauswahl		 ;;;
;;;              3.1 -> 2023/Juni																 ;;;
;;;              	Fehlerbehebung bei ungleichlangen 3D-Polylinien												 ;;;
;;;              4.0 -> 2025/Februar-Mai															 ;;;
;;;              	Generalüberarbeitung nach ACAD-Bug mit grossen Koordinaten, behoben durch einen Transformations-Shift zu Null, Umbau & Überarbeitung	 ;;;
;;;              	sämtlicher Funktionen & Verbesserung des Fehlerabfangs, Einbau neuer Funktionen wie Offset & 3d-Winkel, Einbau Errorhandler,		 ;;;
;;;              	verbesserte Vorschau mit Live-Aktualisierung, verbesserte Berechnung der Böschungen mit flexibleren, dynamischen Werten, etc.		 ;;;
;;;              4.1 -> 2025/Juni																 ;;;
;;;              	Generalüberarbeitung der Mehrfachauswahl und rückwirkende Änderungen an der Linienauswahl, Live-Berechnung der Mehrfachauswahl, 	 ;;;
;;;              	Mischung von Linientypen bei Mehrfachauswahl nun möglich, Einbau einer separaten Undomarks für das Tool					 ;;;
;;;  Argumente:  DflMlt  --> Angabe des Standard-Layers für neue Top- / Low-Curves	|  Typ:	Sting								 ;;;
;;;              DflSlp  --> Angabe des Standard-Layers für die Böschungslinien		|  Typ:	Sting								 ;;;
;;;              DflDst  --> Angabe des Standard-Abstands der Böschungslinien		|  Typ:	- nil für Dynamisch						 ;;;
;;;              									|	- Integer/Real als fixen Wert					 ;;;
;;;              Dfl3dS  --> Angabe des Standard-Modus für 3d-Winkel/längen berechnen	|  Typ:	Boolean (t/nil)							 ;;;
;;;  Variablen:  ObL  --> Liste mit Top & Low															 ;;;
;;;              Sft  --> Shift-Vektor für die Transformation													 ;;;
;;;              Slp  --> Liste mit den Böschungslinien (Koordinaten, ENames o. Variant)									 ;;;
;;;              Dic  --> Extensiondictionary & FullDrawOrder für die Zeichenreihenfolge									 ;;;
;;;              Tbl  --> Sortents-Table-Object für die Zeichenreihenfolge											 ;;;
;;;  Func-Key:   val																		 ;;;
;;;  Code:
(defun L-Boeschung ( DflMlt DflSlp DflDst Dfl3dS / *ERROR* CLSTPT LSTN CRVL CRVS SFTT MBBOX LM:POPUP DIALOG ObL Sft Slp Dic Tbl val )
;;; Beginn nach den def's der Unterfunktionen

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> *error*															 ;;;
;;;  Zweck:      Error-Handler																	 ;;;
;;;  Funktionen: Keine Unterfunktionen																 ;;;
;;;  Autor:      Lee Mac / Lee Mac Programming															 ;;;
;;;              Angepasst: Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt									 ;;;
;;;  URL:        http://www.lee-mac.com/errorhandling.html													 ;;;
;;;  Datum:      -/-																		 ;;;
;;;              Angepasst: 2025/Mai																 ;;;
;;;  Argumente:  Msg  --> Fehlermeldung																 ;;;
;;;  Variablen:  -																		 ;;;
;;;  Func-Key:   val																		 ;;;
;;;  Code:
  (defun *error* ( Msg / val )
    (and Old (mapcar 'setvar '(CMDECHO QAFLAGS) Old))
    (and Dcl (vl-file-delete Dcl))
    (and ObL Sft (mapcar '(lambda ( val )(if (not (vlax-erased-p val))(vl-catch-all-apply 'SftT (list val nil Sft))))(mapcar 'car ObL)))
    (if (not (member Msg '("Function cancelled" "Funktion abgebrochen" "quit / exit abort" "verlassen / abbruch")))
        (alert (strcat "\nError: " Msg))
    );end if
    (princ)
  );end defun
    
;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> ClstPt																 ;;;
;;;  Zweck:      Wrapper für Ausgabe des nächstgelegensten Punktes auf einer Curve.										 ;;;
;;;  Funktionen: Keine Unterfunktionen																 ;;;
;;;  Autor:      Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt											 ;;;
;;;  Datum:      2025/Februar																	 ;;;
;;;  Argumente:  Crv  --> Eine Curve als Vla-Objekt oder EName													 ;;;
;;;              Pt   --> Eine Punktkoordinate															 ;;;
;;;  Variablen:  -																		 ;;;
;;;  Code:
  (defun ClstPt ( Crv Pt / )
    (cond ((vlax-curve-getClosestPointToProjection Crv Pt (trans '(0 0 1) 1 0 t)))
          ((vlax-curve-getClosestPointTo Crv Pt))
    );end cond
  );end defun

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> LstN																 ;;;
;;;  Zweck:      Verpackt die Elemente einer Liste in Unterlisten mit der länge N (Rekursiv)									 ;;;
;;;  Funktionen: Keine Unterfunktionen																 ;;;
;;;  Autor:      Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt											 ;;;
;;;  Datum:      2025/Februar																	 ;;;
;;;  Argumente:  Lst  --> Liste mit den Elementen die unterteilt werden sollen											 ;;;
;;;              N    --> Länge der Unterlisten als Integer													 ;;;
;;;  Variablen:  Rtn  --> Unterliste zum verpacken														 ;;;
;;;  Code:
  (defun LstN ( Lst N / Rtn )
    (if Lst (cons (reverse (repeat (fix N)(setq Rtn (cons (car Lst) Rtn) Lst (cdr Lst)) Rtn))(LstN Lst N)))
  );end defun

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> SftT																 ;;;
;;;  Zweck:      Transformieren/Shiften von Objekten oder Koordinatenlisten mit einer 4x4 Matrix								 ;;;
;;;  Funktionen: Keine Unterfunktionen																 ;;;
;;;  Autor:      Lee Mac / Lee Mac Programming															 ;;;
;;;              Angepasst: Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt									 ;;;
;;;  URL:        https://www.lee-mac.com/matrixtransformationfunctions.html											 ;;;
;;;  Datum:      -/-																		 ;;;
;;;              Angepasst: 2025/April																 ;;;
;;;  Argumente:  Arg  --> Vla-Object oder Koordinatenliste													 ;;;
;;;              Mtx  --> 3x3 Matrix (Skalierung / Rotation)													 ;;;
;;;              Vec  --> Vector (Versatz)															 ;;;
;;;  Variablen:  -																		 ;;;
;;;  Func-Key:   m																		 ;;;
;;;              v																		 ;;;
;;;              p																		 ;;;
;;;  Code:
  (defun SftT ( Arg Mtx Vec / m v p )
    (if (not Mtx)(setq Mtx '((1. 0. 0.)(0. 1. 0.)(0. 0. 1.))))
    (cond ((eq (type Arg) 'VLA-OBJECT)(vla-TransformBy Arg (vlax-tMatrix (append (mapcar '(lambda ( m v )(append m (list v))) Mtx Vec)'((0. 0. 0. 1.))))))
          ((listp Arg)(mapcar '(lambda ( v )(mapcar '+ (mapcar '(lambda ( m )(apply '+ (mapcar '* m v))) Mtx) Vec)) Arg))
    );end cond
  );end defun

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> mBBox																 ;;;
;;;  Zweck:      Berechnen der Bounding Box für eine Liste an Objekten in WCS oder active UCS									 ;;;
;;;  Funktionen: Keine Unterfunktionen																 ;;;
;;;  Autor:      Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt											 ;;;
;;;  Datum:      2025/April																	 ;;;
;;;  Argumente:  ObL  --> Liste mit vla-objects															 ;;;
;;;              UCS  --> 'T für Ausgabe in UCS-Koordinaten													 ;;;
;;;  Variablen:  BB  --> Koordinatenliste															 ;;;
;;;              Mn  --> Array mit kleinsten Koordinaten													 ;;;
;;;              Mx  --> Array mit grössten Koordinaten														 ;;;
;;;  Func-Key:   val																		 ;;;
;;;  Code:
  (defun mBBox ( ObL UCS / BB Mn Mx val )
    (if UCS (mapcar '(lambda ( val )(SftT val (mapcar '(lambda ( val )(trans val 1 0 t))'((1. 0. 0.)(0. 1. 0.)(0. 0. 1.)))(trans '(0.0 0.0 0.0) 0 1))) ObL))
    (setq BB (apply 'append (mapcar '(lambda ( val / Mn Mx )(vla-getBoundingBox val 'Mn 'Mx)(list (vlax-safearray->list Mn)(vlax-safearray->list Mx))) ObL))
          BB (list (mapcar 'car BB)(mapcar 'cadr BB)(mapcar 'caddr BB))
    );end setq
    (if UCS (mapcar '(lambda ( val )(SftT val (mapcar '(lambda ( val )(trans val 0 1 t))'((1. 0. 0.)(0. 1. 0.)(0. 0. 1.)))(trans '(0.0 0.0 0.0) 1 0))) ObL))
    (mapcar '(lambda ( val )(mapcar 'apply (list val val val) BB))'(min max))
  );end defun

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> CrvL																 ;;;
;;;  Zweck:      Ausgabe der Koordinatenliste passend zum Curve-Objekt												 ;;;
;;;  Funktionen: Keine Unterfunktionen																 ;;;
;;;  Autor:      Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt											 ;;;
;;;  Datum:      2025/Februar																	 ;;;
;;;              Angepasst: 2025/Mai																 ;;;
;;;  Argumente:  Crv  --> Vla-Objekt einer Curve														 ;;;
;;;              CS   --> Auswahl des Koordinatensystems [-1 = OCS / 0 = WCS / 1 = UCS]										 ;;;
;;;  Variablen:  Nme  --> ObjectName von Crv															 ;;;
;;;              Lst  --> Koordinatenliste															 ;;;
;;;  Func-Key:   val																		 ;;;
;;;  Code:
  (defun CrvL ( Crv CS / Nme Lst val )
    (if (setq Lst (cond ((or (null Crv)(vl-catch-all-error-p (setq Nme (vl-catch-all-apply 'vla-get-ObjectName (list Crv))))) nil)
                        ((wcmatch (strcase Nme) "ACDBLINE")(list (vlax-curve-getStartPoint Crv)(vlax-curve-getEndPoint Crv)))
                        ((wcmatch (strcase Nme) "ACDBSPLINE")(LstN (vlax-safearray->list (vlax-variant-value (vla-get-FitPoints Crv))) 3))
                        ((wcmatch (strcase Nme) "ACDB*POLYLINE")
                           (LstN (vlax-safearray->list (vlax-variant-value (vla-get-Coordinates Crv)))(if (wcmatch Nme "*[23]*") 3 2))
                        );end
                  );end cond
        );end setq
        (cond ((minusp CS) Lst)
              ((zerop CS)(mapcar '(lambda ( val )(trans val (vlax-vla-object->ename Crv) 0)) Lst))
              (t (mapcar '(lambda ( val )(trans val 0 1))(mapcar '(lambda ( val )(trans val (vlax-vla-object->ename Crv) 0)) Lst)))
        );end cond
    );end if
  );end defun

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> CrvS 																 ;;;
;;;  Zweck:      Auswahl eines oder mehrerer Curve-Objekte													 ;;;
;;;  Funktionen: (MrgCrv . 1)																	 ;;;
;;;              |->(CRVSTART . 2)																 ;;;
;;;                 |->(LSTR . 2)																 ;;;
;;;              |->(BRK3DP . 2)																 ;;;
;;;  Autor:      Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt											 ;;;
;;;  Datum:      2023/März																	 ;;;
;;;              Angepasst: 2025/Februar															 ;;;
;;;              Angepasst: 2025/Juni																 ;;;
;;;  Argumente:  Top  --> Vla-Objekt der Top Curve um doppelte Auswahl zu verhindern										 ;;;
;;;  Variablen:  Crv   --> EName der ausgewählten Curve														 ;;;
;;;              MCrv  --> Liste mit Mehrfachauswahl (neue Crv (grund Crvs & PPs))										 ;;;
;;;              Old  --> Speichert die Werte div. Systemvariablen												 ;;;
;;;  Code:
  (defun CrvS ( Top / MRGCRV Crv MCrv Old );Beginn nach den def's der Unterfunktionen

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> CrvS |-> MrgCrv														 ;;;
;;;  Zweck:      Berechnet und erstellt eine neue, durchgehende Linie aus den ausgewählten Segmenten der Linien anhand der Pickpoint-Auswahl			 ;;;
;;;  Funktionen: (CRVSTART . 1)																	 ;;;
;;;              |->(LSTR . 2)																	 ;;;
;;;              (BRK3DP . 2)																	 ;;;
;;;  Autor:      Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt											 ;;;
;;;  Datum:      2023/April																	 ;;;
;;;              Angepasst: 2025/Juni																 ;;;
;;;  Argumente:  Crv   --> EName & Pickpoint der ausgewählten Curve												 ;;;
;;;              MCrv  --> Liste mit bereits ausgewählten Enames & Pickpoints											 ;;;
;;;  Variablen:  ObL  --> Liste mit den kopierten Vla-Objekten													 ;;;
;;;              Vec  --> Shift-Vektor für die Transformation der Kopien											 ;;;
;;;              l    --> Liste mit den Intersection-Koordinaten												 ;;;
;;;              pp   --> Zwischenspeicher der Pickpoint-Params													 ;;;
;;;              p    --> Zwischenspeicher der Schnitt-Params													 ;;;
;;;              ss   --> Selectionset der gebrochenen Kopien für den Join											 ;;;
;;;              e    --> EName der zu brechenden Curve														 ;;;
;;;  Func-Key:   o																		 ;;;
;;;              e																		 ;;;
;;;  Code:
    (defun MrgCrv ( Crv MCrv / CRVSTART BRK3DP ObL Vec l pp p ss e o e );Beginn nach den def's der Unterfunktionen

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> CrvS |-> MrgCrv |-> CrvStart													 ;;;
;;;  Zweck:      Verändert den Startpunkt einer geschlossenen Line (true wie false) in die nähe des Pickpoints und gibt diesen korrigiert aus			 ;;;
;;;  Funktionen: (LSTR . 2)																	 ;;;
;;;  Autor:      Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt											 ;;;
;;;  Datum:      2025/Juni																	 ;;;
;;;  Argumente:  Crv  --> EName der ausgewählten Curve														 ;;;
;;;              PP   --> Der Pickpoint von Crv als Koordinate													 ;;;
;;;  Variablen:  Prm  --> Param des Pickpoints															 ;;;
;;;              N    --> Integer mit Anzahl der zu verschiebenden Knoten											 ;;;
;;;              Lst  --> Liste mit allen Params aller Knoten													 ;;;
;;;              Blg  --> Liste mit (Params . (Bulge-Werte))													 ;;;
;;;              Arr  --> Neues Koordinaten Array														 ;;;
;;;  Func-Key:   val																		 ;;;
;;;  Code:
      (defun CrvStart ( Crv PP / LSTR Prm Lst N Blg Arr val );Beginn nach den def's der Unterfunktionen

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> CrvS |-> MrgCrv |-> CrvStart |-> LstR												 ;;;
;;;  Zweck:      Rotiert die Elemente in der Liste nach Anzahl N												 ;;;
;;;  Funktionen: Keine Unterfunktionen																 ;;;
;;;  Autor:      Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt											 ;;;
;;;  Datum:      2025/Juni																	 ;;;
;;;  Argumente:  Lst  --> Liste die verändert werden soll													 ;;;
;;;              N    --> Anzahl der Durchläufe als Integer													 ;;;
;;;  Variablen:  -	 																	 ;;;
;;;  Code:
        (defun LstR ( Lst N / )(if Lst (repeat N (setq Lst (reverse (cons (car Lst)(reverse (cdr Lst))))))) Lst)

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;Weiter mit CrvStart
        (setq Crv (if (eq (type Crv) 'ENAME)(vlax-ename->vla-object Crv) Crv)
              Prm (vlax-curve-getParamAtPoint Crv PP)
        );end setq
        (cond ((and (not (vlax-curve-isClosed Crv))(not (equal (vlax-curve-getStartPoint Crv)(vlax-curve-getEndPoint Crv) 1e-6))) Prm)
              ((and (not (vlax-curve-isClosed Crv))(vla-put-Closed Crv :vlax-true)))
              ((setq Lst (if (wcmatch (strcase (vla-get-ObjectName Crv)) "ACDBSPLINE")
                             (vlax-safearray->list (vlax-variant-value (vla-get-Knots Crv)))
                           (mapcar '(lambda ( val )(vlax-curve-getParamAtPoint Crv val))(CrvL Crv 0))
                         );end if
               );end setq
                 (if (zerop (setq N (1- (vl-position Prm (vl-sort (cons Prm Lst) '<)))))(setq N (1+ N)))
                 (cond ((wcmatch (strcase (vla-get-ObjectName Crv)) "ACDBSPLINE")
                          (mapcar '(lambda ( val )(vl-catch-all-apply val (list Crv 0)))'(vla-put-SplineMethod vla-put-KnotParameterization))
                          (setq Lst (vl-remove 0.0 (LstR Lst N))
                                Lst (mapcar '(lambda ( val )(cons (vl-position val Lst)(vlax-curve-getPointAtParam Crv val))) Lst)
                                Lst (cons (cons (length Lst)(cdar Lst)) Lst) 
                          );end setq
                          (mapcar '(lambda ( val )(setq Rtn (vl-catch-all-apply 'vla-SetFitPoint (list Crv (car val)(vlax-3d-Point (cdr val)))))) Lst)
                       );end
                       ((wcmatch (strcase (vla-get-ObjectName Crv)) "ACDB*POLYLINE")
                          (if (not (wcmatch (vla-get-ObjectName Crv) "*3*"))
                              (setq Blg (mapcar '(lambda ( val )(cons val (vla-getBulge Crv val))) Lst))
                          );end if
                          (setq Lst (cons (apply 'append (mapcar '(lambda ( val )(mapcar '+
                                                                                         (vlax-curve-getPointAtParam Crv val)
                                                                                         (if (wcmatch (vla-get-ObjectName Crv) "*3*")'(0. 0. 0.)'(0. 0.))
                                                                                 );end mapcar
                                                                  );end lambda
                                                                 (setq Lst (LstR Lst N))
                                                         );end mapcar
                                          );end apply
                                          Lst
                                    );end cons
                          );end setq
                          (vlax-safearray-fill (setq Arr (vlax-make-safearray vlax-vbdouble (cons 1 (length (car Lst)))))(car Lst))
                          (vl-catch-all-apply 'vla-put-Coordinates (list Crv Arr))
                          (if Blg (mapcar '(lambda ( val )(vl-catch-all-apply 'vla-setBulge (list Crv (vl-position (car val)(cdr Lst))(cdr val)))) Blg))
                       );end
                 );end cond
                 (vlax-curve-getParamAtPoint Crv PP)
              );end
        );end cond
      );end defun

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> CrvS |-> MrgCrv |-> CrvStart													 ;;;
;;;  Zweck:      Zum "brechen" von 3dPolylinien, da diese ein leicht anderes Verhalten mit dem command "_BREAK" aufweisen.					 ;;;
;;;  Funktionen: Keine Unterfunktionen																 ;;;
;;;  Autor:      Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt											 ;;;
;;;  Datum:      2025/Juni																	 ;;;
;;;  Argumente:  Crv  --> Vla-Object der ausgewählten Curve													 ;;;
;;;              Brk  --> Liste der Brechpunkte als ((1.Prm . 2.Prm).(1.Pt . 2Pt))										 ;;;
;;;  Variablen:  Lst  --> Liste mit allen Knotenpunkten														 ;;;
;;;              Arr  --> Neues Koordinaten Array														 ;;;
;;;  Func-Key:   val																		 ;;;
;;;  Code:
      (defun Brk3dP ( Crv Brk / Lst Arr val )
        (cond ((not (wcmatch (strcase (vla-get-ObjectName Crv)) "ACDB3DPOLYLINE")) nil)
              (t (setq Lst (LstN (vlax-safearray->list (vlax-variant-value (vla-get-Coordinates Crv))) 3)
                       Lst (vl-remove-if '(lambda ( val )(if (< (caar Brk)(cdar Brk))(not (< (caar Brk)(car val)(cdar Brk)))(<= (cdar Brk)(car val)(caar Brk))))
                                         (mapcar '(lambda ( val )(cons (vlax-curve-getParamAtPoint Crv val) val)) Lst)
                           );end vl-remove
                       Lst (apply 'append (if (< (caar Brk)(cdar Brk))
                                              (append (list (cadr Brk))(mapcar 'cdr Lst)(list (cddr Brk)))
                                            (append (list (cadr Brk))
                                                    (mapcar 'cdr (vl-remove-if '(lambda ( val )(< (car val)(cdar Brk))) Lst))
                                                    (mapcar 'cdr (vl-remove-if '(lambda ( val )(> (car val)(caar Brk))) Lst))
                                                    (list (cddr Brk))
                                            );end append
                                          );end if
                           );end apply
                 );end setq
                 (vl-catch-all-apply 'vla-put-closed (list Crv :vlax-false))
                 (vlax-safearray-fill (setq Arr (vlax-make-safearray vlax-vbdouble (cons 1 (length Lst)))) Lst)
                 (null (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-Coordinates (list Crv Arr))))
              );end
        );end cond
      );end defun
               
;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;Weiter mit MrgCrv
      (cond ((not MCrv)(setq MCrv (list (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object (car Crv)))) Crv))(redraw (car MCrv) 3) MCrv)
            ((or (redraw (car MCrv) 4)
                 (null (entdel (car MCrv)))
                 (not (setq MCrv (cons Crv (cdr MCrv))))
                 (member nil (setq ObL (mapcar '(lambda ( o )(cons (vla-copy (vlax-ename->vla-object (car o)))(cdr o))) MCrv)))
             );end or
               (if ObL (mapcar '(lambda ( o )(vl-catch-all-apply 'vla-delete (list o)))(mapcar 'car ObL)))
            );end
            ((and (setq Vec (car (mBBox (mapcar 'car ObL) nil)))(mapcar '(lambda ( o )(SftT o nil (mapcar '- Vec)))(mapcar 'car ObL)))
               (setq ObL (mapcar '(lambda ( o / l pp p )
                                    (setq pp (CrvStart (car o)(ClstPt (car o)(car (SftT (list (trans (cadr o) 1 0)) nil (mapcar '- Vec))))))
                                    (cond ((setq l (apply 'append (mapcar '(lambda ( e )(if (not (vlax-erased-p (setq e (car e))))
                                                                                            (mapcar '(lambda ( p )(vlax-curve-getParamAtPoint (car o) p))
                                                                                                    (LstN (vlax-invoke (car o) 'intersectWith e acExtendNone) 3)
                                                                                            );end mapcar
                                                                                        );end if
                                                                           );end lambda
                                                                          (vl-remove o ObL)
                                                                  );end mapcar
                                                   );end apply
                                           );end setq
                                             (cond ((and (= 1 (length l))(vlax-curve-isClosed (car o)))
                                                      (vl-list* (car o)
                                                                (if (vlax-curve-getDistAtParam (car o)(setq p (+ (car l) 1e-4))) p (abs (- (car l) 1e-4)))
                                                                (car l)
                                                      );end vl-list*
                                                   );end
                                                   (t (if (and (not (member (setq p (vlax-curve-getStartParam (car o))) l))(not (vlax-curve-isClosed (car o))))
                                                          (setq l (cons p l))
                                                      );end if
                                                      (if (and (not (member (setq p (vlax-curve-getEndParam (car o))) l))(not (vlax-curve-isClosed (car o))))
                                                          (setq l (cons p l))
                                                      );end if
                                                      (setq l (cons pp l))
                                                      (if (not (setq p (cadr (member pp (vl-sort l '<)))))
                                                          (setq p (car (vl-sort l '<)))
                                                      );end if
                                                      (if (not (setq pp (cadr (member pp (vl-sort l '>)))))
                                                          (setq pp (car (vl-sort l '>)))
                                                      );end if
                                                      (vl-list* (car o) pp p)
                                                   );end
                                             );end cond
                                          );end
                                          (t (setq MCrv (vl-remove Crv MCrv))
                                             (vl-catch-all-apply 'vla-delete (list (car o)))
                                          );end
                                    );end cond
                                  );end lambda
                                 (reverse ObL)
                         );end mapcar
                     ss (ssadd)
               );end setq
               (mapcar '(lambda ( o / p e )
                          (cond ((null o) nil)
                                ((not (setq p (vl-list* (cdr o)
                                                        (trans (vlax-curve-getPointAtParam (car o)(cadr o)) 0 1)
                                                        (trans (vlax-curve-getPointAtParam (car o)(cddr o)) 0 1)
                                              );end vl-list*
                                            e (vlax-vla-object->ename (car o))
                                            o (car o)
                                      );end setq
                                 );end not
                                );end
                                (t (cond ((and (not (vlax-curve-isClosed o))(= (vlax-curve-getStartParam o)(caar p))(= (vlax-curve-getEndParam o)(cdar p))))
                                         ((Brk3dP o p))
                                         ((and (vlax-curve-isClosed o)(> (caar p)(cdar p)))(vl-cmdf "_.BREAK" e (cadr p)(cddr p)))
                                         (t (vl-cmdf "_.BREAK" e (trans (vlax-curve-getStartPoint o) 0 1)(cadr p))
                                            (vl-cmdf "_.BREAK" e (cddr p)(trans (vlax-curve-getEndPoint o) 0 1))
                                         );end
                                   );end cond
                                   (if (entget e)(setq ss (ssadd e ss)))
                                );end
                          );end cond
                        );end lambda
                       ObL
               );end mapcar
               (cond ((setq Crv (cond ((> (sslength ss) 1)
                                         (setq Old (mapcar 'getvar '(CMDECHO QAFLAGS)))
                                         (mapcar 'setvar '(CMDECHO QAFLAGS)'(0 1))
                                         (vl-cmdf "_.JOIN" ss "")
                                         (mapcar 'setvar '(CMDECHO QAFLAGS) Old)
                                         (if (< 1 (length (setq Crv (vl-remove-if 'vlax-erased-p (mapcar 'car (vl-remove nil Obl))))))
                                             (vl-cmdf "_.JOIN" (ssname ss 0) ss "")
                                         );end if
                                         (cond ((< 1 (length (setq Crv (vl-remove-if 'vlax-erased-p (mapcar 'car (vl-remove nil Obl))))))
                                                  (mapcar 'vla-delete (cdr Crv))
                                                  (vlax-vla-object->ename (car Crv))
                                               );end
                                               ((car Crv)(vlax-vla-object->ename (car Crv)))
                                               (t (entlast))
                                         );end cond
                                      );end
                                      ((not (zerop (sslength ss)))(setq Crv (ssname ss 0)))
                                );end cond
                      );end setq
                        (SftT (vlax-ename->vla-object Crv) nil Vec)
                     );end
                     (t (setq Crv (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object (caar MCrv))))))
               );end cond
               (redraw Crv 3)
               (cons Crv MCrv)
            );end
      );end cond
    );end defun

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;Weiter mit CrvS
    (if Top (redraw (vlax-vla-object->ename Top) 3))
    (cond ((progn (while (and (/= Crv "Mehrere")
                              (not (vl-catch-all-error-p Crv))
                              (or (null Crv)(not (wcmatch (cdr (assoc 0 (entget (car Crv)))) "LINE,POLYLINE,LWPOLYLINE,SPLINE"))
                                  (and Top (eq (car Crv)(vlax-vla-object->ename Top)))
                              );end or
                         );end and
                    (initget "Mehrere")
                    (setq Crv (vl-catch-all-apply 'entsel (list (strcat "\n'" (if Top "Untere" "Obere") " Grenzkante wählen oder [Mehrere]: "))))
                  );end while
                  (vl-catch-all-error-p Crv)
           );end progn
             (if Top (redraw (vlax-vla-object->ename Top) 4))
          );end
          ((eq Crv "Mehrere")
             (setq Crv (null (setvar 'ERRNO 0)))
             (while (not (or (while (and (not (vl-catch-all-error-p Crv))
                                         (or (and (null Crv)(/= 52 (getvar 'ERRNO)))
                                             (and Crv (not (wcmatch (cdr (assoc 0 (entget (car Crv)))) "LINE,POLYLINE,LWPOLYLINE,SPLINE")))
                                             (and (member (car Crv)(cons (car MCrv)(mapcar 'car (cdr MCrv))))(null (redraw (car MCrv) 3)))
                                             (and Top (eq (car Crv)(vlax-vla-object->ename Top)))
                                         );end or
                                    );end and
                               (setq Crv (vl-catch-all-apply 'entsel (list (strcat "\nMehrere zu verbindende " (if Top "untere" "obere") " Grenzkanten wählen: "))))
                               nil
                             );end while
                             (or (vl-catch-all-error-p Crv)(null Crv))
                         );end or
                    );end not
               (if Crv (setq MCrv (MrgCrv Crv MCrv) Crv nil))
             );end while
             (if Top (redraw (vlax-vla-object->ename Top) 4))
             (cond ((null Crv)(redraw (car MCrv) 4)(cons (vlax-ename->vla-object (car MCrv)) t))
                   (t (vl-catch-all-apply 'entdel (list (car MCrv))) nil)
             );end cond
          );end
          (t (if Top (redraw (vlax-vla-object->ename Top) 4))
             (cons (vlax-ename->vla-object (car Crv)) nil)
          );end
    );end cond
  );end defun

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> LM:Popup															 ;;;
;;;  Zweck:      A wrapper for the WSH popup method to display a message box prompting the user.								 ;;;
;;;  Funktionen: Keine Unterfunktionen																 ;;;
;;;  Autor:      Lee Mac / Lee Mac Programming															 ;;;
;;;  URL:        http://lee-mac.com/popup.html															 ;;;
;;;  Datum:      -/-																		 ;;;
;;;  Argumente:  Ttl  --> Angabe der "Fensterbezeichnung"													 ;;;
;;;              Msg  --> Angabe des Textes für das Fenster													 ;;;
;;;              Bit  --> Angabe des Bit-Codes für Definition der Fenstereigenschaften (siehe auch URL)								 ;;;
;;;  Variablen:  Wsh  --> Das "wscript.shell" Objekt														 ;;;
;;;              Rtn  --> Die Ausgabe als Integer														 ;;;
;;;  Code:
  (defun LM:Popup ( Ttl Msg Bit / Wsh Rtn )
    (if (setq Wsh (vlax-create-object "wscript.shell"))
        (progn (setq Rtn (vl-catch-all-apply 'vlax-invoke-method (list Wsh 'POPUP Msg 0 Ttl Bit)))
               (vlax-release-object Wsh)
               (if (not (vl-catch-all-error-p Rtn)) Rtn)
        );end progn
    );end if
  );end defun

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> Dialog																 ;;;
;;;  Zweck:      Steuerung des Dialogfensters															 ;;;
;;;  Funktionen: (WRITEFILE . 3)																 ;;;
;;;              (CRVL . 2)																	 ;;;
;;;              (REVCRV . 1)																	 ;;;
;;;              (DIR? . 2)																	 ;;;
;;;              (DST<>% . 3)																	 ;;;
;;;              (DST<>PT . 2)																	 ;;;
;;;              (SLPL . 7)																	 ;;;
;;;              (DRWVECIMG . 8)																 ;;;
;;;  Autor:      Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt											 ;;;
;;;  Datum:      2023/Januar																	 ;;;
;;;              Angepasst: 2023/März																 ;;;
;;;              Angepasst: 2025/April-Mai															 ;;;
;;;  Argumente:  DflMlt  --> Angabe des Standard-Layers für neue Top- / Low-Curves										 ;;;
;;;              DflSlp  --> Angabe des Standard-Layers für die Böschungslinien											 ;;;
;;;              DflDst  --> Angabe des Standard-Abstands der Böschungslinien											 ;;;
;;;              Dfl3dS  --> Angabe des Standard-Modus für 3d-Winkel/längen berechnen										 ;;;
;;;              Top     --> Oberkante (vla-object . multi)													 ;;;
;;;              Low     --> Unterkante (vla-object . multi)													 ;;;
;;;  Variablen:  Dcl  --> Angabe des .dcl Pfads															 ;;;
;;;              dID  --> Angabe der Dialog ID															 ;;;
;;;              BB   --> Bounding Box von Top&Low in UCS													 ;;;
;;;              Lay  --> Liste aller Zeichnungslayer + Defaultauswahl												 ;;;
;;;              Lng  --> Maximal Länge von Top															 ;;;
;;;              SOf  --> Start-Offset als REAL															 ;;;
;;;              EOf  --> End-Offset als REAL															 ;;;
;;;              Mn   --> Systemischer Minimalabstand														 ;;;
;;;              Dst  --> Genutzter Minimalabstand														 ;;;
;;;              Slp  --> Koordinatenliste der Böschungslinien													 ;;;
;;;  Code:
  (defun Dialog ( DflMlt DflSlp DflDst Dfl3dS Top Low / WRITEFILE LAY? REVCRV DIR? DST<>% DST<>PT SLPL DRWVECIMG Dcl dID BB Lay Lng SOf EOf Mn Dst Slp )
  ;;;Beginn nach den def's der Unterfunktionen

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> Dialog |-> WriteFile														 ;;;
;;;  Zweck:      Erstellt eine temporäre Dcl-Datei														 ;;;
;;;  Funktionen: Keine Unterfunktionen																 ;;;
;;;  Autor:      Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt											 ;;;
;;;  Datum:      2025/April																	 ;;;
;;;  Argumente:  Pth  --> Speicherpfad als String oder nil für Temp												 ;;;
;;;              Ext  --> Dateiformat als String mit . (z.B ".dcl")												 ;;;
;;;              Lst  --> Liste mit dem Zeileninhalt für das File												 ;;;
;;;  Variablen:  Tmp   --> Angabe des Dateipfads														 ;;;
;;;              File  --> Das geöffnete File															 ;;;
;;;  Func-Key:   l																		 ;;;
;;;  Code:
    (defun WriteFile ( Pth Ext Lst / Tmp File l )
      (if (and (setq Tmp (vl-filename-mktemp "LISP-" Pth Ext))
               (setq File (open Tmp "w"))
          );end and
          (progn (mapcar '(lambda ( l )(write-line l File)) Lst)
                 (close File)
                 Tmp
          );end progn
      );end if
    );end defun

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> Dialog |-> Lay?														 ;;;
;;;  Zweck:      Kontrolliert ob der gewählte Layer vorhanden ist												 ;;;
;;;  Funktionen: Keine Unterfunktionen																 ;;;
;;;  Autor:      Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt											 ;;;
;;;  Datum:      2021/August																	 ;;;
;;;              Angepasst: 2025/Mai																 ;;;
;;;  Argumente:  Lay  --> Angabe des Layers															 ;;;
;;;  Variablen:  -																		 ;;;
;;;  Code:
      (defun Lay? ( Lay / )
        (if (or (tblsearch "LAYER" Lay)
                (and (load "L-Layer.lsp")(L-Layer (list Lay 0)))
                (= 6 (LM:PopUp "LISP Meldung"
                               (strcat "Layer: \"" Lay "\" nicht vorhanden.\n\nMit Standardwerten erstellen?\n\n(Alternativ: " (getvar 'CLAYER) ")")
                               (+ 4 32 4096)
                     );end LM:PopUp
                );end =
            );end or
            Lay
          (getvar 'CLAYER)
        );end if
      );end defun

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> Dialog |-> RevCrv														 ;;;
;;;  Zweck:      Wechselt die Richtung eines Curve-Objekts													 ;;;
;;;  Funktionen: Keine Unterfunktionen																 ;;;
;;;  Autor:      Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt											 ;;;
;;;  Datum:      2025/Februar																	 ;;;
;;;              Angepasst: 2025/Mai																 ;;;
;;;  Argumente:  Crv  --> Vla-Objekt einer Curve														 ;;;
;;;  Variablen:  Lst  --> Koordinatenliste der Curve														 ;;;
;;;              Blg  --> Liste mit ((Bulge-Werte) . Params)													 ;;;
;;;              Arr  --> Koordinatenarray															 ;;;
;;;  Func-Key:   p																		 ;;;
;;;              b																		 ;;;
;;;  Code:
    (defun RevCrv ( Crv / Lst Blg Arr p b )
      (cond ((wcmatch (strcase (vla-get-ObjectName Crv)) "ACDBSPLINE")(vl-catch-all-apply 'vla-Reverse (list Crv)))
            ((not (setq Lst (reverse (CrvL Crv 0)))))
            ((wcmatch (strcase (vla-get-ObjectName Crv)) "ACDBLINE")
               (vl-catch-all-apply 'vla-put-StartPoint (list Crv (vl-catch-all-apply 'vlax-3d-point (list (car Lst)))))
               (vl-catch-all-apply 'vla-put-EndPoint (list Crv (vl-catch-all-apply 'vlax-3d-point (list (last Lst)))))
            );end
            ((wcmatch (strcase (vla-get-ObjectName Crv)) "ACDB*POLYLINE")
               (if (not (wcmatch (vla-get-ObjectName Crv) "*3*"))
                   (setq Blg (cons (mapcar '(lambda ( p )(vla-getBulge Crv p))(setq Blg (mapcar '(lambda ( p )(vlax-curve-getParamAtPoint Crv p)) Lst))) Blg))
               );end if
               (vlax-safearray-fill (setq Arr (vlax-make-safearray vlax-vbdouble (cons 1 (length (setq Lst (apply 'append (reverse (CrvL Crv -1)))))))) Lst)
               (vl-catch-all-apply 'vla-put-Coordinates (list Crv Arr))
               (if Blg (mapcar '(lambda ( b p )(vl-catch-all-apply 'vla-setBulge (list Crv p (- b))))
                               (cdr (reverse (cons (caar Blg)(reverse (car Blg)))))
                               (reverse (cdr Blg))
                       );end mapcar
               );end if
            );end
      );end cond
      't
    );end defun

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> Dialog |-> Dir?														 ;;;
;;;  Zweck:      Vergleicht die Laufrichtung von Top & Low													 ;;;
;;;  Funktionen: (CW? . 1)																	 ;;;
;;;  Autor:      Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt											 ;;;
;;;  Datum:      2023/Januar																	 ;;;
;;;              Angepasst - 2025/Februar															 ;;;
;;;  Argumente:  Top  --> Oberkante als Vla-Object														 ;;;
;;;              Low  --> Unterkante als Vla-Object														 ;;;
;;;  Variablen:  -																		 ;;;
;;;  Code:
    (defun Dir? ( Top Low / CW? );Beginn nach den def's der Unterfunktionen

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> Dialog |-> Dir? |-> CW?													 ;;;
;;;  Zweck:      Bewertet ob eine Liste mit Koordinaten im Uhrzeigersin läuft											 ;;;
;;;  Funktionen: Keine Unterfunktionen																 ;;;
;;;  Autor:      Marko_ribar (AutoCAD Comunity Forum)														 ;;;
;;;              Angepasst - Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt									 ;;;
;;;  URL:        https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/polyline-direction-clockwise-or-counterclockwise/td-p/6050612			 ;;;
;;;  Datum:      2016/Februar																	 ;;;
;;;              Angepasst - 2023/Januar															 ;;;
;;;              Angepasst - 2025/Februar															 ;;;
;;;  Argumente:  L  --> Liste mit Koordinatenpunkten														 ;;;
;;;  Variablen:  -																		 ;;;
;;;  Func-Key:   x																		 ;;;
;;;              y																		 ;;;
;;;  Code:
      (defun CW? ( L / x y )
        (if (and (not (null L))(listp L))
            (minusp (apply '+ (mapcar '(lambda ( x y )(- (* (car x)(cadr y))(* (car y)(cadr x))))
                                      (setq L (mapcar '(lambda ( x y )(mapcar '- y x))(mapcar '(lambda ( x )(car L)) L)(cdr (reverse (cons (car L)(reverse L))))))
                                      (cdr (reverse (cons (car L)(reverse L))))
                              );end mapcar
                    );end apply
            );end minusp
        );end if
      );end defun

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;Weiter mit CrvDir
      (if (or (and (or (vlax-curve-isClosed Top)(vlax-curve-isClosed Low))
                   (/= (CW? (CrvL Top 1))(CW? (CrvL Low 1)))
              );end and
              (and (not (or (vlax-curve-isClosed Top)(vlax-curve-isClosed Low)))
                   (> (distance (vlax-curve-getStartPoint Top)(vlax-curve-getStartPoint Low))(distance (vlax-curve-getStartPoint Top)(vlax-curve-getEndPoint Low)))
              );end and
          );end or
          (RevCrv Low)
      );end if
    );end defun

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> Dialog |-> Dst<>%														 ;;;
;;;  Zweck:      Umrechnen zwischen Distanzen und Prozent für Abgleich Editbox & Slider										 ;;;
;;;  Funktionen: Keine Unterfunktionen																 ;;;
;;;  Autor:      Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt											 ;;;
;;;  Datum:      2025/Mai																	 ;;;
;;;  Argumente:  Arg  --> Wert als [REAL/INT = Distanz / STR = Prozent]												 ;;;
;;;              Mn   --> Minimaldistanz (0%)															 ;;;
;;;              Mx   --> Maximaldistanz (1000%)														 ;;;
;;;  Variablen:  -																		 ;;;
;;;  Code:
    (defun Dst<>% ( Arg Mn Mx / )
      (cond ((eq (type Arg) 'STR)(if (= (atoi Arg) 1000.) Mx (* (atoi Arg)(/ (- Mx Mn) 1000.))))
            ((eq (type Arg) 'REAL)(itoa (fix (/ Arg (/ (- Mx Mn) 1000.)))))
      );end cond
    );end defun

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> Dialog |-> Dst<>Pt														 ;;;
;;;  Zweck:      Wrapper für die Umrechnungen Punkt -> Distanz / Distanz -> Punkt										 ;;;
;;;  Funktionen: Keine Unterfunktionen																 ;;;
;;;  Autor:      Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt											 ;;;
;;;  Datum:      2025/Februar																	 ;;;
;;;  Argumente:  Crv  --> Vla-Objekt einer Curve														 ;;;
;;;              Arg  --> Punktkoordinate oder Distanz														 ;;;
;;;  Variablen:  Rtn  --> Zwischenspeicher einer Punktkoordinate für Ausgabe											 ;;;
;;;  Code:
    (defun Dst<>Pt ( Crv Arg / Rtn )
      (cond ((null Arg) nil)
            ((listp Arg)(vlax-curve-getDistAtPoint Crv (ClstPt Crv Arg)))
            ((member (type Arg)'(REAL INT))
               (if (and (null (setq Rtn (vlax-curve-getPointAtDist Crv Arg)))(equal Arg (Dst<>Pt Crv (vlax-curve-getEndPoint Crv)) 1e-8))
                   (vlax-curve-getEndPoint Crv)
                 Rtn
               );end if
            );end
      );end cond
    );end defun

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> Dialog |-> SlpL														 ;;;
;;;  Zweck:      Berechnen der Böschungslinien															 ;;;
;;;              Linien nach dem nächstgelegenen Punkt einer Projektion der anderen Kante ausgerichtet.								 ;;;
;;;              Die Berechnung erfolgt Vorgreifend und wird dann nochmals angepasst (NCP -> CP -> LCP), die kurzen Linien werden zwischen die Langen gemittelt. ;;;
;;;              Bei dynamischer Berechnung (Abstand = 1/3 Strichlänge, passend Minimum) hat der Algorithmus mehr Optionen um Ungleichheiten abzufangen.	 ;;;
;;;              Werden die Abstände auf der UK zu gross, wird die Dynamische Berechnung erst verkürzt und im weiteren von der UK zur OK berechnet.		 ;;;
;;;  Funktionen: (2DDST . 2)																	 ;;;
;;;              (ONCRV . 3)																	 ;;;
;;;              (OVRCRV . 3)																	 ;;;
;;;              (3DANG . 2)																	 ;;;
;;;  Autor:      Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt											 ;;;
;;;  Datum:      2021/August																	 ;;;
;;;              Angepasst - 2023/Januar															 ;;;
;;;              Angepasst - 2025/Februar															 ;;;
;;;              Angepasst - 2025/Mai																 ;;;
;;;  Argumente:  Top  --> Oberkante als vla-object														 ;;;
;;;              Low  --> Unterkante als vla-object														 ;;;
;;;              SOf  --> Start-Offset / Berechnungsdistanz													 ;;;
;;;              EOf  --> End-Offset																 ;;;
;;;              Sze  --> Abstandsstandard															 ;;;
;;;              Mn   --> Minimalabstand															 ;;;
;;;              3dS  --> Boolean für 3d-Winkellängen														 ;;;
;;;  Variablen:  Tp   --> Koordinatenpunkt auf Top														 ;;;
;;;              LP   --> Koordinatenpunkt auf Low														 ;;;
;;;              Prg  --> Maximaler Wert für Fortschrittsanzeige												 ;;;
;;;              i    --> Zähler für [gerade = lang / ungerade = kurz]												 ;;;
;;;              LTP  --> Letzter Koordinatenpunkt auf Top													 ;;;
;;;              LLP  --> Letzter Koordinatenpunkt auf Low													 ;;;
;;;              Dst  --> Abstand zwischen den Linien														 ;;;
;;;              NTP  --> Nächster Koordinatenpunkt auf Top													 ;;;
;;;              NLP  --> Nächster Koordinatenpunkt auf Low													 ;;;
;;;              MP   --> Endpunkt der kurzen Linien														 ;;;
;;;              Lst  --> Koordinatenliste aller Böschungslinien als Ausgabe											 ;;;
;;;  Func-Key:   val																		 ;;;
;;;  Code:
    (defun SlpL ( Top Low SOf EOf Sze Mn 3dS / 2DDST ONCRV OVRCRV 3DANG TP LP Prg i LTP LLP Dst NTP NLP MP Lst val ); Beginn nach den def's der Unterfunktionen

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> Dialog |-> SlpL |-> 2dDst													 ;;;
;;;  Zweck:      Berechnen der 2d-Distanz auf dem aktuellen BKS zwischen zwei 3d-Punkten									 ;;;
;;;  Funktionen: Keine Unterfunktionen																 ;;;
;;;  Autor:      Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt											 ;;;
;;;  Datum:      2025/Mai																	 ;;;
;;;  Argumente:  P1  --> Koordinatenpunkt															 ;;;
;;;              P2  --> Koordinatenpunkt															 ;;;
;;;  Variablen:  -																		 ;;;
;;;  Func-Key:   p																		 ;;;
;;;  Code:
      (defun 2dDst ( P1 P2 / p )(apply 'distance (mapcar '(lambda ( p )(mapcar '+ '(0. 0.)(trans p 0 1)))(list p1 p2))))

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> Dialog |-> SlpL |-> OnCrv													 ;;;
;;;  Zweck:      Kontrolliert ob der nächste Punkt noch auf der Curve liegt											 ;;;
;;;  Funktionen: Keine Unterfunktionen																 ;;;
;;;  Autor:      Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt											 ;;;
;;;  Datum:      2023/Januar																	 ;;;
;;;              Angepasst - 2025/April																 ;;;
;;;  Argumente:  Crv  --> Vla-Objekt einer Curve														 ;;;
;;;              Dst  --> Distanz des nächsten Punktes														 ;;;
;;;              EOf  --> End-Offset																 ;;;
;;;  Variablen:  Pt  --> Koordinatenpunkt als Ausgabe														 ;;;
;;;  Code:
      (defun OnCrv ( Crv Dst EOf / Pt )(if (or (null (setq Pt (Dst<>Pt Crv Dst)))(equal Dst 0. 1e-4)(equal Dst EOf 1e-4)(> Dst EOf)) nil Pt))

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> Dialog |-> SlpL |-> OvrCrv													 ;;;
;;;  Zweck:      Kontrolliert ob der nächste Punkt auf geschlossenen Curves bereits über dem Startpunkt liegt							 ;;;
;;;  Funktionen: Keine Unterfunktionen																 ;;;
;;;  Autor:      Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt											 ;;;
;;;  Datum:      2023/Januar																	 ;;;
;;;              Angepasst - 2025/April																 ;;;
;;;  Argumente:  Crv  --> Vla-Objekt einer Curve														 ;;;
;;;              NPt  --> Neuer Punkt																 ;;;
;;;              LPt  --> Vorheriger Punkt															 ;;;
;;;  Variablen:  -																		 ;;;
;;;  Code:
      (defun OvrCrv ( Crv NPt LPt / )
        (cond ((or (not NPt)(not LPt)) nil)
              ((>= (Dst<>Pt Crv NPt)(Dst<>Pt Crv LPt))(Dst<>Pt Crv (+ (Dst<>Pt Crv LPt)(/ (- (Dst<>Pt Crv NPt)(Dst<>Pt Crv LPt)) 2.))))
              (t (Dst<>Pt Crv ((if (> (- (vlax-curve-getDistAtParam Crv (vlax-curve-getEndParam Crv))(Dst<>Pt Crv LPt))(Dst<>Pt Crv NPt)) + -)
                                 (Dst<>Pt Crv (if (> (- (vlax-curve-getDistAtParam Crv (vlax-curve-getEndParam Crv))(Dst<>Pt Crv LPt))(Dst<>Pt Crv NPt)) LPt NPt))
                                 (/ (- (+ (vlax-curve-getDistAtParam Crv (vlax-curve-getEndParam Crv))(Dst<>Pt Crv NPt))(Dst<>Pt Crv LPt)) 2.)
                              );end +/-
                 );end Dst<>Pt
              );end
        );end cond
      );end defun

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> Dialog |-> SlpL |-> 3dAng													 ;;;
;;;  Zweck:      Berechnen eines 3d-Punktes nach Prozent des Winkels zwischen TP und LP (Winkel + 5 = %)							 ;;;
;;;  Funktionen: Keine Unterfunktionen																 ;;;
;;;  Autor:      Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt											 ;;;
;;;  Datum:      2025/April																	 ;;;
;;;  Argumente:  TP  --> Koordinatenpunkt auf Top														 ;;;
;;;              LP  --> Koordinatenpunkt auf Low														 ;;;
;;;  Variablen:  x  --> Länge Gegenkathete															 ;;;
;;;  Code:
      (defun 3dAng ( TP LP / x )
        (setq x (/ (2dDst TP LP)(distance TP LP)))
        (abs (1- (/ (+ (* (/ 180 pi)(atan (sqrt (- 1 (* x x))) x)) 5) 100)))
      );end defun

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;Weiter mit SlpL
      (cond ((not (and (setq TP (Dst<>Pt Top SOf))(setq LP (ClstPt Low TP))(setq i 0 LTP TP LLP LP))))
            ((while (and TP LP)
               (cond ;|;--== Durchgehende Linien ==--;|;
                     ((equal (/ i 2.)(fix (/ i 2.)) 1e-3)
                        (if (< (setq Dst (if (null Sze)(/ (2dDst TP LP) 3.) Mn)) Mn)(setq Dst Mn))
                        (cond ((not (and (setq NTP (OnCrv Top (+ SOf Dst) EOf))(setq NLP (ClstPt Low NTP)))))
                              ((and (not Sze)(> (- (Dst<>Pt Low NLP)(Dst<>Pt Low LP))(/ (2dDst TP LP) 2.5)))
                                 (if (< (setq Dst (/ Dst 2.)) Mn)(setq Dst Mn))
                                 (and (setq NTP (OnCrv Top (+ SOf Dst) EOf))(setq NLP (ClstPt Low NTP)))
                              );end
                        );end cond
                     );end
                     ;|;--==    Kurze Linien     ==--;|;
                     (t (cond ((not (and (setq NTP (OnCrv Top (+ SOf Dst) EOf))(setq NLP (ClstPt Low NTP))))
                                 (if (and (vlax-curve-isClosed Top)(equal EOf (vlax-curve-getDistAtParam Top (vlax-curve-getEndParam Top)) 1e-8))
                                     (setq TP (Dst<>Pt Top (+ (Dst<>Pt Top LTP)(/ (- EOf (Dst<>Pt Top LTP)) 2.)))
                                           LP (OvrCrv Low (ClstPt Low (vlax-curve-getStartPoint Top)) LLP)
                                     );end setq
                                 );end if
                                 (and TP LP (setq MP (mapcar '+ (mapcar '(lambda ( val )(* val (if 3dS (3dAng TP LP) 0.5)))(mapcar '- LP TP)) TP)))
                              );end
                              (t (if (and (or (equal LLP NLP 1e-4)(> (Dst<>Pt Low LLP)(Dst<>Pt Low NLP)))
                                          (not (<= (Dst<>Pt Low NLP)(- (Dst<>Pt Low LLP)(Dst<>Pt Low NLP))))
                                     );end and
                                     (or (setq NLP (OnCrv Low (+ (/ Dst 20.)(Dst<>Pt Low LLP))(vlax-curve-getDistAtParam Low (vlax-curve-getEndParam Low))))
                                         (setq NLP (vlax-curve-getEndPoint Low))
                                     );end or
                                 );end if
                                 (cond ((not (and (not Sze)(> (- (Dst<>Pt Low NLP)(Dst<>Pt Low LLP))(2dDst LTP LLP))(> (2dDst LTP LLP)(* 3 Mn)))))
                                       ((not (and (or (setq NLP (OnCrv Low (+ (Dst<>Pt Low LLP)(2dDst LTP LLP))(vlax-curve-getDistAtParam Low (vlax-curve-getEndParam Low))))
                                                      (setq NLP (ClstPt Low (Dst<>Pt Top EOf)))
                                                  );end or
                                                  (or (setq NTP (OnCrv Top (Dst<>Pt Top (ClstPt Top NLP)) EOf))
                                                      (setq NTP (Dst<>Pt Top EOf))
                                                  );end or
                                             );end and
                                        );end not
                                       );end
                                       (t (if (or (equal LTP NTP 1e-3)(> (Dst<>Pt Top LTP)(Dst<>Pt Top NTP)))
                                              (setq NTP (Dst<>Pt Top (+ (Dst<>Pt Top LTP) Mn))
                                                    NLP (Dst<>Pt Low (+ (Dst<>Pt Low NLP) Mn))
                                              );end setq
                                          );end if
                                          (and NTP LTP (setq TP (Dst<>Pt Top (/ (+ (Dst<>Pt Top LTP)(Dst<>Pt Top NTP)) 2.))))
                                       );end
                                 );end cond
                                 (setq LP (if (not (equal NLP LLP 1e-8))(OvrCrv Low NLP LLP) NLP))
                                 (and TP LP (setq MP (mapcar '+ (mapcar '(lambda ( val )(* val (if 3dS (3dAng TP LP) 0.5)))(mapcar '- LP TP)) TP)))
                              );end
                        );end cond
                     );end
               );end cond
               (cond ((equal SOf 0. 1e-8))
                     ((and TP LP (equal (/ i 2.)(fix (/ i 2.)) 1e-8))(setq Lst (append Lst (list (list TP LP)))))
                     ((and TP MP (not (equal (/ i 2.)(fix (/ i 2.)) 1e-8)))(setq Lst (append Lst (list (list TP MP)))))
               );end cond
               (setq SOf (if NTP (Dst<>Pt Top NTP)(+ SOf Dst)) i (1+ i) LTP TP LLP LP LP NLP TP NTP MP nil)
             );end while
            );end
            ((and (vlax-curve-isClosed Top)
                  (equal EOf (vlax-curve-getDistAtParam Top (vlax-curve-getEndParam Top)) 1e-8)
                  (not (equal (/ (length Lst) 2.)(fix (/ (length Lst) 2.)) 1e-8))
             );end and
               (setq Lst (cons (list (setq TP (OvrCrv Top (caar Lst)(car (last Lst))))(ClstPt Low TP)) Lst))
            );end
            (t Lst)
      );end cond
    );end defun

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> Dialog |-> DrwVecImg														 ;;;
;;;  Zweck:      Transformieren der Koordinatenlisten zu Pixelvektoren und zeichnen der Bildvorschau								 ;;;
;;;  Funktionen: (SPLV . 2)																	 ;;;
;;;  Autor:      Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt											 ;;;
;;;  Datum:      2023/Januar																	 ;;;
;;;              Angepasst: 2025/April																 ;;;
;;;  Argumente:  Key  --> Image-Key																 ;;;
;;;              BB   --> Bounding Box von Top&Low in UCS													 ;;;
;;;              Top  --> Oberkante als vla-object														 ;;;
;;;              Low  --> Unterkante als vla-object														 ;;;
;;;              Slp  --> Koordinatenliste der Böschungslinien													 ;;;
;;;              LyS  --> Layername der Böschungslinien als String												 ;;;
;;;              SOf  --> Start-Offset																 ;;;
;;;              EOf  --> End-Offset																 ;;;
;;;  Variablen:  Wnd  --> X&Y Grösse des Image															 ;;;
;;;              Off  --> Offset zwischen Koordinaten und Pixeln												 ;;;
;;;              Scl  --> Skalierungsfaktor zwischen Koordinaten und Pixeln											 ;;;
;;;              Col  --> ACI Farbwert																 ;;;
;;;              Lst  --> Vektorliste mit Farbwerten														 ;;;
;;;  Func-Key:   val																		 ;;;
;;;              ang																		 ;;;
;;;  Code:
  (defun DrwVecImg ( Key BB Top Low Slp LyS SOf EOf / SPLV Wnd Off Scl Col Lst val ang )

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;  Befehl:     L-Boeschung |-> Dialog |-> DrwVecImg |-> SplV													 ;;;
;;;  Zweck:      Berechnen einer Koordinaten-/Vektorliste für Splines nach Anzahl Segmenten									 ;;;
;;;  Funktionen: Keine Unterfunktionen																 ;;;
;;;  Autor:      Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt											 ;;;
;;;  Datum:      2025/April																	 ;;;
;;;  Argumente:  Spl  --> Vla-Objekt einer Spline														 ;;;
;;;              Sgm  --> Anzahl der Segmente															 ;;;
;;;  Variablen:  Dst  --> Länge der Segmente															 ;;;
;;;              Lst  --> Liste aller Distanzwerte von Start bis ende Segment											 ;;;
;;;  Func-Key:   val																		 ;;;
;;;  Code:
    (defun SplV ( Spl Sgm / Dst Lst val )
      (setq Dst (/ (vlax-curve-getDistAtParam Spl (vlax-curve-getEndParam Spl)) Sgm) Lst '(0.))
      (mapcar '(lambda ( val )(trans (Dst<>Pt Spl val) 0 1))(reverse (repeat Sgm (setq Lst (cons (+ (car Lst) Dst) Lst)))))
    );end defun

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;;Weiter mit DrwVecImg
    (setq Wnd (list (dimx_tile Key)(dimy_tile Key))
          Scl (apply 'min (mapcar '/ Wnd (mapcar '(lambda ( val )(- (cadr val)(car val)))(setq Off (list (mapcar 'car BB)(mapcar 'cadr BB))))))
          Off (append (mapcar '- (mapcar '/ Wnd '(2 2))(mapcar '* (mapcar '/ (mapcar 'apply '(+ +) Off)'(2 2))(list Scl Scl)))'(0.))
          Lst (append (apply 'append (mapcar '(lambda ( val )
                                                (mapcar '(lambda ( ang )
                                                           (vl-list* 30
                                                                     (list (trans (Dst<>Pt Top val) 0 1)
                                                                           (polar (trans (Dst<>Pt Top val) 0 1) ang (/ (distance (car BB)(cadr BB)) 200))
                                                                     );end list
                                                           );end vl-list*
                                                         );end lambda
                                                        (list 0. (/ pi 2) pi (+ pi (/ pi 2)))
                                                );end mapcar
                                              );end lambda
                                             (list SOf EOf)
                                     );end mapcar
                      );end apply
                      (apply 'append (mapcar '(lambda ( val / Col Lst )
                                                (setq Col (if (or (vl-catch-all-error-p (setq Col (vl-catch-all-apply 'vla-get-Color (list val))))
                                                                  (and (= Col 256)(not (setq Col (cdr (assoc 62 (tblsearch "LAYER" (vla-get-Layer val)))))))
                                                              );end or
                                                              1
                                                            Col
                                                          );end if
                                                      Lst (if (wcmatch (strcase (vla-get-ObjectName val)) "ACDBSPLINE")(SplV val 128)(CrvL val 1))
                                                );end setq
                                                (mapcar '(lambda ( val )(vl-list* Col val))
                                                        (mapcar 'list Lst (if (vlax-curve-isClosed val)(append (cdr Lst)(list (car Lst)))(cdr Lst)))
                                                );end mapcar
                                              );end lambda
                                             (list Top Low)
                                     );end mapcar
                      );end apply
                      (progn (setq Col (if (setq Col (cdr (assoc 62 (tblsearch "LAYER" LyS)))) Col 1))
                             (mapcar '(lambda ( val )(vl-list* Col (mapcar '(lambda ( val )(trans val 0 1)) val))) Slp)
                      );end progn
              );end append
    );end setq
    (start_image Key)
    (fill_image 0 0 (dimx_tile Key)(dimy_tile Key) -2)
    (mapcar '(lambda ( val )(apply 'vector_image val))
            (mapcar '(lambda ( val )(append (mapcar 'fix (apply 'append (mapcar '(lambda ( val )(list (car val)(- (cadr Wnd)(cadr val))))
                                                                                (SftT (cdr val)(list (list Scl 0. 0.)(list 0. Scl 0.)(list 0. 0. Scl)) Off)
                                                                        );ans mapcar
                                                         );end apply
                                            );end mapcar
                                            (list (car val))
                                    );end append
                     );end lambda
                    (reverse Lst)
            );end mapcar
    );end mapcar
    (end_image)
  );end defun

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;; Weiter mit Dialog
    (cond ((not (setq Dcl (WriteFile nil ".dcl" (append
              (list "///Automatisch generiertes, temporäres DCL-File für die Boeschungs-LISP."
            (strcat "///Erstellt durch:  " (getvar 'LOGINNAME))
            (strcat "///Erstellt am/um:  " (rtos (getvar 'CDATE) 2 6))
            (strcat "///Erstellt in:     " (getvar 'DWGPREFIX)(getvar 'DWGNAME))
                    "///Sollte diese Datei nicht automatisch gelöscht worden sein, Bitte manuell löschen."
                    "///---------------------------------------------------------------------------------------------------------------------------------------///"
                    "DBoesch"
                    "///---------------------------------------------------------------------------------------------------------------------------------------///"
                    ": dialog {label = \"Böschungslinien erstellen:\";"
                    "         : row {"
                    "               : column {"
                    "                        : boxed_column {label = \"Vorschau:\";"
                    "                                       : image {key = \"Img\"; color = -2; aspect_ratio = 1; width = 90; height = 41.5385;}"
                    "                        }//end boxed_column"
                    "                        : boxed_row {label = \"Offset:\";"
                    "                                    : text {label = \"Start\"; fixed_width = true;}"
                    "                                    : edit_box {key = \"SOE\"; edit_width = 4; fixed_width = true;}"
                    "                                    : slider {key = \"SOS\"; width = 35; max_value = 1000; value = 0;}"
                    "                                    : slider {key = \"EOS\"; width = 35; max_value = 1000; value = 1000;}"
                    "                                    : edit_box {key = \"EOE\"; edit_width = 4; fixed_width = true;}"
                    "                                    : text {label = \"Ende\"; fixed_width = true;}"
                    "                        }//end boxed_row"
                    "               }//end column"
                    "               : column {width = 30;"
                    "                        : boxed_column {label = \"Layer:\"; children_alignment = left;"
                    "                                       : spacer {height = 0.05;}"
                    "                                       : text {label = \"Böschung:\"; fixed_height = true;}"
                    "                                       : popup_list {key = \"Slp\"; fixed_height = true;}"
              );end list
     (cond ((and (cdr Top)(cdr Low))
              (list "                                       : text {label = \"OK | UK:\"; fixed_height = true;}"
                    "                                       : popup_list {key = \"New\"; fixed_height = true;}"
                    "                                       : spacer {height = 0.5;}"
                    "                                       : toggle {label = \"OK | UK beibehalten\"; key = \"Kep\";}"
              );end list
           );end
           ((cdr Top)
              (list "                                       : text {label = \"Oberkante:\"; fixed_height = true;}"
                    "                                       : popup_list {key = \"New\"; fixed_height = true;}"
                    "                                       : spacer {height = 0.5;}"
                    "                                       : toggle {label = \"OK beibehalten\"; key = \"Kep\";}"
              );end list
           );end
           ((cdr Low)
              (list "                                       : text {label = \"Unterkante:\"; fixed_height = true;}"
                    "                                       : popup_list {key = \"New\"; fixed_height = true;}"
                    "                                       : spacer {height = 0.5;}"
                    "                                       : toggle {label = \"UK beibehalten\"; key = \"Kep\";}"
              );end list
           );end
           (t (list "                                       : spacer {height = 7;}"))
     );end cond
              (list "                        }//end boxed_column"
                    "                        : row {"
                    "                              : column {width = 20;"
                    "                                       : boxed_column {label = \"Richtung\";"
                    "                                                      : spacer {height = 0.05;}"
                    "                                                      : toggle {label = \"OK umkehren\"; key = \"TDr\";}"
                    "                                                      : toggle {label = \"UK umkehren\"; key = \"LDr\";}"
                    "                                                      : spacer {height = 0.05;}"
                    "                                       }//end boxed_column"
                    "                                       : boxed_column {label = \"Winkel\";"
                    "                                                      : spacer {height = 0.05;}"
                    "                                                      : toggle {label = \"3D Längen\";"
                    "                                                                key = \"3dS\";"
                    "                                                                fixed_width = true;"
     (cond ((and (vl-every 'vlax-curve-isPlanar (list (car Top)(car Low)))
                 (equal (last (trans (Dst<>Pt (car Top) 0.) 0 1))(last (trans (Dst<>Pt (car Low) 0.) 0 1)) 1e-4)
                 (not (setq Dfl3dS nil))
            );end and
                    "                                                                is_enabled = false;"
           );end
           (Dfl3dS  "                                                                value = 1;")
           (t       "")
     );end cond
                    "                                                      }//end toggle"
                    "                                                      : spacer {height = 0.05;}"
                    "                                       }//end boxed_column"
                    "                                       : boxed_column {label = \"Abstand\"; children_alignment = left;"
                    "                                                      : spacer {height = 0.05;}"
                    "                                                      : radio_button {label = \"Dynamisch\"; key = \"Dyn\";}"
                    "                                                      : radio_button {label = \"Festgelegt\"; key = \"Fix\";}"
                    "                                                      : spacer {height = 0.1;}"
                    "                                                      : row {"
                    "                                                            : edit_box {key = \"DsE\"; edit_width = 7; fixed_width = true;}"
                    "                                                            : text {label= \"Min.\"; fixed_width = true; is_enabled = false;}"
                    "                                                            : spacer {width = 0.5;}"
                    "                                                      }//end row"
                    "                                       }//end boxed_column"
                    "                              }//end column"
                    "                              : boxed_column {label = \"Min.\"; fixed_width = true;"
                    "                                             : slider {key = \"DsS\"; layout = vertical; max_value = 1000;}"
                    "                              }//end boxed_column"
                    "                        }//end row"
                    "                        : boxed_column {fixed_height = true;"
                    "                                       : button {label = \"Erstellen\"; key = \"act\"; is_default = false; height = 2.5;}"
                    "                                       : button {label = \"Abbrechen\"; key = \"ccl\"; is_cancel = true; is_default = true; height = 2.5;}"
                    "                        }//end boxed_column"
                    "               }//end column"
                    "         }//end row"
                    "         : text {label = \"Copyright© 2025;\t\t\tArchäologische Bodenforschung Basel-Stadt;\t\t\tF.Bubendorf\";"
                    "                 fixed_width = true;"
                    "         }//end text"
                    "}//end dialog"
                    "///---------------------------------------------------------------------------------------------------------------------------------------///"
              );end list
                                                );end append
                          );end WriteFile
                );end setq
           );end not
             (LM:Popup "LISP Meldung" "Dialogfenster konnte nicht erstellt werden!.\n\nLISP wird beendet!" (+ 0 16 4096))
          );end
          ((not (new_dialog "DBoesch" (setq dID (load_dialog Dcl))))
             (LM:Popup "LISP Meldung" "Dialogfenster konnte nicht geladen werden!.\n\nLISP wird beendet!" (+ 0 16 4096))
          );end
          (t (setq BB (mBBox (list (car Top)(car Low)) t)
                   Lay (list (setq DflMlt (if (or (cdr Top)(cdr Low))(Lay? DflMlt) DflMlt)) DflSlp)
                   Lng (vlax-curve-getDistAtParam (car Top)(vlax-curve-getEndParam (car Top)))
                   SOf 0.
                   EOf Lng
                   Mn (cond ((> Lng (* 5. 0.015)) 0.015)((> (/ Lng 10) 0.001)(/ Lng 10))(t 0.001))
                   Dst (if DflDst DflDst Mn)
             );end setq
             (mapcar '(lambda ( val )(if (cdr val)(vl-catch-all-apply 'vla-put-Layer (list (car val) DflMlt))))(list Top Low))
             (vlax-map-collection (vla-get-Layers (vla-get-ActiveDocument (vlax-get-acad-object)))
                                  '(lambda ( val )(if (not (member (vla-get-Name val)(list DflMlt DflSlp)))(setq Lay (cons (vla-get-Name val) Lay))))
             );end vlax-map-collection
             (setq Lay (vl-sort Lay '<))
             (mapcar '(lambda ( key val )(set_tile key (rtos val 2)))'("SOE" "EOE")(list SOf EOf))
             (action_tile "SOE" (vl-prin1-to-string '(progn (setq SOf (cond ((> (atof $value)(- EOf Dst))(- EOf Dst))((< (atof $value) 0.) 0.)(t (atof $value))))
                                                            (mapcar 'set_tile '("SOE" "SOS" "EOS")(list (rtos SOf 2)(Dst<>% SOf 0. EOf)(Dst<>% (- EOf SOf) SOf Lng)))
                                                            (DrwVecImg "Img" BB (car Top)(car Low)(setq Slp (SlpL (car Top)(car Low) SOf EOf DflDst Dst Dfl3dS)) DflSlp SOf EOf)
                                                     );end progn
                                );end vl-prin1-to-string
             );end action_tile
             (action_tile "EOE" (vl-prin1-to-string '(progn (setq EOf (cond ((> (atof $value) Lng) Lng)((< (atof $value)(+ SOf Dst))(+ SOf Dst))(t (atof $value))))
                                                            (mapcar 'set_tile '("EOE" "SOS" "EOS")(list (rtos EOf 2)(Dst<>% SOf 0. EOf)(Dst<>% (- EOf SOf) SOf Lng)))
                                                            (DrwVecImg "Img" BB (car Top)(car Low)(setq Slp (SlpL (car Top)(car Low) SOf EOf DflDst Dst Dfl3dS)) DflSlp SOf EOf)
                                                     );end progn
                                );end vl-prin1-to-string
             );end action_tile
             (action_tile "SOS" (vl-prin1-to-string '(progn (setq SOf (cond ((> (setq SOf (Dst<>% $value 0. (- EOf Dst)))(- EOf Dst))(- EOf Dst))((< SOf 0.) 0.)(t SOf)))
                                                            (mapcar 'set_tile '("SOE" "EOS")(list (rtos SOf 2)(Dst<>% (- EOf SOf) SOf Lng)))
                                                            (DrwVecImg "Img" BB (car Top)(car Low)(setq Slp (SlpL (car Top)(car Low) SOf EOf DflDst Dst Dfl3dS)) DflSlp SOf EOf)
                                                     );end prognn
                                );end vl-prin1-to-string
             );end action_tile
             (action_tile "EOS" (vl-prin1-to-string '(progn (setq EOf (cond ((> (setq EOf (+ SOf (Dst<>% $value (+ SOf Dst) Lng))) Lng) Lng)((< EOf (+ SOf Dst))(+ SOf Dst))(t EOf)))
                                                            (mapcar 'set_tile '("EOE" "SOS")(list (rtos EOf 2)(Dst<>% SOf 0. EOf)))
                                                            (DrwVecImg "Img" BB (car Top)(car Low)(setq Slp (SlpL (car Top)(car Low) SOf EOf DflDst Dst Dfl3dS)) DflSlp SOf EOf)
                                                     );end prognn
                                );end vl-prin1-to-string
             );end action_tile
             (mapcar '(lambda ( key val )(start_list key)(mapcar 'add_list Lay)(end_list)(set_tile key (itoa (vl-position val Lay))))
                     '("Slp" "New")(list DflSlp DflMlt)
             );end mapcar
             (action_tile "Slp" (vl-prin1-to-string '(DrwVecImg "Img" BB (car Top)(car Low)(setq Slp (SlpL (car Top)(car Low) SOf EOf DflDst Dst Dfl3dS))(setq DflSlp (nth (atoi $value) Lay)) SOf EOf)))
             (action_tile "New" (vl-prin1-to-string '(progn (mapcar '(lambda ( val )(if (cdr val)
                                                                                        (entmod (subst (cons 8 (nth (atoi $value) Lay))
                                                                                                       (assoc 8 (entget (vlax-vla-object->ename (car val))))
                                                                                                       (entget (vlax-vla-object->ename (car val)))
                                                                                                );end subst
                                                                                        );end entmod
                                                                                    );end if
                                                                     );end lambda
                                                                    (list Top Low)
                                                            );end mapcar
                                                            (DrwVecImg "Img" BB (car Top)(car Low)(setq Slp (SlpL (car Top)(car Low) SOf EOf DflDst Dst Dfl3dS)) DflSlp SOf EOf)
                                                     );end progn
                                );end vl-prin1-to-string
             );end action_tile
             (set_tile "LDr" (if (Dir? (car Top)(car Low)) "1" "0"))
             (action_tile "TDr" (vl-prin1-to-string '(progn (RevCrv (car Top))(DrwVecImg "Img" BB (car Top)(car Low)(setq Slp (SlpL (car Top)(car Low) SOf EOf DflDst Dst Dfl3dS)) DflSlp SOf EOf))))
             (action_tile "LDr" (vl-prin1-to-string '(progn (RevCrv (car Low))(DrwVecImg "Img" BB (car Top)(car Low)(setq Slp (SlpL (car Top)(car Low) SOf EOf DflDst Dst Dfl3dS)) DflSlp SOf EOf))))
             (action_tile "3dS" (vl-prin1-to-string '(progn (setq Dfl3dS (not (zerop (atoi $value))))
                                                            (DrwVecImg "Img" BB (car Top)(car Low)(setq Slp (SlpL (car Top)(car Low) SOf EOf DflDst Dst Dfl3dS)) DflSlp SOf EOf)
                                                     );end progn
                                );end vl-prin1-to-string
             );end action_tile
             (mapcar 'set_tile '("Dyn" "Fix" "DsE" "DsS")(append (if DflDst '("0" "1")'("1" "0"))(list (rtos Dst 2)(Dst<>% Dst Mn Lng))))
             (action_tile "Dyn" (vl-prin1-to-string '(progn (mapcar 'set_tile '("DsE" "DsS")(list (rtos (setq Dst Mn) 2)(Dst<>% Dst Mn (/ Lng 5.))))
                                                            (DrwVecImg "Img" BB (car Top)(car Low)(setq Slp (SlpL (car Top)(car Low) SOf EOf (setq DflDst nil) Dst Dfl3dS)) DflSlp SOf EOf)
                                                     );end progn
                                );end vl-prin1-to-string
             );end action_tile
             (action_tile "Fix" (vl-prin1-to-string '(progn (mapcar 'set_tile '("DsE" "DsS")(list (rtos (setq DflDst (/ Lng 5.) Dst DflDst) 2)(Dst<>% Dst Mn (/ Lng 5.))))
                                                            (DrwVecImg "Img" BB (car Top)(car Low)(setq Slp (SlpL (car Top)(car Low) SOf EOf DflDst Dst Dfl3dS)) DflSlp SOf EOf)
                                                     );end progn
                                );end vl-prin1-to-string
             );end action_tile
             (action_tile "DsE" (vl-prin1-to-string '(progn (setq Dst (cond ((> (atof $value)(/ Lng 5.))(/ Lng 5.))((< (atof $value) Mn) Mn)(t (atof $value))))
                                                            (mapcar 'set_tile '("DsE" "DsS")(list (rtos Dst 2)(Dst<>% Dst Mn (/ Lng 5.))))
                                                            (DrwVecImg "Img" BB (car Top)(car Low)(setq Slp (SlpL (car Top)(car Low) SOf EOf DflDst Dst Dfl3dS)) DflSlp SOf EOf)
                                                     );end progn
                                );end vl-prin1-to-string
             );end action_tile
             (action_tile "DsS" (vl-prin1-to-string '(progn (setq Dst (cond ((> (setq Dst (Dst<>% $value Mn (/ Lng 5.)))(/ Lng 5.))(/ Lng 5.))((< Dst Mn) Mn)(t Dst)))
                                                            (set_tile "DsE" (rtos Dst 2))
                                                            (DrwVecImg "Img" BB (car Top)(car Low)(setq Slp (SlpL (car Top)(car Low) SOf EOf DflDst Dst Dfl3dS)) DflSlp SOf EOf)
                                                     );end progn
                                );end vl-prin1-to-string
             );end action_tile
             (DrwVecImg "Img" BB (car Top)(car Low)(setq Slp (SlpL (car Top)(car Low) SOf EOf DflDst Dst Dfl3dS)) DflSlp SOf EOf)
             (action_tile "act" (vl-prin1-to-string '(progn (mapcar '(lambda ( key val )
                                                                       (if (not (zerop (atoi key)))(RevCrv (car val)))
                                                                       (if (and (cdr val)(zerop (atoi (get_tile "Kep"))))(vl-catch-all-apply 'vla-delete (list (car val))))
                                                                     );end lambda
                                                                    (list (get_tile "TDr")(get_tile "LDr"))
                                                                    (list Top Low)
                                                            );end mapcar
                                                            (setq Slp (cons Slp (Lay? DflSlp)))
                                                            (done_dialog)
                                                     );end progn
                                );end vl-prin1-to-string
             );end action_tile
             (action_tile "ccl" (vl-prin1-to-string '(progn (mapcar '(lambda ( key val )
                                                                       (if (not (zerop (atoi key)))(RevCrv (car val)))
                                                                       (if (cdr val)(vl-catch-all-apply 'vla-delete (list (car val))))
                                                                     );end lambda
                                                                    (list (get_tile "TDr")(get_tile "LDr"))
                                                                    (list Top Low)
                                                            );end mapcar
                                                            (setq Slp nil)
                                                            (done_dialog)
                                                     );end progn
                                );end vl-prin1-to-string
             );end action_tile
             (start_dialog)
          );end
    );end cond
    (if dID (unload_dialog dID))
    (if Dcl (vl-file-delete Dcl))
    Slp
  );end defun

;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;;
;;; Weiter mit L-Boeschung
  (vl-load-com)
  (while (= 8 (logand 8 (getvar 'UNDOCTL)))(vla-endUndoMark (vla-get-ActiveDocument (vlax-get-acad-object))))
  (vla-startUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
  (cond ((or (not (car (setq ObL (list (CrvS nil)))))(not (cadr (setq ObL (append ObL (list (CrvS (caar Obl))))))))
           (if (cdar ObL)(vl-catch-all-apply 'vla-delete (list (caar ObL))))
           (prompt "\n'Böschungs-Tool' (©ABBS/F.Bubendorf); Abbruch durch User.")
        );end
        ((car (mapcar 'SftT (mapcar 'car ObL)'(nil nil)(list (mapcar '- (setq Sft (car (mBBox (mapcar 'car ObL) nil))))(mapcar '-  Sft))))
           (LM:PopUp "LISP Meldung" "'Böschungs-Tool' (©ABBS/F.Bubendorf)\n\nMatrix-Versatz fehlgeschlagen!\nBerechnung nicht möglich." (+ 0 16 4096))
        );end
        ((not (setq ObLTmp ObL SftTmp Sft)))
        ((not (setq Slp (Dialog DflMlt DflSlp DflDst Dfl3dS (car ObL)(cadr ObL))))
           (mapcar '(lambda ( val )(if (not (vlax-erased-p val))(SftT val nil Sft)))(mapcar 'car ObL))
           (prompt "\n'Böschungs-Tool' (©ABBS/F.Bubendorf); Abbruch durch User.")
        );end
        (t (mapcar '(lambda ( val )(if (not (vlax-erased-p val))(SftT val nil Sft)))(mapcar 'car ObL))
           (setq Slp (mapcar '(lambda ( val )(setq val (SftT val nil Sft))(entmakex (list '(0 . "LINE")(cons 8 (cdr Slp))(cons 10 (car val))(cons 11 (cadr val)))))
                             (car Slp)
                     );end mapcar
           );end setq
           (cond ((not (and (setq Dic (vla-GetExtensionDictionary (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))))
                            (setq Slp (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbObject (cons 0 (1- (length Slp))))
                                                                              (mapcar 'vlax-ename->vla-object Slp)
                                                         );end vlax-safearray-fill
                                      );end vlax-make-variant
                            );end setq
                       );end and
                  );end not
                 );end
                 ((and (vl-catch-all-error-p (setq Tbl (vl-catch-all-apply 'vla-GetObject (list Dic "ACAD_SORTENTS"))))
                       (vl-catch-all-error-p (setq Tbl (vl-catch-all-apply 'vla-AddObject (list Dic "ACAD_SORTENTS" "AcDbSortentsTable"))))
                  );end and
                 );end
                 ((vl-catch-all-apply 'vla-getFullDrawOrder (list Tbl 'Dic :vlax-false)))
                 ((or (member (caar ObL)(setq Dic (reverse (vlax-safearray->list Dic))))(member (caadr ObL) Dic))
                    (vla-MoveBelow Tbl Slp (if (> (vl-position (caar ObL) Dic)(vl-position (caadr ObL) Dic))(caar ObL)(caadr ObL)))
                    (vla-update (vlax-get-acad-object))
                 );end
           );end cond
        );end
  );end cond
  (while (= 8 (logand 8 (getvar 'UNDOCTL)))(vla-endUndoMark (vla-get-ActiveDocument (vlax-get-acad-object))))
  (princ)
);end defun

;;; --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --=={ ABBS }==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- ;;;