LISP. Отрисовка внешнего контура выбранных объектов (Страница 2 из 2)

;;;------------------------TSP------------------------------------------------------------;;;
;;;---------------------------------------------------------------------------------------;;;
(defun c:test (/ foo f2 ptl lst l n i d0 l0 l1 d1)
  ;;by GSLS(SS)
  ;;refer ElpanovEvgeniy's method from  http://www.theswamp.org/index.php?topic=30434.75
  ;;2012-8-10
  (defun foo (l / D D0 D1)
    (setq l0 (mapcar (function list) (cons (last l) l) l)) ;_  setq
 ;_  defun
    (setq d0 (get-closedpolygon-length l))
    (while
      (> d0
     (progn
       (foreach a l0
         (setq d (get-closedpolygon-length l))
         (setq l1 (vl-remove (car a) (vl-remove (cadr a) l)))
         (setq l1 (f1 (car a) l1))
         (setq l1 (f1 (cadr a) l1))
         (if (> d
            (setq d1 (get-closedpolygon-length l1))
         )
           (setq d d1
             l l1
           ) ;_  setq
         ) ;_  if
         (setq l1 (vl-remove (car a) (vl-remove (cadr a) l)))
         (setq l1 (f1 (cadr a) l1))
         (setq l1 (f1 (car a) l1))
         (if (> d
            (setq d1 (get-closedpolygon-length l1))
         )
           (setq d d1
             l l1
           )
         )
       )
       d
     ) ;_  progn
      ) ;_  <
       (setq d0 d)
    ) ;_  while    
    (setq d (get-closedpolygon-length l))    
    l
  )
  (defun f1 (a l)
    (ins-lst a (get-closest-i l a) l)
  )
  (defun f2 (lst)
    (mapcar (function (lambda (p0 p p1 / a)
            (setq a (- (angle p p0) (angle p p1)))
            (if (< a (- pi))
              (abs (+ a pi pi))
              (if (> a pi)
                (abs (- a pi pi))
                (abs a)
              )
            )
              )
        )
        (cons (last lst) lst)
        lst
        (reverse (cons (car lst) (reverse (cdr lst))))
    )
  )
  (setq    ptl (my-getpt)
    ptl (mapcar (function (lambda (p) (list (car p) (cadr p)))) ptl)
  )
  (setq t1 (getvar "MilliSecs"))
  (setq lst (Graham-scan ptl))
  (foreach a lst
    (setq ptl (vl-remove a ptl))
  )
  (while (and (> (length ptl) 2) (setq l (Graham-scan ptl)))
    (foreach p l
      (setq ptl (vl-remove p ptl))
      (setq n (get-minadddist-i lst p))
      (setq lst (ins-lst p n lst))
    )
  )
  (if ptl
    (foreach p ptl
      (setq n (get-minadddist-i lst p))
      (setq lst (ins-lst p n lst))
    )
  )
  (setq lst (foo lst))
  (setq l (f2 lst))
  (setq    i  0
    l0 lst
    n  (length lst)
    d0 (get-closedpolygon-length lst)
  )
  (foreach a l
    (if    (and (< a _pi3) (= (setq p (nth i lst)) (nth i l0)))
      (progn
    (if (= i 0)
      (setq p0 (last lst))
      (setq p0 (nth (1- i) lst))
    )
    (if (= i (1- n))
      (setq p1 (car lst))
      (setq p1 (nth (1+ i) lst))
    )
    (setq m    (list (list p0 p1 p)
              (list p1 p p0)
              (list p1 p0 p)
              (list p p0 p1)
              (list p p1 p0)
        )
    )
    (setq l1
           (car (vl-sort (mapcar (function (lambda (x)
                         (ch-para-lst x i lst)
                           )
                     )
                     m
                 )
                 (function (lambda (e1 e2)
                     (< (get-closedpolygon-length e1)
                        (get-closedpolygon-length e2)
                     )
                       )
                 )
            )
           )
    )
    (setq d1 (get-closedpolygon-length l1))
    (if (< d1 d0)
      (setq    d0  d1
        lst l1
      )
    )
      )
    )
    (setq i (1+ i))
  )
  (setq l (f2 lst))
  (setq    i  0
    l0 lst
    d0 (get-closedpolygon-length lst)
  )
  (foreach a l
    (if    (and (< a _pi2) (setq p (nth i l0)))
      (progn
    (setq l1 (f1 p (vl-remove p lst)))
    (setq d1 (get-closedpolygon-length l1))
    (if (< d1 d0)
      (setq    d0  d1
        lst l1
      )
    )
      )
    )
    (setq i (1+ i))
  )
  (entmake
    (append (list '(0 . "LWPOLYLINE")
          '(100 . "AcDbEntity")
          '(8 . "temp")
          '(62 . 1)
          '(100 . "AcDbPolyline")
          (cons 90 (length lst))
          '(70 . 1)
        )
        (mapcar (function (lambda (p) (cons 10 p))) lst)
    )
  )
  (setq t2 (getvar "MilliSecs"))
  (princ (strcat "\nTSP Length :" (rtos d0 2 0) "."))
  (princ (strcat "\nUse Time :" (rtos (- t2 t1) 2 0) "ms."))
  (princ)
)
;;;Use Funtions
;;;--------------------------------------------------------------
;; Convex hull of pts , Graham scan method
;; by Highflybird
  (defun Graham-scan (ptl / hPs rPs PsY Pt0 sPs P Q)
    (if    (< (length ptl) 4)        ;3??? 
      ptl                ;???? 
      (progn
    (setq rPs (mapcar (function (lambda (x)
                      (if (= (length x) 3)
                    (cdr x)    x)))
              (mapcar 'reverse ptl));_???X?Y?? 
          PsY (mapcar 'cadr ptl) ;_???Y??? 
          Pt0 (reverse (assoc (apply 'min PsY) rPs)) ;_?????       
          sPs (sort-ad ptl Pt0) ;_????????? 
          hPs (list (caddr sPs) (cadr sPs) Pt0) ;_????? 
    )
    (foreach n (cdddr sPs)        ;??4??? 
      (setq    hPs (cons n hPs)    ;?Pi????? 
        P   (cadr hPs)        ;Pi-1 
        Q   (caddr hPs)        ;Pi-2 
      )
      (while (and q (> (det n P Q) -1e-6)) ;???? 
        (setq hPs (cons n (cddr hPs)) ;??Pi-1? 
          P   (cadr hPs)    ;????Pi-1? 
          Q   (caddr hPs)    ;????Pi-2? 
        )))
    hPs                ;???? 
      ))
  )
;;;?????????,??????????? 
(defun sort-ad (pl pt)
  (vl-sort pl
       (function (lambda (e1 e2 / an1 an2)
           (setq an1 (angle pt e1)
             an2 (angle pt e2))
           (if (equal an1 an2 1e-6);_??????,???????
         (< (distance pt e1) (distance pt e2))
         (< an1 an2)
           ))))
)
;;????????,??????? 
(defun det (p1 p2 p3)
  (- (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
     (* (- (car p3) (car p1)) (- (cadr p2) (cadr p1)))
  ))
;;;
;;;------------------------
(defun my-getpt    (/ ss i en l)
  (setq ss (ssget '((0 . "point,insert"))))
  (setq i -1)
  (while (setq en (ssname ss (setq i (1+ i))))
    (setq l (cons (cdr (assoc 10 (entget en))) l))
  )
)
;;;------------------------
;;;
;;(ins-lst 10 5 '(1 2 3 4 5))
;; i ?????????
(defun ins-lst (new i lst / len fst)
  (cond
    ((minusp i)
     lst
    )
    ((> i (setq len (length lst)))
     lst
    )
    ((> i (/ len 2))
     (reverse (ins-lst new (- len i) (reverse lst)))
    )
    (t
     (append
       (progn
     (setq fst nil)
     (repeat (rem i 4)
       (setq fst (cons (car lst) fst)
         lst (cdr lst)
       )
     )
     (repeat (/ i 4)
       (setq fst (cons (cadddr lst)
               (cons (caddr lst)
                 (cons
                   (cadr lst)
                   (cons
                     (car lst)
                     fst
                   )
                 )
               )
             )
         lst (cddddr lst)
       )
     )
     (reverse fst)
       )
       (list new)
       lst
     )
    )
  )
)
;;;------------------------
;;
;;(ch-para-lst '(7 8 9) 3 '(1 2 3 4 5))
(defun ch-para-lst (para i lst / len fst)
  (setq len (length lst))
  (cond
    ((minusp i)
     lst
    )
    ((> i (1- len))
     lst
    )
    ((= i 0)
     (cons (cadr para)
       (cons (caddr para)
         (reverse (cons (car para) (cdr (reverse (cddr lst)))))
       )
     )
    )
    ((= i (1- len))
     (reverse
       (append (cdr (reverse para))
           (cddr (reverse (cons (last para) (cdr lst))))
       )
     )
    )
    ((> i (/ len 2))
     (reverse
       (ch-para-lst (reverse para) (- len i 1) (reverse lst))
     )
    )
    (t
     (append
       (progn
     (setq fst nil)
     (repeat (rem i 4)
       (setq fst (cons (car lst) fst)
         lst (cdr lst)
       )
     )
     (repeat (/ i 4)
       (setq fst (cons (cadddr lst)
               (cons (caddr lst)
                 (cons
                   (cadr lst)
                   (cons
                     (car lst)
                     fst
                   )
                 )
               )
             )
         lst (cddddr lst)
       )
     )
     (reverse
       (cons (caddr para)
         (cons (cadr para) (cons (car para) (cdr fst)))
       )
     )
       )
       (cdr lst)
     )
    )
  )
)
;;;------------------------
;;
(defun get-minadddist-i    (lst p)
  (car
    (vl-sort-i
      (mapcar (function    (lambda    (p1 p2)
              (- (+ (distance p p1) (distance p p2))
                 (distance p1 p2)
              )
            )
          )
          (cons (last lst) lst)
          lst
      )
      '<
    )
  )
)
;;;------------------------
(defun get-closest-i (lst p)
  (car
    (vl-sort-i
      (mapcar
    (function
      (lambda (p1 p2 / pt d d1 d2)
        (setq pt (inters p
                 (polar p (+ (/ pi 2.) (angle p1 p2)) 1.)
                 p1
                 p2
                 nil
             )
          d  (distance p1 p2)
          d1 (distance p p1)
          d2 (distance p p2)
        )
        (if    pt
          (if (equal (+ (distance pt p1) (distance pt p2)) d 1e-8)
        (distance p pt)
        d2
          )
          1e99
        )
      )
    )
    (cons (last lst) lst)
    lst
      )
      '<
    )
  )
)
;;;------------------------
;;
(defun get-closedpolygon-length    (l)
  (apply (function +)
     (mapcar (function (lambda (p1 p2)
                 (distance p1 p2)
               )
         )
         (cons (last l) l)
         l
     )
  )
)