;|
*******************************************************************
*                                                                 *
* Wir sind das "Express-Tools 2 German Project"                   *
* Nachfolgend nur noch abgekürzt durch "ET2GP" !                  *
* --------------------------------------------------------------- *
* Die Beteiligten in alphabetischer Reihenfolge:                  *
*                                                                 *
* Vorname, Name         E-Mail-Adresse          Website           *
* --------------------------------------------------------------- *
* Holger Brischke       kontakt@defun.de        www.defun.de      *
* Martin Drese          drese@defun.de          keine Website     *
* Markus Hoffmann       hoffmann@defun.de       keine Website     *
* Marc Scherer          marc.scherer@zvo.com    keine Website     *
* Peter Tropf           info@petertropf.de      keine Website     *
*                                                                 *
*******************************************************************

***ET2GP-Anpassung*** -> Kommentar
Diese Übersetzung der Express-Tools für AutoCAD 2006 basiert auf den
originalen, mit AutoCAD 2006 gelieferten Express-Tools von Autodesk.
Da nicht jeder deutsch-sprachige User von AutoCAD des Englischen
mächtig ist, haben wir diese Übersetzung vorgenommen.

Änderungen an den Originaltexten sind immer mit einem einleitenden
Kommentar versehen, wobei die Steuerzeichen für Kommentare je nach
Dateiart variieren:

Eine Änderung an einer Lisp-Datei ist folgendermaßen markiert:

;;; ***ET2GP-Anpassung*** ...

Bei einem DCL-File dann so:

/// ***ET2GP-Anpassung*** ...

Originalzeilen bleiben soweit wie möglich erhalten, werden jedoch durch
ein "Auskommentieren" deaktiviert.

Anderweitige Modifikationen, wie z.B. komplett neue Zeilen oder permanent 
deaktivierte Funktionen sind mit einem erklärendem Kommentar versehen.

Beispiel:
...
;;; ***ET2GP-Anpassung*** -> Dialog übersetzt...
         ;_ (prompt "\nSelect object(s) on the layer(s) to be isolated: ")
         (prompt "\nObjekt(e) auf zu isolierenden Layern wählen: ")
...

Jede angepasste Datei wird mit diesem Header vorneweg versehen, wobei die
nachfolgenden Zeilen bezüglich der Informationen (wie z.B. Name des Übersetzers)
natürlich variabel sind.

***ET2GP-Anpassung*** -> Kommentar
Version 1.0
17.06.2005
Holger Brischke
Marc Scherer
|;
;;;
;;;    CLIPIT.LSP
;;;    Copyright © 1999 by Autodesk, Inc.
;;;
;;;    Your use of this software is governed by the terms and conditions of the
;;;    License Agreement you accepted prior to installation of this software.
;;;    Please note that pursuant to the License Agreement for this software,
;;;    "[c]opying of this computer program or its documentation except as
;;;    permitted by this License is copyright infringement under the laws of
;;;    your country.  If you copy this computer program without permission of
;;;    Autodesk, you are violating the law."
;;;
;;;    AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.
;;;    AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF
;;;    MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE.  AUTODESK, INC.
;;;    DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
;;;    UNINTERRUPTED OR ERROR FREE.
;;;
;;;    Use, duplication, or disclosure by the U.S. Government is subject to
;;;    restrictions set forth in FAR 52.227-19 (Commercial Computer
;;;    Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)
;;;    (Rights in Technical Data and Computer Software), as applicable.
;;;
;;;  ----------------------------------------------------------------
 
(defun c:clipit ( / na na2 e1 e2 a lst zflag redraw_it glst vplocked vpna )
 
(acet-error-init (list
                   (list   "cmdecho" 0
                         "highlight" 0
                         "regenmode" 1
                            "osmode" 0
                         "orthomode" 0
                         "ucsfollow" 0
                          "limcheck" 0
                          "plinewid" 0
                   )
                   T     ;flag. True means use undo for error clean up.
                  '(while redraw_it
                     (redraw (car redraw_it) 4)
                     (setq redraw_it (cdr redraw_it))
                   )
                  );list
);acet-error-init
 
(setq glst (bns_groups_unsel));setq
 
(princ
  ;;; ***ET2GP-Anpassung*** -> Info übersetzt
  ;"\nPick a POLYLINE, CIRCLE, ARC, ELLIPSE, or TEXT object for clipping edge..."
  "\nWählen Sie ein Objekt vom Typ POLYLINIE, KREIS, BOGEN, ELLIPSE oder TEXT als Grenze ..."
  )
(setq na (acet-ui-single-select '((-4 . "<OR")
                           (0 . "*POLYLINE")
                           (0 . "ARC")
                           (0 . "CIRCLE")
                           (0 . "ATTDEF")
                           (0 . "TEXT")
                           (0 . "MTEXT")
                           (0 . "ELLIPSE")
                           (0 . "SPLINE")
                           (0 . "3DFACE")
                           (0 . "SOLID")
                           (0 . "TRACE")
                          (-4 . "OR>")
                         )
                         T ;enable locked layer selection for boundary
         );acet-ui-single-select
);setq
(if na
    (progn
 
     (setq e1 (entget na))
     (setq redraw_it (list na))
     (redraw na 3)
     (princ
       ;;; ***ET2GP-Anpassung*** -> Info übersetzt
       ;"\nPick an IMAGE, a WIPEOUT, or an XREF/BLOCK to clip... "
       "\nWählen Sie ein BILD, ein WIPEOUT, ein XREF oder einen BLOCK zum Beschneiden... "
       )
     (setq na2 (acet-ui-single-select '((-4 . "<OR")
                                (0 . "IMAGE")
                                (0 . "INSERT")
                                (0 . "WIPEOUT")
                                (-4 . "OR>")
                               )
                               nil ;dis-allow locked layer selection for object to be clipped
               );acet-ui-single-select
     );setq
     (setq redraw_it nil)
     (redraw na 4)
  (if na2
      (progn
       (setq e2 (entget na2))
       (setvar "cmdecho" 0)
       (setvar "highlight" 1)
       (command "_.select" na na2)
 
       (setq a (get_clipitres))
       (command "")
 
       (entupd na)
       (setq lst (acet-geom-object-point-list na a))
       (if (or (not (equal "INSERT" (acet-dxf 0 e2)))
               (not (acet-geom-self-intersect lst nil))
           );or
           (progn
            (if (equal (car lst) (last lst) 0.001)
                (setq lst (cdr lst))
            );if
            (if (or (equal "INSERT" (acet-dxf 0 e2))
                    (equal "IMAGE"  (acet-dxf 0 e2))
                );or
                (progn
                 (if (setq vpna (acet-currentviewport-ename))
                     (setq vplocked (acet-viewport-lock-set vpna nil))
                 );if
                 (if (setq zflag (acet-geom-zoom-for-select lst))
                     (command "_.zoom" "_w" (car zflag) (cadr zflag))
                 );if
                 (c_clipit na2 lst)
                 (if zflag (command "_.zoom" "_p"))
                 (if vplocked
                     (acet-viewport-lock-set vpna T) ;relock the viewport
                 );if
                );progn then
                (wipeout_clipit na2 lst)
            );if
           );progn then valid boundary selected
           (princ
             ;;; ***ET2GP-Anpassung*** -> Info übersetzt
             ;"\nInvalid. Bounding entity cannot self intersect for xclip."
             "\nUngültig! Grenzobjekt darf sich nicht mit sich selbst schneiden."
             )
       );if
      );progn then got na2
  );if
   );progn then got na
);if
 
(bns_groups_sel glst)
(acet-error-restore)
(princ)
);defun c:clipit
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun get_clipitres ( / a n)
 
(if (not #clipitres)
    (progn
     (setq #clipitres 0.0);setq
     (setq n 0)
     (while (equal #clipitres 0.0)
      (setq #clipitres (acet-geom-pixel-unit)
            #clipitres (rtos #clipitres 2
                             (+ (fix (/ (getvar "luprec") 2.0)) n)
                       )
            #clipitres (atof #clipitres)
      );setq
      (setq n (+ n 1));setq
     );while
    );progn then
);if
(initget 2)
(setq  a (getdist
           (acet-str-format
             ;;; ***ET2GP-Anpassung*** -> Info übersetzt
             ;"\nEnter maximum allowable error distance for resolution of arc segments <%1>: "
             "\nErlaubte Fehlertoleranz beim Auflösen von Bogensegmenten eingeben <%1>: "
             (rtos #clipitres))
         );getdist
);setq
(if (not a)
    (setq a #clipitres)
    (setq #clipitres a)
);if
 
#clipitres
);defun get_clipitres
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c_clipit ( na lst / e1 n lst2 lst3 res)
 
 
(setq lst (plist_optimize lst));setq
 
 
(if (equal 'PICKSET (type na))
    (setq e1 (entget (ssname na 0)));setq then it's a selection set
    (setq e1 (entget na));setq else
);if
(if (equal "IMAGE" (cdr (assoc 0 e1)))
    (progn
 
     (setq lst2 (acet-geom-image-bounds na)
           lst3 (pre_proccess_boundary lst lst2)
     );setq
 
 
     (setq n 0);setq
     (repeat (length lst3)
     (setq lst (nth n lst3))
 
 
     (setq res (c_clipit_sub na lst))
     (command "_.copy" na "" "0,0,0" "0,0,0")
     (setq na (entlast))
     (setq n (+ n 1));setq
     );repeat
     (entdel na)
    );progn
    (setq res (c_clipit_sub na lst))
);if
 
res
);defun c_clipit
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c_clipit_sub ( na lst / e1 lst2 a n )
 
;(setvar "cecolor" "1")
;(pline (list lst))
;(if (equal (type na) (type (entlast)))
;    (ss_visible (ssadd na (ssadd)) 0)
;    (ss_visible na 0)
;);if
;(if (equal "" (getstring "hey"))
;    (entdel (entlast))
;);if
 
 (if (equal 'PICKSET (type na))
     (setq e1 (entget (ssname na 0)));setq then it's a selection set
     (setq e1 (entget na));setq else
 );if
 (if (equal "INSERT" (cdr (assoc 0 e1)))
     (progn
      (command "_.xclip" na "" "_n")
      (if (and (setq e1 (member '(102 . "{ACAD_XDICTIONARY") e1))
               (setq e1 (cdr e1))
               (setq na (cdr (assoc 360 e1)))
               (setq e1 (entget na))
               (assoc 360 (member '(3 . "ACAD_FILTER") e1))
          );and
          (command "_y") ;delete previous clipping boundary
      );if
     );progn then
     (progn
      (setq lst2 (acet-geom-image-bounds na)
            ;lst3 (pre_proccess_boundary lst lst2) ;12:34 PM 8/18/97
      );setq
      (setq  ;lst lst3 ;12:34 PM 8/18/97
            lst2 nil
            ;lst3 nil
      );setq
      (command "_.imageclip" na "_n")
      (if (equal 1 (cdr (assoc 280 e1)))
          (command "_y")
      );if
     );progn else
 );if
 (command "_p")
 (setq n 0);setq
 (repeat (length lst)
  (setq a (nth n lst))
  (if (and ;(not (member a lst2))
           (or (not lst2)
               (not (equal (nth n lst) (last lst2) 0.000001))
           );or
      );and
      (progn
       (command a)
       (setq lst2 (append lst2 (list a)))
      );progn
  );if
  (setq n (+ n 1));setq
 );repeat
 
 
 (if (< (length lst2) 3)
     (command nil) ;just cancel out
     (command "")
 );if
 
(>= (length lst2) 3);return success or failure
);defun c_clipit_sub
 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun pre_proccess_boundary ( lst lst2 / sp_inters a lst3 dst p1 p2 p3 p4
                                          n b side d c lst4 cnt lst5 lst6 j
                                          dx dy
                             )
 
 (defun sp_inters ( a b c d / x )
;(setvar "cecolor" "1")
;(command "_.line" a b "")
;(command "_.line" c d "")
 
  (if (setq x (inters a b c d))
      (setq x (list x))
  );if
 
;(print x)
;(getstring "whatup")
;(entdel (entlast))
;(entdel (entlast))
 
  x
 );defun sp_inters
 
(if (not (equal (car lst) (last lst) 0.0001))
    (setq lst (append lst (list (car lst))));setq then
);if
(setq    a (car lst)   ;The first point of the first segment to check
      lst3 (list a)    ;
       dst (list a)    ;dst will hold the max and min points of lst later
        p1 (nth 0 lst2);the rectang bounds
        p2 (nth 1 lst2)
        p3 (nth 2 lst2)
        p4 (nth 3 lst2)
);setq
(setq n 1);setq
(repeat (max 0 (- (length lst) 1))
(setq    b (nth n lst)
       dst (acet-clipit-list-extents (append dst (list b))) ;max and min points of lst
      side 0
);setq
 (setq d nil)
 (if (setq c (sp_inters a b p1 p2)) ;check the a-b segment against the boundary rectang
     (setq    d (append d c)
           side (+ side 1)
     );setq
 );if
 (if (setq c (sp_inters a b p2 p3))
     (setq    d (append d c)
           side (+ side 2)
     );setq
 );if
 (if (setq c (sp_inters a b p3 p4))
     (setq    d (append d c)
           side (+ side 4)
     );setq
 );if
 (if (setq c (sp_inters a b p4 p1))
     (setq    d (append d c)
           side (+ side 8)
     );setq
 );if
;(print c)
;(getstring "hey")
(if d
    (progn
     (if (> (length d) 1)
         (progn
     
          (if ;(equal (length d) 4) ;rk commented out and added line below 7:41 PM 8/27/97
              (> (length d) 2)
              (progn
               (setq d (list (car d) (caddr d)));setq
              );progn
          );if
          ;find the closest intersection and append that one first
          (if (< (distance (car d) a) (distance (cadr d) a))
              (setq lst3 (append lst3 d))
              (setq lst3 (append lst3 (reverse d)))
          );if
     
          ;lst3 (a list of the resulting boundary points)
          ;lst4 is a list of sublists. Each sub-list has the form: (index, flag, side)
          ;where index is an index to lst3
          ;and flag is 0 or 1 meaning enter and exit respectively.
          ;side is a bit coded value. The sum of the bits where:
          ; crossing segment 1 is bit 1
          ; crossing segment 2 is bit 2
          ; crossing segment 3 is bit 4
          ; crossing segment 4 is bit 8
          (if (and
                (or
                    (not (in_bounds a lst2))
                    (equal a (car d) 0.0001)
                    (equal a (cadr d) 0.0001)
                );or
                (not (equal 0 (cadr (last lst4))))
              );and
              (setq lst4 (append lst4
                                 (list (list (- (length lst3) 2)
                                             0                    ;enter
                                             side                 ;
                                       );list
                                 );list
                         );append
              );setq
          );if
          (if (and (not (in_bounds b lst2))
                   (not (equal 1 (cadr (last lst4))))
              );and
              (setq lst4 (append lst4
                                 (list (list (- (length lst3) 1)
                                             1                  ;exit
                                             side
                                       );list
                                 );list
                         );append
              );setq
          );if
         );progn then passing through the rectang bounds with segment a-b
         (progn
          (setq d (car d));setq
        
          (setq lst3 (append lst3 (list d)));setq
          (if (and (in_bounds b lst2)
                   (or
                       (not (in_bounds a lst2))
                       (equal a d 0.0001)
                   );or
                   (not (equal 0 (cadr (last lst4))))
              );and
              (progn
               ;(print "enter")
               (setq lst4 (append lst4
                                  (list (list (- (length lst3) 1)
                                              0           ;entering
                                              side
                                        );list
                                  );list
                          );append
               );setq
              );progn then entering
              (progn
               (if (and (in_bounds a lst2)
                        (not (in_bounds b lst2))
                        (not (equal 1 (cadr (last lst4))))
                   );and
                   (progn
                    ;(print "exit")
                    (setq lst4 (append lst4
                                       (list (list (- (length lst3) 1)
                                                   1                 ;exiting
                                                   side
                                             );list
                                       );list
                               );append
                    );setq
                   );progn then exiting
               );if
              );progn else possibly exiting
          );if
         );progn else
     );if
    );progn then we are entering or exiting the rectang boundary
);if
;(print b)
;(getstring "yo")
(if (not (equal b (last lst3) 0.0001))
    (setq lst3 (append lst3 (list b)));setq
);if
 
(setq a b)
(setq n (+ n 1));setq
);repeat
 
;(print lst3)
;(print lst4)
;(getstring "heydude")
 
(setq dst (* 2.0 (distance (car dst) (cadr dst))));setq
(if lst4
    (progn ;then possibly need to add corners of image to clip boundary loop
 
     (if (not (equal 1 (cadr (car lst4))))
         (setq lst4 (append (cdr lst4) (list (car lst4))));setq
     );if
     (if (not (equal (length lst4) (* 2 (/ (length lst4) 2)))) ;odd number of exits/entries
         (progn
          (setq lst4 (reverse (cdr (reverse lst4))));setq
         );progn then remove the last one.
     );if
 
     (setq n 0)
     (repeat (/ (length lst4) 2)
     (setq   b (nth n lst4)
             c (nth (+ n 1) lst4)
           cnt (length lst5)
     );setq
     (setq lst5 (append lst5
                        (add_corners (car b) (car c) lst3 lst2)
                );append
     );setq
 
     (while (< (+ cnt 1) (length lst5))
      (setq lst6 (append lst6
                         (list cnt);list
                 );append
      );setq
     (setq cnt (+ cnt 1))
     );while save a list of index's to lst5 to use for boundary overlap checking later.
 
     (setq j (car c));setq
     (if (equal (+ n 2) (length lst4))
         (setq c (car lst4))
         (setq c (nth (+ n 2) lst4));setq
     );if
     (while (/= j (car c))
      (if (not (equal (last lst5) (nth j lst3) 0.0001))
          (setq lst5 (append lst5 (list (nth j lst3))));setq
      );if
      (setq j (+ j 1));setq
      (if (equal j (length lst3)) (setq j 0))
     );while
 
     (setq n (+ n 2));setq
     );repeat
    );progn then lst4
);if
 
;(print lst5)
(if lst5
    (progn
;(getstring "1")
     (setq dx 0.0
           dy 0.0
     );setq
     (setq n 0)
     (while (and (< (+ n 1) (length lst5))  ;make sure lst5 has non-zero extents
                 (or (equal dx 0.0 0.00001)
                     (equal dy 0.0 0.00001)
                 );or
            );and
     (setq dx (+ (abs (- (car (nth (+ n 1) lst5))
                         (car (nth n lst5))
                      );minus
                 );abs
                 dx
              );plus
           dy (+ (abs (- (cadr (nth (+ n 1) lst5))
                         (cadr (nth n lst5))
                      );minus
                 );abs
                 dy
              );plus
     );setq
     (setq n (+ n 1))
     );while
     (if (or (equal dx 0.0 0.00001)
             (equal dy 0.0 0.00001)
         );or
         (setq lst3 nil
               lst5 nil
         );setq
         (progn
          (setq lst3 lst5
                lst5 nil
          );setq
          (if (and lst3
                   lst6
              );and
              (progn
               (setq lst3 (split_at_pinch2 lst3 lst6))
              );progn
              (progn
               (if lst3
                   (setq lst3 (list lst3));setq
               );if
              );progn then
          );if
         );progn else lst5 has non-zero extents
     );if
 
    );progn
    (progn
;(getstring "2")
     (if (not (in_bounds (car lst3) lst2))
         (progn
          (if (or (acet-geom-point-inside (nth 0 lst2) lst3 dst)
                  (acet-geom-point-inside (nth 1 lst2) lst3 dst)
                  (acet-geom-point-inside (nth 2 lst2) lst3 dst)
                  (acet-geom-point-inside (nth 3 lst2) lst3 dst)
              );or
              (setq lst3 lst2);then clip boundary totally encloses the image bounds
                              ;so use image_bounds as clip boundary
              (setq lst3 nil);else clip boundary has no overlap with image so return nil
          );if
         );progn then clip boundary is not within the image_bounds
     );if
     (if lst3
         (setq lst3 (list lst3));setq
     );if
    );progn else either totally inside or totally outside with no intersections
);if
 
 
lst3
);defun pre_proccess_boundary
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun split_at_pinch2 ( lst lst2 / n k a b x1 flag j m c d x2 x3 lst3 lst4 lst5
                       )
 
(setq n 0)
(repeat (max (- (length lst2) 1) 0)
(setq    k (nth n lst2)
         a (nth k lst)
         b (nth (+ k 1) lst)
        x1 (acet-clipit-list-extents (list a b))
);setq
 (setq flag nil)
 (setq j (+ n 1))
 (while (and (not flag)
             (< j (length lst2))
        );and
 (setq m (nth j lst2)
       c (nth m lst)
       d (nth (+ m 1) lst)
      x2 (acet-clipit-list-extents (list c d))
      x3 (acet-clipit-list-extents (append x1 x2))
 );setq
 (if (and (or (and (equal (car x3) (car x1) 0.0001)
                   (equal (cadr x3) (cadr x1) 0.0001)
              );and
              (and (equal (car x3) (car x2) 0.0001)
                   (equal (cadr x3) (cadr x2) 0.0001)
              );and
          );or
          (equal 0.0 (acet-geom-vector-side c a b))
          (equal 0.0 (acet-geom-vector-side d a b))
     );and
     (setq lst3 (append lst3
                        (list (list k m))
                );append
     );setq then
 );if
 (setq j (+ j 1));setq
 );while
 
(setq n (+ n 1));setq
);repeat
 
(setq n 0);setq
(repeat (max 0 (- (length lst3) 1))
(setq a (nth n lst3)
      b (cadr a)
      a (car a)
      c (nth (+ n 1) lst3)
      d (cadr c)
      c (car c)
);setq
(setq lst4 (append lst4
                   (list (list (+ a 1)
                               (if (not (equal (min b c) a))
                                   (min b c)
                                   b
                               );if
                         );list
                   );list
           );append
);setq
(setq n (+ n 1));setq
);repeat
(if lst3
    (progn
     (setq a (nth n lst3)
           b (cadr a)
           a (car a)
           c (car lst3)
           d (cadr c)
           c (car c)
     );setq
     (setq lst4 (append lst4
                        (list (list (max (+ a 1)
                                         (if lst4
                                             (+ (cadr (last lst4)) 1)
                                             0
                                         );if
                                    );max
                                    b
                              );list
                        );list
                        (list (list (+ b 1)
                                    c
                              );list
                        );list
                );append
     );setq
    );progn then
);if
 
(if (and lst3 lst4)
    (progn
     (setq n 0)
     (repeat (length lst4)
     (setq a (nth n lst4)
           j (car a)
     );setq
     (setq lst3 nil)
     (while (not (equal j (cadr a)))
      (setq lst3 (append lst3 (list (nth j lst))));setq
     (setq j (+ j 1))
     (if (= j (length lst))
         (setq j 0)
     );if
     );while
     (setq lst3 (append lst3 (list (nth j lst))));setq
     (if (> (length lst3) 2)
         (progn
          (if (> (length lst3) 3)
              (progn
               (if (not (equal (car lst3) (last lst3)))
                   (setq lst3 (append lst3 (list (car lst3))));setq
               );if
               (setq lst3 (split_at_pinch2 lst3    ;a little recursion excursion.
                                           (list 0 (- (length lst3) 2))
                          );split_at_pinch2
               );setq
              );progn then
              (setq lst3 (list lst3))
          );if
          (setq lst5 (append lst5 lst3));setq
          ;(setq lst5 (append lst5 (list lst3)));setq
 
         );progn
     );if
     (setq n (+ n 1));setq
     );repeat
     (if lst5
         (setq lst lst5)
         (setq lst (list lst))
     );if
    );progn then
    (setq lst (list lst));setq else
);if
 
lst
);defun split_at_pinch2
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun add_corners ( nn jj lst3 lst2 / mxmn len n a b lst lst4
                                       ;func flag flag2 mxmn len lst lst4
                                       ;n a b d1 d2 d3 d4
                   )
 
 
(setq mxmn (list (nth nn lst3))
       len (length lst3)
);setq
 
(setq n nn)
(while (not (equal n jj));build a list that's a loop of points from exit to entry point
(setq    a (nth n lst3)
      mxmn (acet-clipit-list-extents (append (list a) mxmn))
);setq
(if (not (equal a (last lst) 0.0001))
    (setq lst (append lst (list a)));setq
);if
(setq n (+ n 1))
(if (= n len) (setq n 0));if
);while
(setq    a (nth n lst3)
      mxmn (acet-clipit-list-extents (append (list a) mxmn))
       lst (append lst (list a))
);setq
 
(setq mxmn (* 4.0 (distance (car mxmn) (cadr mxmn)))
         b mxmn
);setq
(if (not (equal (car lst) (last lst) 0.0001)) ;make sure the loop is fully closed
    (setq lst (append lst (list (car lst))));setq then
);if
(setq lst2 (cdr lst2))
(setq n 0)
(repeat (length lst2)
(setq a (nth n lst2))
(if (not (acet-geom-point-inside a lst mxmn))
    (setq a nil)
);if
(setq lst4 (append lst4 (list a)))
(setq n (+ n 1));setq
);repeat
(setq b (list b (car lst4)))
(if (member nil lst4)
    (progn
     (while (car lst4)
      (setq lst4 (append (cdr lst4) (list (car lst4))))
     );while
     (while (and lst4
                 (not (car lst4))
            );and
      (setq lst4 (cdr lst4))
     );while
     (if (not (last lst4))
         (progn
          (setq lst4 (reverse lst4))
          (while (and lst4
                      (not (car lst4))
                 );and
           (setq lst4 (cdr lst4))
          );while
          (setq lst4 (reverse lst4))
         );progn
     );if
    );progn
    (progn
     (if (equal (length lst4) 4)
         (progn
          (while (not (equal 0
                             (acet-geom-vector-side (nth nn lst3) (car lst4) (last lst4))
                 )    )
           (setq lst4 (append (cdr lst4) (list (car lst4))));setq
          );while
         );progn
     );if
    );progn
);if
 
(if lst4
    (progn
     (if (< (distance (nth nn lst3) (last lst4))
            (distance (nth nn lst3) (car lst4))
         )
         (setq lst4 (reverse lst4))
     );if
     (if (and (< (distance (nth jj lst3) (car lst4))
                 (distance (nth nn lst3) (car lst4))
              )
              (< (distance (nth jj lst3) (car lst4))
                 (distance (nth jj lst3) (last lst4))
              )
         );and
         (setq lst4 (reverse lst4))
     );if
    );progn then
);if
(if (not (equal (nth nn lst3) (car lst4) 0.0001))
    (setq lst4 (append (list (nth nn lst3))
                       lst4
               );append
    );setq
);if
(if (not (equal (nth jj lst3) (last lst4) 0.0001))
    (setq lst4 (append lst4
                       (list (nth jj lst3))
               );append
    );setq
);if
 
lst4
);defun add_corners
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun in_bounds ( p1 lst / a b c)
 (setq b (car lst)
       b (list (car b) (cadr b))
       c (caddr lst)
       c (list (car c) (cadr c))
       a (angle b (cadr lst))
 );setq
 (if (< a 0) (setq a (+ a (* 2.0 pi))))
 (setq  a (* -1.0 a)
        c (acet-geom-point-rotate c b a)
       p1 (acet-geom-point-rotate p1 b a)
      lst (acet-clipit-list-extents (list b c p1))
 );setq
 (and (equal (car lst) b 0.000001)
      (equal (cadr lst) c 0.000001)
 );and
);defun in_bounds
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun wipeout_clipit ( na lst / na2 la n a)
(if na
    (entdel na)
);if
(if (setq la (acet-layer-locked (getvar "clayer")))
    (command "_.layer" "_un" (getvar "clayer") "")
);if
 
(command "_.pline")
(setq n 0)
(repeat (length lst)
(setq a (nth n lst));setq
(command a)
(setq n (+ n 1));setq
);repeat
(command "")

(setq na2 (entlast))
(command "_.pedit" na2 "_cl" "_x")
;;; ***ET2GP-Anpassung*** -> An neuen 2004-Dialog angepasst
;;;  (command "_.wipeout" "_n" na2 "_y")
(command "_.wipeout" "_p" na2 "_y")
(if la
    (command "_.layer" "_lock" (getvar "clayer") "")
);if
);defun wipeout_clipit
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;take a list of point ans removes duplicated points and unneeded points
;as a result of no angle change.
(defun plist_optimize ( lst / n a b c d lst2)
 
(if (not (equal (car lst) (last lst) 0.00001))
    (setq lst (append lst (list (car lst))));setq then
);if
(setq n 0)
(repeat (max 0
             (- (length lst) 1)
        )
(setq a (nth n lst)
      b (nth (+ n 1) lst)
);setq
(if (equal n 0)
    (setq lst2 (list a b))
);if
(setq c (nth (max (- (length lst2) 2) 0) lst2)
      d (last lst2)
);setq
 (if (equal (angle a b)
            (angle c d)
            0.000001
     );equal
     (setq lst2 (reverse (cdr (reverse lst2))));setq
 );if
 (if (not (equal b (last lst2)))
     (setq lst2 (append lst2 (list b)));setq
 );if
(setq n (+ n 1));setq
);repeat
(if (and (>= (length lst2) 4)
         (equal (angle (car lst2) (cadr lst2))
                (angle (nth (- (length lst2) 2) lst2) (last lst2))
                0.000001
         );equal
    );and
    (setq lst2 (cdr lst2)
          lst2 (reverse (cdr (reverse lst2)))
    );setq
);if
 
lst2
);defun plist_optimize
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun acet-clipit-list-extents ( lst / a b )
  (setq lst (acet-geom-list-extents lst)
          a (car  lst)
          b (cadr lst)
  )
  (list (list (car a) (cadr a))
        (list (car b) (cadr b))
  );list
);defun acet-clipit-list-extents


(princ)