TheSwamp

Code Red => AutoLISP (Vanilla / Visual) => Topic started by: ElpanovEvgeniy on September 25, 2009, 09:22:35 AM

Title: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 25, 2009, 09:22:35 AM

Hello!
I wish to offer you the next competition.
It is given: the list of points
It is necessary: to draw lwpolyline passing through all points.

I think, it is necessary to pay attention on length lwpolyline.
Two lists of points are attached.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 25, 2009, 10:05:24 AM

Explanation

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: VovKa on September 25, 2009, 10:12:23 AM

seems that Evgeniy is trying to spoil other people's friday night :)

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 25, 2009, 10:14:34 AM

Quote from: VovKa on September 25, 2009, 10:12:23 AM

seems that Evgeniy is trying to spoil other people's friday night :)

On the native land of a forum, now morning!

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: CAB on September 25, 2009, 11:13:42 AM

Oh, The Traveling Salesman Problem.
Wish I had time today but a deadline calls.  :?

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 25, 2009, 11:39:16 AM

Well, I do not put deadline.

Enjoy the task! :)

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 25, 2009, 11:59:40 AM

I see, it is necessary to lay out a simple code, I am fast it I will make!
Any code, will be better...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 25, 2009, 12:15:55 PM

Code: [Select]

(defun make-lwpolyline(l / e)
 ;;(make-lwpolyline lst)
 (setq e (entmakex (append (list '(0 . "LWPOLYLINE")
                                 '(100 . "AcDbEntity")
                                 '(67 . 0)
                                 '(410 . "Model")
                                 '(8 . "Kant")
                                 '(62 . 3)
                                 '(100 . "AcDbPolyline")
                                 (cons 90 (length l))
                                 '(70 . 1)
                           ) ;_  list
                           (mapcar (function (lambda (a) (cons 10 a))) l)
                   ) ;_  append
         ) ;_  entmakex
 ) ;_  setq
 (Princ (strcat "\n length lwpolyline "
                (rtos (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) 2 4)
                " mm."
        ) ;_  strcat
 ) ;_  Princ
 (Princ)
) ;_  defun

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 25, 2009, 12:38:26 PM

The interesting approach, for the chaotic list, results is better than the starting list.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ronjonp on September 25, 2009, 12:41:12 PM

Here's mine:

Code: [Select]

(defun rjp-sortpt2pt (pt lst / tmp newlst)
  (defun dsort (pt lst / d1 d2)
    (vl-sort lst (function (lambda (d1 d2) (< (distance pt d1) (distance pt d2)))))
  )
  (setq tmp (dsort pt lst))
  (repeat (length lst)
    (setq tmp (dsort (car tmp) tmp)
 newlst (cons (car tmp) newlst)
 tmp (vl-remove (car tmp) tmp)
    )
  )
  (reverse newlst)
)
(make-lwpolyline (rjp-sortpt2pt (car lst-a) lst-a))
;;3908.169
(make-lwpolyline (rjp-sortpt2pt (car lst-b) lst-b))
;;3206.567

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Lee Mac on September 25, 2009, 12:46:30 PM

Nice one Ron,

I tried a different approach, but I think mine misses a few points  :oops:

Code: [Select]

(defun mkPoly (lst / rslt tmp lst ply)
 
  (setq rslt (list (car lst)))
  (while (setq lst (cdr lst))
    (setq tmp (car rslt))
    (setq rslt
      (cons
        (car (vl-sort lst
               (function
                 (lambda (a b)
                   (< (distance tmp a)
                        (distance tmp b)))))) rslt)))

  (setq ply
    (entmakex
      (append (list (cons 0 "LWPOLYLINE")
                    (cons 100 "AcDbEntity")
                    (cons 100 "AcDbPolyline")
                    (cons 90 (length rslt))
                    (cons 70 1))
              (mapcar (function (lambda (x) (cons 10 x))) rslt))))

  (princ (strcat "\nPolyline Length: " (rtos (vlax-curve-getDistatParam ply
                                               (vlax-curve-getEndParam ply)) 2 4) " mm."))
  (princ))


Code: [Select]

lst-a  Polyline Length: 968.1675 mm.

lst-b Polyline Length: 1019.6264 mm.


Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 25, 2009, 12:48:34 PM

Hello Ron.
I liked your code!
My code, much more long...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: It's Alive! on September 25, 2009, 12:49:29 PM

heres mine ... am I even close?

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ronjonp on September 25, 2009, 12:49:58 PM

Quote from: ElpanovEvgeniy on September 25, 2009, 12:48:34 PM

Hello Ron.
I liked your code!
My code, much more long...

Thanks ElpanovEvgeniy  :oops:

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 25, 2009, 12:57:10 PM

Quote from: Daniel on September 25, 2009, 12:49:29 PM

heres mine ... am I even close?

Salesman should return!

ps. For the list lst-b the result will be nearby 2500 mm.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 25, 2009, 01:01:28 PM

> Daniel
Your program on arx!
It is a pity, I am not able to enjoy such code.
 But result good!

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Lee Mac on September 25, 2009, 01:02:24 PM

Got the same result as Ron, but maybe with quicker code  ^-^

Code: [Select]

(defun mkPoly (lst / qsort rslt x)

  (defun qsort (pt lst)
    (vl-sort lst
      (function (lambda (a b) (< (distance pt a) (distance pt b))))))

  (setq rslt (list (car lst)))
  (while (setq x (car (setq lst (qsort (car rslt) (cdr lst)))))
    (setq rslt (cons x rslt)))

  (make-lwpolyline rslt)
  (princ))


Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: VovKa on September 25, 2009, 01:02:54 PM

i vote for the long code.
i think we have to bruteforce it. thus making factorial of (length lst) iterations.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 25, 2009, 01:06:48 PM

Quote from: VovKa on September 25, 2009, 01:02:54 PM

i vote for the long code.
i think we have to bruteforce it. thus making factorial of (length lst) iterations.

 Bruteforce any of the offered lists, some years will occupy! :)
This method is not interesting

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: It's Alive! on September 25, 2009, 01:13:05 PM

I'm also getting the same result as Ron when I return the end point

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ronjonp on September 25, 2009, 01:22:12 PM

Quote from: Lee Mac on September 25, 2009, 01:02:24 PM

Got the same result as Ron, but maybe with quicker code  ^-^

Code: [Select]

(defun mkPoly (lst / qsort rslt x)

  (defun qsort (pt lst)
    (vl-sort lst
      (function (lambda (a b) (< (distance pt a) (distance pt b))))))

  (setq rslt (list (car lst)))
  (while (setq x (car (setq lst (qsort (car rslt) (cdr lst)))))
    (setq rslt (cons x rslt)))

  (make-lwpolyline rslt)
  (princ))


I like it Lee  :-) ...that's how I'd write it now. I wrote that function about 2 years ago for an in-house routine  :-o. It's funny how different the mind thinks after years of practice.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Lee Mac on September 25, 2009, 01:24:58 PM

Thanks Ron :-)

The penny suddenly dropped when I realised in my previous code that I was removing items in the list that I hadn't added to the result list - I was shortening the input list before it was sorted - bad idea...   :wink:

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 25, 2009, 01:38:15 PM

Here you will find different ideas concerning the task (http://en.wikipedia.org/wiki/Travelling_salesman_problem)

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: VovKa on September 25, 2009, 03:36:22 PM

Lee, this task is not as simple as it appears. Evgeniy is not up to thowing easy tasks :)
try your function on both list-b and (reverse lst-b)

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 26, 2009, 05:42:36 AM

Has come to give time the first help...
Each self-crossing, increases length of a contour!

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Lee Mac on September 26, 2009, 08:41:57 AM

Quote from: VovKa on September 25, 2009, 03:36:22 PM

Lee, this task is not as simple as it appears. Evgeniy is not up to thowing easy tasks :)
try your function on both list-b and (reverse lst-b)

Good spot Vovka -

this solves the inconsistency, but its still not the shortest...

Code: [Select]

(defun mkPoly (lst / qsort mPt rslt x)

  (defun qsort (pt lst)
    (vl-sort lst
      (function (lambda (a b) (< (distance pt a) (distance pt b))))))

  (setq lst (cons mPt (qsort (setq mPt (apply 'mapcar (cons 'min lst)))
                             (vl-remove mPt lst))))
 
  (setq rslt (list mPt))
  (while (setq x (car (setq lst (qsort (car rslt) (cdr lst)))))
    (setq rslt (cons x rslt)))

  (make-lwpolyline rslt)
  (princ))


Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Lee Mac on September 26, 2009, 09:48:41 AM

Looking at your link, I tried the inversion method - I don't get a better result though - if anything, worse...

Code: [Select]

(defun mkPoly (lst / x sect lst nlst e nlen end)

  (defun SubLst (lst i j / k)
    (setq k -1)
    (or j (setq j (length lst)))
    (vl-remove-if-not
      (function
        (lambda (x)
          (<= i (setq k (1+ k)) (+ i (1- j))))) lst))

  (setq x -1)

  (while (and (setq sect (SubLst lst (setq x (1+ x)) 4))
              (= 4 (length sect)))

    (setq nlst (append (if (zerop x) '( ) (SubLst lst 0 x))
                       (reverse sect)
                       (if (= (length lst) (+ x 4)) '( ) (SubLst lst (+ x 4) nil))))

    (setq e (make-lwpolyline nlst))
    (setq nLen (vlax-curve-getDistatParam e (vlax-curve-getEndParam e)))
    (entdel e)

    (if len
      (if (< nlen len)
        (setq len nlen lst nlst))
      (setq len nlen)))

  (setq e (make-lwpolyline lst))
  (Princ (strcat "\n length lwpolyline "
                (rtos (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) 2 4)" mm."))
  (princ))


Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 26, 2009, 10:02:21 AM

Hello Lee Mac.
I see, you very much liked the task.
I hope, you will receive a lot of pleasure from the topic decision.

For reception of the best results, I have written two programs - the first for the first list, the second for the second...

My way, laid through genetic algorithm.
At first, I ordered the list. After, I repeatedly improved it, using small shifts.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Lee Mac on September 26, 2009, 12:31:18 PM

I'm enjoying this task very much  :-)

Need one more column of points to make this efficient  :-(

Code: [Select]

(defun mkPoly (lst / on_line qsort lst mPt ePt lLst rLst rslt)

  (defun on_line (pt p1 p2)
    (or (equal (angle p1 pt) (angle p1 p2) 0.01)
        (equal (angle p1 pt) (+ pi (angle p1 p2)) 0.01)))

  (defun qsort (pt lst)
    (vl-sort lst
      (function (lambda (a b) (< (distance pt a) (distance pt b))))))

  (setq lst (qsort (setq mPt (apply 'mapcar (cons 'min lst)))
                   (vl-remove mPt lst)))
  
  (setq ePt
    (car
      (vl-sort
        (vl-sort lst
          (function
            (lambda (a b)
              (< (cadr a) (cadr b)))))
        (function
          (lambda (c d)
            (> (car c) (car d)))))))

  (mapcar
    (function
      (lambda (x)
        (if (on_line x mPt ePt)
          (setq lLst  (cons x lLst))
          (setq rlst  (cons x rlst))))) lst)
  (setq lLst (cons mPt (reverse lLst)) rLst (reverse rLst))
  
  (setq rslt (list (car rlst)))
  (while (setq x (car (setq rlst (qsort (car rslt) (cdr rlst)))))
    (setq rslt (cons x rslt)))

  (make-lwpolyline (append rslt llst))
  (princ))


Code: [Select]

length lwpolyline 3850.0010 mm.


Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 26, 2009, 12:40:07 PM

Quote from: Lee Mac on September 26, 2009, 12:31:18 PM

I'm enjoying this task very much  :-)

Need one more column of points to make this efficient  :-(

Excellent work Lee!
I have specially given odd quantity of points in rows and columns.
Otherwise, the decision will be trivial and discussion will be not about algorithm, and about speed or beauty.
Now, the guru and beginners are equal - the main thing algorithm, instead of knowledge lisp...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Lee Mac on September 26, 2009, 12:58:19 PM

Quote from: ElpanovEvgeniy on September 26, 2009, 12:40:07 PM

Excellent work Lee!
I have specially given odd quantity of points in rows and columns.
Otherwise, the decision will be trivial and discussion will be not about algorithm, and about speed or beauty.
Now, the guru and beginners are equal - the main thing algorithm, instead of knowledge lisp...

Good point, although it still seems that the lisp guru (you) has the best solution so far...  :-)

This is marginally better by the triangle inequality... :P

Code: [Select]

(defun mkPoly (lst / on_line qsort lst mPt MaPt ePt lLst rLst rslt bLst)

  (defun on_line (pt p1 p2)
    (or (equal (angle p1 pt) (angle p1 p2) 0.01)
        (equal (angle p1 pt) (+ pi (angle p1 p2)) 0.01)))

  (defun qsort (pt lst)
    (vl-sort lst
      (function (lambda (a b) (< (distance pt a) (distance pt b))))))

  (setq lst (qsort (setq mPt (apply 'mapcar (cons 'min lst)))
                   (vl-remove mPt lst)))
 
  (setq ePt
    (car
      (vl-sort
        (vl-sort lst
          (function (lambda (a b) (< (cadr a) (cadr b)))))
        (function (lambda (c d) (> (car c) (car d)))))))
  (setq MaPt (apply 'mapcar (cons 'max lst)))

  (mapcar
    (function
      (lambda (x)
        (cond (  (on_line x mPt ePt)
                 (setq lLst  (cons x lLst)))
              (  (on_line x ePt MaPt)
                 (setq bLst  (cons x bLst)))
              (t (setq rlst  (cons x rlst)))))) lst)
  (setq lLst (cons mPt (reverse lLst))
        bLst (vl-remove ePt (reverse bLst)) rLst (reverse rLst))
 
  (setq rslt (list (car rlst)))
  (while (setq x (car (setq rlst (qsort (car rslt) (cdr rlst)))))
    (setq rslt (cons x rslt)))

  (make-lwpolyline (append rslt llst bLst))
  (princ))


Code: [Select]

length lwpolyline 3826.5970 mm.

(http://www.theswamp.org/screens/leemac/ex2.png)

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Lee Mac on September 26, 2009, 01:14:11 PM

This seems pretty short for the second one  :evil:

Code: [Select]

(defun mkPoly (lst / av tLst bLst)

  (setq av (mapcar
             (function
               (lambda (x)
                 (/ (float x) (length lst))))
             (apply 'mapcar (cons '+ lst))))

  (mapcar
    (function
      (lambda (x)
        (cond (  (>= (cadr x) (cadr av))
                 (setq tLst (cons x tLst)))
              (t (setq bLst (cons x bLst)))))) lst)

  (setq tLst (vl-sort tLst (function (lambda (a b) (< (car a) (car b))))))
  (setq bLst (vl-sort bLst (function (lambda (a b) (> (car a) (car b))))))
             
  (make-lwpolyline (append tLst bLst)))


Code: [Select]

length lwpolyline 2897.1142 mm.


(http://www.theswamp.org/screens/leemac/ex3.png)

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: VovKa on September 26, 2009, 01:16:38 PM

Lee, test it on this

Code: [Select]

(setq lst '((2142.0 1310.52 0.0) (2096.3 1195.7 0.0) (2212.65 1191.2 0.0) (2097.43 1466.42 0.0) (2002.47 1474.35 0.0) (2123.32 1309.75 0.0)))
my bruteforce method gives the route of 821.9093 length

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Lee Mac on September 26, 2009, 01:24:35 PM

VovKa - I am not writing generic functions  :wink:

As Elpanov says, he wrote one for each list...

Quote

For reception of the best results, I have written two programs - the first for the first list, the second for the second...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: VovKa on September 26, 2009, 01:32:02 PM

Quote from: Lee Mac on September 26, 2009, 01:24:35 PM

VovKa - I am not writing generic functions  :wink:

As Elpanov says, he wrote one for each list...

aha, that clears the situation

i wonder how many lists does Evgeniy have :)

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 26, 2009, 01:32:21 PM

Yes, for each list, I generate in the different ways a primary loop which then I improve...

For the list lst-a I as and as well as you, originally use greedy algorithm. For the list lst-b I receive an initial loop, in another way.
The secrets, I will tell next week...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 26, 2009, 01:35:41 PM

Quote from: VovKa on September 26, 2009, 01:32:02 PM

i wonder how many lists does Evgeniy have :)

600 000 only for tests and checks of work of my program... :-)

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 28, 2009, 04:38:59 AM

Hello Lee Mac!
Now, I have studied your code and have studied algorithm for the list lst-a.
Your approach deserves a high estimation, but you wrote the program,
Only for this list! My program, can
To process any sequences and to delete crossings.
You tried to find consecutive numbers and columns, I to remove crossings.


Here an explanation:
We check all segments and we find crossing.

In figure, crossing bc and fg is visible
For removal of crossing, it is possible reverse for sequence cdef or ghab and association in a polyline.
It will turn out abfedcgh

For search and removal of crossings, I used sequence, as well as in your program

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Lee Mac on September 28, 2009, 05:09:40 AM

Ahh, I see... - thanks for the pointer Elpanov  :wink:

I tried to optimise for the specific lists a bit too much - hoping to get a generic algorithm... but your method is much better - similar to the "inversion method", but less random.

Thanks,

Lee

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 28, 2009, 06:30:53 AM

For the list lst-b I use other algorithm.
1. I create external - covering contour, for example a rectangular the repeating dimensional container.
2. I sort all points on the shortest distance up to an external contour.
3. Consistently, I find the segment nearest to a point and I add this point in the given segment.
4. I delete tops of an external contour.
5. Consistently, I delete a point from a contour and I check the nearest segment to the given point.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Lee Mac on September 28, 2009, 06:41:21 AM

Genius  :-)

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Lee Mac on September 28, 2009, 07:32:31 AM

I tried to emulate your method - only up to Step 4, so not quite as short as you:

Code: [Select]

(defun mkPoly (lst / mklw vlax-list->2D-point SubLst
                     miP maP tmp lst nlst par ptlst obj)
  (vl-load-com)

  (defun mklw (l / e)
    (entmakex (append (list (cons 0   "LWPOLYLINE")
                            (cons 100 "AcDbEntity")
                            (cons 100 "AcDbPolyline")
                            (cons 90 (length l))
                            (cons 70 1))
                      (mapcar (function (lambda (a) (cons 10 a))) l))))

  (defun vlax-list->2D-point (lst)
    (if lst
      (cons (list (car lst) (cadr lst))
            (vlax-list->2D-point (cddr lst)))))

  (defun SubLst (lst i j / k)
    (setq k -1)
    (or j (setq j (length lst)))
    (vl-remove-if-not
      (function
        (lambda (x)
          (<= i (setq k (1+ k)) (+ i (1- j))))) lst))

  (setq miP (apply 'mapcar (cons 'min lst)))
  (setq maP (apply 'mapcar (cons 'max lst)))

  (setq obj (vlax-ename->vla-object
              (mklw (list miP (list (car miP) (cadr maP)) maP (list (car maP) (cadr miP))))))

  (setq lst (vl-sort lst
              (function
                (lambda (a b) (< (distance (vlax-curve-getClosestPointto obj a) a)
                                 (distance (vlax-curve-getClosestPointto obj b) b))))))

  (setq nlst lst)
  (while (setq x (car nLst))
    (setq nLst (cdr nLst) par (fix (vlax-curve-getParamatPoint obj
                                     (vlax-curve-getClosestPointto obj x))))

    (setq ptlst (vlax-list->2D-point (vlax-get obj 'Coordinates)))

    (setq ptlst (append (SubLst ptlst 0 (1+ par)) (list x)
                        (SubLst ptlst   (1+ par) nil)))

    (vlax-put obj 'Coordinates (apply 'append ptlst)))

  (vlax-put obj 'Coordinates (apply 'append
                               (vl-remove-if-not
                                 (function (lambda (x) (vl-position x lst))) ptlst)))

  (princ (strcat "\nPolyline Length: " (rtos (vla-get-Length obj) 2 2) " mm."))
  (princ))


Code: [Select]

Polyline Length: 2760.18 mm.


Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 28, 2009, 08:26:29 AM

Quote from: Lee Mac on September 28, 2009, 07:32:31 AM

I tried to emulate your method - only up to Step 4, so not quite as short as you:

You have completely repeated my algorithm! Our results are various - I not precisely check a site of a segment in which it is necessary to add a point in the fourth Step. If the nearest point lays on vertex self-crossing is possible. I suppose it. In the fifth Step, all point will be borrowed with new places.

Now it is necessary to start genetic algorithm.
To write one or several functions which improve a contour moving one or several points, to other place of all contour.
Each time, it is necessary to check, whether the contour became shorter, if improvement will stop.

Everything, by me it is made two programs, for genetic algorithm.
The first - search of new sites of points on a contour.
The second - removal of self-crossings.

For the list lst-a I use two programs of improvement.
For the list lst-b I use only the first program.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 28, 2009, 09:46:46 AM

I think, it will be interesting to learn, how I have found the shortest polyline.  :-)

If to do pair rearrangements in 5 step the result will be even better!

Pair rearrangements:
1. We delete two consecutive points, we add the first, then the second, we measure length.
2. Again we delete two points, we add the second, then the first and we compare length.
3. We choose the shortest variant.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Lee Mac on September 28, 2009, 10:03:38 AM

I have updated my routine, but I'm still not as short as yours...  :|

Code: [Select]

(defun mkPoly (lst / mklw vlax-list->2D-point SubLst remove_nth
               
                     i x miP maP tmp lst nlst par ptlst obj)
  (vl-load-com)

  ;;(foreach pt lst (command "_.point" "_non" pt))

  (defun mklw (l / e)
    (entmakex (append (list (cons 0   "LWPOLYLINE")
                            (cons 100 "AcDbEntity")
                            (cons 100 "AcDbPolyline")
                            (cons 90 (length l))
                            (cons 70 1))
                      (mapcar (function (lambda (a) (cons 10 a))) l))))

  (defun vlax-list->2D-point (lst)
    (if lst
      (cons (list (car lst) (cadr lst))
            (vlax-list->2D-point (cddr lst)))))

  (defun SubLst (lst i j / k)
    (setq k -1)
    (or j (setq j (length lst)))
    (vl-remove-if-not
      (function
        (lambda (x)
          (<= i (setq k (1+ k)) (+ i (1- j))))) lst))

  (defun remove_nth (k lst / j)
    (setq j -1)
    (vl-remove-if
      (function
        (lambda (x)
          (= k (setq j (1+ j))))) lst))

  (setq miP (apply 'mapcar (cons 'min lst)))
  (setq maP (apply 'mapcar (cons 'max lst)))

  (setq obj (vlax-ename->vla-object
              (mklw (list miP (list (car miP) (cadr maP)) maP (list (car maP) (cadr miP))))))

  (setq lst (vl-sort lst
              (function
                (lambda (a b) (< (distance (vlax-curve-getClosestPointto obj a) a)
                                 (distance (vlax-curve-getClosestPointto obj b) b))))))

  (setq nlst lst)
  (while (setq x (car nLst))
    (setq nLst (cdr nLst) par (fix (vlax-curve-getParamatPoint obj
                                     (vlax-curve-getClosestPointto obj x))))

    (setq ptlst (vlax-list->2D-point (vlax-get obj 'Coordinates)))

    (setq ptlst (append (SubLst ptlst 0 (1+ par)) (list x)
                        (SubLst ptlst   (1+ par) nil)))

    (vlax-put obj 'Coordinates (apply 'append ptlst)))

  (vlax-put obj 'Coordinates (apply 'append
                               (setq ptlst
                                 (vl-remove-if-not
                                   (function (lambda (x) (vl-position x lst))) ptlst))))

  (setq i -1)
  (repeat (length ptlst)
    (setq x (nth (setq i (1+ i)) ptlst))
   
    (vlax-put obj 'Coordinates (apply 'append (Remove_nth i ptlst)))

    (setq par (fix (vlax-curve-getParamatPoint obj
                     (vlax-curve-getClosestPointto obj x))))

    (setq ptlst (vlax-list->2D-point (vlax-get obj 'Coordinates)))

    (setq ptlst (append (SubLst ptlst 0 (1+ par)) (list x)
                        (SubLst ptlst   (1+ par) nil)))

    (vlax-put obj 'Coordinates (apply 'append ptlst)))

  (vlax-put obj 'Coordinates (apply 'append ptlst))
 
  (princ (strcat "\nPolyline Length: " (rtos (vla-get-Length obj) 2 2) " mm."))
  (princ))

Code: [Select]

Polyline Length: 2535.09 mm.

(http://www.theswamp.org/screens/leemac/example2.png)

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 28, 2009, 10:15:37 AM

Quote from: Lee Mac on September 28, 2009, 10:03:38 AM

I have updated my routine, but I'm still not as short as yours...  

(http://www.theswamp.org/screens/leemac/example2.png)

Your result is magnificent.
Using manual designing, not probably to make better!
Manual methods, it is impossible even to repeat your result, for reasonable time if to speak about a permanent job.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Lee Mac on September 28, 2009, 10:21:04 AM

Thanks ElpanovEvgeniy  :-)

I have used your "pair rearrangment" algorithm idea - and improved my result slightly  :-)

Code: [Select]

(defun mkPoly (lst / mklw vlax-list->2D-point SubLst remove_nth
               
                     i x miP maP tmp lst nlst par ptlst obj nlst nlen)
  (vl-load-com)

  (defun mklw (l / e)
    (entmakex (append (list (cons 0   "LWPOLYLINE")
                            (cons 100 "AcDbEntity")
                            (cons 100 "AcDbPolyline")
                            (cons 90 (length l))
                            (cons 70 1))
                      (mapcar (function (lambda (a) (cons 10 a))) l))))

  (defun vlax-list->2D-point (lst)
    (if lst
      (cons (list (car lst) (cadr lst))
            (vlax-list->2D-point (cddr lst)))))

  (defun SubLst (lst i j / k)
    (setq k -1)
    (or j (setq j (length lst)))
    (vl-remove-if-not
      (function
        (lambda (x)
          (<= i (setq k (1+ k)) (+ i (1- j))))) lst))

  (defun remove_nth (k lst / j)
    (setq j -1)
    (vl-remove-if
      (function
        (lambda (x)
          (= k (setq j (1+ j))))) lst))

  (setq miP (apply 'mapcar (cons 'min lst)))
  (setq maP (apply 'mapcar (cons 'max lst)))

  (setq obj (vlax-ename->vla-object
              (mklw (list miP (list (car miP) (cadr maP)) maP (list (car maP) (cadr miP))))))

  (setq lst (vl-sort lst
              (function
                (lambda (a b) (< (distance (vlax-curve-getClosestPointto obj a) a)
                                 (distance (vlax-curve-getClosestPointto obj b) b))))))

  (setq nlst lst)
  (while (setq x (car nLst))
    (setq nLst (cdr nLst) par (fix (vlax-curve-getParamatPoint obj
                                     (vlax-curve-getClosestPointto obj x))))

    (setq ptlst (vlax-list->2D-point (vlax-get obj 'Coordinates)))

    (setq ptlst (append (SubLst ptlst 0 (1+ par)) (list x)
                        (SubLst ptlst   (1+ par) nil)))

    (vlax-put obj 'Coordinates (apply 'append ptlst)))

  (vlax-put obj 'Coordinates (apply 'append
                               (setq ptlst
                                 (vl-remove-if-not
                                   (function (lambda (x) (vl-position x lst))) ptlst))))

    (setq i -1)
    (repeat (length ptlst)
      (setq x (nth (setq i (1+ i)) ptlst))
     
      (vlax-put obj 'Coordinates (apply 'append (Remove_nth i ptlst)))
      (setq par (fix (vlax-curve-getParamatPoint obj
                       (vlax-curve-getClosestPointto obj x))))

      (setq ptlst (vlax-list->2D-point (vlax-get obj 'Coordinates)))

      (setq ptlst (append (SubLst ptlst 0 (1+ par)) (list x)
                          (SubLst ptlst   (1+ par) nil)))

      (vlax-put obj 'Coordinates (apply 'append ptlst)))

  (setq i -1)
  (repeat (- (length ptlst) 1)
    (setq x (nth (setq i (1+ i)) ptlst) y (nth (1+ i) ptlst))

    (vlax-put obj 'Coordinates (apply 'append ptlst))
    (setq len (vla-get-length obj))

    (setq nlst (append (SubLst ptlst 0 i) (list y x)
                       (Sublst ptlst (+ i 2) nil)))

    (vlax-put obj 'Coordinates (apply 'append nlst))
    (if (< (setq nlen (vla-get-length obj)) len)
      (setq ptlst nlst len nlen)))

  (vlax-put obj 'Coordinates (apply 'append ptlst))
 
  (princ (strcat "\nPolyline Length: " (rtos (vla-get-Length obj) 2 4) " mm."))
  (princ))


(http://www.theswamp.org/screens/leemac/example3.png)


Almost there - although I don't think I'm anywhere near a Generic one!  :lol:

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 28, 2009, 10:30:16 AM

Excellent result!
You very quickly understand an essence.

I shall dare to give one more advice.
Functions vlax-curve-* work much more quickly if it to transfer argument ename than object.
Especially strongly, it is appreciable on the contours having a plenty of segments.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Lee Mac on September 28, 2009, 10:37:14 AM

Quote from: ElpanovEvgeniy on September 28, 2009, 10:30:16 AM

Excellent result!
You very quickly understand an essence.

I shall dare to give one more advice.
Functions vlax-curve-* work much more quickly if it to transfer argument ename than object.
Especially strongly, it is appreciable on the contours having a plenty of segments.

Thank you  :-)

I didn't realise that curve functions worked faster with enames... I thought they had the same performance with objects and enames... thanks for that.  :wink:

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Lee Mac on September 28, 2009, 10:39:12 AM

Just had to test it :P

Code: [Select]

Elapsed milliseconds / relative speed for 16384 iteration(s):

    (vlax-curve-getEndParam ENT).....1233 / 1.43 <fastest>
    (vlax-curve-getEndParam OBJ).....1763 / 1.00 <slowest>


Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 28, 2009, 10:48:38 AM

Quote from: Lee Mac on September 28, 2009, 10:39:12 AM

Just had to test it :P

Code: [Select]

Elapsed milliseconds / relative speed for 16384 iteration(s):

    (vlax-curve-getEndParam ENT).....1233 / 1.43 <fastest>
    (vlax-curve-getEndParam OBJ).....1763 / 1.00 <slowest>


It is not enough, who knows. In the help autocad it is told, it is necessary to use curve-obj - VLA-object.
About an opportunity of use ename - it is not written.

Try to create a polygon "_polygon" with a lot of segments, for example 600 and try to compare speed for
vlax-curve-getDistAtPoint
You will be strongly surprised...

ps. If the polyline has arc segments, the difference is even more!
In my practice there was a difference in 200 times!

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 28, 2009, 10:59:43 AM

It is very a pity, I hoped, in a theme will be more participants...

Earlier, themes with the name " (Challenge) *** " were more often also than participants was more.
Prompt me, it was very complex task or it was not interesting?
Probably, I have had time to offend?

Whether themes " (Challenge) *** " with tasks for algorithms are necessary or programming with comparison of quantity of lines and is interesting only to time of performance?

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Lee Mac on September 28, 2009, 11:08:41 AM

Quote from: ElpanovEvgeniy on September 28, 2009, 10:59:43 AM

It is very a pity, I hoped, in a theme will be more participants...

Earlier, themes with the name " (Challenge) *** " were more often also than participants was more.
Prompt me, it was very complex task or it was not interesting?
Probably, I have had time to offend?

Whether themes " (Challenge) *** " with tasks for algorithms are necessary or programming with comparison of quantity of lines and is interesting only to time of performance?

I think rather that this task is based more on the best Algorithm rather than the fastest programming solution, and hence knowledge of the language.

Therefore there are fewer "obvious" solutions.

Quote from: ElpanovEvgeniy on September 28, 2009, 10:59:43 AM

Probably, I have had time to offend?

No, I very much doubt that.  :-)

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: T.Willey on September 28, 2009, 11:12:13 AM

I liked the idea, but I didn't have time to participate.  I don't think I have the knowledge either.  I would have to read the link supplied, and then come up with some code.  I might have some time this week, but no promises.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 28, 2009, 11:14:00 AM

Quote from: Lee Mac on September 28, 2009, 11:08:41 AM

I think rather that this task is based more on the best Algorithm rather than the fastest programming solution, and hence knowledge of the language.

For the second list, we pressed out covering loop, and it was possible to inflate a bubble.
In general, it is possible to think up many different algorithms.
By the way, I am not assured, that my result the shortest!

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: VovKa on September 28, 2009, 11:29:22 AM

Lee, your code crashes when supplied '((20.0 0.0) (80.0 0.0) (100.0 100.0) (0.0 100.0)) as an argument

Quote

; error: Exception occurred: 0xC0000005 (Access Violation)
; warning: unwind skipped on unknown exception

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Lee Mac on September 28, 2009, 11:34:05 AM

Quote from: VovKa on September 28, 2009, 11:29:22 AM

Lee, your code crashes when supplied '((20.0 0.0) (80.0 0.0) (100.0 100.0) (0.0 100.0)) as an argument

Quote

; error: Exception occurred: 0xC0000005 (Access Violation)
; warning: unwind skipped on unknown exception

VovKa, I find I sometimes get those errors when using the 'Coordinates Property - I am not entirely sure what causes it though, I am not sure why my code would work with Evgeniy's long list of points as opposed to your 4 points.  :?

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: VovKa on September 28, 2009, 12:30:36 PM

Lee, it crashes almost all the time for me. I can't even test your code :(

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 28, 2009, 12:34:20 PM

Quote from: VovKa on September 28, 2009, 12:30:36 PM

Lee, it crashes almost all the time for me. I can't even test your code :(

Clean from a code recursion...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Lee Mac on September 28, 2009, 01:16:43 PM

Quote from: ElpanovEvgeniy on September 28, 2009, 12:34:20 PM

Quote from: VovKa on September 28, 2009, 12:30:36 PM

Lee, it crashes almost all the time for me. I can't even test your code :(

Clean from a code recursion...

Sorry Elpanov, I don't follow you  :?

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 28, 2009, 01:33:54 PM

Quote

; error: Exception occurred: 0xC0000005 (Access Violation)
; warning: unwind skipped on unknown exception

It is a memory error, it often cause recursion, by too deep calls.

recursion:

Code: [Select]

(defun vlax-list->2D-point (lst)
    (if lst
      (cons (list (car lst) (cadr lst))
            (vlax-list->2D-point (cddr lst)))))
Still, such error is caused by such code:

Code: [Select]

(setq miP (apply 'mapcar (cons 'min lst)))
  (setq maP (apply 'mapcar (cons 'max lst)))
There was a theme, about such error:
 Error lisp (autocad 2008)  (http://www.theswamp.org/index.php?topic=24940.0)

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: VovKa on September 28, 2009, 02:35:13 PM

Evgeniy, as Lee've already guessed it is (vlax-put 'Coordinates ...) that issues the error.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Lee Mac on September 28, 2009, 06:40:17 PM

Quote from: VovKa on September 28, 2009, 02:35:13 PM

Evgeniy, as Lee've already guessed it is (vlax-put 'Coordinates ...) that issues the error.

My code seems to work fine when testing, but I have had issues with that in the past.  :-(

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: VovKa on September 29, 2009, 11:35:05 AM

Quote from: ElpanovEvgeniy on September 28, 2009, 11:14:00 AM

By the way, I am not assured, that my result the shortest!

i think it's time to post your code, Evgeniy.
i've tested Lee's a bit, and sometimes it's mistaken.
so, seeing your code is essential :)

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Lee Mac on September 29, 2009, 01:56:49 PM

I think so too  8-)

Mine is messy with all the alterations I've made to it  :oops:

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 29, 2009, 02:22:33 PM

Quote from: Lee Mac on September 29, 2009, 01:56:49 PM

I think so too  8-)

Mine is messy with all the alterations I've made to it  :oops:

Well, tomorrow I will show the code

Quote from: VovKa on September 29, 2009, 11:35:05 AM

i think it's time to post your code, Evgeniy.
i've tested Lee's a bit, and sometimes it's mistaken.
so, seeing your code is essential :)

Where your variant?  :police:

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: VovKa on September 29, 2009, 06:06:54 PM

Quote from: ElpanovEvgeniy on September 29, 2009, 02:22:33 PM

Where your variant?  :police:

come on, i remember you saying that you're not interested in a bruteforce solution? :)
ok, here i go

Code: [Select]

(defun vk_GetPerimeter (CoordsList)
(apply '+
(mapcar (function (lambda (p1 p2) (distance p1 p2)))
CoordsList
(cons (last CoordsList) CoordsList)
)
)
       )
       (defun vk_GetPermutations (lst)
(if (cdr lst)
   (apply 'append
  (mapcar (function (lambda (e1)
      (mapcar (function (lambda (e2) (cons e1 e2)))
      (vk_GetPermutations (vl-remove e1 lst))
      )
    )
  )
  lst
  )
   )
   (list lst)
)
       )
       (defun mkPoly (lst / mlst mdst dst)
(setq lst  (vk_GetPermutations lst)
       mlst (car lst)
       mdst (vk_GetPerimeter mlst)
)
(foreach chain (cdr lst)
   (if (< (setq dst (vk_GetPerimeter chain)) mdst)
     (setq mdst dst
   mlst chain
     )
   )
)
mlst
       )
as any bruteforce attack it is one hundred percent foolproof and one billion percent slow :)
don't even try it on lists longer than 10 points

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 30, 2009, 08:42:34 AM

Code: [Select]

(test lst-b) =>> "Polyline Length: 2521.6043 mm."

Code: [Select]

(defun test (l / D D1 E ENT EP LL LS P)
 (setq ll  (list (apply (function mapcar) (cons (function min) l))
                 (apply (function mapcar) (cons (function max) l))
           ) ;_  append
       ll  (list (car ll) (list (caadr ll) (cadar ll)) (cadr ll) (list (caar ll) (cadadr ll)))
       ent (entmakex (append (list '(0 . "LWPOLYLINE")
                                   '(100 . "AcDbEntity")
                                   '(8 . "temp")
                                   '(62 . 1)
                                   '(100 . "AcDbPolyline")
                                   (cons 90 (length l))
                                   '(70 . 1)
                             ) ;_  list
                             (mapcar (function (lambda (a) (cons 10 a))) ll)
                     ) ;_  append
           ) ;_  entmakex
       l   (mapcar
            (function cddr)
            (vl-sort
             (mapcar (Function (lambda (a / b)
                                (cons (distance a (setq b (vlax-curve-getClosestPointTo ent a)))
                                      (cons (vlax-curve-getParamAtPoint ent b) a)
                                ) ;_  cons
                               ) ;_  lambda
                     ) ;_  Function
                     l
             ) ;_  mapcar
             (function (lambda (a b)
                        (if (equal (car a) (car b) 1)
                         (<= (cadr a) (cadr b))
                         (< (car a) (car b))
                        ) ;_  if
                       ) ;_  lambda
             ) ;_  function
            ) ;_  vl-sort
           ) ;_  mapcar
       ls  l
 ) ;_  setq
 (foreach a ll (setq ls (vl-remove a ls)))
 (foreach a ls
  (setq p (vlax-curve-getParamAtPoint ent (vlax-curve-getClosestPointTo ent a))
        p (if (zerop (rem p 1.))
           (if (zerop p)
            (vlax-curve-getEndParam ent)
            (1- p)
           ) ;_  if
           (fix p)
          ) ;_  if
        p (vlax-curve-getPointAtParam ent p)
        p (list 10 (car p) (cadr p))
  ) ;_  setq
  (entmod (append (reverse (member p (reverse (entget ent))))
                  (list (cons 10 a))
                  (cdr (member p (entget ent)))
          ) ;_  append
  ) ;_  entmod
 ) ;_  foreach
 (foreach a l (setq ll (vl-remove a ll)))
 (entmod (vl-remove-if (function (lambda (a) (member (cdr a) ll))) (entget ent)))
 (setq l  (mapcar (function cdr)
                  (vl-remove-if-not (function (lambda (a) (= (car a) 10))) (entget ent))
          ) ;_  mapcar
       l  (mapcar (function list) (cons (last l) l) l)
       ep (length l)
 ) ;_  setq
 (foreach a l
  (setq e (entget ent)
        d (vlax-curve-getDistAtParam ent ep)
  ) ;_  setq
  (entmod (vl-remove (cons 10 (car a)) (vl-remove (cons 10 (cadr a)) e)))
  (setq p (vlax-curve-getPointAtParam
           ent
           (fix (vlax-curve-getParamAtPoint ent (vlax-curve-getClosestPointTo ent (car a))))
          ) ;_  vlax-curve-getPointAtParam
        p (list 10 (car p) (cadr p))
  ) ;_  setq ;_  setq
  (entmod (append (reverse (member p (reverse (entget ent))))
                  (list (cons 10 (car a)))
                  (cdr (member p (entget ent)))
          ) ;_  append
  ) ;_  entmod
  (setq p (vlax-curve-getPointAtParam
           ent
           (fix (vlax-curve-getParamAtPoint ent (vlax-curve-getClosestPointTo ent (cadr a))))
          ) ;_  vlax-curve-getPointAtParam
        p (list 10 (car p) (cadr p))
  ) ;_  setq
  (entmod (append (reverse (member p (reverse (entget ent))))
                  (list (cons 10 (cadr a)))
                  (cdr (member p (entget ent)))
          ) ;_  append
  ) ;_  entmod
  (if (<= d (setq d1 (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent))))
   (entmod e)
   (setq d d1
         e (entget ent)
   ) ;_  setq
  ) ;_  if
  (entmod (vl-remove (cons 10 (car a)) (vl-remove (cons 10 (cadr a)) e)))
  (setq p (vlax-curve-getPointAtParam
           ent
           (fix (vlax-curve-getParamAtPoint ent (vlax-curve-getClosestPointTo ent (cadr a))))
          ) ;_  vlax-curve-getPointAtParam
        p (list 10 (car p) (cadr p))
  ) ;_  setq
  (entmod (append (reverse (member p (reverse (entget ent))))
                  (list (cons 10 (cadr a)))
                  (cdr (member p (entget ent)))
          ) ;_  append
  ) ;_  entmod
  (setq p (vlax-curve-getPointAtParam
           ent
           (fix (vlax-curve-getParamAtPoint ent (vlax-curve-getClosestPointTo ent (car a))))
          ) ;_  vlax-curve-getPointAtParam
        p (list 10 (car p) (cadr p))
  ) ;_  setq
  (entmod (append (reverse (member p (reverse (entget ent))))
                  (list (cons 10 (car a)))
                  (cdr (member p (entget ent)))
          ) ;_  append
  ) ;_  entmod
  (if (<= d (setq d1 (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent))))
   (entmod e)
   (setq d d1
         e (entget ent)
   ) ;_  setq
  ) ;_  if
 ) ;_  foreach
 (princ (strcat "\nPolyline Length: " (rtos d 2 4) " mm."))
 (princ)
)

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Lee Mac on September 30, 2009, 08:53:27 AM

Nice code - works well for lst-b, but you get a freaky result for lst-a  :lol:

I haven't studied your code in depth yet Elpanov, but I shall look at how you changed the points - I think the entmod method is much more reliable than vlax-put...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 30, 2009, 08:56:25 AM

Quote from: Lee Mac on September 30, 2009, 08:53:27 AM

Nice code - works well for lst-b, but you get a freaky result for lst-a  :lol:

I haven't studied your code in depth yet Elpanov, but I shall look at how you changed the points - I think the entmod method is much more reliable than vlax-put...

For lst-a at me other code...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 30, 2009, 09:26:00 AM

Code: [Select]

(test lst-a) =>> "Polyline Length: 3709.0142 mm."

Code: [Select]

(defun test (l / A B D E LL P PL)
   (setq p  (car l)
         pl (list p)
         l  (cdr l)
   ) ;_  setq
   (while l
    (setq b (car l)
          d (distance p (car l))
    ) ;_  setq
    (foreach a l
     (if (<= (setq e (distance p a)) d)
      (setq b a
            d e
      ) ;_  setq
     ) ;_  if
    ) ;_  foreach
    (setq pl (cons b pl)
          l  (vl-remove b l)
          p  b
          b  (car l)
    ) ;_  setq
   ) ;_  while
   (setq e  nil
         l  pl
         ll l
   ) ;_  setq
   (while (and (not e) ll)
    (setq e  t
          ll l
    ) ;_  setq
    (while (and e ll)
     (setq ll (if (listp (caar ll))
               ll
               (mapcar (function list) (cons (last ll) ll) ll)
              ) ;_  if
           a  (car ll)
           pl (vl-remove-if (function (lambda (b) (or (member (car a) b) (member (cadr a) b))))
                            (cdr ll)
              ) ;_  vl-remove-if
           ll (cdr ll)
     ) ;_  setq
     (while (and pl (setq b (car pl)) (not (inters (car a) (cadr a) (car b) (cadr b))))
      (setq pl (cdr pl))
     ) ;_  while
     (if pl
      (progn (setq l (append (member (car a) l) (reverse (cdr (member (car a) (reverse l)))))
                   l (append (list (car a)) (member (car b) (reverse (cdr l))) (member (cadr b) l))
                   e nil
             ) ;_  setq
      ) ;_  progn
     ) ;_  if
    ) ;_  while
   ) ;_  while
   (setq e (entmakex (append (list '(0 . "LWPOLYLINE")
                                   '(100 . "AcDbEntity")
                                   '(8 . "temp")
                                   '(62 . 1)
                                   '(100 . "AcDbPolyline")
                                   (cons 90 (length l))
                                   '(70 . 1)
                             ) ;_  list
                             (mapcar (function (lambda (a) (cons 10 a))) l)
                     ) ;_  append
           ) ;_  entmakex
   ) ;_  setq
   (princ (strcat "\nPolyline Length: "
                  (rtos (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) 2 4)
                  " mm."
          ) ;_  strcat
   ) ;_  princ
   (princ)
  )

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: VovKa on September 30, 2009, 11:19:41 AM

Evgeniy, i have a list for you :)

Code: [Select]

'((34.0417 53.3357) (78.9539 28.539) (45.5878 3.32332) (92.1425 23.3752) (60.589
27.9296) (34.469 8.53055) (97.5564 8.39047) (8.10511 51.1888))
and i insist that minimum length is 225.88

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 30, 2009, 11:31:04 AM

Quote from: VovKa on September 30, 2009, 11:19:41 AM

Evgeniy, i have a list for you :)

Code: [Select]

'((34.0417 53.3357) (78.9539 28.539) (45.5878 3.32332) (92.1425 23.3752) (60.589
27.9296) (34.469 8.53055) (97.5564 8.39047) (8.10511 51.1888))
and i insist that minimum length is 225.88

For this case, it is enough to execute two times last code of shifts
Generally, the genetic algorithm should work until it is possible to improve result.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 30, 2009, 11:45:17 AM

Now really genetic algorithm for search of best of possible results in the program

Code: [Select]

(defun test (l / D D0 D1 E ENT EP LL LS P)
 (setq ll  (list (apply (function mapcar) (cons (function min) l))
                 (apply (function mapcar) (cons (function max) l))
           ) ;_  append
       ll  (list (car ll) (list (caadr ll) (cadar ll)) (cadr ll) (list (caar ll) (cadadr ll)))
       ent (entmakex (append (list '(0 . "LWPOLYLINE")
                                   '(100 . "AcDbEntity")
                                   '(8 . "temp")
                                   '(62 . 1)
                                   '(100 . "AcDbPolyline")
                                   (cons 90 (length l))
                                   '(70 . 1)
                             ) ;_  list
                             (mapcar (function (lambda (a) (cons 10 a))) ll)
                     ) ;_  append
           ) ;_  entmakex
       l   (mapcar
            (function cddr)
            (vl-sort
             (mapcar (Function (lambda (a / b)
                                (cons (distance a (setq b (vlax-curve-getClosestPointTo ent a)))
                                      (cons (vlax-curve-getParamAtPoint ent b) a)
                                ) ;_  cons
                               ) ;_  lambda
                     ) ;_  Function
                     l
             ) ;_  mapcar
             (function (lambda (a b)
                        (if (equal (car a) (car b) 1)
                         (<= (cadr a) (cadr b))
                         (< (car a) (car b))
                        ) ;_  if
                       ) ;_  lambda
             ) ;_  function
            ) ;_  vl-sort
           ) ;_  mapcar
       ls  l
 ) ;_  setq
 (foreach a ll (setq ls (vl-remove a ls)))
 (foreach a ls
  (setq p (vlax-curve-getParamAtPoint ent (vlax-curve-getClosestPointTo ent a))
        p (if (zerop (rem p 1.))
           (if (zerop p)
            (vlax-curve-getEndParam ent)
            (1- p)
           ) ;_  if
           (fix p)
          ) ;_  if
        p (vlax-curve-getPointAtParam ent p)
        p (list 10 (car p) (cadr p))
  ) ;_  setq
  (entmod (append (reverse (member p (reverse (entget ent))))
                  (list (cons 10 a))
                  (cdr (member p (entget ent)))
          ) ;_  append
  ) ;_  entmod
 ) ;_  foreach
 (foreach a l (setq ll (vl-remove a ll)))
 (entmod (vl-remove-if (function (lambda (a) (member (cdr a) ll))) (entget ent)))
 (setq l  (mapcar (function cdr)
                  (vl-remove-if-not (function (lambda (a) (= (car a) 10))) (entget ent))
          ) ;_  mapcar
       l  (mapcar (function list) (cons (last l) l) l)
       ep (length l)
 ) ;_  setq
 (defun f1 (a ent / p)
  (setq p (vlax-curve-getPointAtParam
           ent
           (fix (vlax-curve-getParamAtPoint ent (vlax-curve-getClosestPointTo ent a)))
          ) ;_  vlax-curve-getPointAtParam
        p (list 10 (car p) (cadr p))
  ) ;_  setq ;_  setq
  (entmod (append (reverse (member p (reverse (entget ent))))
                  (list (cons 10 a))
                  (cdr (member p (entget ent)))
          ) ;_  append
  ) ;_  entmod
 ) ;_  defun
 (setq d0 (vlax-curve-getDistAtParam ent ep))
 (while
  (> d0
     (progn
      (foreach a l
       (setq e (entget ent)
             d (vlax-curve-getDistAtParam ent ep)
       ) ;_  setq
       (entmod (vl-remove (cons 10 (car a)) (vl-remove (cons 10 (cadr a)) e)))
       (f1 (car a) ent)
       (f1 (cadr a) ent)
       (if (<= d (setq d1 (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent))))
        (entmod e)
        (setq d d1
              e (entget ent)
        ) ;_  setq
       ) ;_  if
       (entmod (vl-remove (cons 10 (car a)) (vl-remove (cons 10 (cadr a)) e)))
       (f1 (cadr a) ent)
       (f1 (car a) ent)
       (if (<= d (setq d1 (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent))))
        (entmod e)
        (setq d d1
              e (entget ent)
        ) ;_  setq
       ) ;_  if
      ) ;_  foreach
      d
     ) ;_  progn
  ) ;_  <
  (setq d0 d)
 ) ;_  while
 (princ (strcat "\nPolyline Length: " (rtos d 2 4) " mm."))
 (princ)
)

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 30, 2009, 11:48:28 AM

I repeat, my program searches for results close to best. It not necessarily best result!

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: VovKa on September 30, 2009, 12:30:26 PM

Quote from: ElpanovEvgeniy on September 30, 2009, 11:48:28 AM

my program searches for results close to best. It not necessarily best result!

your last code works much better
and of course there are still lists that can not be "perfectly" traced
anyway it's an excellent job, Evgeniy!

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 30, 2009, 12:37:39 PM

Let's return to a brute force method

It is necessary for each point, to make the list of 3-5 nearest points,
To apply a brute force method, only to these steams.
It is possible to reduce time very much...

ps. It is necessary to pay attention, on five points, being away from other cloud points. :)

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Lee Mac on September 30, 2009, 12:50:03 PM

So you mean something like, take a point, and the next nearest four points.

Rearrange these four points through all combinations (4!), and find the shortest path.

Repeat the process for all the points.

Is this what you had in mind?

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: VovKa on September 30, 2009, 12:55:31 PM

Evgeniy, as you have seen, my code has absolutely no AI: generate a list of all possible routes, then find the shortest one.
yes, i thought of bruteforcing separate "clouds" and then bruteforce "cloud of clouds" and so on, but that demands lots of thinking and i am not into it :)

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: chlh_jd on August 09, 2012, 12:06:59 PM

Hi All , Good topic of discussion .
ElpanovEvgeniy's method is so cool ,Now I rewrite base on his , it seems getting better result and run faster .
Kinds of advice . :-)

Code: [Select]

;;;------------------------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"))))
  (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
)
  )
)


Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: chlh_jd on August 09, 2012, 12:40:20 PM

The codes in up pop use 4 steps complete the Shortest Path Algorithm :
1. Cal Initial feasible path
 1.1 Use Graham Scan algorithm cal  the outermost convex Hull ,
 1.2  Then cal  the remaining internal points convex hull ,
 1.3  Force the collapse of the internal convex hull point , the point join postion is whers increase min distance .
 1.4  repeat 1.2 1.3 until the remaining points less than 3 .
 1.5  Use 1.3 method join remains .
2. Use ElpanovEvgeniy's method Optimize the polyline .
3. Optimize the location of the points which acute angle formed between two adjacent points , this use changing 3p postion .
4. ReOptimize the location of the points which acute angle formed between two adjacent points ,  This use 'getclosestpointto' method .
and so

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on August 09, 2012, 12:57:05 PM

Quote from: chlh_jd on August 09, 2012, 12:06:59 PM

Hi All , Good topic of discussion .
ElpanovEvgeniy's method is so cool ,Now I rewrite base on his , it seems getting better result and run faster .
Kinds of advice . :-)

vertex the top without a point here?

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: chlh_jd on August 10, 2012, 01:14:11 AM

Quote from: ElpanovEvgeniy on August 09, 2012, 12:57:05 PM

Quote from: chlh_jd on August 09, 2012, 12:06:59 PM

Hi All , Good topic of discussion .
ElpanovEvgeniy's method is so cool ,Now I rewrite base on his , it seems getting better result and run faster .
Kinds of advice . :-)

vertex the top without a point here?

Sorry to ElpanovEvgeniy for taking the wrong result , See following and upload doct .

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on August 10, 2012, 02:14:32 AM

I am proud that my humble contribution, helping you to reach even greater heights!  :-)

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on August 10, 2012, 02:21:43 AM

The gist of my code - show the applicability of the genetic algorithm.
The code shown here is just a demonstration for the forum. For a real project, I used about a dozen different subroutine optimization. Calling the subroutine was also intellectually ie not a simple iteration...

ps. In fact, writing such programs is difficult - if you are doing to improve, will inevitably begin to optimize for a particular point cloud...

Congratulations on your excellent results!  :-)

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: chlh_jd on August 10, 2012, 06:30:49 AM

Quote from: ElpanovEvgeniy on August 10, 2012, 02:14:32 AM

I am proud that my humble contribution, helping you to reach even greater heights!  :-)

First ，I always must thank you a lot . So kindness without saying thanks . :-)
Second , I really envy your proficiency on LISP and algorithms . :lol:

Quote from: ElpanovEvgeniy on August 10, 2012, 02:21:43 AM

The gist of my code - show the applicability of the genetic algorithm.
The code shown here is just a demonstration for the forum. For a real project, I used about a dozen different subroutine optimization. Calling the subroutine was also intellectually ie not a simple iteration...

ps. In fact, writing such programs is difficult - if you are doing to improve, will inevitably begin to optimize for a particular point cloud...

Congratulations on your excellent results!  :-)

'Serious' support  !

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on August 10, 2012, 07:07:08 AM

Quote from: chlh_jd on August 10, 2012, 06:30:49 AM

'Serious' support  !

Try your code on regular lattices...

(http://www.theswamp.org/index.php?action=dlattach;topic=30434.0;attach=13699;image)
 lst-a.lsp  (http://www.theswamp.org/index.php?action=dlattach;topic=30434.0;attach=13685)

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: chlh_jd on August 11, 2012, 08:54:36 AM

Quote from: ElpanovEvgeniy on August 10, 2012, 07:07:08 AM

Quote from: chlh_jd on August 10, 2012, 06:30:49 AM

'Serious' support  !

Try your code on regular lattices...

(http://www.theswamp.org/index.php?action=dlattach;topic=30434.0;attach=13699;image)
 lst-a.lsp  (http://www.theswamp.org/index.php?action=dlattach;topic=30434.0;attach=13685)

I think you misunderstood " 'Serious' support ! " , What I mean is very supportive of your views  :-D
Just like you say , the GA method only provide a relatively feasible results . I'v try so much for lst-a and lst-b in your 1st post  , The code I post would not got the best .
 

Quote from: ElpanovEvgeniy on September 30, 2009, 11:45:17 AM

Now really genetic algorithm for search of best of possible results in the program

TSP problem using the improved genetic algorithm to solve, may take years for me can not be resolved ,
However , your encouragement is my greatest motivation. :-)

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on October 22, 2018, 07:25:30 AM

Here are couple of brute-force versions for 3D points... Note that all of these are incredibly slower and can operate up to max 9 points for which routines will give results in reasonbly long time... They are based on permutations of points - so main sub function is (permutate) by Reini Urban... I only modified (permutate) in one example for which I thought I'll gain some better results but I was wrong... Pure brute force (permutate) + calculation of min. distances is the fastest - up to 9 points; then slower - up to 8 points; and last one with additional sub - up to 7 points...
So like Evgeniy I don't like big codes and I have hard time to understand big codes, but of course I like when I see that something is good and working better, so thanks to chlh_jd who helped me many times, still I trust these more general codes more, despite they can do it with only few points but correctly getting the result that was expected for TSP no matter what disposition of points are in 3D space...

Up to 9 points :

Code - Auto/Visual Lisp: [Select]

1. (defun c:TSP-bruteforce-3dpoints ( / unique permutate ss i pl n k l ti ll dmin x d rtn )
2.  
3.   (defun unique ( l )
4.     (if l (cons (car l) (unique (vl-remove-if '(lambda ( x ) (equal x (car l) 1e-6)) l))))
5.   )
6.  
7.   ;;;--------------------------------------------------------------------------
8.   ;;; Permutate a single list.
9.   ;;; Recursive solution by Reini Urban
10.   ;;; (permutate '(0 1 2)) => ((0 1 2) (0 2 1) (1 2 0) (1 0 2) (2 0 1) (2 1 0))
11.   ;;;--------------------------------------------------------------------------
12.   (defun permutate ( l / x1 )
13.     (cond
14.       ( (null l) l )
15.       ( (= (length l) 2) (list l (reverse l)) )
16.       ( t
17.         (repeat (length l)
18.           (foreach x (permutate (cdr l)) ;; loop1 = (foreach x '((1 2) (2 1)) [(permutate (cdr '(0 1 2))) = (permutate '(1 2)) = '((1 2) (2 1))] ; loop2 = (foreach x '((2 0) (0 2)) ; loop3 = (foreach x '((0 1) (1 0))
19.             (setq x1 (cons (cons (car l) x) x1)) ;; loop1 = x1 = '((0 2 1) (0 1 2)) ; loop2 = x1 = '((1 0 2) (1 2 0) (0 2 1) (0 1 2)) ; loop3 = x1 = '((2 1 0) (2 0 1) (1 0 2) (1 2 0) (0 2 1) (0 1 2))
20.           )
21.           (setq l (append (cdr l) (list (car l)))) ;; l = '(0 1 2) - loop1; l = '(1 2 0) - loop2; l = '(2 0 1) - loop3
22.         )
23.         (reverse x1)
24.       )
25.     )
26.   )
27.  
28.   (setq ss (ssget '((0 . "POINT"))))
29.   (repeat (setq i (sslength ss))
30.     (setq pl (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) pl))
31.   )
32.   (setq pl (unique pl))
33.   (setq n (length pl))
34.   (setq k n)
35.   (repeat n
36.     (setq l (cons (setq k (1- k)) l))
37.   )
38.   (setq ti (car (_vl-times)))
39.   (setq ll (permutate l))
40.   (setq dmin 1e+308)
41.   (foreach x ll
42.     (setq x (mapcar '(lambda ( a ) (nth a pl)) x))
43.     (setq d (apply '+ (mapcar '(lambda ( a b ) (distance a b)) x (append (cdr x) (list (car x))))))
44.     (if (> dmin d)
45.       (setq dmin d rtn x)
46.     )
47.   )
48.   (vl-cmdf "_.3DPOLY")
49.   (foreach p rtn
50.     (vl-cmdf "_non" (trans p 0 1))
51.   )
52.   (vl-cmdf "_C")
53.   (prompt "\nDistance : ") (princ (rtos dmin 2 50))
54.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
55.   (princ)
56. )
57.  

Up to 8 points, I tried but its still slower (permutate) sub modified :

Code - Auto/Visual Lisp: [Select]

1. (defun c:TSP-bruteforce-3dpoints ( / unique permutate-exclude-reverses ss i pl n k l ti ll dmin x d rtn )
2.  
3.   (defun unique ( l )
4.     (if l (cons (car l) (unique (vl-remove-if '(lambda ( x ) (equal x (car l) 1e-6)) l))))
5.   )
6.  
7.   ;;;--------------------------------------------------------------------------
8.   ;;; Permutate a single list.
9.   ;;; Recursive solution by Reini Urban
10.   ;;; (permutate '(0 1 2)) => ((0 1 2) (0 2 1) (1 2 0) (1 0 2) (2 0 1) (2 1 0))
11.   ;;; Modified version for exclude reverses sublists by M.R.
12.   ;;; (permutate-exclude-reverses '(0 1 2)) => ((0 1 2) (0 2 1) (1 0 2))
13.   ;;;--------------------------------------------------------------------------
14.   (defun permutate-exclude-reverses ( l / x1 q )
15.     (cond
16.       ( (null l) l )
17.       ( (= (length l) 2) (list l (reverse l)) )
18.       ( t
19.         (repeat (length l)
20.           (foreach x (permutate-exclude-reverses (cdr l)) ;; loop1 = (foreach x '((1 2) (2 1)) [(permutate (cdr '(0 1 2))) = (permutate '(1 2)) = '((1 2) (2 1))] ; loop2 = (foreach x '((2 0) (0 2)) ; loop3 = (foreach x '((0 1) (1 0))
21.             (if (= (length l) n) ;; n - lexical global from routine processing previous steps
22.               (if (not (vl-position (reverse (setq q (cons (car l) x))) x1)) ;; final recursion - check for reversers and (cons) only unique lists
23.                 (setq x1 (cons q x1))
24.               )
25.               (setq x1 (cons (cons (car l) x) x1)) ;; all inner recursions ;; loop1 = x1 = '((0 2 1) (0 1 2)) ; loop2 = x1 = '((1 0 2) (1 2 0) (0 2 1) (0 1 2)) ; loop3 = x1 = '((2 1 0) (2 0 1) (1 0 2) (1 2 0) (0 2 1) (0 1 2))
26.             )
27.           )
28.           (setq l (append (cdr l) (list (car l)))) ;; l = '(0 1 2) - loop1; l = '(1 2 0) - loop2; l = '(2 0 1) - loop3
29.         )
30.         (reverse x1)
31.       )
32.     )
33.   )
34.  
35.   (setq ss (ssget '((0 . "POINT"))))
36.   (repeat (setq i (sslength ss))
37.     (setq pl (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) pl))
38.   )
39.   (setq pl (unique pl))
40.   (setq n (length pl))
41.   (setq k n)
42.   (repeat n
43.     (setq l (cons (setq k (1- k)) l))
44.   )
45.   (setq ti (car (_vl-times)))
46.   (setq ll (permutate-exclude-reverses l))
47.   (setq dmin 1e+308)
48.   (foreach x ll
49.     (setq x (mapcar '(lambda ( a ) (nth a pl)) x))
50.     (setq d (apply '+ (mapcar '(lambda ( a b ) (distance a b)) x (append (cdr x) (list (car x))))))
51.     (if (> dmin d)
52.       (setq dmin d rtn x)
53.     )
54.   )
55.   (vl-cmdf "_.3DPOLY")
56.   (foreach p rtn
57.     (vl-cmdf "_non" (trans p 0 1))
58.   )
59.   (vl-cmdf "_C")
60.   (prompt "\nDistance : ") (princ (rtos dmin 2 50))
61.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
62.   (princ)
63. )
64.  

Up to 7 points, the worst one :

Code - Auto/Visual Lisp: [Select]

1. (defun c:TSP-bruteforce-3dpoints ( / unique exclude-reverses permutate ss i pl n k l ti ll dmin x d rtn )
2.  
3.   (defun unique ( l )
4.     (if l (cons (car l) (unique (vl-remove-if '(lambda ( x ) (equal x (car l) 1e-6)) l))))
5.   )
6.  
7.   (defun exclude-reverses ( l )
8.     (while (vl-some '(lambda ( x ) (if (vl-position (reverse x) l) (setq l (vl-remove x l)))) l))
9.     l
10.   )
11.  
12.   ;;;--------------------------------------------------------------------------
13.   ;;; Permutate a single list.
14.   ;;; Recursive solution by Reini Urban
15.   ;;; (permutate '(0 1 2)) => ((0 1 2) (0 2 1) (1 2 0) (1 0 2) (2 0 1) (2 1 0))
16.   ;;;--------------------------------------------------------------------------
17.   (defun permutate ( l / x1 )
18.     (cond
19.       ( (null l) l )
20.       ( (= (length l) 2) (list l (reverse l)) )
21.       ( t
22.         (repeat (length l)
23.           (foreach x (permutate (cdr l)) ;; loop1 = (foreach x '((1 2) (2 1)) [(permutate (cdr '(0 1 2))) = (permutate '(1 2)) = '((1 2) (2 1))] ; loop2 = (foreach x '((2 0) (0 2)) ; loop3 = (foreach x '((0 1) (1 0))
24.             (setq x1 (cons (cons (car l) x) x1)) ;; loop1 = x1 = '((0 2 1) (0 1 2)) ; loop2 = x1 = '((1 0 2) (1 2 0) (0 2 1) (0 1 2)) ; loop3 = x1 = '((2 1 0) (2 0 1) (1 0 2) (1 2 0) (0 2 1) (0 1 2))
25.           )
26.           (setq l (append (cdr l) (list (car l)))) ;; l = '(0 1 2) - loop1; l = '(1 2 0) - loop2; l = '(2 0 1) - loop3
27.         )
28.         (reverse x1)
29.       )
30.     )
31.   )
32.  
33.   (setq ss (ssget '((0 . "POINT"))))
34.   (repeat (setq i (sslength ss))
35.     (setq pl (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) pl))
36.   )
37.   (setq pl (unique pl))
38.   (setq n (length pl))
39.   (setq k n)
40.   (repeat n
41.     (setq l (cons (setq k (1- k)) l))
42.   )
43.   (setq ti (car (_vl-times)))
44.   (setq ll (exclude-reverses (permutate l)))
45.   (setq dmin 1e+308)
46.   (foreach x ll
47.     (setq x (mapcar '(lambda ( a ) (nth a pl)) x))
48.     (setq d (apply '+ (mapcar '(lambda ( a b ) (distance a b)) x (append (cdr x) (list (car x))))))
49.     (if (> dmin d)
50.       (setq dmin d rtn x)
51.     )
52.   )
53.   (vl-cmdf "_.3DPOLY")
54.   (foreach p rtn
55.     (vl-cmdf "_non" (trans p 0 1))
56.   )
57.   (vl-cmdf "_C")
58.   (prompt "\nDistance : ") (princ (rtos dmin 2 50))
59.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
60.   (princ)
61. )
62.  

Regards, M.R.
Maybe someone will find it useful after all...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on October 22, 2018, 06:43:36 PM

I've tried to optimize up to 8 points to up to 10 points, but something went wrong... I removed sublists that are good; it seems that this tracking method is less reliable... See attached DWG for test... Sorry... M.R.

[EDIT : I fixed wrong formula, but now for 10 points, I get : ]

Code: [Select]

; error: Exception occurred: 0xC0000005 (Access Violation)
; warning: unwind skipped on exception
; error: Exception occurred: 0xC0000005 (Access Violation)

[EDIT : I thought that error was due to recursion of (factorial) sub, but I am wrong again... The same error occur even when iterative version...]

Code - Auto/Visual Lisp: [Select]

1. (defun c:TSP-bruteforce-3dpoints ( / unique factorial permutate-exclude-reverses ss i pl n k l ti ll dmin x d rtn )
2.  
3.   (defun unique ( l )
4.     (if l (cons (car l) (unique (vl-remove-if '(lambda ( x ) (equal x (car l) 1e-6)) l))))
5.   )
6.  
7. ;|
8.   (defun factorial ( k )
9.     (if (> k 1) (setq k (* k (factorial (1- k)))) k)
10.   )
11. |;
12.  
13.   (defun factorial ( k / kk r )
14.     (while (> k 0)
15.       (setq k (1- k))
16.       (if (null kk)
17.         (setq kk 1)
18.         (setq kk (1+ kk))
19.       )
20.       (if (null r)
21.         (setq r 1)
22.         (setq r (* kk r))
23.       )
24.     )
25.     r
26.   )
27.  
28.   ;;;--------------------------------------------------------------------------
29.   ;;; Permutate a single list.
30.   ;;; Recursive solution by Reini Urban
31.   ;;; (permutate '(0 1 2 3)) => ((0 1 2 3) (0 1 3 2) (0 2 3 1) (0 2 1 3) (0 3 1 2) (0 3 2 1) (1 2 3 0) (1 2 0 3) (1 3 0 2) (1 3 2 0) (1 0 2 3) (1 0 3 2) (2 3 0 1) (2 3 1 0) (2 0 1 3) (2 0 3 1) (2 1 3 0) (2 1 0 3) (3 0 1 2) (3 0 2 1) (3 1 2 0) (3 1 0 2) (3 2 0 1) (3 2 1 0))
32.   ;;; Modified version for exclude reverses sublists by M.R.
33.   ;;; (permutate-exclude-reverses '(0 1 2 3)) => ((0 1 2 3) (0 1 3 2) (0 2 3 1) (0 2 1 3) (0 3 1 2) (0 3 2 1) (1 2 3 0) (1 2 0 3) (1 3 0 2) (1 3 2 0) (2 3 0 1) (2 3 1 0))
34.   ;;;--------------------------------------------------------------------------
35.   (defun permutate-exclude-reverses ( l / x1 z k kk )
36.     (cond
37.       ( (null l) l )
38.       ( (= (length l) 2) (list l (reverse l)) )
39.       ( t
40.         (setq z 1)
41.         (repeat (length l)
42.           (foreach x (permutate-exclude-reverses (cdr l)) ;; loop1 = (foreach x '((1 2) (2 1)) [(permutate (cdr '(0 1 2))) = (permutate '(1 2)) = '((1 2) (2 1))] ; loop2 = (foreach x '((2 0) (0 2)) ; loop3 = (foreach x '((0 1) (1 0))
43.             (if (= (length l) n) ;; n - lexical global from routine processing previous steps
44.               (progn
45.                 (if (null k)
46.                   (setq k 0)
47.                   (setq k (1+ k))
48.                 )
49.                 (if (null kk)
50.                   (setq kk 0)
51.                   (setq kk (1+ kk))
52.                 )
53.                 (if (= (factorial (1- n)) kk)
54.                   (setq z (1+ z) kk 0)
55.                 )
56.                 (if (and (<= (* (1- z) (factorial (1- n))) k) (< k (+ (* (1- z) (factorial (1- n))) (- (factorial (1- n)) (* (factorial (1- (1- n))) (1- z))))))
57.                   (setq x1 (cons (cons (car l) x) x1)) ;; final recursion - check for reversers and (cons) only unique lists
58.                 )
59.               )
60.               (setq x1 (cons (cons (car l) x) x1)) ;; all inner recursions ;; loop1 = x1 = '((0 2 1) (0 1 2)) ; loop2 = x1 = '((1 0 2) (1 2 0) (0 2 1) (0 1 2)) ; loop3 = x1 = '((2 1 0) (2 0 1) (1 0 2) (1 2 0) (0 2 1) (0 1 2))
61.             )
62.           )
63.           (setq l (append (cdr l) (list (car l)))) ;; l = '(0 1 2) - loop1; l = '(1 2 0) - loop2; l = '(2 0 1) - loop3
64.         )
65.         (reverse x1)
66.       )
67.     )
68.   )
69.  
70.   (setq ss (ssget '((0 . "POINT"))))
71.   (repeat (setq i (sslength ss))
72.     (setq pl (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) pl))
73.   )
74.   (setq pl (unique pl))
75.   (setq n (length pl))
76.   (setq k n)
77.   (repeat n
78.     (setq l (cons (setq k (1- k)) l))
79.   )
80.   (setq ti (car (_vl-times)))
81.   (setq ll (permutate-exclude-reverses l))
82.   (setq dmin 1e+308)
83.   (foreach x ll
84.     (setq x (mapcar '(lambda ( a ) (nth a pl)) x))
85.     (setq d (apply '+ (mapcar '(lambda ( a b ) (distance a b)) x (append (cdr x) (list (car x))))))
86.     (if (> dmin d)
87.       (setq dmin d rtn x)
88.     )
89.   )
90.   (vl-cmdf "_.3DPOLY")
91.   (foreach p rtn
92.     (vl-cmdf "_non" (trans p 0 1))
93.   )
94.   (vl-cmdf "_C")
95.   (prompt "\nDistance : ") (princ (rtos dmin 2 50))
96.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
97.   (princ)
98. )
99.  

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on October 23, 2018, 03:09:36 AM

Something's still wrong... If you set break point at line (setq dmin 1e+308), just when ll is evaluated and you picked 5 points, you can test list ll by :

Code: [Select]

(vl-some '(lambda ( x ) (vl-position (reverse x) ll)) ll)

If everyting's fine this should return nil showing that there are no reversed sub lists, but it returns 59, so 1 good sub list wasn't calculated and instead there is one reversed (nth 59 ll) - (nth 1 ll) are reverses... I am very sorry, but I think I can't track this thing, simply either order of creation of sub lists are wrong, or my estimation that there should be 60 sub lists out of 120 that are reverses is wrong for which I doubt... Simple tests for 3 and 4 points return always half (6/2 = 3) and (24/2 = 12)... So next one would be (120/2 = 60)...

And in my comment there is reverse pair (nth 11 ll) - (nth 1 ll) - look closer they are reverses - read one of them reverse and it should be exactly the same as other one... Wait there are more : (nth 2 ll) and (nth 9 ll) - check it out... And even more (nth 5 ll) and (nth 6 ll)...

When I look closer in my comment, I think that here is an error too there should be (n!/(n - 1)), so (6/2 = 3); (24/3 = 9); so next one is (120/4 = 30), and so on...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on October 23, 2018, 06:14:09 AM

I've tried it again, still no good, there are reverse sub lists - you can see it from comment - now it's little different, but not good...

Code - Auto/Visual Lisp: [Select]

1. (defun c:TSP-bruteforce-3dpoints ( / unique factorial permutate-exclude-reverses ss i pl n k l ti ll dmin x d rtn )
2.  
3.   (defun unique ( l )
4.     (if l (cons (car l) (unique (vl-remove-if '(lambda ( x ) (equal x (car l) 1e-6)) l))))
5.   )
6.  
7. ;|
8.   (defun factorial ( k )
9.     (if (> k 1) (setq k (* k (factorial (1- k)))) k)
10.   )
11. |;
12.  
13.   (defun factorial ( k / kk r )
14.     (while (> k 0)
15.       (setq k (1- k))
16.       (if (null kk)
17.         (setq kk 1)
18.         (setq kk (1+ kk))
19.       )
20.       (if (null r)
21.         (setq r 1)
22.         (setq r (* kk r))
23.       )
24.     )
25.     r
26.   )
27.  
28.   ;;;--------------------------------------------------------------------------
29.   ;;; Permutate a single list.
30.   ;;; Recursive solution by Reini Urban
31.   ;;; (permutate '(0 1 2 3)) => ((0 1 2 3) (0 1 3 2) (0 2 3 1) (0 2 1 3) (0 3 1 2) (0 3 2 1) (1 2 3 0) (1 2 0 3) (1 3 0 2) (1 3 2 0) (1 0 2 3) (1 0 3 2) (2 3 0 1) (2 3 1 0) (2 0 1 3) (2 0 3 1) (2 1 3 0) (2 1 0 3) (3 0 1 2) (3 0 2 1) (3 1 2 0) (3 1 0 2) (3 2 0 1) (3 2 1 0))
32.   ;;; Modified version for exclude reverses sublists by M.R.
33.   ;;; (permutate-exclude-reverses '(0 1 2 3)) => ((0 1 2 3) (0 1 3 2) (0 2 3 1) (0 2 1 3) (0 3 1 2) (0 3 2 1) (1 2 3 0) (1 2 0 3) (1 3 2 0) (1 0 2 3) (2 3 0 1) (2 3 1 0))
34.   ;;;--------------------------------------------------------------------------
35.   (defun permutate-exclude-reverses ( l / x1 z k kk q qq qqq lll )
36.     (cond
37.       ( (null l) l )
38.       ( (= (length l) 2) (list l (reverse l)) )
39.       ( t
40.         (if (= (length l) n)
41.           (progn
42.             (setq z 0)
43.             (setq qqq (1- n))
44.             (repeat (1- n)
45.               (if (not (zerop (rem (setq qqq (1+ qqq)) (1- n))))
46.                 (setq lll (cons t lll))
47.                 (setq lll (cons nil lll))
48.               )
49.             )
50.             (setq lll (reverse lll))
51.           )
52.         )
53.         (repeat (length l)
54.           (foreach x (permutate-exclude-reverses (cdr l)) ;; loop1 = (foreach x '((1 2) (2 1)) [(permutate (cdr '(0 1 2))) = (permutate '(1 2)) = '((1 2) (2 1))] ; loop2 = (foreach x '((2 0) (0 2)) ; loop3 = (foreach x '((0 1) (1 0))
55.             (if (= (length l) n) ;; n - lexical global from routine processing previous steps ;; final recursion - check for reversers and (cons) only unique lists
56.               (progn
57.                 (if (null k)
58.                   (setq k 1)
59.                   (setq k (1+ k))
60.                 )
61.                 (if (null kk)
62.                   (setq kk 1)
63.                 )
64.                 (if (= (factorial (1- n)) (1- kk))
65.                   (setq z (1+ z) kk 1 qq nil)
66.                 )
67.                 (setq q (- (factorial (1- n)) (* (factorial (1- (1- n))) z)))
68.                 (if (> z 0)
69.                   (if (and (nth (rem (1- k) (1- n)) lll) (< (length qq) q))
70.                     (setq x1 (cons (cons (car l) x) x1) qq (cons t qq))
71.                   )
72.                   (setq x1 (cons (cons (car l) x) x1))
73.                 )
74.                 (setq kk (1+ kk))
75.               )
76.               (setq x1 (cons (cons (car l) x) x1)) ;; all inner recursions ;; loop1 = x1 = '((0 2 1) (0 1 2)) ; loop2 = x1 = '((1 0 2) (1 2 0) (0 2 1) (0 1 2)) ; loop3 = x1 = '((2 1 0) (2 0 1) (1 0 2) (1 2 0) (0 2 1) (0 1 2))
77.             )
78.           )
79.           (setq l (append (cdr l) (list (car l)))) ;; l = '(0 1 2) - loop1; l = '(1 2 0) - loop2; l = '(2 0 1) - loop3
80.         )
81.         (reverse x1)
82.       )
83.     )
84.   )
85.  
86.   (setq ss (ssget '((0 . "POINT"))))
87.   (repeat (setq i (sslength ss))
88.     (setq pl (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) pl))
89.   )
90.   (setq pl (unique pl))
91.   (setq n (length pl))
92.   (setq k n)
93.   (repeat n
94.     (setq l (cons (setq k (1- k)) l))
95.   )
96.   (setq ti (car (_vl-times)))
97.   (setq ll (permutate-exclude-reverses l))
98.   (setq dmin 1e+308)
99.   (foreach x ll
100.     (setq x (mapcar '(lambda ( a ) (nth a pl)) x))
101.     (setq d (apply '+ (mapcar '(lambda ( a b ) (distance a b)) x (append (cdr x) (list (car x))))))
102.     (if (> dmin d)
103.       (setq dmin d rtn x)
104.     )
105.   )
106.   (vl-cmdf "_.3DPOLY")
107.   (foreach p rtn
108.     (vl-cmdf "_non" (trans p 0 1))
109.   )
110.   (vl-cmdf "_C")
111.   (prompt "\nDistance : ") (princ (rtos dmin 2 50))
112.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
113.   (princ)
114. )
115.  

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on October 23, 2018, 10:09:54 AM

I achieved what I wanted... This is good version, there are no reverse sub lists... The code is little shorter, and it was in front of my eyes all the time, just had to think more over it...

Code - Auto/Visual Lisp: [Select]

1. (defun c:TSP-bruteforce-3dpoints ( / unique factorial permutate-exclude-reverses ss i pl n k l ti ll dmin x d rtn )
2.  
3.   (defun unique ( l )
4.     (if l (cons (car l) (unique (vl-remove-if (function (lambda ( x ) (equal x (car l) 1e-6))) l))))
5.   )
6.  
7. ;|
8.   (defun factorial ( k )
9.     (if (> k 1) (setq k (* k (factorial (1- k)))) k)
10.   )
11. |;
12.  
13.   (defun factorial ( k / kk r )
14.     (while (> k 0)
15.       (setq k (1- k))
16.       (if (null kk)
17.         (setq kk 1)
18.         (setq kk (1+ kk))
19.       )
20.       (if (null r)
21.         (setq r 1)
22.         (setq r (* kk r))
23.       )
24.     )
25.     r
26.   )
27.  
28.   ;;;--------------------------------------------------------------------------
29.   ;;; Permutate a single list.
30.   ;;; Recursive solution by Reini Urban
31.   ;;; (permutate '(0 1 2 3)) => ((0 1 2 3) (0 1 3 2) (0 2 3 1) (0 2 1 3) (0 3 1 2) (0 3 2 1) (1 2 3 0) (1 2 0 3) (1 3 0 2) (1 3 2 0) (1 0 2 3) (1 0 3 2) (2 3 0 1) (2 3 1 0) (2 0 1 3) (2 0 3 1) (2 1 3 0) (2 1 0 3) (3 0 1 2) (3 0 2 1) (3 1 2 0) (3 1 0 2) (3 2 0 1) (3 2 1 0))
32.   ;;; Modified version for exclude reverses sublists by M.R.
33.   ;;; (permutate-exclude-reverses '(0 1 2 3)) => ((0 1 2 3) (0 1 3 2) (0 2 3 1) (0 2 1 3) (0 3 1 2) (0 3 2 1) (1 2 0 3) (1 3 0 2) (1 0 2 3) (1 0 3 2) (2 0 1 3) (2 1 0 3))
34.   ;;;--------------------------------------------------------------------------
35.   (defun permutate-exclude-reverses ( l / x1 z zz zp kk q qq g gg )
36.     (cond
37.       ( (null l) l )
38.       ( (= (length l) 2) (list l (reverse l)) )
39.       ( t
40.         (if (= (length l) n)
41.           (setq z 0)
42.         )
43.         (repeat (length l)
44.           (foreach x (permutate-exclude-reverses (cdr l)) ;; loop1 = (foreach x '((1 2) (2 1)) [(permutate (cdr '(0 1 2))) = (permutate '(1 2)) = '((1 2) (2 1))] ; loop2 = (foreach x '((2 0) (0 2)) ; loop3 = (foreach x '((0 1) (1 0))
45.             (if (= (length l) n) ;; n - lexical global from routine processing previous steps ;; final recursion - check for reversers and (cons) only unique lists
46.               (progn
47.                 (if (null kk)
48.                   (setq kk 1)
49.                 )
50.                 (if (null g)
51.                   (setq g (factorial (1- n)))
52.                 )
53.                 (if (null gg)
54.                   (setq gg (/ g (1- n)))
55.                 )
56.                 (setq zp zz)
57.                 (if (= g (1- kk))
58.                   (setq z (1+ z) kk 1 qq nil zz (cons (1- z) zz))
59.                 )
60.                 (if (/= (length zp) (length zz))
61.                   (setq q (- g (* gg z)))
62.                 )
63.                 (if (> z 0)
64.                   (if (and (< (length qq) q) (not (vl-position (last x) zz)))
65.                     (setq x1 (cons (cons (car l) x) x1) qq (cons t qq))
66.                   )
67.                   (setq x1 (cons (cons (car l) x) x1))
68.                 )
69.                 (setq kk (1+ kk))
70.               )
71.               (setq x1 (cons (cons (car l) x) x1)) ;; all inner recursions ;; loop1 = x1 = '((0 2 1) (0 1 2)) ; loop2 = x1 = '((1 0 2) (1 2 0) (0 2 1) (0 1 2)) ; loop3 = x1 = '((2 1 0) (2 0 1) (1 0 2) (1 2 0) (0 2 1) (0 1 2))
72.             )
73.           )
74.           (setq l (append (cdr l) (list (car l)))) ;; l = '(0 1 2) - loop1; l = '(1 2 0) - loop2; l = '(2 0 1) - loop3
75.         )
76.         (reverse x1)
77.       )
78.     )
79.   )
80.  
81.   (setq ss (ssget '((0 . "POINT"))))
82.   (repeat (setq i (sslength ss))
83.     (setq pl (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) pl))
84.   )
85.   (setq pl (unique pl))
86.   (setq n (length pl))
87.   (setq k n)
88.   (repeat n
89.     (setq l (cons (setq k (1- k)) l))
90.   )
91.   (setq ti (car (_vl-times)))
92.   (setq ll (permutate-exclude-reverses l))
93.   (setq dmin 1e+308)
94.   (foreach x ll
95.     (setq x (mapcar (function (lambda ( a ) (nth a pl))) x))
96.     (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) x (append (cdr x) (list (car x))))))
97.     (if (> dmin d)
98.       (setq dmin d rtn x)
99.     )
100.   )
101.   (vl-cmdf "_.3DPOLY")
102.   (foreach p rtn
103.     (vl-cmdf "_non" (trans p 0 1))
104.   )
105.   (vl-cmdf "_C")
106.   (prompt "\nDistance : ") (princ (rtos dmin 2 50))
107.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
108.   (princ)
109. )
110.  

P.S. 10 points are still too much for PC, so still up to 9 pts...
Regards, M.R.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on October 24, 2018, 09:26:34 AM

Still though I am boggling with this issue : Why is my firstly posted code faster than last one? IMHO it should be opposite... Who can explain it?

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: It's Alive! on October 26, 2018, 11:02:05 PM

Straight up Approximate Nearest Neighbor (ANN) algorithm, using nanoflann.
In some cases using Manhattan worked better than Euclidian… 
red=first
yellow = last

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on October 27, 2018, 01:50:31 AM

Daniel, chlh_jd's code is more accurate, and BTW. real TSP is considered as 3D problem too with 3D points in 3D space...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: It's Alive! on October 27, 2018, 05:04:43 AM

Quote from: ribarm on October 27, 2018, 01:50:31 AM

Daniel, chlh_jd's code is more accurate

Doh! crushed

Quote from: ribarm on October 27, 2018, 01:50:31 AM

real TSP is considered as 3D problem too with 3D points in 3D space...

your right, that adds a whole new dimension!

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: It's Alive! on October 27, 2018, 05:07:36 AM

New 3d datasets, used
std::random_device
std::mt19937
std::uniform_real_distribution

10,100,1000 and 10000 points

edit, rand 100000 seems way to big, attached 10000

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: It's Alive! on October 27, 2018, 05:15:59 AM

just sort by distance (greedy)?  :mrgreen:

rand10 = 44.252606
rand100 = 2049.632063
rand1000 = 84593.961921
rand10000 = 3731327.006039

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on October 27, 2018, 08:05:32 AM

1. find center point of complete point cloud
2. take closest point to center point as start
3. find path from start point to outer points using shortest distance between 2, 3, 4, 5 points cloud in one direction from inner to outer point of point cloud
4. append path 3. to main path - store last point as start for next loop
5. find next direction for next point cloud from start point (last from previous step) to center point - step 1.
6. loop 3-4 until all points are processed and calculate final path and its length

3rd step is the most important...
This is my vision and its not foolprof, but I think it may give desired in quickest time processed...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on October 27, 2018, 02:27:19 PM

At least it works, but it's terribly wrong in difference of my previous codes that are good but useless for 10 and more points...

Code - Auto/Visual Lisp: [Select]

1. (defun c:TSP-3dpoints-MR ( / unique ptonline unit v^v rayincone car-sort nextpt ss i pl pll c p cpcloud cpcloudr dist ti )
2.  
3.   (defun unique ( l )
4.     (if l (cons (car l) (unique (vl-remove-if (function (lambda ( x ) (equal x (car l) 1e-6))) l))))
5.   )
6. ;|
7.   (defun ptonline ( p p1 p2 )
8.     (equal (distance p1 p2) (+ (distance p1 p) (distance p p2)) 1e-8)
9.   )
10. |;
11.   (defun unit ( v / d )
12.     (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-8))
13.       (mapcar (function (lambda ( x ) (/ x d))) v)
14.     )
15.   )
16.  
17.   (defun v^v ( u v )
18.     (list
19.       (- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
20.       (- (* (caddr u) (car v)) (* (car u) (caddr v)))
21.       (- (* (car u) (cadr v)) (* (cadr u) (car v)))
22.     )
23.   )
24.  
25.   (defun rayincone ( apex paxis ang pray / d h p nv pv p1 p2 )
26.     (setq d 10.0)
27.     (setq h (* d (/ (sin ang) (cos ang))))
28.     (setq p (mapcar (function *) (unit (mapcar (function -) paxis apex)) (list d d d)))
29.     (setq nv (v^v (mapcar (function -) paxis apex) (mapcar (function -) pray apex)))
30.     (setq pv (v^v nv (mapcar (function -) paxis apex)))
31.     (setq p1 (mapcar (function +) p (mapcar (function *) (unit pv) (list h h h))))
32.     (setq p2 (mapcar (function +) p (mapcar (function *) (unit pv) (list (- h) (- h) (- h)))))
33.     (if (inters p1 p2 apex (mapcar (function +) apex (mapcar (function *) (unit (mapcar (function -) pray apex)) (list 100.0 100.0 100.0))))
34.       t
35.     )
36.   )
37.  
38.   ;;; (car-sort '(2 4 1 3 5 1) '<) => nil
39.   ;;; (car-sort '(2 4 1 3 5 1) '<=) => 1
40.   (defun car-sort ( l f / removenth r k )
41.  
42.     (defun removenth ( l n / k )
43.       (setq k -1)
44.       (vl-remove-if (function (lambda ( x ) (= (setq k (1+ k)) n))) l)
45.     )
46.  
47.     (setq k -1)
48.     (vl-some (function (lambda ( a ) (setq k (1+ k)) (if (vl-every (function (lambda ( x ) (apply f (list a x)))) (removenth l k)) (setq r a)))) l)
49.     r
50.   )
51.  
52.   (defun nextpt ( p ptlst )
53.     (car-sort (vl-remove p ptlst) (function (lambda ( a b ) (<= (distance p a) (distance p b)))))
54.   )
55.  
56.   (setq ss (ssget '((0 . "POINT"))))
57.   (setq ti (car (_vl-times)))
58.   (if ss
59.     (repeat (setq i (sslength ss))
60.       (setq pl (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) pl))
61.     )
62.   )
63.   (setq pl (unique pl))
64.   (setq c (mapcar (function (lambda ( x ) (/ x (length pl)))) (apply (function mapcar) (cons (function +) pl))))
65.   (setq pl (vl-sort pl (function (lambda ( a b ) (< (distance c a) (distance c b))))))
66.   (while pl
67.     (while (and pl (null cpcloud))
68.       (setq p (car pl))
69.       (setq cpcloud (vl-sort (vl-remove-if-not (function (lambda ( x ) (rayincone c p (/ pi 6.0) x))) (vl-remove p pl)) (function (lambda ( a b ) (< (distance p a) (distance p b))))))
70.       (setq pll (cons p pll))
71.       (setq pl (cdr pl))
72.     )
73.     (if (and pl cpcloud)
74.       (progn
75.         (setq pp (last cpcloud))
76.         (while (and (setq p (nextpt p (setq cpcloud (vl-remove p cpcloud)))) (not (equal p pp 1e-6)))
77.           (setq pll (cons p pll))
78.           (setq pl (vl-remove p pl))
79.         )
80.         (setq cpcloud nil)
81.       )
82.     )
83.     (if (and pl p (equal p pp 1e-6))
84.       (progn
85.         (setq pll (cons p pll))
86.         (setq pl (vl-remove p pl))
87.         (while (and pl (null cpcloudr))
88.           (setq cpcloudr (vl-sort (vl-remove-if-not (function (lambda ( x ) (rayincone p c (/ pi 6.0) x))) (vl-remove p pl)) (function (lambda ( a b ) (< (distance p a) (distance p b))))))
89.           (setq p (car-sort pl (function (lambda ( a b ) (<= (distance p a) (distance p b))))))
90.           (setq pll (cons p pll))
91.           (setq pl (vl-remove p pl))
92.         )
93.       )
94.     )
95.     (if (and pl cpcloudr)
96.       (progn
97.         (setq pp (car-sort cpcloudr (function (lambda ( a b ) (<= (distance c a) (distance c b))))))
98.         (while (and (setq p (nextpt p (setq cpcloudr (vl-remove p cpcloudr)))) (not (equal p pp 1e-6)))
99.           (setq pll (cons p pll))
100.           (setq pl (vl-remove p pl))
101.         )
102.       )
103.     )
104.     (setq cpcloudr nil)
105.     (if (and pl p (equal p pp 1e-6))
106.       (progn
107.         (setq pll (cons p pll))
108.         (setq pl (vl-remove p pl))
109.       )
110.     )
111.   )
112.   (setq dist (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pll (append (cdr pll) (list (car pll))))))
113.   (vl-cmdf "_.3DPOLY")
114.   (foreach p pll
115.     (vl-cmdf "_non" (trans p 0 1))
116.   )
117.   (vl-cmdf "_C")
118.   (prompt "\nDistance : ") (princ (rtos dist 2 50))
119.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
120.   (princ)
121. )
122.  

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: It's Alive! on October 27, 2018, 10:38:15 PM

Quote from: ribarm on October 27, 2018, 02:27:19 PM

At least it works, but it's terribly wrong in difference of my previous codes that are good but useless for 10 and more points...

what is your result for rand10? I tried to run it, but select , copy paste gives me line numbers... lol

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on October 28, 2018, 06:07:52 AM

RAND10 :
Distance : 62.71290278984382
Elapsed time : 0.04699999999999999 seconds.

RAND100 :
Distance : 6679.527823958952
Elapsed time : 0.7189999999999999 seconds.

RAND1000 :
Distance : 631481.0073386774
Elapsed time : 68.10999999999999 seconds.

RAND10000 :
I need about 10 hours of running... But I'll be back with info as soon as it finishes...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: It's Alive! on October 28, 2018, 06:45:41 AM

Quote from: ribarm on October 28, 2018, 06:07:52 AM

I need about 10 hours of running... But I'll be back with info as soon as it finishes...

LOL! I tried adding 2-opt to mine, had to kill the process , I’m going to skip the bigger sets until I have a better algorithm

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on October 28, 2018, 07:01:22 AM

Quote from: nullptr on October 28, 2018, 06:45:41 AM

LOL!...

But I am pretty sure that my Salesman haven't traveled neither shortest nor longest... So he enjoyed travel the most... LOL!

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on November 02, 2018, 01:02:37 PM

One variant of TSP - start/end point is known...

http://www.theswamp.org/index.php?topic=54636.0

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on November 05, 2018, 11:57:33 AM

Here is my greedy version...

And here are results :

RAND10 :
Distance : 39.57484137324679
Elapsed time : 0.031 seconds.

RAND100 :
Distance : 1948.071162589293
Elapsed time : 1.983999999999999 seconds.

RAND1000 :
Distance : 85218.62326581254
Elapsed time : 990.4059999999999 seconds.

Code - Auto/Visual Lisp: [Select]

1. (defun c:TSP-MR ( / car-sort nextpt pathbynextshortdst sortpl ss i pl ti rtn d )
2.  
3.   ;;; (car-sort '(2 4 1 3 5 1) '<) => nil
4.   ;;; (car-sort '(2 4 1 3 5 1) '<=) => 1
5.   (defun car-sort ( l f / removenth r k )
6.  
7.     (defun removenth ( l n / k )
8.       (setq k -1)
9.       (vl-remove-if (function (lambda ( x ) (= (setq k (1+ k)) n))) l)
10.     )
11.  
12.     (setq k -1)
13.     (vl-some (function (lambda ( a ) (setq k (1+ k)) (if (vl-every (function (lambda ( x ) (apply f (list a x)))) (removenth l k)) (setq r a)))) l)
14.     r
15.   )
16.  
17.   (defun nextpt ( p l ) ; p - point ; l - list of points without point p
18.     (car-sort l (function (lambda ( a b ) (<= (distance a p) (distance b p)))))
19.   )
20.  
21.   (defun pathbynextshortdst ( l / p pl pp ) ; l - list of points to sort by starting point (car l)
22.     (while (setq p (car l))
23.       (setq pl (cons p pl))
24.       (setq l (vl-remove p l))
25.       (if (car l)
26.         (setq l (cons (setq pp (nextpt p l)) (vl-remove pp l)))
27.       )
28.     )
29.     (reverse pl)
30.   )
31.  
32.   (defun sortpl ( l / pdl pl1 pl2 d1 d2 ) ; l - list of points to sort by shortest next distances
33.     (foreach p l
34.       (setq pdl (cons (cons (distance p (nextpt p (vl-remove p l))) p) pdl))
35.     )
36.     (setq pdl (vl-sort pdl (function (lambda ( a b ) (< (car a) (car b))))))
37.     (setq pl1 (pathbynextshortdst (cons (cdar pdl) (vl-remove (cdar pdl) pl))))
38.     (setq pl2 (pathbynextshortdst (cons (cdadr pdl) (vl-remove (cdadr pdl) pl))))
39.     (setq d1 (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pl1 (append (cdr pl1) (list (car pl1))))))
40.     (setq d2 (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pl2 (append (cdr pl2) (list (car pl2))))))
41.     (if (< d1 d2)
42.       (list pl1 d1)
43.       (list pl2 d2)
44.     )
45.   )
46.  
47.   (setq ss (ssget '((0 . "POINT"))))
48.   (repeat (setq i (sslength ss))
49.     (setq pl (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) pl))
50.   )
51.   (setq ti (car (_vl-times)))
52.   (setq rtn (sortpl pl))
53.   (setq pl (car rtn))
54.   (setq d (cadr rtn))
55.   (vl-cmdf "_.3DPOLY")
56.   (foreach p pl
57.     (vl-cmdf "_non" (trans p 0 1))
58.   )
59.   (vl-cmdf "_C")
60.   (prompt "\nDistance : ") (princ (rtos d 2 50))
61.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
62.   (princ)
63. )
64.  

BTW. How did you do it for 10000 pts? It seems that with LISP it takes forever...
P.S. I attached DWG with 1000 pts...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: It's Alive! on November 05, 2018, 11:10:45 PM

>>BTW. How did you do it for 10000 pts?
Length = 84593.961921, time = 6.203176ms
I used a kd-tree,  https://github.com/jlblancoc/nanoflann

Once I start adding stuff, its starts taking more time.

edit: blue is mine, if you want to compare

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: It's Alive! on November 06, 2018, 05:06:56 AM

here is my source, and a build for ac2019

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on November 07, 2018, 11:44:04 AM

Another variant of greedy... It was created under impression of @handasa's request - search for path between start/end points... So 2 point lists are finally appended to create main sorted point list... Now it seems just a little faster and code is even shorter...

Results :
RAND10 :
Distance : 43.03222468732679
Elapsed time : 0.031 seconds.

RAND100 :
Distance : 1985.343456459591
Elapsed time : 1.780999999999999 seconds.

RAND1000 :
Distance : 83530.26850483351
Elapsed time : 914.953 seconds.

Code - Auto/Visual Lisp: [Select]

1. (defun c:TSP-MR ( / car-sort nextpt ss i pl ti pdl pl1 pl2 p1 p2 d1 d2 d )
2.  
3.   ;;; (car-sort '(2 4 1 3 5 1) '<) => nil
4.   ;;; (car-sort '(2 4 1 3 5 1) '<=) => 1
5.   (defun car-sort ( l f / removenth r k )
6.  
7.     (defun removenth ( l n / k )
8.       (setq k -1)
9.       (vl-remove-if (function (lambda ( x ) (= (setq k (1+ k)) n))) l)
10.     )
11.  
12.     (setq k -1)
13.     (vl-some (function (lambda ( a ) (setq k (1+ k)) (if (vl-every (function (lambda ( x ) (apply f (list a x)))) (removenth l k)) (setq r a)))) l)
14.     r
15.   )
16.  
17.   (defun nextpt ( p l ) ; p - point ; l - list of points without point p
18.     (car-sort l (function (lambda ( a b ) (<= (distance a p) (distance b p)))))
19.   )
20.  
21.   (setq ss (ssget '((0 . "POINT"))))
22.   (repeat (setq i (sslength ss))
23.     (setq pl (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) pl))
24.   )
25.   (setq ti (car (_vl-times)))
26.   (foreach p pl
27.     (setq pdl (cons (cons (distance p (nextpt p (vl-remove p pl))) p) pdl))
28.   )
29.   (setq pdl (vl-sort pdl (function (lambda ( a b ) (< (car a) (car b))))))
30.   (setq pl1 (cons (cdar pdl) pl1))
31.   (setq pl2 (cons (cdadr pdl) pl2))
32.   (setq pl (vl-remove (car pl1) pl) pl (vl-remove (car pl2) pl))
33.   (while pl
34.     (setq p1 (nextpt (car pl1) pl))
35.     (setq p2 (nextpt (car pl2) pl))
36.     (setq d1 (distance (car pl1) p1))
37.     (setq d2 (distance (car pl2) p2))
38.     (if (< d1 d2)
39.       (setq pl1 (cons p1 pl1) pl (vl-remove p1 pl))
40.       (setq pl2 (cons p2 pl2) pl (vl-remove p2 pl))
41.     )
42.   )
43.   (setq pl (append (reverse pl1) pl2))
44.   (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pl (append (cdr pl) (list (car pl))))))
45.   (vl-cmdf "_.3DPOLY")
46.   (foreach p pl
47.     (vl-cmdf "_non" (trans p 0 1))
48.   )
49.   (vl-cmdf "_C")
50.   (prompt "\nDistance : ") (princ (rtos d 2 50))
51.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
52.   (princ)
53. )
54.  

In attachment is RAND100-MR-2.DWG...
P.S. I didn't looked your version, Daniel, but I think that now my is better for 1000 pts...

M.R.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: It's Alive! on November 09, 2018, 06:37:20 AM

new try, times are jumping

rand10 = Length = 38.870136, time in seconds = 0.000913
rand100 = Length = 1888.492776, time in seconds = 0.016582
rand1000 = Length = 82430.569174, time in seconds = 2.645039
rand10000 = Length = 3707449.504854, time in seconds = 3.827995, was 3731327.006039

arx command is 'doit '

edit: changed, the larger the set, the less optimal, otherwise times shoot through the roof lol

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on December 06, 2018, 11:06:02 AM

Back to original task, not to look like I hijacked topic... My version, although too slow, but it's more generic and applicable to both lst-a and lst-b, as also with chlh_jd's DWG, and there is also my test DWG for which my version yields best result from all codes - I don't know, but I can't apply Lee's version correctly - it gives me ConvexHull - don't have time right now, but that's how it turns out on my PC... My version uses Lee's ConvexHull sub that I modified to suit my version better and it's used as starting point, then point list is calculated as concave inward collapsing of ConvexHull... Here is the code and examples used in this topic in attachment...

Code - Auto/Visual Lisp: [Select]

1. (defun c:TSP-2D-MR ( / LM:ConvexHull-ptsonHull LM:Clockwise-p ss ti i pl pln dmin k plp pld pll d r pp )
2.  
3.   ;; Convex Hull  -  Lee Mac
4.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
5.  
6.   (defun LM:ConvexHull-ptsonHull ( lst / ch p0 lstl )
7.       (cond
8.           (   (< (length lst) 4) lst)
9.           (   (setq p0 (car lst))
10.               (foreach p1 (cdr lst)
11.                   (if (or (< (cadr p1) (cadr p0))
12.                           (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
13.                       )
14.                       (setq p0 p1)
15.                   )
16.               )
17.               (setq lst (vl-remove p0 lst))
18.               (setq lst (append (list p0) lst))
19.               (setq lst
20.                   (vl-sort lst
21.                       (function
22.                           (lambda ( a b / c d )
23.                               (if (or (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8) (and (or (equal c 0.0 1e-8) (equal c (* 2 pi) 1e-8)) (or (equal d 0.0 1e-8) (equal d (* 2 pi) 1e-8))))
24.                                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
25.                                   (< c d)
26.                               )
27.                           )
28.                       )
29.                   )
30.               )
31.               (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
32.               (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
33.               (setq lstl (vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
34.               (setq lst (append lst lstl))
35.               (setq ch (list (cadr lst) (car lst)))
36.               (foreach pt (cddr lst)
37.                   (setq ch (cons pt ch))
38.                   (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
39.                       (setq ch (cons pt (cddr ch)))
40.                   )
41.               )
42.               (reverse ch)
43.           )
44.       )
45.   )
46.  
47.   ;; Clockwise-p  -  Lee Mac
48.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
49.  
50.   (defun LM:Clockwise-p ( p1 p2 p3 )
51.       (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
52.               (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
53.           )
54.           0.0
55.       )
56.   )
57.  
58.   (setq ss (ssget '((0 . "POINT"))))
59.   (repeat (setq i (sslength ss))
60.     (setq pl (cons (mapcar '+ '(0 0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
61.   )
62.   (setq ti (car (_vl-times)))
63.   (setq pln (LM:ConvexHull-ptsonHull pl))
64.   (foreach p pln
65.     (setq pl (vl-remove p pl))
66.   )
67.   (while pl
68.     (setq dmin 1e+99)
69.     (foreach p pl
70.       (setq k -1)
71.       (repeat (length pln)
72.         (setq k (1+ k))
73.         (setq plp (reverse (cdr (member (nth k pln) (reverse pln)))))
74.         (setq pls (member (nth k pln) pln))
75.         (setq pll (append plp (list p) pls))
76.         (setq d (apply '+ (mapcar '(lambda ( a b ) (distance a b)) pll (append (cdr pll) (list (car pll))))))
77.         (if (< d dmin)
78.           (setq dmin d r pll pp p)
79.         )
80.       )
81.     )
82.     (setq pln r)
83.     (setq pl (vl-remove pp pl))
84.   )
85.   (entmake
86.     (append
87.       (list
88.         '(0 . "LWPOLYLINE")
89.         '(100 . "AcDbEntity")
90.         '(100 . "AcDbPolyline")
91.         (cons 90 (length pln))
92.         (cons 70 (1+ (* (getvar 'plinegen) 128)))
93.         '(38 . 0.0)
94.       )
95.       (mapcar '(lambda ( x ) (cons 10 x)) pln)
96.       (list
97.         '(210 0.0 0.0 1.0)
98.         '(62 . 1)
99.       )
100.     )
101.   )
102.   (prompt "\nDistance : ") (princ (rtos dmin 2 50))
103.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds...")
104.   (princ)
105. )
106.  

Regards, M.R.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on December 06, 2018, 11:07:12 AM

My testing DWG in attachment...

M.R.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on December 07, 2018, 12:37:56 PM

https://www.youtube.com/watch?v=W-aAjd8_bUc

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on December 08, 2018, 07:07:20 AM

I've changed a little my version... Forgot to sort initial point list at start and little different "plp" and "pls" variables...

Code - Auto/Visual Lisp: [Select]

1. (defun c:TSP-2D-MR ( / LM:ConvexHull-ptsonHull LM:Clockwise-p ss ti i pl pln dmin k plp pld pll d r pp )
2.  
3.   ;; Convex Hull  -  Lee Mac
4.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
5.  
6.   (defun LM:ConvexHull-ptsonHull ( lst / ch p0 lstl )
7.       (cond
8.           (   (< (length lst) 4) lst)
9.           (   (setq p0 (car lst))
10.               (foreach p1 (cdr lst)
11.                   (if (or (< (cadr p1) (cadr p0))
12.                           (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
13.                       )
14.                       (setq p0 p1)
15.                   )
16.               )
17.               (setq lst (vl-remove p0 lst))
18.               (setq lst (append (list p0) lst))
19.               (setq lst
20.                   (vl-sort lst
21.                       (function
22.                           (lambda ( a b / c d )
23.                               (if (or (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8) (and (or (equal c 0.0 1e-8) (equal c (* 2 pi) 1e-8)) (or (equal d 0.0 1e-8) (equal d (* 2 pi) 1e-8))))
24.                                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
25.                                   (< c d)
26.                               )
27.                           )
28.                       )
29.                   )
30.               )
31.               (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
32.               (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
33.               (setq lstl (vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
34.               (setq lst (append lst lstl))
35.               (setq ch (list (cadr lst) (car lst)))
36.               (foreach pt (cddr lst)
37.                   (setq ch (cons pt ch))
38.                   (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
39.                       (setq ch (cons pt (cddr ch)))
40.                   )
41.               )
42.               (reverse ch)
43.           )
44.       )
45.   )
46.  
47.   ;; Clockwise-p  -  Lee Mac
48.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
49.  
50.   (defun LM:Clockwise-p ( p1 p2 p3 )
51.       (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
52.               (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
53.           )
54.           0.0
55.       )
56.   )
57.  
58.   (setq ss (ssget '((0 . "POINT"))))
59.   (repeat (setq i (sslength ss))
60.     (setq pl (cons (mapcar '+ '(0 0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
61.   )
62.   (setq ti (car (_vl-times)))
63.   (setq pl (vl-sort pl '(lambda ( a b ) (if (= (cadr a) (cadr b)) (> (car a) (car b)) (> (cadr a) (cadr b))))))
64.   (setq pln (LM:ConvexHull-ptsonHull pl))
65.   (foreach p pln
66.     (setq pl (vl-remove p pl))
67.   )
68.   (while pl
69.     (setq dmin 1e+99)
70.     (foreach p pl
71.       (setq k -1)
72.       (repeat (length pln)
73.         (setq k (1+ k))
74.         (setq plp (reverse (member (nth k pln) (reverse pln))))
75.         (setq pls (cdr (member (nth k pln) pln)))
76.         (setq pll (append plp (list p) pls))
77.         (setq d (apply '+ (mapcar '(lambda ( a b ) (distance a b)) pll (append (cdr pll) (list (car pll))))))
78.         (if (< d dmin)
79.           (setq dmin d r pll pp p)
80.         )
81.       )
82.     )
83.     (setq pln r)
84.     (setq pl (vl-remove pp pl))
85.   )
86.   (entmake
87.     (append
88.       (list
89.         '(0 . "LWPOLYLINE")
90.         '(100 . "AcDbEntity")
91.         '(100 . "AcDbPolyline")
92.         (cons 90 (length pln))
93.         (cons 70 (1+ (* (getvar 'plinegen) 128)))
94.         '(38 . 0.0)
95.       )
96.       (mapcar '(lambda ( x ) (cons 10 x)) pln)
97.       (list
98.         '(210 0.0 0.0 1.0)
99.         '(62 . 1)
100.       )
101.     )
102.   )
103.   (prompt "\nDistance : ") (princ (rtos dmin 2 50))
104.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds...")
105.   (princ)
106. )
107.  

P.S. One would thought that with square grid pattern of points, it's only needed to alter Evgeniy's - lst-a sub function, but no...
Neither this - following path in spiral manner is not good :

Code: [Select]

(defun test-lst-a (l / A B BB D E LL P PL AN)
   (setq l (vl-sort l (function (lambda (a b) (if (= (car a) (car b)) (< (cadr a) (cadr b)) (< (car a) (car b))))))) ;_  setq
   (setq p  (car l)
         pl (list p)
         l  (cdr l)
   ) ;_  setq
   (while l
    (setq d (distance p (car l))) ;_  setq
    (foreach a l
     (if (<= (setq e (distance p a)) d)
      (if (and an (or (equal (angle p a) an 1e-6) (equal (angle p a) (rem (+ pi an) (+ pi pi)) 1e-6) (if (or (equal an 0.0 1e-6) (equal an (* 2 pi) 1e-6)) (equal (angle p a) (* 2 pi) 1e-6))))
       (setq bb a
             d e
       ) ;_  setq
       (setq b a
             d e
       ) ;_  setq
      ) ;_  if
     ) ;_  if
    ) ;_  foreach
    (cond
     ((and bb b (<= (distance p bb) (distance p b)))
      (setq b bb) ;_  setq
     )
     ((and bb b)
      (setq bb b) ;_ setq
     )
     (bb
      (setq b bb) ;_  setq
     )
    ) ;_  cond
    (setq pl (cons b pl)
          an (angle p b)
          l  (vl-remove b l)
          p  b
          b  nil
          bb nil
    ) ;_  setq
   ) ;_  while
   (setq pl (reverse pl)) ;_  setq
   (setq e  nil
         l  pl
         ll l
   ) ;_  setq
   (while (and (not e) ll)
    (setq e  t
          ll l
    ) ;_  setq
    (while (and e ll)
     (setq ll (if (listp (caar ll))
               ll
               (mapcar (function list) (cons (last ll) ll) ll)
              ) ;_  if
           a  (car ll)
           pl (vl-remove-if (function (lambda (b) (or (member (car a) b) (member (cadr a) b))))
                            (cdr ll)
              ) ;_  vl-remove-if
           ll (cdr ll)
     ) ;_  setq
     (while (and pl (setq b (car pl)) (not (inters (car a) (cadr a) (car b) (cadr b))))
      (setq pl (cdr pl))
     ) ;_  while
     (if pl
      (progn (setq l (append (member (car a) l) (reverse (cdr (member (car a) (reverse l)))))
                   l (append (list (car a)) (member (car b) (reverse (cdr l))) (member (cadr b) l)) ;;; (car a) (cadr a) + ... + (car b) (cadr b) + ... ->end ;;; => ;;; (car a) + (reversed (car b)->(cadr a)) + (not reversed (cadr b)->end)
                   e nil
             ) ;_  setq
      ) ;_  progn
     ) ;_  if
    ) ;_  while
   ) ;_  while
   (setq e (entmakex (append (list '(0 . "LWPOLYLINE")
                                   '(100 . "AcDbEntity")
                                   '(8 . "temp")
                                   '(62 . 1)
                                   '(100 . "AcDbPolyline")
                                   (cons 90 (length l))
                                   '(70 . 1)
                             ) ;_  list
                             (mapcar (function (lambda (a) (cons 10 a))) l)
                     ) ;_  append
           ) ;_  entmakex
   ) ;_  setq
   (princ (strcat "\nPolyline Length: "
                  (rtos (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) 2 4)
                  " mm."
          ) ;_  strcat
   ) ;_  princ
   (princ)
  )
(test-lst-a (mapcar '(lambda ( x ) (cdr (assoc 10 (entget x)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "POINT"))))))))

Neither is good following path by favoring either X or Y axis, so that path goes like snake like Evgeniy's original lst-a is doing because of rectangular grid pattern :

Code: [Select]

(defun test-lst-a (l / A B BB D E LL P PL AN W H)
   (setq l (vl-sort l (function (lambda (a b) (if (= (car a) (car b)) (< (cadr a) (cadr b)) (< (car a) (car b))))))) ;_  setq
   (setq w (- (car (last l)) (car (car l))) h (- (cadr (last l)) (cadr (car l)))) ;_  setq
   (if (< w h)
    (setq an (* 0.5 pi)) ;_  setq
    (setq an 0.0) ;_  setq
   ) ;_  if
   (setq p  (car l)
         pl (list p)
         l  (cdr l)
   ) ;_  setq
   (while l
    (setq d (distance p (car l))) ;_  setq
    (foreach a l
     (if (<= (setq e (distance p a)) d)
      (if (and an (or (equal (angle p a) an 1e-6) (equal (angle p a) (rem (+ pi an) (+ pi pi)) 1e-6) (if (or (equal an 0.0 1e-6) (equal an (* 2 pi) 1e-6)) (equal (angle p a) (* 2 pi) 1e-6))))
       (setq bb a
             d e
       ) ;_  setq
       (setq b a
             d e
       ) ;_  setq
      ) ;_  if
     ) ;_  if
    ) ;_  foreach
    (cond
     ((and bb b (<= (distance p bb) (distance p b)))
      (setq b bb) ;_  setq
     )
     ((and bb b)
      (setq bb b) ;_ setq
     )
     (bb
      (setq b bb) ;_  setq
     )
    ) ;_  cond
    (setq pl (cons b pl)
          l  (vl-remove b l)
          p  b
          b  nil
          bb nil
    ) ;_  setq
   ) ;_  while
   (setq pl (reverse pl)) ;_  setq
   (setq e  nil
         l  pl
         ll l
   ) ;_  setq
   (while (and (not e) ll)
    (setq e  t
          ll l
    ) ;_  setq
    (while (and e ll)
     (setq ll (if (listp (caar ll))
               ll
               (mapcar (function list) (cons (last ll) ll) ll)
              ) ;_  if
           a  (car ll)
           pl (vl-remove-if (function (lambda (b) (or (member (car a) b) (member (cadr a) b))))
                            (cdr ll)
              ) ;_  vl-remove-if
           ll (cdr ll)
     ) ;_  setq
     (while (and pl (setq b (car pl)) (not (inters (car a) (cadr a) (car b) (cadr b))))
      (setq pl (cdr pl))
     ) ;_  while
     (if pl
      (progn (setq l (append (member (car a) l) (reverse (cdr (member (car a) (reverse l)))))
                   l (append (list (car a)) (member (car b) (reverse (cdr l))) (member (cadr b) l)) ;;; (car a) (cadr a) + ... + (car b) (cadr b) + ... ->end ;;; => ;;; (car a) + (reversed (car b)->(cadr a)) + (not reversed (cadr b)->end)
                   e nil
             ) ;_  setq
      ) ;_  progn
     ) ;_  if
    ) ;_  while
   ) ;_  while
   (setq e (entmakex (append (list '(0 . "LWPOLYLINE")
                                   '(100 . "AcDbEntity")
                                   '(8 . "temp")
                                   '(62 . 1)
                                   '(100 . "AcDbPolyline")
                                   (cons 90 (length l))
                                   '(70 . 1)
                             ) ;_  list
                             (mapcar (function (lambda (a) (cons 10 a))) l)
                     ) ;_  append
           ) ;_  entmakex
   ) ;_  setq
   (princ (strcat "\nPolyline Length: "
                  (rtos (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) 2 4)
                  " mm."
          ) ;_  strcat
   ) ;_  princ
   (princ)
  )
(test-lst-a (mapcar '(lambda ( x ) (cdr (assoc 10 (entget x)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "POINT"))))))))

AND FINALLY, SOLUTION THAT IS CORRECT AND FAST FOR SQUARE GRID PATTERN DISPOSITION OF POINTS :

Code - Auto/Visual Lisp: [Select]

1. (defun test-lst-a (l / A B BB D E LL P PL AN W H F)
2.    (setq l (vl-sort l (function (lambda (a b) (if (= (car a) (car b)) (< (cadr a) (cadr b)) (< (car a) (car b))))))) ;_  setq
3.    (setq w (- (car (setq ll (last l))) (car (car l))) h (- (cadr (last l)) (cadr (car l)))) ;_  setq
4.    (if (< w h)
5.     (setq an (* 0.5 pi)) ;_  setq
6.     (setq an 0.0) ;_  setq
7.    ) ;_  if
8.    (setq p  (car l)
9.          pl (list p)
10.          l  (cdr l)
11.    ) ;_  setq
12.    (while l
13.     (setq d (distance p (car l))) ;_  setq
14.     (foreach a l
15.      (if (<= (setq e (distance p a)) d)
16.       (if (and an (or (equal (angle p a) an 1e-6) (equal (angle p a) (rem (+ pi an) (+ pi pi)) 1e-6) (if (or (equal an 0.0 1e-6) (equal an (* 2 pi) 1e-6)) (equal (angle p a) (* 2 pi) 1e-6))))
17.        (setq bb a
18.              d e
19.        ) ;_  setq
20.        (setq b a
21.              d e
22.        ) ;_  setq
23.       ) ;_  if
24.      ) ;_  if
25.     ) ;_  foreach
26.     (cond
27.      ((and bb b (<= (distance p bb) (distance p b)))
28.       (setq b bb) ;_  setq
29.      )
30.      ((and bb b)
31.       (setq bb b) ;_ setq
32.      )
33.      (bb
34.       (setq b bb) ;_  setq
35.      )
36.     ) ;_  cond
37.     (setq pl (cons b pl)
38.           l  (vl-remove b l)
39.           p  b
40.           b  nil
41.           bb nil
42.     ) ;_  setq
43.     (cond
44.      ((and (null f) (= an 0.0) (= (car p) (car ll)) (= (distance p ll) d))
45.       (setq an (* 0.5 pi) f t) ;_  setq
46.      )
47.      ((and (null f) (= an (* 0.5 pi)) (= (cadr p) (cadr ll)) (= (distance p ll) d))
48.       (setq an 0.0 f t) ;_  setq
49.      )
50.     ) ;_  cond
51.    ) ;_  while
52.    (setq pl (reverse pl)) ;_  setq
53.    (setq e  nil
54.          l  pl
55.          ll l
56.    ) ;_  setq
57.    (while (and (not e) ll)
58.     (setq e  t
59.           ll l
60.     ) ;_  setq
61.     (while (and e ll)
62.      (setq ll (if (listp (caar ll))
63.                ll
64.                (mapcar (function list) (cons (last ll) ll) ll)
65.               ) ;_  if
66.            a  (car ll)
67.            pl (vl-remove-if (function (lambda (b) (or (member (car a) b) (member (cadr a) b))))
68.                             (cdr ll)
69.               ) ;_  vl-remove-if
70.            ll (cdr ll)
71.      ) ;_  setq
72.      (while (and pl (setq b (car pl)) (not (inters (car a) (cadr a) (car b) (cadr b))))
73.       (setq pl (cdr pl))
74.      ) ;_  while
75.      (if pl
76.       (progn (setq l (append (member (car a) l) (reverse (cdr (member (car a) (reverse l)))))
77.                    l (append (list (car a)) (member (car b) (reverse (cdr l))) (member (cadr b) l)) ;;; (car a) (cadr a) + ... + (car b) (cadr b) + ... ->end ;;; => ;;; (car a) + (reversed (car b)->(cadr a)) + (not reversed (cadr b)->end)
78.                    e nil
79.              ) ;_  setq
80.       ) ;_  progn
81.      ) ;_  if
82.     ) ;_  while
83.    ) ;_  while
84.    (setq e (entmakex (append (list '(0 . "LWPOLYLINE")
85.                                    '(100 . "AcDbEntity")
86.                                    '(8 . "temp")
87.                                    '(62 . 1)
88.                                    '(100 . "AcDbPolyline")
89.                                    (cons 90 (length l))
90.                                    '(70 . 1)
91.                              ) ;_  list
92.                              (mapcar (function (lambda (a) (cons 10 a))) l)
93.                      ) ;_  append
94.            ) ;_  entmakex
95.    ) ;_  setq
96.    (princ (strcat "\nPolyline Length: "
97.                   (rtos (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) 2 4)
98.                   " mm."
99.           ) ;_  strcat
100.    ) ;_  princ
101.    (princ)
102.   )
103. (test-lst-a (mapcar '(lambda ( x ) (cdr (assoc 10 (entget x)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "POINT"))))))))
104.  

Regards...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on December 11, 2018, 09:20:38 AM

I tried to add checking for intersections using Evgeniy's method... This may and may not produce better (shorter) path, but it's surely better than with crossings... IMO I think when 2D TSP, should yield no crossings no matter what distribution of 2D points... So I agree with Evgeniy - after all he is guru...

Code - Auto/Visual Lisp: [Select]

1. (defun c:TSP-2D-MR ( / prelst suflst LM:ConvexHull-ptsonHull LM:Clockwise-p ss ti i pl pln dmin k plp pld pll d r pp lil lii1 lii2 lil1 lil2 ip ppl ppll )
2.  
3.   (defun prelst ( l n / ll ) ; l - list ; n - 0 based index at which list is split and right-trimmed ; (prelst '(0 1 2 3) 0) => nil ; (prelst '(0 1 2 3) 1) => (0) ; (prelst '(0 1 2 3) 3) => (0 1 2) ; (prelst '(0 1 2 3) 4) => (0 1 2 3) ; (prelst '(0 1 2 3) 5) => (0 1 2 3)
4.     (if (<= n 0)
5.       nil
6.       (if (< n (length l))
7.         (progn
8.           (repeat n
9.             (setq ll (cons (car l) ll))
10.             (setq l (cdr l))
11.           )
12.           (reverse ll)
13.         )
14.         l
15.       )
16.     )
17.   )
18.  
19.   (defun suflst ( l n ) ; l - list ; n - 0 based index at which list is split and left-trimmed ; (suflst '(0 1 2 3) 0) => (0 1 2 3) ; (suflst '(0 1 2 3) 1) => (1 2 3) ; (suflst '(0 1 2 3) 3) => (3) ; (suflst '(0 1 2 3) 4) => nil ; (suflst '(0 1 2 3) 5) => nil
20.     (if (<= n 0)
21.       l
22.       (if (< n (length l))
23.         (progn
24.           (repeat n
25.             (setq l (cdr l))
26.           )
27.           l
28.         )
29.         nil
30.       )
31.     )
32.   )
33.  
34.   ;; Convex Hull  -  Lee Mac
35.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
36.  
37.   (defun LM:ConvexHull-ptsonHull ( lst / ch p0 lstl )
38.       (cond
39.           (   (< (length lst) 4) lst)
40.           (   (setq p0 (car lst))
41.               (foreach p1 (cdr lst)
42.                   (if (or (< (cadr p1) (cadr p0))
43.                           (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
44.                       )
45.                       (setq p0 p1)
46.                   )
47.               )
48.               (setq lst (vl-remove p0 lst))
49.               (setq lst (append (list p0) lst))
50.               (setq lst
51.                   (vl-sort lst
52.                       (function
53.                           (lambda ( a b / c d )
54.                               (if (or (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8) (and (or (equal c 0.0 1e-8) (equal c (* 2 pi) 1e-8)) (or (equal d 0.0 1e-8) (equal d (* 2 pi) 1e-8))))
55.                                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
56.                                   (< c d)
57.                               )
58.                           )
59.                       )
60.                   )
61.               )
62.               (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
63.               (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
64.               (setq lstl (vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
65.               (setq lst (append lst lstl))
66.               (setq ch (list (cadr lst) (car lst)))
67.               (foreach pt (cddr lst)
68.                   (setq ch (cons pt ch))
69.                   (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
70.                       (setq ch (cons pt (cddr ch)))
71.                   )
72.               )
73.               (reverse ch)
74.           )
75.       )
76.   )
77.  
78.   ;; Clockwise-p  -  Lee Mac
79.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
80.  
81.   (defun LM:Clockwise-p ( p1 p2 p3 )
82.       (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
83.               (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
84.           )
85.           0.0
86.       )
87.   )
88.  
89.   (setq ss (ssget '((0 . "POINT"))))
90.   (repeat (setq i (sslength ss))
91.     (setq pl (cons (mapcar (function +) '(0 0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
92.   )
93.   (setq ti (car (_vl-times)))
94.   (setq pln (LM:ConvexHull-ptsonHull pl))
95.   (foreach p pln
96.     (setq pl (vl-remove p pl))
97.   )
98.   (while pl
99.     (setq ppl (LM:ConvexHull-ptsonHull pl))
100.     (if (< (length ppl) 4)
101.       (setq ppl (vl-sort ppl (function (lambda ( a b ) (< (distance (car pln) a) (distance (car pln) b))))))
102.     )
103.     (foreach p ppl
104.       (setq pl (vl-remove p pl))
105.     )
106.     (setq ppll (append ppll (reverse ppl)))
107.     (setq ppl nil)
108.   )
109.   (setq pl ppll)
110.   (while pl
111.     (setq dmin 1e+99)
112.     (foreach p pl
113.       (setq k -1)
114.       (repeat (length pln)
115.         (setq k (1+ k))
116.         ;|
117.         (setq plp (prelst pln (1+ k)))
118.         (setq pls (suflst pln (1+ k)))
119.         |;
120.         (setq plp (reverse (member (nth k pln) (reverse pln))))
121.         (setq pls (cdr (member (nth k pln) pln)))
122.         (setq pll (append plp (list p) pls))
123.         (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pll (append (cdr pll) (list (car pll))))))
124.         (if (< d dmin)
125.           (setq dmin d r pll pp p)
126.         )
127.       )
128.     )
129.     (setq pln r)
130.     (setq pl (vl-remove pp pl))
131.   )
132.   (setq lil (mapcar (function (lambda ( a b ) (list a b))) pln (append (cdr pln) (list (car pln)))))
133.   (while (vl-some (function (lambda ( li1 ) (vl-some (function (lambda ( li2 ) (if (and (setq ip (inters (car li1) (cadr li1) (car li2) (cadr li2))) (not (equal ip (car li1) 1e-8)) (not (equal ip (cadr li1) 1e-8)) (not (equal ip (car li2) 1e-8)) (not (equal ip (cadr li2) 1e-8))) (setq lii1 li1 lii2 li2)))) (vl-remove li1 lil)))) lil)
134.     (setq lil1 (if (member lii2 (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil))))))) (reverse (cdr (member lii2 (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil))))))))) (reverse (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil)))))))))
135.     (setq lil2 (if (member lii1 (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil))))))) (cdr (member lii1 (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil)))))))) (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil))))))))
136.     (setq lil (append lil1 (list (list (cadr (last lil1)) (cadr (car lil2)))) (mapcar 'reverse lil2) (list (list (car (last lil2)) (car (car lil1))))))
137.   )
138.   (setq pln (mapcar 'car lil))
139.   (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pln (append (cdr pln) (list (car pln))))))
140.   (entmake
141.     (append
142.       (list
143.         '(0 . "LWPOLYLINE")
144.         '(100 . "AcDbEntity")
145.         '(100 . "AcDbPolyline")
146.         (cons 90 (length pln))
147.         (cons 70 (1+ (* (getvar 'plinegen) 128)))
148.         '(38 . 0.0)
149.       )
150.       (mapcar (function (lambda ( x ) (cons 10 x))) pln)
151.       (list
152.         '(210 0.0 0.0 1.0)
153.         '(62 . 1)
154.       )
155.     )
156.   )
157.   (prompt "\nDistance : ") (princ (rtos d 2 50))
158.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds...")
159.   (princ)
160. )
161.  

Regards, M.R.

[EDIT : Forgot to localize "ip" variable...]
[EDIT2 : Tried with subs (prelst) and (suflst), but it seems slower, so I returned to (nth) and (member) variants for "plp" and "pls" variables...]

BTW. My test DWG in now bad, but lst-a of Evgeniy is now little shorter : 3806.343470244899

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Grrr1337 on December 13, 2018, 06:57:42 PM

Impressive work, Marko! 8)

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on December 15, 2018, 12:14:45 AM

Thanks Grrr... I've modified it further more, now my test DWG is fine 77.4142... and lst-a by Evgeniy is also good - around 3800 (look in previous post to see exact number)... Only lack now is that it is 2 times slower on already slow routine... But I am satisfied nevertheless...

Code - Auto/Visual Lisp: [Select]

1. (defun c:TSP-2D-MR ( / LM:ConvexHull-ptsonHull LM:Clockwise-p ss ti i pl pln dmin k plp pld pll d r pp lil lii1 lii2 lil1 lil2 ip ppl ppll )
2.  
3.   ;; Convex Hull  -  Lee Mac
4.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
5.  
6.   (defun LM:ConvexHull-ptsonHull ( lst / ch p0 lstl )
7.       (cond
8.           (   (< (length lst) 4) lst)
9.           (   (setq p0 (car lst))
10.               (foreach p1 (cdr lst)
11.                   (if (or (< (cadr p1) (cadr p0))
12.                           (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
13.                       )
14.                       (setq p0 p1)
15.                   )
16.               )
17.               (setq lst (vl-remove p0 lst))
18.               (setq lst (append (list p0) lst))
19.               (setq lst
20.                   (vl-sort lst
21.                       (function
22.                           (lambda ( a b / c d )
23.                               (if (or (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8) (and (or (equal c 0.0 1e-8) (equal c (* 2 pi) 1e-8)) (or (equal d 0.0 1e-8) (equal d (* 2 pi) 1e-8))))
24.                                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
25.                                   (< c d)
26.                               )
27.                           )
28.                       )
29.                   )
30.               )
31.               (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
32.               (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
33.               (setq lstl (vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
34.               (setq lst (append lst lstl))
35.               (setq ch (list (cadr lst) (car lst)))
36.               (foreach pt (cddr lst)
37.                   (setq ch (cons pt ch))
38.                   (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
39.                       (setq ch (cons pt (cddr ch)))
40.                   )
41.               )
42.               (reverse ch)
43.           )
44.       )
45.   )
46.  
47.   ;; Clockwise-p  -  Lee Mac
48.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
49.  
50.   (defun LM:Clockwise-p ( p1 p2 p3 )
51.       (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
52.               (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
53.           )
54.           0.0
55.       )
56.   )
57.  
58.   (setq ss (ssget '((0 . "POINT"))))
59.   (repeat (setq i (sslength ss))
60.     (setq pl (cons (mapcar (function +) '(0 0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
61.   )
62.   (setq ti (car (_vl-times)))
63.   (setq pln (LM:ConvexHull-ptsonHull pl))
64.   (foreach p pln
65.     (setq pl (vl-remove p pl))
66.   )
67.   (while pl
68.     (setq ppl (LM:ConvexHull-ptsonHull pl))
69.     (if (< (length ppl) 4)
70.       (setq ppl (vl-sort ppl (function (lambda ( a b ) (< (distance (car pln) a) (distance (car pln) b))))))
71.     )
72.     (foreach p ppl
73.       (setq pl (vl-remove p pl))
74.     )
75.     (setq ppll (append ppll (reverse ppl)))
76.     (setq ppl nil)
77.   )
78.   (setq pl ppll)
79.   (while pl
80.     (foreach p pl
81.       (setq k -1)
82.       (repeat (length pln)
83.         (setq k (1+ k))
84.         (setq plp (reverse (member (nth k pln) (reverse pln))))
85.         (setq pls (cdr (member (nth k pln) pln)))
86.         (setq pll (append plp (list p) pls))
87.         (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pll (append (cdr pll) (list (car pll))))))
88.         (setq r (cons (list d pll) r))
89.       )
90.     )
91.     (setq r (vl-sort r (function (lambda ( a b ) (< (car a) (car b))))))
92.     (setq r (vl-remove-if-not (function (lambda ( x ) (equal (caar r) (car x) 1e-8))) r))
93.     (setq dmin 1e+99)
94.     (foreach xx (mapcar (function cadr) r)
95.       (if (vl-remove (vl-some (function (lambda ( x ) (if (vl-position x pl) x))) xx) pl)
96.         (foreach p (vl-remove (vl-some (function (lambda ( x ) (if (vl-position x pl) x))) xx) pl)
97.           (setq k -1)
98.           (repeat (length xx)
99.             (setq k (1+ k))
100.             (setq plp (reverse (member (nth k xx) (reverse xx))))
101.             (setq pls (cdr (member (nth k xx) xx)))
102.             (setq pll (append plp (list p) pls))
103.             (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pll (append (cdr pll) (list (car pll))))))
104.             (if (< d dmin)
105.               (setq dmin d r pll pp (vl-remove nil (mapcar (function (lambda ( x ) (if (vl-position x pl) x))) pll)))
106.             )
107.           )
108.         )
109.         (setq r nil pln xx)
110.       )
111.     )
112.     (if r
113.       (progn
114.         (setq pln r)
115.         (foreach x pp
116.           (setq pl (vl-remove x pl))
117.         )
118.         (setq r nil pp nil)
119.       )
120.       (setq pl nil)
121.     )
122.   )
123.   (setq lil (mapcar (function (lambda ( a b ) (list a b))) pln (append (cdr pln) (list (car pln)))))
124.   (while (vl-some (function (lambda ( li1 ) (vl-some (function (lambda ( li2 ) (if (and (setq ip (inters (car li1) (cadr li1) (car li2) (cadr li2))) (not (equal ip (car li1) 1e-8)) (not (equal ip (cadr li1) 1e-8)) (not (equal ip (car li2) 1e-8)) (not (equal ip (cadr li2) 1e-8))) (setq lii1 li1 lii2 li2)))) (vl-remove li1 lil)))) lil)
125.     (setq lil1 (if (member lii2 (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil))))))) (reverse (cdr (member lii2 (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil))))))))) (reverse (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil)))))))))
126.     (setq lil2 (if (member lii1 (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil))))))) (cdr (member lii1 (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil)))))))) (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil))))))))
127.     (setq lil (append lil1 (list (list (cadr (last lil1)) (cadr (car lil2)))) (mapcar (function reverse) lil2) (list (list (car (last lil2)) (car (car lil1))))))
128.   )
129.   (setq pln (mapcar (function car) lil))
130.   (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pln (append (cdr pln) (list (car pln))))))
131.   (entmake
132.     (append
133.       (list
134.         '(0 . "LWPOLYLINE")
135.         '(100 . "AcDbEntity")
136.         '(100 . "AcDbPolyline")
137.         (cons 90 (length pln))
138.         (cons 70 (1+ (* (getvar 'plinegen) 128)))
139.         '(38 . 0.0)
140.       )
141.       (mapcar (function (lambda ( x ) (cons 10 x))) pln)
142.       (list
143.         '(210 0.0 0.0 1.0)
144.         '(62 . 1)
145.       )
146.     )
147.   )
148.   (prompt "\nDistance : ") (princ (rtos d 2 50))
149.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds...")
150.   (princ)
151. )
152.  

M.R.
Now nullptr and Evgeniy are known for fast algorithms, maybe they can improve it to be faster, but I doubt given the code it is now (nothing much you can't remove not to loose main objective - shortness of TSP 2D)...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on December 16, 2018, 01:42:42 PM

Hi, it's me again...
I've speed up my code, but be aware that it may not yield better result... For lst-a (grid like patterns) speed is much better, if you choose shorter fuzz, it will be faster, but distance may be worse... The best for grid like patterns is to choose big fuzz, but it may be so slooow that you maight not even get result... So this is some kind of greedy algorithm improvement, and I think, because of slowness of my version, it was necessity...

Code - Auto/Visual Lisp: [Select]

1. (defun c:TSP-2D-MR ( / LM:ConvexHull-ptsonHull LM:Clockwise-p unique car-sort ss fuzz ti i pl pln dmin k plp pld pll d dl r rr pp lil lii1 lii2 lil1 lil2 ip ppp pps f )
2.  
3.   ;; Convex Hull  -  Lee Mac
4.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
5.  
6.   (defun LM:ConvexHull-ptsonHull ( lst / ch p0 lstl )
7.       (cond
8.           (   (< (length lst) 4) lst)
9.           (   (setq p0 (car lst))
10.               (foreach p1 (cdr lst)
11.                   (if (or (< (cadr p1) (cadr p0))
12.                           (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
13.                       )
14.                       (setq p0 p1)
15.                   )
16.               )
17.               (setq lst (vl-remove p0 lst))
18.               (setq lst (append (list p0) lst))
19.               (setq lst
20.                   (vl-sort lst
21.                       (function
22.                           (lambda ( a b / c d )
23.                               (if (or (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8) (and (or (equal c 0.0 1e-8) (equal c (* 2 pi) 1e-8)) (or (equal d 0.0 1e-8) (equal d (* 2 pi) 1e-8))))
24.                                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
25.                                   (< c d)
26.                               )
27.                           )
28.                       )
29.                   )
30.               )
31.               (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
32.               (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
33.               (setq lstl (vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
34.               (setq lst (append lst lstl))
35.               (setq ch (list (cadr lst) (car lst)))
36.               (foreach pt (cddr lst)
37.                   (setq ch (cons pt ch))
38.                   (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
39.                       (setq ch (cons pt (cddr ch)))
40.                   )
41.               )
42.               (reverse ch)
43.           )
44.       )
45.   )
46.  
47.   ;; Clockwise-p  -  Lee Mac
48.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
49.  
50.   (defun LM:Clockwise-p ( p1 p2 p3 )
51.       (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
52.               (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
53.           )
54.           0.0
55.       )
56.   )
57.  
58.   (defun unique ( l )
59.     (if l
60.       (cons (car l)
61.         (unique (vl-remove-if (function (lambda ( x ) (equal x (car l) 1e-8))) l))
62.       )
63.     )
64.   )
65.  
66.   ;;; (car-sort '(2 4 1 3 5 1) '<) => nil
67.   ;;; (car-sort '(2 4 1 3 5 1) '<=) => 1
68.   (defun car-sort ( l f / removenth r k )
69.  
70.     (defun removenth ( l n / k )
71.       (setq k -1)
72.       (vl-remove-if (function (lambda ( x ) (= (setq k (1+ k)) n))) l)
73.     )
74.  
75.     (setq k -1)
76.     (vl-some (function (lambda ( a ) (setq k (1+ k)) (if (vl-every (function (lambda ( x ) (apply f (list a x)))) (removenth l k)) (setq r a)))) l)
77.     r
78.   )
79.  
80.   (setq ss (ssget '((0 . "POINT"))))
81.   (repeat (setq i (sslength ss))
82.     (setq pl (cons (mapcar (function +) '(0 0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
83.   )
84.   (initget 7)
85.   (setq fuzz (getdist "\nPick or specify radius of point cloud fuzz : "))
86.   (setq ti (car (_vl-times)))
87.   (setq pln (LM:ConvexHull-ptsonHull pl))
88.   (foreach p pln
89.     (setq pl (vl-remove p pl))
90.   )
91.   (setq ppp (vl-remove-if-not (function (lambda ( p ) (< (distance p (car pln)) fuzz))) pl))
92.   (while pl
93.     (foreach p (if (null ppp) pl ppp)
94.       (setq k -1)
95.       (repeat (length pln)
96.         (setq k (1+ k))
97.         (setq plp (reverse (member (nth k pln) (reverse pln))))
98.         (setq pls (cdr (member (nth k pln) pln)))
99.         (setq pll (append plp (list p) pls))
100.         (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pll (append (cdr pll) (list (car pll))))))
101.         (setq r (cons (list d pll) r))
102.       )
103.     )
104.     ;|
105.     (setq r (vl-sort r (function (lambda ( a b ) (< (car a) (car b))))))
106.     (setq dl (unique (mapcar (function car) r)))
107.     ;(cond
108.     ;  ( (cadddr dl)
109.     ;    (setq d (cadddr dl))
110.     ;  )
111.     ;  ( (caddr dl)
112.     ;    (setq d (caddr dl))
113.     ;  )
114.     ;  ( (cadr dl)
115.     ;    (setq d (cadr dl))
116.     ;  )
117.     ;  ( t
118.     ;    (setq d (car dl))
119.     ;  )
120.     ;)
121.     (setq d (last dl))
122.     (setq r (vl-remove-if-not (function (lambda ( x ) (<= (car x) d))) r))
123.     |;
124.     (setq dmin 1e+99)
125.     (foreach xx (mapcar (function cadr) r)
126.       (if (vl-remove (vl-some (function (lambda ( x ) (if (vl-position x pl) x))) xx) pl)
127.         (foreach p (if (null (vl-remove (vl-some (function (lambda ( x ) (if (vl-position x pl) x))) xx) ppp)) (vl-remove (vl-some (function (lambda ( x ) (if (vl-position x pl) x))) xx) pl) (vl-remove (vl-some (function (lambda ( x ) (if (vl-position x pl) x))) xx) ppp))
128.           (setq k -1)
129.           (repeat (length xx)
130.             (setq k (1+ k))
131.             (setq plp (reverse (member (nth k xx) (reverse xx))))
132.             (setq pls (cdr (member (nth k xx) xx)))
133.             (setq pll (append plp (list p) pls))
134.             (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pll (append (cdr pll) (list (car pll))))))
135.             (if (< d dmin)
136.               (setq dmin d r pll pp (vl-remove nil (mapcar (function (lambda ( x ) (if (vl-position x pl) x))) pll)) rr (cons (list d r pp) rr))
137.             )
138.           )
139.         )
140.         (progn
141.           (setq k -1)
142.           (repeat (length xx)
143.             (setq k (1+ k))
144.             (setq plp (reverse (member (nth k xx) (reverse xx))))
145.             (setq pls (cdr (member (nth k xx) xx)))
146.             (setq pll (append plp (list (car pl)) pls))
147.             (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pll (append (cdr pll) (list (car pll))))))
148.             (if (< d dmin)
149.               (setq dmin d r pll pp (vl-remove nil (mapcar (function (lambda ( x ) (if (vl-position x pl) x))) pll)) rr (cons (list d r pp) rr))
150.             )
151.           )
152.           (setq f t)
153.         )
154.       )
155.     )
156.     (if f
157.       (setq pln (cadr (car-sort rr (function (lambda ( a b ) (<= (car a) (car b)))))) r nil)
158.       (progn
159.         (setq rr (car-sort rr (function (lambda ( a b ) (<= (car a) (car b))))))
160.         (setq r (cadr rr) pp (caddr rr) rr nil)
161.       )
162.     )
163.     (if r
164.       (progn
165.         (setq pln r ppp nil)
166.         (foreach x pp
167.           (setq pl (vl-remove x pl))
168.         )
169.         (foreach x pp
170.           (setq pps (vl-remove-if-not (function (lambda ( p ) (< (distance p x) fuzz))) pl))
171.           (setq pps (vl-remove-if (function (lambda ( p ) (vl-position p ppp))) pps))
172.           (setq ppp (append pps ppp))
173.         )
174.         (setq r nil pp nil)
175.       )
176.       (setq pl nil)
177.     )
178.   )
179.   (setq lil (mapcar (function (lambda ( a b ) (list a b))) pln (append (cdr pln) (list (car pln)))))
180.   (while (vl-some (function (lambda ( li1 ) (vl-some (function (lambda ( li2 ) (if (and (setq ip (inters (car li1) (cadr li1) (car li2) (cadr li2))) (not (equal ip (car li1) 1e-8)) (not (equal ip (cadr li1) 1e-8)) (not (equal ip (car li2) 1e-8)) (not (equal ip (cadr li2) 1e-8))) (setq lii1 li1 lii2 li2)))) (vl-remove li1 lil)))) lil)
181.     (setq lil1 (if (member lii2 (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil))))))) (reverse (cdr (member lii2 (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil))))))))) (reverse (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil)))))))))
182.     (setq lil2 (if (member lii1 (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil))))))) (cdr (member lii1 (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil)))))))) (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil))))))))
183.     (setq lil (append lil1 (list (list (cadr (last lil1)) (cadr (car lil2)))) (mapcar (function reverse) lil2) (list (list (car (last lil2)) (car (car lil1))))))
184.   )
185.   (setq pln (mapcar (function car) lil))
186.   (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pln (append (cdr pln) (list (car pln))))))
187.   (entmake
188.     (append
189.       (list
190.         '(0 . "LWPOLYLINE")
191.         '(100 . "AcDbEntity")
192.         '(100 . "AcDbPolyline")
193.         (cons 90 (length pln))
194.         (cons 70 (1+ (* (getvar 'plinegen) 128)))
195.         '(38 . 0.0)
196.       )
197.       (mapcar (function (lambda ( x ) (cons 10 x))) pln)
198.       (list
199.         '(210 0.0 0.0 1.0)
200.         '(62 . 1)
201.       )
202.     )
203.   )
204.   (prompt "\nDistance : ") (princ (rtos d 2 50))
205.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds...")
206.   (princ)
207. )
208.  

Regards, M.R.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on January 04, 2019, 04:59:41 AM

Hi again, my latest revision... I returned back to slow but perhaps more reliable coding... Although its maximum is about 20 points for factor 2, that's also better than brute force... For 3, 4, ... don't even think you'll see the result - its computing large lists and may never finish... So I suggest default 1 and hope that result will be optimal as much as possible, if not then you are practically doomed like with brute force... I'll also input version for start-end in the topic by user @handasa - there is link for it when I compete with @nullptr - Daniel - I post it somewhere in the middle when it was started...

Code - Auto/Visual Lisp: [Select]

1. (defun c:TSP-2D-MR ( / LM:ConvexHull-ptsonHull LM:Clockwise-p car-sort plstdiff processrs ss ti i pl pln k plp pld pll d r rr ppp lil lii1 lii2 lil1 lil2 ip f kk n )
2.  
3.   ;; Convex Hull  -  Lee Mac
4.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
5.  
6.   (defun LM:ConvexHull-ptsonHull ( lst / ch p0 lstl )
7.       (cond
8.           (   (< (length lst) 4) lst)
9.           (   (setq p0 (car lst))
10.               (foreach p1 (cdr lst)
11.                   (if (or (< (cadr p1) (cadr p0))
12.                           (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
13.                       )
14.                       (setq p0 p1)
15.                   )
16.               )
17.               (setq lst (vl-remove p0 lst))
18.               (setq lst (append (list p0) lst))
19.               (setq lst
20.                   (vl-sort lst
21.                       (function
22.                           (lambda ( a b / c d )
23.                               (if (or (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8) (and (or (equal c 0.0 1e-8) (equal c (* 2 pi) 1e-8)) (or (equal d 0.0 1e-8) (equal d (* 2 pi) 1e-8))))
24.                                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
25.                                   (< c d)
26.                               )
27.                           )
28.                       )
29.                   )
30.               )
31.               (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
32.               (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
33.               (setq lstl (vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
34.               (setq lst (append lst lstl))
35.               (setq ch (list (cadr lst) (car lst)))
36.               (foreach pt (cddr lst)
37.                   (setq ch (cons pt ch))
38.                   (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
39.                       (setq ch (cons pt (cddr ch)))
40.                   )
41.               )
42.               (reverse ch)
43.           )
44.       )
45.   )
46.  
47.   ;; Clockwise-p  -  Lee Mac
48.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
49.  
50.   (defun LM:Clockwise-p ( p1 p2 p3 )
51.       (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
52.               (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
53.           )
54.           0.0
55.       )
56.   )
57.  
58.   ;;; (car-sort '(2 4 1 3 5 1) '<) => nil
59.   ;;; (car-sort '(2 4 1 3 5 1) '<=) => 1
60.   (defun car-sort ( l f / removenth r k )
61.  
62.     (defun removenth ( l n / k )
63.       (setq k -1)
64.       (vl-remove-if (function (lambda ( x ) (= (setq k (1+ k)) n))) l)
65.     )
66.  
67.     (setq k -1)
68.     (vl-some (function (lambda ( a ) (setq k (1+ k)) (if (vl-every (function (lambda ( x ) (apply f (list a x)))) (removenth l k)) (setq r a)))) l)
69.     r
70.   )
71.  
72.   (defun plstdiff ( l1 l2 )
73.     (foreach p l1
74.       (setq l2 (vl-remove p l2))
75.     )
76.     l2
77.   )
78.  
79.   (defun processrs ( r / rr )
80.     (foreach xx r
81.       (if (and (null f) (if (equal xx pln) (setq ppp pl) (setq ppp (plstdiff xx pl))))
82.         (foreach p ppp
83.           (setq k -1)
84.           (repeat (length xx)
85.             (setq k (1+ k))
86.             (setq plp (reverse (member (nth k xx) (reverse xx))))
87.             (setq pls (cdr (member (nth k xx) xx)))
88.             (setq pll (append plp (list p) pls))
89.             (setq rr (cons pll rr))
90.           )
91.         )
92.         (setq f t)
93.       )
94.     )
95.     (if f
96.       (progn
97.         (setq pl nil)
98.         r
99.       )
100.       (if (= kk n)
101.         (progn
102.           (setq kk 0)
103.           (setq rr (mapcar (function (lambda ( x ) (list (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) x (append (cdr x) (list (car x))))) x))) rr))
104.           (setq rr (list (cadr (car-sort rr (function (lambda ( a b ) (<= (car a) (car b))))))))
105.         )
106.         rr
107.       )
108.     )
109.   )
110.  
111.   (setq ss (ssget '((0 . "POINT"))))
112.   (repeat (setq i (sslength ss))
113.     (setq pl (cons (mapcar (function +) '(0 0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
114.   )
115.   (initget 6)
116.   (setq n (getint "\nSpecify speed factor - reliability - [1-fast/2-slow] <1> : "))
117.   (if (null n)
118.     (setq n 1)
119.   )
120.   (setq ti (car (_vl-times)))
121.   (setq pln (LM:ConvexHull-ptsonHull pl))
122.   (foreach p pln
123.     (setq pl (vl-remove p pl))
124.   )
125.   (setq kk 0)
126.   (while pl
127.     (setq kk (1+ kk))
128.     (if (null rr)
129.       (setq rr (processrs (list pln)))
130.       (setq rr (processrs rr))
131.     )
132.   )
133.   (setq rr (mapcar (function (lambda ( x ) (list (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) x (append (cdr x) (list (car x))))) x))) rr))
134.   (setq pln (cadr (car-sort rr (function (lambda ( a b ) (<= (car a) (car b)))))))
135.   (setq lil (mapcar (function (lambda ( a b ) (list a b))) pln (append (cdr pln) (list (car pln)))))
136.   (while (vl-some (function (lambda ( li1 ) (vl-some (function (lambda ( li2 ) (if (and (setq ip (inters (car li1) (cadr li1) (car li2) (cadr li2))) (not (equal ip (car li1) 1e-8)) (not (equal ip (cadr li1) 1e-8)) (not (equal ip (car li2) 1e-8)) (not (equal ip (cadr li2) 1e-8))) (setq lii1 li1 lii2 li2)))) (vl-remove li1 lil)))) lil)
137.     (setq lil1 (if (member lii2 (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil))))))) (reverse (cdr (member lii2 (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil))))))))) (reverse (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil)))))))))
138.     (setq lil2 (if (member lii1 (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil))))))) (cdr (member lii1 (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil)))))))) (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil))))))))
139.     (setq lil (append lil1 (list (list (cadr (last lil1)) (cadr (car lil2)))) (mapcar (function reverse) lil2) (list (list (car (last lil2)) (car (car lil1))))))
140.   )
141.   (setq pln (mapcar (function car) lil))
142.   (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pln (append (cdr pln) (list (car pln))))))
143.   (entmake
144.     (append
145.       (list
146.         '(0 . "LWPOLYLINE")
147.         '(100 . "AcDbEntity")
148.         '(100 . "AcDbPolyline")
149.         (cons 90 (length pln))
150.         (cons 70 (1+ (* (getvar 'plinegen) 128)))
151.         '(38 . 0.0)
152.       )
153.       (mapcar (function (lambda ( x ) (cons 10 x))) pln)
154.       (list
155.         '(210 0.0 0.0 1.0)
156.         '(62 . 1)
157.       )
158.     )
159.   )
160.   (prompt "\nDistance : ") (princ (rtos d 2 50))
161.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds...")
162.   (princ)
163. )
164.  

P.S. If you are lucky enough that your points almost all form shape of ConvexHull then it will be fast and reliable, but if not, then you'll have to wait and only hope for correct result... So this is actually my remark to remove doubts that TSP can be solved, but never give up... chlh_jd's code is fast and superior to my versions, but still not full reliable answer, I mean, so what if it can finish in 1 second, when you don't get correct result, you can get only close to correct...

Regards, happy New Year holidays...
M.R.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: mailmaverick on March 26, 2019, 07:43:15 AM

Hi All

Out of the various routines given by various people, which one is the latest / fastest / best ?

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on March 26, 2019, 08:20:25 AM

Quote from: mailmaverick on March 26, 2019, 07:43:15 AM

Hi All

Out of the various routines given by various people, which one is the latest / fastest / best ?

Hi, I am finally using CADSTUDIO's SHORTPATH.VLX with my additional LISP that calls it and then checks for intersecting lines with Evgeniy's method and prompts total length of path in 15 decimal places precision...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ronjonp on March 26, 2019, 08:23:38 AM

Quote from: mailmaverick on March 26, 2019, 07:43:15 AM

Hi All

Out of the various routines given by various people, which one is the latest / fastest / best ?

The latest is right before your post  :-P .. the solutions in here vary based on the length of the list being processed. You'll have to test to see what works for you.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on May 22, 2020, 03:17:16 PM

Hi there...
Long time I haven't played with TSP...
I decided to post my latest version to see if someone will reply and give me any comments... For now it proved the most comprehensive for me... Only problem I see is that it's slow with minimal input options... For example if you use depth 1 and 1 solution attempt per depth iteration it is still very slow... The point now is that if you input depth smaller than maximum (number of free points inside convex hull), you can watch lwpolyline changing its shape until routine finishes task... So for speed computation and with best quality/speed I still recommend shortpath.vlx... This is only if you have specific task to do and you must be sure result is perfect - so you specify maximal input options (greatest depth allowed and all solution attempts <all> and then <100%> as percentage of attempts per depth iterations)... If you have more than 10 free points inside convex hull, you'll have to wait for a very long time, but if you have less than 10, then I suggest depending on PC that you input maximal values and still wait until it finishes... This is very complex problem and it requires very long computations, so just for fun and experimentation you may use this code, but at your own risk that you'll loose el. energy and time if PC is with low performances like my PC (old over 20 years)...

Code - Auto/Visual Lisp: [Select]

1. (defun c:TSP-2D-MR-LATEST-NEW ( / LM:ConvexHull-ptsonHull LM:Clockwise-p sort processpt depth _do-events cmde ss n m j i p ppp pl pll plll pllll lw lwx lil k ilil pre mid suf dmin d ti )
2.  
3.   ;; Convex Hull  -  Lee Mac
4.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
5.  
6.   (defun LM:ConvexHull-ptsonHull ( lst / ch p0 lstl )
7.     (cond
8.       ( (< (length lst) 4) lst)
9.       ( (setq p0 (car lst))
10.         (foreach p1 (cdr lst)
11.           (if (or (< (cadr p1) (cadr p0))
12.                   (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
13.               )
14.               (setq p0 p1)
15.           )
16.         )
17.         (setq lst (vl-remove p0 lst))
18.         (setq lst (append (list p0) lst))
19.         (setq lst
20.           (vl-sort lst
21.             (function
22.               (lambda ( a b / c d )
23.                 (if (or (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8) (and (or (equal c 0.0 1e-8) (equal c (* 2 pi) 1e-8)) (or (equal d 0.0 1e-8) (equal d (* 2 pi) 1e-8))))
24.                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
25.                   (< c d)
26.                 )
27.               )
28.             )
29.           )
30.         )
31.         (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
32.         (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
33.         (setq lstl (vl-sort lstl (function (lambda ( a b ) (> (distance p0 a) (distance p0 b))))))
34.         (setq lst (append lst lstl))
35.         (setq ch (list (cadr lst) (car lst)))
36.         (foreach pt (cddr lst)
37.           (setq ch (cons pt ch))
38.           (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
39.             (setq ch (cons pt (cddr ch)))
40.           )
41.         )
42.         (reverse ch)
43.       )
44.     )
45.   )
46.  
47.   ;; Clockwise-p  -  Lee Mac
48.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
49.  
50.   (defun LM:Clockwise-p ( p1 p2 p3 )
51.     (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
52.             (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
53.         )
54.         0.0
55.     )
56.   )
57.  
58.   (defun sort ( l )
59.     (vl-sort l (function (lambda ( a b ) (< (apply (function +) (mapcar (function (lambda ( c d ) (distance c d))) a (append (cdr a) (list (car a))))) (apply (function +) (mapcar (function (lambda ( c d ) (distance c d))) b (append (cdr b) (list (car b)))))))))
60.   )
61.  
62.   (defun processpt ( ppp p j / ppl pll plll pllll )
63.     (gc)
64.     (if j
65.       (progn
66.         (foreach pp ppp
67.           (setq ppl (append (member pp ppp) (reverse (cdr (member pp (reverse ppp))))))
68.           (setq pll (append (list pp) (list p) (cdr ppl)))
69.           (setq plll (cons pll plll))
70.         )
71.         (setq plll (sort plll))
72.         (repeat j
73.           (if (car plll)
74.             (setq pllll (cons (car plll) pllll))
75.           )
76.           (setq plll (cdr plll))
77.         )
78.       )
79.       (progn
80.         (foreach pp ppp
81.           (setq ppl (append (member pp ppp) (reverse (cdr (member pp (reverse ppp))))))
82.           (setq pll (append (list pp) (list p) (cdr ppl)))
83.           (setq plll (cons pll plll))
84.         )
85.         (setq pllll plll)
86.       )
87.     )
88.     pllll
89.   )
90.  
91.   (defun depth ( plll m / unique trimbynum trimbyperc ff plr pllll )
92.  
93.     (defun unique ( l / x ll f1 f2 )
94.  
95.       (defun f1 ( a b ) (equal a b 1e-6))
96.  
97.       (defun f2 ( y ) (vl-every (function f1) y (member (car y) x)))
98.  
99.       (gc)
100.       (while (setq x (car l))
101.         (setq ll (cons x ll)
102.               x  (append x x)
103.               l  (vl-remove-if (function f2) (cdr l))
104.         )
105.       )
106.       ll
107.     )
108.  
109.     (defun trimbynum ( l m / ll )
110.       (if (< m (length l))
111.         (progn
112.           (repeat m
113.             (setq ll (cons (car l) ll))
114.             (setq l (cdr l))
115.           )
116.           (setq ll (reverse ll))
117.         )
118.         (setq ll l)
119.       )
120.       ll
121.     )
122.  
123.     (defun trimbyperc ( l m / ll )
124.       (if (< m 100)
125.         (progn
126.           (repeat (fix (* (length l) (/ m 100.0)))
127.             (setq ll (cons (car l) ll))
128.             (setq l (cdr l))
129.           )
130.           (setq ll (reverse ll))
131.         )
132.         (setq ll l)
133.       )
134.       ll
135.     )
136.  
137.     (defun ff ( x )
138.       (vl-position x lww)
139.     )
140.  
141.     (if m
142.       (progn
143.         (setq plll (unique plll))
144.         (if (= (type m) 'INT)
145.           (foreach lww (trimbynum (if (< m (length plll)) (sort plll) plll) m)
146.             (setq plr (vl-remove-if (function ff) pl))
147.             (foreach p plr
148.               (setq pllll (append (processpt lww p j) pllll))
149.             )
150.           )
151.           (foreach lww (trimbyperc (if (< m 100) (sort plll) plll) m)
152.             (setq plr (vl-remove-if (function ff) pl))
153.             (foreach p plr
154.               (setq pllll (append (processpt lww p j) pllll))
155.             )
156.           )
157.         )
158.       )
159.       (foreach lww (unique plll)
160.         (setq plr (vl-remove-if (function ff) pl))
161.         (foreach p plr
162.           (setq pllll (append (processpt lww p j) pllll))
163.         )
164.       )
165.     )
166.     pllll
167.   )
168.  
169.   (defun _do-events nil
170.     (gc)
171.     (repeat 2 (vl-cmdf "_.DELAY" 0) (princ ""))
172.   )
173.  
174.   (setq cmde (getvar 'cmdecho))
175.   (setvar 'cmdecho 0)
176.   (if
177.     (and
178.       (princ "\nSelect points, blocks or circles in WCS...")
179.       (setq ss (ssget '((0 . "POINT,CIRCLE,INSERT"))))
180.     )
181.     (progn
182.       (repeat (setq i (sslength ss))
183.         (setq p (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))))
184.         (setq pl (cons (mapcar (function +) '(0 0) p) pl))
185.       )
186.       (setq pll (LM:ConvexHull-ptsonHull pl))
187.       (setq lw
188.         (entmakex
189.           (append
190.             (list
191.               '(0 . "LWPOLYLINE")
192.               '(100 . "AcDbEntity")
193.               '(100 . "AcDbPolyline")
194.               (cons 90 (length pll))
195.               (cons 70 (1+ (* 128 (getvar 'plinegen))))
196.               '(38 . 0.0)
197.             )
198.             (mapcar (function (lambda ( x ) (cons 10 x))) pll)
199.             '((210 0.0 0.0 1.0))
200.           )
201.         )
202.       )
203.       (setq lwx (entget lw))
204.       (setq pl (vl-remove-if (function (lambda ( x ) (vl-position x pll))) pl))
205.       (initget 6)
206.       (setq n (getint (strcat "\nSpecify depth number - positive integer - from 1 to " (itoa (length pl)) " - preferable 3 <" (itoa (length pl)) "> : ")))
207.       (if (null n)
208.         (setq n (length pl))
209.       )
210.       (while (> n (length pl))
211.         (prompt "\nYou specified number greater than : ") (princ (length pl))
212.         (initget 6)
213.         (setq n (getint (strcat "\nSpecify depth number - positive integer - from 1 to " (itoa (length pl)) " - preferable 3 <" (itoa (length pl)) "> : ")))
214.         (if (null n)
215.           (setq n (length pl))
216.         )
217.       )
218.       (if (/= n (length pl))
219.         (progn
220.           (initget 4)
221.           (setq i (getreal "\nIncremental depth - preferable 0 <1> - you can specify 1.5, 0.5, 0.33333334, 0.25 : "))
222.           (if (null i)
223.             (setq i 1)
224.           )
225.           (while (or (and (minusp (- (length pl) n n)) (> i 0)) (> i (- (length pl) n n) 0))
226.             (prompt "\nYou specified number greater than : ") (if (minusp (- (length pl) n n)) (prompt "0 - you must specify \"0\"") (princ (- (length pl) n n)))
227.             (initget 4)
228.             (setq i (getreal "\nIncremental depth - preferable 0 <1> - you can specify 1.5, 0.5, 0.33333334, 0.25 : "))
229.             (if (null i)
230.               (setq i 1)
231.             )
232.           )
233.         )
234.       )
235.       (initget 6)
236.       (setq m (getint (strcat "\nSpecify number of solution attempts per depth iteration - preferable " (itoa (fix (/ 1600.0 (length pl)))) " <all> : ")))
237.       (if (null m)
238.         (progn
239.           (initget 6)
240.           (setq m (getreal "\nSpecify percentage of solution attempts per depth iteration <100%> : "))
241.           (while (and m (> m 100))
242.             (prompt "\nYou specified number greater than 100...")
243.             (initget 6)
244.             (setq m (getreal "\nSpecify percentage of solution attempts per depth iteration <100%> : "))
245.           )
246.         )
247.       )
248.       (initget 6)
249.       (setq j (getint "\nSpecify number of list length processed by (processpt) sub function - preferable 2 <all> : "))
250.       (setq ti (car (_vl-times)))
251.       (setq ppp pll)
252.       (while pl
253.         (if (not (equal ppp pll))
254.           (setq n (+ n i))
255.         )
256.         (foreach p pl
257.           (setq plll (append (processpt ppp p j) plll))
258.         )
259.         (setq pllll plll)
260.         (repeat (if (<= (fix n) (length pl)) (1- (fix n)) (1- (length pl)))
261.           (setq pllll (depth pllll m))
262.         )
263.         (setq dmin 1e+308)
264.         (foreach xxx pllll
265.           (if (and xxx (< (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) xxx (append (cdr xxx) (list (car xxx)))))) dmin))
266.             (setq dmin d pllll xxx)
267.           )
268.         )
269.         (entupd
270.           (cdr
271.             (assoc -1
272.               (entmod
273.                 (setq lwx
274.                   (append
275.                     (subst (cons 90 (length pllll)) (assoc 90 lwx) (reverse (cdr (member (assoc 10 lwx) (reverse lwx)))))
276.                     (mapcar (function (lambda ( x ) (cons 10 x))) pllll)
277.                   )
278.                 )
279.               )
280.             )
281.           )
282.         )
283.         (setq pl (vl-remove-if (function (lambda ( x ) (vl-position x pllll))) pl))
284.         (setq ppp pllll)
285.         (_do-events)
286.         (redraw lw)
287.         (setq plll nil pllll nil)
288.       )
289.       (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) lwx)))
290.       (setq lil (mapcar (function list) pl (append (cdr pl) (list (car pl)))))
291.       (setq k -1)
292.       (while (and (< (setq k (1+ k)) (length lil)) (setq a (nth k lil)))
293.         (setq ilil (vl-some (function (lambda ( b / ip ) (setq ip (inters (car a) (cadr a) (car b) (cadr b))) (if (and ip (setq ip (mapcar (function +) '(0 0) ip)) (or (and (or (equal ip (car a) 1e-6) (equal ip (cadr a) 1e-6)) (not (equal ip (car b) 1e-6)) (not (equal ip (cadr b) 1e-6))) (and (or (equal ip (car b) 1e-6) (equal ip (cadr b) 1e-6)) (not (equal ip (car a) 1e-6)) (not (equal ip (cadr a) 1e-6))) (and (not (equal ip (car a) 1e-6)) (not (equal ip (cadr a) 1e-6)) (not (equal ip (car b) 1e-6)) (not (equal ip (cadr b) 1e-6))))) (list a b)))) (vl-remove a lil)))
294.         (if ilil
295.           (progn
296.             (setq pre (reverse (cdr (member (car ilil) (reverse lil)))))
297.             (setq mid (cdr (member (car ilil) lil)))
298.             (setq mid (cdr (member (cadr ilil) (reverse mid))))
299.             (setq mid (mapcar (function reverse) mid))
300.             (setq suf (cdr (member (cadr ilil) lil)))
301.             (setq lil (append pre (list (list (car (car ilil)) (car (cadr ilil)))) mid (list (list (cadr (car ilil)) (cadr (cadr ilil)))) suf))
302.             (setq pre nil mid nil suf nil)
303.             (setq pl (mapcar (function car) lil))
304.             (entupd
305.               (cdr
306.                 (assoc -1
307.                   (entmod
308.                     (append
309.                       (reverse (cdr (member (assoc 10 lwx) (reverse lwx))))
310.                       (mapcar (function (lambda ( x ) (cons 10 x))) pl)
311.                     )
312.                   )
313.                 )
314.               )
315.             )
316.             (_do-events)
317.             (redraw lw)
318.             (setq ilil nil k -1)
319.           )
320.         )
321.       )
322.     )
323.   )
324.   (setvar 'cmdecho cmde)
325.   (prompt "\nDistance : ") (princ (rtos (apply (function +) (mapcar (function distance) pl (append (cdr pl) (list (car pl))))) 2 20))
326.   (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
327.   (princ)
328. )
329.  

Stay well and be healthy my friends...
M.R.
 :-) :wink:

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on May 26, 2020, 07:39:03 AM

I see there is no comment for my code...
Just a thought, wouldn't be nice if someone would convert LISP into some faster language... I mean - this is TSP problem, so it needs boosting in speed of calculations... However I am not educated in other than LISP... Maybe if Daniel could see it, or Gilles (.NET)... But I need it for A2018, so maybe I am old with my wishes, but that's the problem with other languages (ObjectARX, C#, ... )... It would be the best if it could work faster than LISP, but compatible with all AutoCAD releases...

This is just my thought, no one replied, so I had to step in again...
Thanks for attention, M.R.

[EDIT : If someone succeds to translate LISP, just don't give some stupid command names for execution like : "DOIT", "TEST", ... It would be nice something like : "TSP-2D-LSP-CONVERTED" or similar...]

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: VovKa on May 26, 2020, 08:16:34 AM

Quote from: ribarm on May 26, 2020, 07:39:03 AM

I see there is no comment for my code...

because the code is long and rather difficult to read and understand

i'm pretty sure it could be optimized more
at least some simple things as

Code: [Select]

(setq mid (reverse (cdr (member (cadr ilil) (reverse mid)))))
(setq mid (reverse mid))


Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on May 26, 2020, 11:29:10 AM

Quote from: VovKa on May 26, 2020, 08:16:34 AM

i'm pretty sure it could be optimized more
at least some simple things as

Code: [Select]

(setq mid (reverse (cdr (member (cadr ilil) (reverse mid)))))
(setq mid (reverse mid))


I see...
So instead of those 2 lines, just replace them in my code (lastly portion - lines 298 and 299) with :

Code: [Select]

(setq mid (cdr (member (cadr ilil) (reverse mid))))

But this is really nothing in overall performance... I mean that we need boost in speed with *.arx or maybe *.dll that will replicate functionality of above posted LISP...

Thanks for reply, anyway...
[EDIT : Corrected my above posted code...]

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on May 26, 2020, 04:57:12 PM

Just to inform...

I've changed (processpt) sub function to be more efficient... To me the code looks now without evident lacks and ready for further process of translating/converting into faster programming language...

Regards...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on May 28, 2020, 09:59:30 AM

I have a problem LISP crashed in BricsCAD with this message :

Code: [Select]

; ----- LISP : Call Stack -----
; [0]...C:TSP-2D-MR-LATEST-NEW
; [1].....DEPTH
; [2].......UNIQUE # 1108 <<--
;
; ----- Error around expression -----
; (EQUAL A B 1.0e-06)
;
; error : out of LISP 'Heap' memory at [gc]

Then I've changed this portion :

Code - Auto/Visual Lisp: [Select]

1. ...
2.   (defun depth ( plll m / unique sort trimbynum trimbyperc plr pllll )
3.  
4.     (defun unique ( l )
5.       (gc)
6.       (if l (cons (car l) (unique (vl-remove-if (function (lambda ( x ) (vl-every (function (lambda ( a b ) (equal a b 1e-6))) x (member (car x) (append (car l) (car l)))))) l))))
7.     )
8. ...
9.  

As you can see I've added (gc) in recursive sub function...
But still I run it and it crashes at about the same place with this error message :

Code: [Select]

: TSP-2D-MR-LATEST-NEW

Select points, blocks or circles in WCS...
Select entities:
Opposite Corner:
Entities in set: 40
Select entities:
Specify depth number - positive integer - from 0 to 32 <32> :
Specify number of solution attempts per depth iteration - preferable 50 <all> : 100
Specify number of list length processed by (processpt) sub function - preferable 2 <all> : 4

; ----- LISP : Call Stack -----
; [0]...C:TSP-2D-MR-LATEST-NEW
; [1].....DEPTH
; [2].......UNIQUE # 1130 <<--
;
; ----- Error around expression -----
; (CAR L)
;
; error : out of LISP 'Heap' memory at [gc]

So how can I fix it?

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on May 28, 2020, 10:13:13 AM

Sorry it was my mistake, I forgot to owerwrite correct LISP which has (gc) added with old one which was loaded...
I am testing it again, we'll see how will it go...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on May 28, 2020, 10:31:36 AM

No it won't pass...
Now I have this :

Code: [Select]

: TSP-2D-MR-LATEST-NEW

Select points, blocks or circles in WCS...
Select entities:
Opposite Corner:
Entities in set: 40
Select entities:
Specify depth number - positive integer - from 0 to 32 <32> :
Specify number of solution attempts per depth iteration - preferable 50 <all> : 100
Specify number of list length processed by (processpt) sub function - preferable 2 <all> : 4

; ----- LISP : Call Stack -----
; [0]...C:TSP-2D-MR-LATEST-NEW
; [1].....DEPTH
; [2].......UNIQUE # 897 <<--
;
; ----- Error around expression -----
; (GC)
;
; error : out of LISP 'Heap' memory at [gc]

Can someone fix it?

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on May 28, 2020, 01:43:53 PM

It worked and in BricsCAD with those inputs... It looks like BricsCAD don't like recursions... So I've replaced (unique) with iterative version and it worked well...

Code - Auto/Visual Lisp: [Select]

1. ...
2.   (defun depth ( plll m / unique sort trimbynum trimbyperc plr pllll )
3.  
4.     (defun unique ( l / x ll )
5.       (while (setq x (car l))
6.         (setq ll (cons x ll))
7.         (setq l (vl-remove-if (function (lambda ( y ) (vl-every (function (lambda ( a b ) (equal a b 1e-6))) y (member (car y) (append x x))))) l))
8.       )
9.       ll
10.     )
11. ...
12.  

Regards, M.R.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: VovKa on May 28, 2020, 07:40:27 PM

Quote from: ribarm on May 26, 2020, 11:29:10 AM

But this is really nothing in overall performance...

this is true
but the devil is in the detail
i think you should spend more time on optimizing

Code: [Select]

(defun unique3 (l / x ll f1 f2)
  (defun f1 (a b) (equal a b 1e-6))
  (defun f2 (y) (vl-every 'f1 y (member (car y) x)))
  (while (setq x (car l))
    (setq ll (cons x ll)
  x  (append x x)
  l  (vl-remove-if 'f2 (cdr l))
    )
  )
  ll
)
your algorithm is unchanged but it is written in a more 'optimized' way
and i believe it will run a bit faster

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on May 29, 2020, 01:16:24 AM

But those are minimal improvements...

Code - Auto/Visual Lisp: [Select]

1. (defun c:test ( / l t0 t1 k f )
2.   (repeat 10
3.     (setq l (append l (atoms-family 1)))
4.   )
5.   (setq t0 (car (_vl-times)))
6.   (foreach a l
7.     (princ "")
8.   )
9.   (setq t1 (car (_vl-times)))
10.   (prompt "\nElapsed time for (foreach a l) : ") (princ (rtos (- t1 t0) 2 20)) (prompt " milliseconds...")
11.   (setq t0 (car (_vl-times)))
12.   (while (setq a (car l))
13.     (princ "")
14.     (setq l (cdr l))
15.   )
16.   (setq t1 (car (_vl-times)))
17.   (prompt "\nElapsed time for (while (setq a (car l))) : ") (princ (rtos (- t1 t0) 2 20)) (prompt " milliseconds...")
18.   (repeat 10
19.     (setq l (append l (atoms-family 1)))
20.   )
21.   (setq k -1)
22.   (setq t0 (car (_vl-times)))
23.   (while (and (setq k (1+ k)) (< k (length l)) (setq a (nth k l)))
24.     (princ "")
25.   )
26.   (setq t1 (car (_vl-times)))
27.   (prompt "\nElapsed time for (while (and (setq k (1+ k)) (< k (length l)) (setq a (nth k l)))) : ") (princ (rtos (- t1 t0) 2 20)) (prompt " milliseconds...")
28.   (setq t0 (car (_vl-times)))
29.   (mapcar (function (lambda ( x ) (princ ""))) l)
30.   (setq t1 (car (_vl-times)))
31.   (prompt "\nElapsed time for (mapcar (function (lambda ( x ) (princ \"\"))) l) : ") (princ (rtos (- t1 t0) 2 20)) (prompt " milliseconds...")
32.   (setq t0 (car (_vl-times)))
33.   (defun f ( x ) (princ ""))
34.   (mapcar (function f) l)
35.   (setq t1 (car (_vl-times)))
36.   (prompt "\nElapsed time for (mapcar (function f) l) : ") (princ (rtos (- t1 t0) 2 20)) (prompt " milliseconds...")
37.   (princ)
38. )
39.  
40. ;;; On BricsCAD
41. ;|
42. : TEST
43.  
44. Elapsed time for (foreach a l) : 2187 milliseconds...
45. Elapsed time for (while (setq a (car l))) : 2312 milliseconds...
46. Elapsed time for (while (and (setq k (1+ k)) (< k (length l)) (setq a (nth k l)))) : 8219 milliseconds...
47. Elapsed time for (mapcar (function (lambda ( x ) (princ ""))) l) : 2235 milliseconds...
48. Elapsed time for (mapcar (function f) l) : 2219 milliseconds...
49. |;
50.  

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Marc'Antonio Alessi on May 29, 2020, 03:19:13 AM

Quote from: ribarm on May 28, 2020, 09:59:30 AM

I have a problem LISP crashed in BricsCAD with this message :

Code: [Select]

; ----- LISP : Call Stack -----
; [0]...C:TSP-2D-MR-LATEST-NEW
; [1].....DEPTH
; [2].......UNIQUE # 1108 <<--
;
; ----- Error around expression -----
; (EQUAL A B 1.0e-06)
;
; error : out of LISP 'Heap' memory at [gc]
<clip>

Keep in mind that the list with atoms-family  is at the limit of the memory (also in AutoCAD) and depends on your starting atoms-family length:

Code: [Select]

(length(atoms-family 1)) => 5519
:(progn
(_> (gc)
(_> (setq aList (atoms-family 1))
(_> (repeat 11 (setq aList (append aList aList)))
(_> (prompt "\nLength: ") (princ (length aList))
(_> (princ)
(_> )
Length: 11302912

: (progn
(_> (gc)
(_> (setq aList (atoms-family 1))
(_> (repeat 12 (setq aList (append aList aList)))
(_> (prompt "\nLength: ") (princ (length aList))
(_> (princ)
(_> )
; ----- Error around expression -----
; (APPEND ALIST ALIST)
;
; error : out of LISP 'Heap' memory at [gc]

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: VovKa on May 29, 2020, 06:19:23 AM

Quote from: ribarm on May 29, 2020, 01:16:24 AM

But those are minimal improvements...

i don't have bcad
can you benchmark TSP-2D-MR-LATEST-NEW with different versions of unique?

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on May 29, 2020, 07:04:01 AM

Quote from: VovKa on May 29, 2020, 06:19:23 AM

Quote from: ribarm on May 29, 2020, 01:16:24 AM

But those are minimal improvements...

i don't have bcad
can you benchmark TSP-2D-MR-LATEST-NEW with different versions of unique?

Indeed you are right, but what's the trick???

Code: [Select]

With my (unique) on BricsCAD :

: TSP-2D-MR-LATEST-NEW

Select points, blocks or circles in WCS...
Select entities:
Opposite Corner:
Entities in set: 40
Select entities:
Specify depth number - positive integer - from 0 to 32 <32> :
Specify number of solution attempts per depth iteration - preferable 50 <all> : 100
Specify number of list length processed by (processpt) sub function - preferable 2 <all> : 2

Distance : 19586.78862941693
Elapsed time : 157734 milliseconds...

With your (unique) on BricsCAD :

: TSP-2D-MR-LATEST-NEW

Select points, blocks or circles in WCS...
Select entities:
Opposite Corner:
Entities in set: 40
Select entities:
Specify depth number - positive integer - from 0 to 32 <32> :
Specify number of solution attempts per depth iteration - preferable 50 <all> : 100
Specify number of list length processed by (processpt) sub function - preferable 2 <all> : 2

Distance : 19586.78862941693
Elapsed time : 146703 milliseconds...


Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on May 29, 2020, 07:17:38 AM

This is even more weird :
I changed at the end of my (unique) l into (cdr l) :

Code - Auto/Visual Lisp: [Select]

1. ...
2.   (defun depth ( plll m / unique sort trimbynum trimbyperc plr pllll )
3.  
4.     (defun unique ( l / x ll )
5.       (while (setq x (car l))
6.         (setq ll (cons x ll))
7.         (setq l (vl-remove-if (function (lambda ( y ) (vl-every (function (lambda ( a b ) (equal a b 1e-6))) y (member (car y) (append x x))))) (cdr l)))
8.       )
9.       ll
10.     )
11. ...
12.  

And now instead of TSP beeing faster - it's slower :

Code: [Select]

: TSP-2D-MR-LATEST-NEW

Select points, blocks or circles in WCS...
Select entities:
Opposite Corner:
Entities in set: 40
Select entities:
Specify depth number - positive integer - from 0 to 32 <32> :
Specify number of solution attempts per depth iteration - preferable 50 <all> : 100
Specify number of list length processed by (processpt) sub function - preferable 2 <all> : 2

Distance : 19586.78862941693
Elapsed time : 261766 milliseconds...

I really can'r explain what's going here : It seems that my results are unreliable...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on May 29, 2020, 07:29:09 AM

I restarted BricsCAD and now I get this :

Code: [Select]

: TSP-2D-MR-LATEST-NEW

Select points, blocks or circles in WCS...
Select entities:
Opposite Corner:
Entities in set: 40
Select entities:
Specify depth number - positive integer - from 0 to 32 <32> :
Specify number of solution attempts per depth iteration - preferable 50 <all> : 100
Specify number of list length processed by (processpt) sub function - preferable 2 <all> : 2

Distance : 19586.78862941693
Elapsed time : 155390 milliseconds...

This is my (unique) with (cdr l)...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on May 29, 2020, 07:34:42 AM

I restarted BricsCAD and now I get this with VovKa's (unique) :

Code: [Select]

: TSP-2D-MR-LATEST-NEW

Select points, blocks or circles in WCS...
Select entities:
Opposite Corner:
Entities in set: 40
Select entities:
Specify depth number - positive integer - from 0 to 32 <32> :
Specify number of solution attempts per depth iteration - preferable 50 <all> : 100
Specify number of list length processed by (processpt) sub function - preferable 2 <all> : 2

Distance : 19586.78862941693
Elapsed time : 138094 milliseconds...

So it's faster...
What else can you remedy in my routine VovKa?

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on May 29, 2020, 09:15:35 AM

I decided to update changes by VovKa and my minor things I spoted to make code more concise, but performance is the same as my last test...
Update is here : http://www.theswamp.org/index.php?topic=30434.msg600027#msg600027

M.R.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on May 29, 2020, 10:30:35 AM

I see that VovKa was looking at my revision, but I forgot to add (actually I removed it from unknown reasons) line 77 :
(setq pllll (reverse pllll))

Sorry for my mistake, now should be all as it was before, just fine...

[EDIT : I am still in blunder with this 77 line... It seems that it should be fine and without it. It doesn't matter which order list are processed in (processpt) - all shortest paths are added to pllll - that's important not order in pllll itself... I'll leave line 77, but IMHO there is no need for it actually. So my previous revision was also OK...]

[EDIT : I removed line 77 and added (gc) in both (processpt) and (unique)...]

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: VovKa on May 29, 2020, 11:41:13 AM

Quote from: ribarm on May 29, 2020, 07:34:42 AM

So it's faster...

i benchmarked both functions - your original-while unique and mine unique3

Code: [Select]

_$ (length testlst)
500
_$ (length (unique testlst))
237
_$ (length (unique3 testlst))
237
_$ (BenchMark '((unique testlst) (unique3 testlst)))
Benchmarking ....Elapsed milliseconds / relative speed for 2 iteration(s):

    (UNIQUE3 TESTLST).....1404 / 2.47 <fastest>
    (UNIQUE TESTLST)......3463 / 1 <slowest>
as you can see those small 'technical' changes yield a big speed gain

Quote from: ribarm on May 29, 2020, 07:34:42 AM

What else can you remedy in my routine VovKa?

not me but you :)
analyzing other people's code is a hell of a job. don't have time for it

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on June 03, 2020, 09:17:50 AM

Quote from: Marc'Antonio Alessi on May 29, 2020, 03:19:13 AM

Quote from: ribarm on May 28, 2020, 09:59:30 AM

I have a problem LISP crashed in BricsCAD with this message :

Code: [Select]

; ----- LISP : Call Stack -----
; [0]...C:TSP-2D-MR-LATEST-NEW
; [1].....DEPTH
; [2].......UNIQUE # 1108 <<--
;
; ----- Error around expression -----
; (EQUAL A B 1.0e-06)
;
; error : out of LISP 'Heap' memory at [gc]
<clip>

Keep in mind that the list with atoms-family  is at the limit of the memory (also in AutoCAD) and depends on your starting atoms-family length:

Code: [Select]

(length(atoms-family 1)) => 5519
:(progn
(_> (gc)
(_> (setq aList (atoms-family 1))
(_> (repeat 11 (setq aList (append aList aList)))
(_> (prompt "\nLength: ") (princ (length aList))
(_> (princ)
(_> )
Length: 11302912

: (progn
(_> (gc)
(_> (setq aList (atoms-family 1))
(_> (repeat 12 (setq aList (append aList aList)))
(_> (prompt "\nLength: ") (princ (length aList))
(_> (princ)
(_> )
; ----- Error around expression -----
; (APPEND ALIST ALIST)
;
; error : out of LISP 'Heap' memory at [gc]

According to my tests, on my PC :
AutoCAD 2018 - list length limit : 20,000,000
BricsCAD V20 - list length limit : 10,000,000

So AutoCAD has better chances with this routine, but it's 2-10x slower and it don't crash when limit exceeded but goes into never ending calculations which is bad...

Here is my testing function and my results :

Code - Auto/Visual Lisp: [Select]

1. ;|
2. (c:makestartlsts)
3. *l* and **l** are globals so that you can try upon finish of test, something like this (not to show output) :
4. (progn (gc) (setq *l* (eval (cons 'append (repeat 27 (setq *r* (cons '*l* *r*)))))) (princ (length *l*)) (princ))
5. and then finally :
6. (progn (gc) (setq *l* (append *l* **l**)) (princ (length *l*)) (princ))
7. (setq *l* nil **l** nil *r* nil)
8. |;
9.  
10. (defun c:makestartlsts nil
11.   (setq *l* (atoms-family 1))
12.   (prompt "\nLength - (setq *l* (atoms-family 1)) : ") (princ (length *l*))
13.   (repeat 7
14.     (setq *l* (append *l* *l*))
15.   )
16.   (setq **l** *l*)
17.   (prompt "\nLength - repeat 10 - (setq *l* (append *l* *l*)) = (128 x *l*) : ") (princ (length *l*))
18.   (princ)
19. )
20.  
21. ;;; AutoCAD test ;;;
22. ;|
23. Command: MAKESTARTLSTS
24. Length - (setq *l* (atoms-family 1)) : 5750
25. Length - repeat 10 - (setq *l* (append *l* *l*)) = (128 x *l*) : 736000
26. Command:
27. Command: (progn (gc) (setq *l* (eval (cons 'append (repeat 27 (setq *r* (cons '*l* *r*)))))) (princ (length *l*)) (princ))
28. 19872000
29. |;
30.  
31. ;;; If I then use this line : (progn (gc) (setq *l* (append *l* **l**)) (princ (length *l*)) (princ)) ;;; AutoCAD don't crash but calculates never ending
32.  
33. ;;; BricsCAD test ;;;
34. ;|
35. : MAKESTARTLSTS
36.  
37. Length - (setq *l* (atoms-family 1)) : 4847
38. Length - repeat 10 - (setq *l* (append *l* *l*)) = (128 x *l*) : 620416
39. : (progn (gc) (setq *l* (eval (cons 'append (repeat 32 (setq *r* (cons '*l* *r*)))))) (princ (length *l*)) (princ))
40.  
41. ; ----- Error around expression -----
42. ; (APPEND *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L*)
43. ;
44. ; error : out of LISP 'Heap' memory at [gc]
45. : (progn (gc) (setq *l* (eval (cons 'append (repeat 27 (setq *r* (cons '*l* *r*)))))) (princ (length *l*)) (princ))
46.  
47. ; ----- Error around expression -----
48. ; (GC)
49. ;
50. ; error : out of LISP 'Heap' memory at [gc]
51. |;
52.  
53. ;;; Restart BricsCAD ;;;
54. ;|
55. : MAKESTARTLSTS
56.  
57. Length - (setq *l* (atoms-family 1)) : 4847
58. Length - repeat 10 - (setq *l* (append *l* *l*)) = (128 x *l*) : 620416
59. : (progn (gc) (setq *l* (eval (cons 'append (repeat 24 (setq *r* (cons '*l* *r*)))))) (princ (length *l*)) (princ))
60.  
61. ; ----- Error around expression -----
62. ; (APPEND *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L* *L*)
63. ;
64. ; error : out of LISP 'Heap' memory at [gc]
65. |;
66.  
67. ;;; Restart BricsCAD ;;;
68. ;|
69. : MAKESTARTLSTS
70.  
71. Length - (setq *l* (atoms-family 1)) : 4847
72. Length - repeat 10 - (setq *l* (append *l* *l*)) = (128 x *l*) : 620416
73. : (progn (gc) (setq *l* (eval (cons 'append (repeat 16 (setq *r* (cons '*l* *r*)))))) (princ (length *l*)) (princ))
74. 9926656
75. : (progn (gc) (setq *l* (append *l* **l**)) (princ (length *l*)) (princ))
76.  
77. ; ----- Error around expression -----
78. ; (APPEND *L* **L**)
79. ;
80. ; error : out of LISP 'Heap' memory at [gc]
81. |;
82.  

Regards, M.R.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: Marc'Antonio Alessi on June 03, 2020, 10:35:15 AM

> According to my tests, on my PC :
> AutoCAD 2018 - list length limit : 20,000,000
> BricsCAD V20 - list length limit : 10,000,000

it's pretty much the same on my PC too...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on June 05, 2020, 11:09:52 AM

I discovered that there is no much gain if polyline is updated in each loop by 1 single point if specified depth is less than maximum and calculations of depth start from nil over and over again with each new 1 point update... So I decided to change the code in the way that when depth is calculated, lwpolyline updates with number of points depth calculated and from this update, depth calculations start over from nil, but with more points already processed... So this is now much faster if you for ex. specify preferable values (depth = 3; length of list = 100; processed points = 2)... The result is not as should be with all maximal values which is BTW. impossible to reach if case is with free points more than cca. 10 - allowed list length processed may be over 10,000,000; but the result is satisfactory in relation elapsed time / calculated distance, still not as shortpath.vlx but very satisfactory IMHO...

My code on page 9 updated...
Regards, and stay well, M.R.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on June 06, 2020, 01:17:22 AM

I've added one more input - incremental depth...

Code updated I hope finally...

M.R.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on June 21, 2020, 12:23:53 PM

Hi, here is my new input...
I searched for a ways this could be done in less time, but I found that this is only possible if searching is reduced to point clouds that don't go over 9 points... I coded for all cases - if you want exact solution, you must specify complete point cloud - selection of all points and if it's over 9 points, then you'll have to wait for a long time (if it's even possible to complete the task) - it is strongly recommended that you do not specify in input more than 9 points and if there are many points, then 9 points specification is preferable... Still my already posted code is IMHO the best, but it may prove that the task could be completed in less time, but with less reliability of resulting solution... Until someone convert posted lisp to something else - arx, dll; here is my protected vlx that is alternative to shortpath.vlx... The command to invoke is TSP-2D-PTCLOUDS - the same as the name of vlx... But in almost all cases shortpath.vlx beat my version both in speed and solutions... Still I've found one example where my version found better solution and with my posted lisp (look previous postings) with more exhaustive inputs there was found even better solution... I am still not sure if this is exact solution as there were many points above 10 (18) - convex hull simplified somewhat things and so the green solution was found... When it comes to my vlx - convex hull is used only in finding starting solution - after that all points are considered in finding better - if there is better, so not much help from convex hull... Already posted lisp is still the best if you don't hurry, only someone has to make it even faster by coding other than LISP...

So now no code as it would spoil latest lisp version which is the best IMO, just protected vlx and dwg where shortpath.vlx was beaten - both with white after specified point cloud 9 with my vlx and green solution after long time processing with latest lisp here posted...

BTW. LISP version may prove even faster than my vlx if convex hull is complex and there left small number of free inside points from reasons I explained, so it is the good way for correct solving TSP, just it would be better if programmed other than LISP...

I wish you good luck if you try to improve LISP and (or) you found a ways for solution different than proposed in this topic...
M.R.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on June 24, 2020, 11:29:55 AM

Just to inform... I found some lacks in portion with check of lines intersections, so I updated both *.vlx and posted lisp... It is strongly suggested that you copy+paste lisp in your file and update old one...

Regards, M.R.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on June 30, 2020, 01:09:22 PM

I figured this out : Maybe someone really needs this faster... So I had a time to combine posted codes and I managed to improve shortpath.vlx results... Results are better, but in cost of speed... But all in all I used all fast codes I saw and now I suppose that it's acceptable... So finally this is what I came with, but I must warn you : don't take everything for grand... The results are better, but not reliable like it's supposed to be (my last code I posted), but who the hell can wait to eternity to get a result that is satisfactory enough... And just not to forget, thanks to Mr. Evgeniy Elpanov and chlh_jd who both provided very well codes for us to develop based on them... I know - I haven't stated inside LISP from where codes (subs) originates, but I modified them myself and they are obvious for reader so I believe that anyone can recognize them... So I dwarfed shortpath.vlx which is BTW. not open source and is old enough so I can say with very much confident that that file is no longer efficient - IMO it used E.E. subs combined with chlh_jd's in very direct way... (when you check results - it's almost exact copy of chlh_jd's code posted in this topic)

So here is my LISP and I hope you'll find it somewhat more useful then I do, but anyway it was fun to code it...
Regards, M.R.

[EDIT : There were some lacks in localizing variables of sub functions... I'll reattach LSP - there were 7 downloads till now...]

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on July 02, 2020, 11:41:42 AM

Hi, me again...
After very limited testings, I discovered that there were no differences between original version and my mod. of chlh_jd's sub... I find that using (/ pi 2.0) angle is somewhat more mathematical and theoretical better than using both (/ pi 2.0) and (/ pi 3.0) and therefore I have chosen my mod. better... It's somewhat faster as it don't process last portion I commented and now it's only the question why chlh_jd used both angles in checking... If someone finds differences between those two, please leave the comment... Here is my mod. I am using now :

Code - Auto/Visual Lisp: [Select]

1. ...
2.   (defun chlh_jd-process ( lst / l m p p0 p1 q i d0 l0 l1 d1 _pi2 _pi3 )
3.     (setq _pi2 (/ pi 2.0) _pi3 (/ pi 3.0))
4.     (setq lst (foo lst))
5.     (setq l (f2 lst))
6.     (setq i  0
7.           l0 lst
8.           q  (length lst)
9.           d0 (get-closedpolygon-length lst)
10.     )
11.     (foreach a l
12.       (if (and (< a _pi2) (setq p (nth i lst))) ;;; original version : (and (< a _pi3) (= (setq p (nth i lst)) (nth i l0)))
13.         (progn
14.           (if (= i 0)
15.             (setq p0 (last lst))
16.             (setq p0 (nth (1- i) lst))
17.           )
18.           (if (= i (1- q))
19.             (setq p1 (car lst))
20.             (setq p1 (nth (1+ i) lst))
21.           )
22.           (setq m (list (list p0 p p1)
23.                         (list p0 p1 p)
24.                         (list p1 p p0)
25.                         (list p1 p0 p)
26.                         (list p p0 p1)
27.                         (list p p1 p0)
28.                   )
29.           )
30.           (setq l1
31.             (car
32.               (vl-sort (mapcar
33.                          (function
34.                            (lambda ( x )
35.                              (ch-para-lst x i lst)
36.                            )
37.                          )
38.                          m
39.                        )
40.                 (function (lambda ( e1 e2 )
41.                     (< (get-closedpolygon-length e1)
42.                        (get-closedpolygon-length e2)
43.                     )
44.                   )
45.                 )
46.               )
47.             )
48.           )
49.           (setq d1 (get-closedpolygon-length l1))
50.           (if (< d1 d0)
51.             (setq d0  d1
52.                   lst l1
53.             )
54.           )
55.         )
56.       )
57.       (setq i (1+ i))
58.     )
59.     ;;; original version has this portion that is commented between ;| and |;
60.     ;|
61.     (setq l (f2 lst))
62.     (setq i  0
63.           l0 lst
64.           d0 (get-closedpolygon-length lst)
65.     )
66.     (foreach a l
67.       (if (and (< a _pi2) (setq p (nth i l0)))
68.         (progn
69.           (setq l1 (f1 p (vl-remove p lst)))
70.           (setq d1 (get-closedpolygon-length l1))
71.           (if (< d1 d0)
72.             (setq d0  d1
73.                   lst l1
74.             )
75.           )
76.         )
77.       )
78.       (setq i (1+ i))
79.     )
80.     |;
81.     lst
82.   )
83. ...
84.  

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: JohnK on July 02, 2020, 12:04:45 PM

> slow
I've lost almost all of my lisp abilities but, to me, this seems like an awful lot of anonymous functions and variable declarations.

Also, function names like "foo", "det", "f1", etc. make this code unreadable.

Here are a few quick copy/pastes from the lisp file (not exhaustive or inclusive; just random areas showing excessive annon functions).
Couldn't some of these annon functions be simplified?

Code - Auto/Visual Lisp: [Select]

1. ...
2.               (setq lst
3.                   (vl-sort lst
4.                       (function
5.                           (lambda ( a b / c d )
6.                               (if (or (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8) (and (or (equal c 0.0 1e-8) (equal c (* 2 pi) 1e-8)) (or (equal d 0.0 1e-8) (equal d (* 2 pi) 1e-8))))
7.                                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
8.                                   (< c d)
9.                               )
10.                           )
11.                       )
12.                   )
13.               )
14.               (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
15.               (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
16.               (setq lstl (vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
17.               (setq lst (append lst lstl))
18.  
19. ...
20. (defun chulllw2 ( l v / ll ent ls lll lil lial liall )
21.     (setq ll  (if (= v 1) (LM:ConvexHull-ptsonHull l) (Graham-scan l))
22.           ent (entmakex (append (list '(0 . "LWPOLYLINE")
23.                                       '(100 . "AcDbEntity")
24.                                       '(100 . "AcDbPolyline")
25.                                       (cons 90 (length l))
26.                                       (cons 70 (1+ (* 128 (getvar 'plinegen))))
27.                                       '(38 . 0.0)
28.                                 )
29.                                 (mapcar (function (lambda ( a ) (cons 10 a))) ll)
30.                         )
31.               )
32.     )
33.     (setq ls l)
34.     (foreach a ll (setq ls (vl-remove a ls)))
35.     (setq lll ll)
36.     (while (/= (length lll) (length l))
37.       (setq lil (mapcar (function list) lll (append (cdr lll) (list (car lll)))))
38.       (foreach a ls
39.         (setq lial (mapcar (function (lambda ( x ) (cons (+ (distance (car x) a) (distance (cadr x) a)) (list x a)))) lil))
40.         (setq liall (cons lial liall))
41.       )
42.       (setq liall (vl-sort liall (function (lambda ( a b ) (< (apply (function min) (mapcar (function car) a)) (apply (function min) (mapcar (function car) b)))))))
43.       (setq lial (car (vl-sort (car liall) (function (lambda ( a b ) (< (car a) (car b)))))))
44.       (entmod (append (reverse (member (cons 10 (car (cadr lial))) (reverse (entget ent))))
45.                       (list (cons 10 (caddr lial)))
46.                       (member (cons 10 (cadr (cadr lial))) (entget ent))
47.               )
48.       )
49.       (setq lll (mapcar (function cdr)
50.                         (vl-remove-if (function (lambda ( a ) (/= (car a) 10))) (entget ent))
51.                 )
52.       )
53.       (setq ls (vl-remove (caddr lial) ls))
54.       (setq liall nil)
55.     )
56.     ent
57.   )
58.  
59.   (defun car-sort ( lst cmp / f rtn )
60.  
61.     (defun f ( x )
62.       (setq lst (cdr lst))
63.       (if (apply cmp (list x rtn))
64.         (setq rtn x)
65.       )
66.     )
67.  
68.     (setq rtn (car lst))
69.     (while (vl-some (function f) (cdr lst)))
70.     rtn
71.   )
72.  
73.   (defun chkinters ( pl / lil k a ilil pre mid suf )
74.     (setq lil (mapcar (function list) pl (append (cdr pl) (list (car pl)))))
75.     (setq k -1)
76.     (while (and (< (setq k (1+ k)) (length lil)) (setq a (nth k lil)))
77.       (setq ilil (vl-some (function (lambda ( b / ip ) (setq ip (inters (car a) (cadr a) (car b) (cadr b))) (if (and ip (setq ip (mapcar (function +) '(0 0) ip)) (or (and (or (equal ip (car a) 1e-6) (equal ip (cadr a) 1e-6)) (not (equal ip (car b) 1e-6)) (not (equal ip (cadr b) 1e-6))) (and (or (equal ip (car b) 1e-6) (equal ip (cadr b) 1e-6)) (not (equal ip (car a) 1e-6)) (not (equal ip (cadr a) 1e-6))) (and (not (equal ip (car a) 1e-6)) (not (equal ip (cadr a) 1e-6)) (not (equal ip (car b) 1e-6)) (not (equal ip (cadr b) 1e-6))))) (list a b)))) (vl-remove a lil)))
78.       (if ilil
79.         (progn
80.           (setq pre (reverse (cdr (member (car ilil) (reverse lil)))))
81.           (setq mid (cdr (member (car ilil) lil)))
82.           (setq mid (cdr (member (cadr ilil) (reverse mid))))
83.           (setq mid (mapcar (function reverse) mid))
84.           (setq suf (cdr (member (cadr ilil) lil)))
85.           (setq lil (append pre (list (list (car (car ilil)) (car (cadr ilil)))) mid (list (list (cadr (car ilil)) (cadr (cadr ilil)))) suf))
86.           (setq pre nil mid nil suf nil)
87.           (setq ilil nil k -1)
88.         )
89.       )
90.     )
91.     (mapcar (function car) lil)
92.   )
93.  
94.   (prompt "\nSelect points, blocks or circles...")
95.   (if (setq ss (ssget '((0 . "POINT,INSERT,CIRCLE"))))
96.     (progn
97.       (repeat (setq i (sslength ss))
98.         (setq pl (cons (mapcar (function +) '(0 0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
99.       )
100.       (setq ti (car (_vl-times)))
101.       (setq l pl)
102.       (setq lw (greedy pl))
103.       (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (setq lwx (entget lw)))))
104.       (setq pll (cons pl pll))
105.       (generic lwx)
106.       (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (setq lwx (entget lw)))))
107.       (entdel lw)
108.       (setq pl (chkinters pl))
109.       (setq pll (cons pl pll))
110.       (generic (entget (chulllw1 l 1)))
111.       (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget (entlast)))))
112.       (entdel (entlast))
113.       (setq pl (chkinters pl))
114.       (setq pll (cons pl pll))
115.       (generic (entget (chulllw1 l 2)))
116.       (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget (entlast)))))
117.       (entdel (entlast))
118.       (setq pl (chkinters pl))
119.       (setq pll (cons pl pll))
120.       (generic (entget (chulllw2 l 1)))
121.       (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget (entlast)))))
122.       (entdel (entlast))
123.       (setq pl (chkinters pl))
124.       (setq pll (cons pl pll))
125.       (generic (entget (chulllw2 l 2)))
126.       (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget (entlast)))))
127.       (entdel (entlast))
128.       (setq pl (chkinters pl))
129.       (setq pll (cons pl pll))
130.       (TSP-chlh_jd l 1)
131.       (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget (entlast)))))
132.       (entdel (entlast))
133. ...
134.  

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on July 02, 2020, 12:45:16 PM

Just to reply from my perspective... I am also not so called lisp genius - it takes lots of practice to change style and way you code... Someone is born with that talent, someone not... MP is one fine example of person that has abilities of lisping made to perfection... I am just simple guy that tries to help in the way God has blessed me... As for the code, yes it can always be better written, but I tried to keep as much as possible exactly the same written material as original authors left us... That's why (foo) (f1) (det)... If you have some better remarks in the way posted routine works - functions it would be perfect to make those things implemented... It's just that TSP is way too complex programming challenge and it simply isn't easy to cobble together all needed components that can make it fast/correct in the way it should be expected... There is even no way to test for correctness of results - it's all wild guessing unless you choose simple task (cca. 10 points at maximum) and use checking by all possibilities for order the points that form closed path... Now, please don't avoid to reply on my previous observation about sub function that is used... Actually I even don't care too much how the code looks, someone can always make cosmetic changes... To me it's much more important how it works and what could be better in that manner... And yes, it looks that there are more material than needed, but in fact every sub is used in the code - there is no unused functions - it all works together and only combined it makes completeness...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on July 02, 2020, 06:17:40 PM

I totally discarded checking of angles and let it process all points in list by triplets of points... Also I used (while) as with (foreach) list is not updating during calculations inside sub... I know that this is now slower then it was and perhaps it gives the same results, but in fact it's better coded - more reliable in terms of what it is doing... Also all subs are needed except newly added (ang) and (f2) that are looking for angles, but I leaved them as there are some comments related to them... So nothing is removed only added and commented those things that aren't necessity... In attachment is my mod. version that I use now...

M.R.

[EDIT : I've replaced 2 subs from chlh_jd's codes with newer more obvious versions that are shorter... But still chlh_jd's subs are faster by my testings, so I just added them for comparison reasons and leaved active chlh_jd's and my versions deactivated... There were 3 downloads till now...]

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on July 04, 2020, 01:38:14 PM

From fast routines to implementation of depth permutation parameter...
So your remark (John) is that it is slow...
Well, it can always be slower, lol...

But in fact, I am satisfied now with this depth version... It should yield the same results as previous with depth=3, but if you put a little higher (for ex. 6), IMO it will be very close to exact solution, no matter how long does it take to finish...
I've tested on my tricky example with 11 points and it did correct at about 40 seconds with my PC - this is still faster than doing full permutations... In routine I hard coded - preferable number 3, but maybe it's actually 6, if you have more time...

Regards, M.R.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on July 05, 2020, 01:36:18 AM

shorthpath.vlx results beaten by TSP.lsp at about 300 sec...
TSP.lsp results beaten by TSP-depth.lsp at about 5.5 hours...

http://www.theswamp.org/index.php?topic=30434.msg591042#msg591042
This results were beaten...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on July 10, 2020, 02:22:58 AM

I've reattached TSP-depth.lsp as I improved timings... There is little changes, but there are some and I had to give up of some previous calculations to gain more speed... If you find TSP interesting to you too, then recheck your tasks - it passed all mine very well - not exact solutions as previous were, but that one that was different also yield shortest length as in my example there could be multiple solutions with shortest path...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on August 01, 2020, 11:06:27 AM

This is how story continues...
While testing TSP-depth.lsp through AutoCAD and BricsCAD, I noticed that on one example in BricsCAD, routine caused lag... So I retested it and it was the same... At first glance I thought it was something with BricsCAD, so I left it there and switched to AutoCAD testings... I wander how anyone haven't noticed this issue and report this bug... So there it was all the time routine had lacks and now I dedicated little of my time to debugg it... Everything was correct except (chulllw2) sub function... Nevertheless as I didn't know where the issue was, I remedy and some other things I found... I figured what is the point not to fix it for both ACAD and BCAD when BCAD is faster and is IMHO the best choice for performing this task - TSP solution, so there it was, I had to debugg it under BCAD... So finally I haven't retested it under BricsCAD - that DWG I posted last, but I believe that it would be way under 4-5 hours... It was my pleasure to have sub functions from master Evgeniy, Lee and chlh_jd and make this version that satisfies my needs and I believe and needs of many others...
Thanks for your attention and suggestions I recieved from many that participated and gave cntributions to this challenging topic...
Regards, M.R.
Attahched - my latest debugged version that should work well for both ACAD and BCAD...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on August 04, 2020, 11:09:19 AM

Just to inform and post files...
I've beaten my record both in time and result under BricsCAD - previously timings 97 min. With latest revision now time is around 15 min... Result is shown in *.png and *.dwg...
Important note - now preferable depth is 8 (hard coded 3)...
We'll see if someone can beat now this...
Regards, M.R.

[EDIT : TSP-depth-fast.lsp removed as there were no interest for downloading... There were only 2 downloads till now...]

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on August 08, 2020, 09:15:37 AM

This result was improved too...
My latest code produced most right example in white...
Though, because of this, I had to slower my fast version from 10 min with previous example to about 27 min...
All I do with this codes is heuristic attempts to combine best solution results in one single routine... So actually there is no real logic behind this - logic is behind every portion, but general solution don't exist IMHO...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on September 30, 2020, 01:22:45 AM

Here is the fastest algorithm I know till now... It gives wrong results, but it strives to get as much good as it's possible for the time it draws path... On my slow PC - it took less than 10 min. for 1000 points... Try it and you'll see benefits from it...

Code - Auto/Visual Lisp: [Select]

1. (defun c:tsp-li ( / *error* makeli mindist-eea-MR car-sort chkinters pea ss ti i pl len loop li li1 li2 lil el s lwl enx lwx )
2.  
3.   (defun *error* ( m )
4.     (if pea
5.       (setvar 'peditaccept pea)
6.     )
7.     (if m
8.       (prompt m)
9.     )
10.     (princ)
11.   )
12.  
13.   (defun makeli ( a b )
14.     (entmakex (list '(0 . "LINE") (cons 10 a) (cons 11 b)))
15.   )
16.  
17.   (defun mindist-eea-MR ( l / f d q )
18.    
19.     (defun f ( p l / di )
20.       (while l
21.         (if (equal p (car l) (+ d 1e-8))
22.           (cond ( (= (setq di (distance p (car l))) d) (setq q (list p (car l))) )
23.                 ( (< di d)
24.                   (setq d di
25.                         q (list p (car l))
26.                   )
27.                 )
28.           )
29.         )
30.         (setq l (cdr l))
31.       )
32.     )
33.  
34.     (setq d (distance (car l) (cadr l)))
35.     (foreach a l
36.       (f a (cdr l))
37.       (setq l (cdr l))
38.     )
39.     q
40.   )
41.  
42.   (defun car-sort ( lst cmp / rtn )
43.     (setq rtn (car lst))
44.     (foreach itm (cdr lst)
45.       (if (apply cmp (list itm rtn))
46.         (setq rtn itm)
47.       )
48.     )
49.     rtn
50.   )
51.  
52.   (defun chkinters ( pl / lil k a ilil pre mid suf )
53.     (setq lil (mapcar (function list) pl (append (cdr pl) (list (car pl)))))
54.     (setq k -1)
55.     (while (and (< (setq k (1+ k)) (length lil)) (setq a (nth k lil)))
56.       (setq ilil (vl-some (function (lambda ( b / ip ) (setq ip (inters (car a) (cadr a) (car b) (cadr b))) (if (and ip (setq ip (mapcar (function +) '(0 0) ip)) (or (and (or (equal ip (car a) 1e-6) (equal ip (cadr a) 1e-6)) (not (equal ip (car b) 1e-6)) (not (equal ip (cadr b) 1e-6))) (and (or (equal ip (car b) 1e-6) (equal ip (cadr b) 1e-6)) (not (equal ip (car a) 1e-6)) (not (equal ip (cadr a) 1e-6))) (and (not (equal ip (car a) 1e-6)) (not (equal ip (cadr a) 1e-6)) (not (equal ip (car b) 1e-6)) (not (equal ip (cadr b) 1e-6))))) (list a b)))) (vl-remove a lil)))
57.       (if ilil
58.         (progn
59.           (setq pre (reverse (cdr (member (car ilil) (reverse lil)))))
60.           (setq mid (cdr (member (car ilil) lil)))
61.           (setq mid (cdr (member (cadr ilil) (reverse mid))))
62.           (setq mid (mapcar (function reverse) mid))
63.           (setq suf (cdr (member (cadr ilil) lil)))
64.           (setq lil (append pre (list (list (car (car ilil)) (car (cadr ilil)))) mid (list (list (cadr (car ilil)) (cadr (cadr ilil)))) suf))
65.           (setq pre nil mid nil suf nil)
66.           (setq ilil nil k -1)
67.         )
68.       )
69.     )
70.     (mapcar (function car) lil)
71.   )
72.  
73.   (vl-cmdf "_.UNDO" "_BE")
74.   (setq pea (getvar 'peditaccept))
75.   (setvar 'peditaccept 1)
76.   (if (setq ss (ssget '((0 . "POINT,CIRCLE,INSERT"))))
77.     (progn
78.       (setq ti (car (_vl-times)))
79.       (repeat (setq i (sslength ss))
80.         (setq pl (cons (mapcar (function +) '(0 0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
81.       )
82.       (setq pl (vl-sort pl (function (lambda ( a b ) (if (= (car a) (car b)) (< (cadr a) (cadr b)) (< (car a) (car b)))))))
83.       (setq len (length pl))
84.       (setq loop t)
85.       (while loop
86.         (if (and (car pl) (null (cadr pl)))
87.           (setq pl (cons (car pl) (vl-remove (car pl) (vl-remove-if (function (lambda ( x ) (= (length (vl-remove x (apply (function append) lil))) (- (length (apply (function append) lil)) 2)))) (apply (function append) lil)))))
88.           (setq li (mindist-eea-MR pl))
89.         )
90.         (if (not (vl-position li lil))
91.           (setq lil (cons li lil))
92.         )
93.         (if (not (or (equal li pl 1e-6) (equal li (reverse pl) 1e-6)))
94.           (progn
95.             (if (vl-position (car li) (cdr (member (car li) (apply (function append) lil))))
96.               (setq pl (vl-remove (car li) pl))
97.             )
98.             (if (vl-position (cadr li) (cdr (member (cadr li) (apply (function append) lil))))
99.               (setq pl (vl-remove (cadr li) pl))
100.             )
101.             (if (and (vl-position (car li) pl) (vl-position (cadr li) pl))
102.               (setq pl (vl-remove (cadr li) pl))
103.             )
104.           )
105.           (if (/= len (length lil))
106.             (setq pl (vl-remove-if (function (lambda ( x ) (= (length (vl-remove x (apply (function append) lil))) (- (length (apply (function append) lil)) 2)))) (apply (function append) lil)))
107.           )
108.         )
109.         (setq el (entlast))
110.         (setq s (ssadd))
111.         (foreach li lil
112.           (ssadd (makeli (car li) (cadr li)) s)
113.         )
114.         (vl-cmdf "_.PEDIT" "_M" s "" "_J")
115.         (while (< 0 (getvar 'cmdactive))
116.           (vl-cmdf "")
117.         )
118.         (if (/= (cdr (assoc 90 (entget (entlast)))) len)
119.           (while (setq el (entnext el))
120.             (setq lwl (cons el lwl))
121.           )
122.           (setq loop nil)
123.         )
124.         (if (vl-some (function (lambda ( x ) (= (logand 1 (cdr (assoc 70 (entget x)))) 1))) lwl)
125.           (progn
126.             (if (not (vl-position (car li) pl))
127.               (setq pl (cons (car li) pl))
128.             )
129.             (if (not (vl-position (cadr li) pl))
130.               (setq pl (cons (cadr li) pl))
131.             )
132.             (setq pl (vl-remove (if (> (distance (car li) (car-sort (vl-remove (car li) pl) (function (lambda ( a b ) (< (distance (car li) a) (distance (car li) b)))))) (distance (cadr li) (car-sort (vl-remove (cadr li) pl) (function (lambda ( a b ) (< (distance (cadr li) a) (distance (cadr li) b))))))) (car li) (cadr li)) pl))
133.             (setq lil (cdr lil))
134.           )
135.         )
136.         (if lwl
137.           (mapcar (function entdel) lwl)
138.         )
139.         (setq lwl nil)
140.       )
141.       (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (setq enx (entget (entlast))))))
142.       (setq pl (chkinters pl))
143.       (setq lwx (append (reverse (cdr (member (assoc 10 enx) (reverse enx)))) (mapcar (function (lambda ( x ) (cons 10 x))) pl) '((210 0.0 0.0 1.0))))
144.       (entupd (cdr (assoc -1 (entmod (subst (cons 70 (1+ (* 128 (getvar 'plinegen)))) (assoc 70 lwx) lwx)))))
145.       (prompt "\nDistance : ") (princ (rtos (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pl (append (cdr pl) (list (car pl))))) 2 20))
146.       (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
147.     )
148.   )
149.   (*error* nil)
150. )
151.  

HTH. M.R.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on October 01, 2020, 09:27:08 AM

What is ubeliveable is that I can swear I used the same code I posted above once in ACAD and once in BCAD and as a result I did get 2 different length lwpolylines - paths... So I don't know what's the trick, I even used "all" option for selecting points - everything was done identically... Maybe you'll get third result, who knows??? In attachment are 2 my DWG files...

[EDIT : It seems that now everything is like it's expected - both *.DWG are equal... The problem was sorting points prior routine calculations - so I added this line - look in my previous code...]

Code - Auto/Visual Lisp: [Select]

1. (setq pl (vl-sort pl (function (lambda ( a b ) (if (= (car a) (car b)) (< (cadr a) (cadr b)) (< (car a) (car b)))))))
2.  

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on October 02, 2020, 09:52:25 AM

I think there is more logical variant, but it gives worse (untested...) results than previous code...

Code - Auto/Visual Lisp: [Select]

1. ...
2.         (if (not (or (equal li pl 1e-6) (equal li (reverse pl) 1e-6)))
3.           (progn
4.             (if (vl-position (car li) (cdr (member (car li) (apply (function append) lil))))
5.               (setq pl (vl-remove (car li) pl))
6.             )
7.             (if (vl-position (cadr li) (cdr (member (cadr li) (apply (function append) lil))))
8.               (setq pl (vl-remove (cadr li) pl))
9.             )
10.             (if (and (vl-position (car li) pl) (vl-position (cadr li) pl))
11.               (progn
12.                 (setq li1 (list (car li) (car-sort (vl-remove (car li) pl) (function (lambda ( a b ) (< (distance (car li) a) (distance (car li) b)))))))
13.                 (setq li2 (list (cadr li) (car-sort (vl-remove (cadr li) pl) (function (lambda ( a b ) (< (distance (cadr li) a) (distance (cadr li) b)))))))
14.                 (cond
15.                   ( (and (or (not (equal li1 li 1e-6)) (not (equal li1 (reverse li) 1e-6))) (or (not (equal li2 li 1e-6)) (not (equal li2 (reverse li) 1e-6))) (< (distance (car li1) (cadr li1)) (distance (car li2) (cadr li2))))
16.                     (setq pl (vl-remove (cadr li) pl))
17.                   )
18.                   ( (and (or (not (equal li1 li 1e-6)) (not (equal li1 (reverse li) 1e-6))) (or (not (equal li2 li 1e-6)) (not (equal li2 (reverse li) 1e-6))) (> (distance (car li1) (cadr li1)) (distance (car li2) (cadr li2))))
19.                     (setq pl (vl-remove (car li) pl))
20.                   )
21.                   ( (and (or (not (equal li1 li 1e-6)) (not (equal li1 (reverse li) 1e-6))) (or (equal li2 li 1e-6) (equal li2 (reverse li) 1e-6)) (< (distance (car li1) (cadr li1)) (distance (car li2) (cadr li2))))
22.                     (setq pl (vl-remove (cadr li) pl))
23.                   )
24.                   ( (and (or (not (equal li1 li 1e-6)) (not (equal li1 (reverse li) 1e-6))) (or (equal li2 li 1e-6) (equal li2 (reverse li) 1e-6)) (> (distance (car li1) (cadr li1)) (distance (car li2) (cadr li2))))
25.                     (setq pl (vl-remove (car li) pl))
26.                   )
27.                   ( (and (or (equal li1 li 1e-6) (equal li1 (reverse li) 1e-6)) (or (not (equal li2 li 1e-6)) (not (equal li2 (reverse li) 1e-6))) (< (distance (car li1) (cadr li1)) (distance (car li2) (cadr li2))))
28.                     (setq pl (vl-remove (cadr li) pl))
29.                   )
30.                   ( (and (or (equal li1 li 1e-6) (equal li1 (reverse li) 1e-6)) (or (not (equal li2 li 1e-6)) (not (equal li2 (reverse li) 1e-6))) (> (distance (car li1) (cadr li1)) (distance (car li2) (cadr li2))))
31.                     (setq pl (vl-remove (car li) pl))
32.                   )
33.                   ( t
34.                     (setq li1 (list (car li) (car-sort (vl-remove (car li) (vl-remove (cadr li) pl)) (function (lambda ( a b ) (< (distance (car li) a) (distance (car li) b)))))))
35.                     (setq li2 (list (cadr li) (car-sort (vl-remove (car li) (vl-remove (cadr li) pl)) (function (lambda ( a b ) (< (distance (cadr li) a) (distance (cadr li) b)))))))
36.                     (if (< (distance (car li1) (cadr li1)) (distance (car li2) (cadr li2)))
37.                       (setq pl (vl-remove (cadr li) pl))
38.                       (setq pl (vl-remove (car li) pl))
39.                     )
40.                   )
41.                 )
42.               )
43.             )
44.           )
45.           (if (/= len (length lil))
46.             (setq pl (vl-remove-if (function (lambda ( x ) (= (length (vl-remove x (apply (function append) lil))) (- (length (apply (function append) lil)) 2)))) (apply (function append) lil)))
47.           )
48.         )
49. ...
50.  

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on October 04, 2020, 12:54:56 AM

Quickest on small amount of points... And as my tests prove, it tends toward smallest area of closed path, although intention was distance... This is my prettiest code I managed - it's short, but very thoughtful and powerful especially in usage of (car-sort) sub...

Code - Auto/Visual Lisp: [Select]

1. (defun c:tsp-expand ( / mindist-eea-MR car-sort chkinters insbtwli unique ss ti i pl pll lil li lii )
2.  
3.   (defun mindist-eea-MR ( l / f d q )
4.    
5.     (defun f ( p l / di )
6.       (while l
7.         (if (equal p (car l) (+ d 1e-8))
8.           (cond ( (= (setq di (distance p (car l))) d) (setq q (list p (car l))) )
9.                 ( (< di d)
10.                   (setq d di
11.                         q (list p (car l))
12.                   )
13.                 )
14.           )
15.         )
16.         (setq l (cdr l))
17.       )
18.     )
19.  
20.     (setq d (distance (car l) (cadr l)))
21.     (foreach a l
22.       (f a (cdr l))
23.       (setq l (cdr l))
24.     )
25.     q
26.   )
27.  
28.   (defun car-sort ( lst cmp / rtn )
29.     (setq rtn (car lst))
30.     (foreach itm (cdr lst)
31.       (if (apply cmp (list itm rtn))
32.         (setq rtn itm)
33.       )
34.     )
35.     rtn
36.   )
37.  
38.   (defun chkinters ( pl / lil k a ilil pre mid suf )
39.     (setq lil (mapcar (function list) pl (append (cdr pl) (list (car pl)))))
40.     (setq k -1)
41.     (while (and (< (setq k (1+ k)) (length lil)) (setq a (nth k lil)))
42.       (setq ilil (vl-some (function (lambda ( b / ip ) (setq ip (inters (car a) (cadr a) (car b) (cadr b))) (if (and ip (setq ip (mapcar (function +) '(0 0) ip)) (or (and (or (equal ip (car a) 1e-6) (equal ip (cadr a) 1e-6)) (not (equal ip (car b) 1e-6)) (not (equal ip (cadr b) 1e-6))) (and (or (equal ip (car b) 1e-6) (equal ip (cadr b) 1e-6)) (not (equal ip (car a) 1e-6)) (not (equal ip (cadr a) 1e-6))) (and (not (equal ip (car a) 1e-6)) (not (equal ip (cadr a) 1e-6)) (not (equal ip (car b) 1e-6)) (not (equal ip (cadr b) 1e-6))))) (list a b)))) (vl-remove a lil)))
43.       (if ilil
44.         (progn
45.           (setq pre (reverse (cdr (member (car ilil) (reverse lil)))))
46.           (setq mid (cdr (member (car ilil) lil)))
47.           (setq mid (cdr (member (cadr ilil) (reverse mid))))
48.           (setq mid (mapcar (function reverse) mid))
49.           (setq suf (cdr (member (cadr ilil) lil)))
50.           (setq lil (append pre (list (list (car (car ilil)) (car (cadr ilil)))) mid (list (list (cadr (car ilil)) (cadr (cadr ilil)))) suf))
51.           (setq pre nil mid nil suf nil)
52.           (setq ilil nil k -1)
53.         )
54.       )
55.     )
56.     (mapcar (function car) lil)
57.   )
58.  
59.   (defun insbtwli ( p1 p2 pl )
60.     (car-sort (vl-remove p1 (vl-remove p2 pl)) (function (lambda ( a b ) (< (+ (distance p1 a) (distance p2 a)) (+ (distance p1 b) (distance p2 b))))))
61.   )
62.  
63.   (defun unique ( l )
64.     (if l (cons (car l) (unique (vl-remove (car l) l))))
65.   )
66.  
67.   (if (setq ss (ssget '((0 . "POINT,CIRCLE,INSERT"))))
68.     (progn
69.       (setq ti (car (_vl-times)))
70.       (repeat (setq i (sslength ss))
71.         (setq pl (cons (mapcar (function +) '(0 0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
72.       )
73.       (setq pll (mindist-eea-MR pl))
74.       (setq pll (list (car pll) (insbtwli (car pll) (cadr pll) pl) (cadr pll)))
75.       (setq pl (vl-remove-if (function (lambda ( x ) (vl-position x pll))) pl))
76.       (while pl
77.         (setq lil (mapcar (function (lambda ( a b ) (list a b))) pll (append (cdr pll) (list (car pll)))))
78.         (setq li (car-sort lil (function (lambda ( a b / p1 p2 ) (< (+ (distance (car a) (setq p1 (insbtwli (car a) (cadr a) pl))) (distance (cadr a) p1)) (+ (distance (car b) (setq p2 (insbtwli (car b) (cadr b) pl))) (distance (cadr b) p2)))))))
79.         (setq lii (list (car li) (insbtwli (car li) (cadr li) pl) (cadr li)))
80.         (setq lil (subst lii li lil))
81.         (setq pll (unique (apply (function append) lil)))
82.         (setq pl (vl-remove-if (function (lambda ( x ) (vl-position x pll))) pl))
83.       )
84.       (setq pll (chkinters pll))
85.       (entmake
86.         (append
87.           (list
88.             '(0 . "LWPOLYLINE")
89.             '(100 . "AcDbEntity")
90.             '(100 . "AcDbPolyline")
91.             (cons 90 (length pll))
92.             (cons 70 (1+ (* 128 (getvar 'plinegen))))
93.             '(38 . 0.0)
94.           )
95.           (mapcar (function (lambda ( x ) (cons 10 x))) pll)
96.           '((210 0.0 0.0 1.0))
97.         )
98.       )
99.       (prompt "\nDistance : ") (princ (rtos (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pll (append (cdr pll) (list (car pll))))) 2 20))
100.       (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
101.     )
102.   )
103.   (princ)
104. )
105.  

M.R.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on October 07, 2020, 08:50:02 AM

Has anyone even tried to beat those results?

http://www.theswamp.org/index.php?topic=30434.msg600917#msg600917
http://www.theswamp.org/index.php?topic=30434.msg600982#msg600982

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on October 07, 2020, 02:01:34 PM

Here is my fastest short general solution... So for those that can't wait and in pure ALisp - no VLisp...

Code - Auto/Visual Lisp: [Select]

1. (defun c:TSP-FAST ( / foo f1 ins-lst get-closest-i get-closedpolygon-length car-sort chkinters LM:ConvexHull-ptsonHull LM:Clockwise-p greedy unique generic ss ch ti i pl pl1 pl2 pl3 pl4 )
2.  
3.   (defun foo ( l / d d0 d1 )
4.     (setq l0 (mapcar (function list) (cons (last l) l) l))
5.     (setq d0 (get-closedpolygon-length l))
6.     (while
7.       (> d0
8.         (progn
9.           (foreach a l0
10.             (setq d (get-closedpolygon-length l))
11.             (setq l1 (vl-remove (car a) (vl-remove (cadr a) l)))
12.             (setq l1 (f1 (car a) l1))
13.             (setq l1 (f1 (cadr a) l1))
14.             (if (> d (setq d1 (get-closedpolygon-length l1)))
15.               (setq d d1
16.                     l l1
17.               )
18.             )
19.             (setq l1 (vl-remove (car a) (vl-remove (cadr a) l)))
20.             (setq l1 (f1 (cadr a) l1))
21.             (setq l1 (f1 (car a) l1))
22.             (if (> d (setq d1 (get-closedpolygon-length l1)))
23.               (setq d d1
24.                     l l1
25.               )
26.             )
27.           )
28.           d
29.         )
30.       )
31.       (setq d0 d)
32.     )  
33.     (setq d (get-closedpolygon-length l))  
34.     l
35.   )
36.  
37.   (defun f1 ( a l )
38.     (ins-lst a (get-closest-i l a) l)
39.   )
40.  
41.   (defun ins-lst ( new i lst / len fst )
42.     (setq len (length lst))
43.     (cond
44.       ( (= i 0)
45.         (cons new lst)
46.       )
47.       ( (> i (/ len 2))
48.         (reverse (ins-lst new (- len i) (reverse lst)))
49.       )
50.       ( t
51.         (append
52.           (progn
53.             (setq fst nil)
54.             (repeat (rem i 4)
55.               (setq fst (cons (car lst) fst)
56.                     lst (cdr lst)
57.               )
58.             )
59.             (repeat (/ i 4)
60.               (setq fst
61.                 (cons (cadddr lst)
62.                   (cons (caddr lst)
63.                     (cons (cadr lst)
64.                       (cons (car lst)
65.                             fst
66.                       )
67.                     )
68.                   )
69.                 )
70.                 lst (cddddr lst)
71.               )
72.             )
73.             (reverse fst)
74.           )
75.           (list new)
76.           lst
77.         )
78.       )
79.     )
80.   )
81.  
82.   (defun get-closest-i ( lst p )
83.     (car
84.       (vl-sort-i
85.         (mapcar
86.           (function
87.             (lambda ( p1 p2 / pt d d1 d2 )
88.               (setq pt (inters p (polar p (+ (/ pi 2.0) (angle p1 p2)) 1.0) p1 p2 nil)
89.                     d  (distance p1 p2)
90.                     d1 (distance p p1)
91.                     d2 (distance p p2)
92.               )
93.               (if pt
94.                 (if (equal (+ (distance pt p1) (distance pt p2)) d 1e-8)
95.                   (distance p pt)
96.                   d2
97.                 )
98.                 1e+99
99.               )
100.             )
101.           )
102.           (cons (last lst) lst)
103.           lst
104.         )
105.         (function <)
106.       )
107.     )
108.   )
109.  
110.   (defun get-closedpolygon-length ( l )
111.     (apply (function +) (mapcar (function distance) (cons (last l) l) l))
112.   )
113.  
114.   (defun car-sort ( lst cmp / rtn )
115.     (setq rtn (car lst))
116.     (foreach itm (cdr lst)
117.       (if (apply cmp (list itm rtn))
118.         (setq rtn itm)
119.       )
120.     )
121.     rtn
122.   )
123.  
124.   (defun chkinters ( pl / lil k a ilil pre mid suf )
125.     (setq lil (mapcar (function list) pl (append (cdr pl) (list (car pl)))))
126.     (setq k -1)
127.     (while (and (< (setq k (1+ k)) (length lil)) (setq a (nth k lil)))
128.       (setq ilil (vl-some (function (lambda ( b / ip ) (setq ip (inters (car a) (cadr a) (car b) (cadr b))) (if (and ip (setq ip (mapcar (function +) '(0 0) ip)) (or (and (or (equal ip (car a) 1e-6) (equal ip (cadr a) 1e-6)) (not (equal ip (car b) 1e-6)) (not (equal ip (cadr b) 1e-6))) (and (or (equal ip (car b) 1e-6) (equal ip (cadr b) 1e-6)) (not (equal ip (car a) 1e-6)) (not (equal ip (cadr a) 1e-6))) (and (not (equal ip (car a) 1e-6)) (not (equal ip (cadr a) 1e-6)) (not (equal ip (car b) 1e-6)) (not (equal ip (cadr b) 1e-6))))) (list a b)))) (vl-remove a lil)))
129.       (if ilil
130.         (progn
131.           (setq pre (reverse (cdr (member (car ilil) (reverse lil)))))
132.           (setq mid (cdr (member (car ilil) lil)))
133.           (setq mid (cdr (member (cadr ilil) (reverse mid))))
134.           (setq mid (mapcar (function reverse) mid))
135.           (setq suf (cdr (member (cadr ilil) lil)))
136.           (setq lil (append pre (list (list (car (car ilil)) (car (cadr ilil)))) mid (list (list (cadr (car ilil)) (cadr (cadr ilil)))) suf))
137.           (setq pre nil mid nil suf nil)
138.           (setq ilil nil k -1)
139.         )
140.       )
141.     )
142.     (mapcar (function car) lil)
143.   )
144.  
145.   ;; Convex Hull  -  Lee Mac
146.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
147.  
148.   (defun LM:ConvexHull-ptsonHull ( lst / ch p0 lstl )
149.       (cond
150.           (   (< (length lst) 4) lst)
151.           (   (setq p0 (car lst))
152.               (foreach p1 (cdr lst)
153.                   (if (or (< (cadr p1) (cadr p0))
154.                           (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
155.                       )
156.                       (setq p0 p1)
157.                   )
158.               )
159.               (setq lst (vl-remove p0 lst))
160.               (setq lst (append (list p0) lst))
161.               (setq lst
162.                   (vl-sort lst
163.                       (function
164.                           (lambda ( a b / c d )
165.                               (if (or (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8) (and (or (equal c 0.0 1e-8) (equal c (* 2 pi) 1e-8)) (or (equal d 0.0 1e-8) (equal d (* 2 pi) 1e-8))))
166.                                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
167.                                   (< c d)
168.                               )
169.                           )
170.                       )
171.                   )
172.               )
173.               (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
174.               (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
175.               (setq lstl (vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
176.               (setq lst (append lst lstl))
177.               (setq ch (list (cadr lst) (car lst)))
178.               (foreach pt (cddr lst)
179.                   (setq ch (cons pt ch))
180.                   (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
181.                       (setq ch (cons pt (cddr ch)))
182.                   )
183.               )
184.               (reverse ch)
185.           )
186.       )
187.   )
188.  
189.   ;; Clockwise-p  -  Lee Mac
190.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
191.  
192.   (defun LM:Clockwise-p ( p1 p2 p3 )
193.       (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
194.               (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
195.           )
196.           0.0
197.       )
198.   )
199.  
200.   (defun greedy ( l / a b bb d1 d2 a1 a2 e ll p pl an f )
201.     (setq l (vl-sort l (function (lambda ( a b ) (if (equal (car a) (car b) 1e-6) (< (cadr a) (cadr b)) (< (car a) (car b)))))))
202.     (setq ll (last l))
203.     (setq an 0.0)
204.     (setq p  (car l)
205.           pl (list p)
206.           l  (cdr l)
207.     )
208.     (while l
209.       (setq l (vl-sort l (function (lambda ( a b ) (< (distance p a) (distance p b))))))
210.       (setq a1 (car l) a2 (cadr l))
211.       (setq d1 (distance p a1) d2 (if a2 (distance p a2)))
212.       (if (and d2 (equal d1 d2 1e-6))
213.         (if (and an (or (equal (angle p a1) an 1e-6) (equal (angle p a1) (rem (+ pi an) (+ pi pi)) 1e-6) (if (or (equal an 0.0 1e-6) (equal an (* 2 pi) 1e-6)) (equal (angle p a1) (* 2 pi) 1e-6))))
214.           (setq a a1)
215.           (setq a a2)
216.         )
217.         (setq a a1)
218.       )
219.       (if (and an (or (equal (angle p a) an 1e-6) (equal (angle p a) (rem (+ pi an) (+ pi pi)) 1e-6) (if (or (equal an 0.0 1e-6) (equal an (* 2 pi) 1e-6)) (equal (angle p a) (* 2 pi) 1e-6))))
220.         (setq bb a)
221.         (setq b a)
222.       )
223.       (if bb
224.         (setq b bb)
225.       )
226.       (cond
227.         ( (equal a1 ll 1e-6)
228.           (setq a a1 b a an (* 0.5 pi) f t)
229.         )
230.         ( (equal a2 ll 1e-6)
231.           (setq a a2 b a an (* 0.5 pi) f t)
232.         )
233.       )
234.       (setq pl (cons b pl)
235.             l  (vl-remove b l)
236.             p  b
237.             b  nil
238.             bb nil
239.       )
240.       (if f
241.         (cond
242.           ( (= an 0.0)
243.             (setq an (* 0.5 pi))
244.           )
245.           ( t
246.             (setq an 0.0)
247.           )
248.         )
249.         (cond
250.           ( (and (= an 0.0) (equal (car p) (car ll) 1e-6))
251.             (setq an (* 0.5 pi))
252.           )
253.           ( (and (= an (* 0.5 pi)) (equal (cadr p) (cadr ll) 1e-6))
254.             (setq an 0.0)
255.           )
256.           ( (and (= an (* 0.5 pi)) (equal (car p) (car ll) 1e-6))
257.             (setq an 0.0)
258.           )
259.           ( (and (= an 0.0) (equal (cadr p) (cadr ll) 1e-6))
260.             (setq an (* 0.5 pi))
261.           )
262.         )
263.       )
264.     )
265.     (setq pl (reverse pl))
266.     (setq e  nil
267.           l  pl
268.           ll l
269.     )
270.     (while (and (not e) ll)
271.       (setq e  t
272.             ll l
273.       )
274.       (while (and e ll)
275.         (setq ll (if (listp (caar ll))
276.                   ll
277.                   (mapcar (function list) (cons (last ll) ll) ll)
278.                  )
279.               a  (car ll)
280.               pl (vl-remove-if (function (lambda ( b ) (or (member (car a) b) (member (cadr a) b))))
281.                                (cdr ll)
282.                  )
283.               ll (cdr ll)
284.         )
285.         (while (and pl (setq b (car pl)) (not (inters (car a) (cadr a) (car b) (cadr b))))
286.           (setq pl (cdr pl))
287.         )
288.         (if pl
289.           (progn (setq l (append (member (car a) l) (reverse (cdr (member (car a) (reverse l))))) ;;; [(car a) (cadr a) ... ->end] + ((car b) (cadr b)) - in middle of concatenated l + [start ... ->] ... (car a) - don't exist - it was (cdr-ed)
290.                        l (append (list (car a)) (member (car b) (reverse (cdr l))) (member (cadr b) l)) ;;; [(car a)] + [(car b) + end<- ... (cadr a)] + [(cadr b) + start ... ->]
291.                        e nil
292.                  )
293.           )
294.         )
295.       )
296.     )
297.     l
298.   )
299.  
300.   (defun unique ( l )
301.     (if l
302.       (cons (car l)
303.         (unique (vl-remove (car l) l))
304.       )
305.     )
306.   )
307.  
308.   (defun generic ( l / ch inpts lil d p lilp lip )
309.     (setq ch (LM:ConvexHull-ptsonHull l))
310.     (setq inpts (vl-remove-if (function (lambda ( x ) (vl-position x ch))) l))
311.     (while inpts
312.       (setq lil (mapcar (function list) ch (append (cdr ch) (list (car ch)))))
313.       (foreach li lil
314.         (setq d (distance (car li) (cadr li)))
315.         (setq p (car-sort inpts (function (lambda ( a b ) (< (- (+ (distance (car li) a) (distance a (cadr li))) d) (- (+ (distance (car li) b) (distance b (cadr li))) d))))))
316.         (setq lilp (cons (list li p) lilp))
317.       )
318.       (setq lip (car-sort lilp (function (lambda ( a b ) (< (- (+ (distance (caar a) (cadr a)) (distance (cadr a) (cadar a))) (distance (caar a) (cadar a))) (- (+ (distance (caar b) (cadr b)) (distance (cadr b) (cadar b))) (distance (caar b) (cadar b))))))))
319.       (setq lil (subst (list (caar lip) (cadr lip) (cadar lip)) (car lip) lil))
320.       (setq ch (unique (apply (function append) lil)))
321.       (setq inpts (vl-remove (cadr lip) inpts))
322.       (setq lilp nil)
323.     )
324.     ch
325.   )
326.  
327.   (prompt "\nSelect 2D points, inserts or circles...")
328.   (if (setq ss (ssget '((0 . "POINT,INSERT,CIRCLE"))))
329.     (progn
330.       (initget "1 2 3 4 All")
331.       (setq ch (getkword "\nDo you want computation by [1.greedy/2.generic/3.greedy+foo/4.generic+foo/All] <All - slower> : "))
332.       (setq ti (car (_vl-times)))
333.       (repeat (setq i (sslength ss))
334.         (setq pl (cons (mapcar (function +) '(0 0) (trans (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) 0 1)) pl))
335.       )
336.       (cond
337.         ( (= ch "1")
338.           (setq pl (greedy pl))
339.         )
340.         ( (= ch "2")
341.           (setq pl (chkinters (generic pl)))
342.         )
343.         ( (= ch "3")
344.           (setq pl (chkinters (foo (greedy pl))))
345.         )
346.         ( (= ch "4")
347.           (setq pl (chkinters (foo (chkinters (generic pl)))))
348.         )
349.         ( t
350.           (setq pl1 (greedy pl))
351.           (setq pl2 (chkinters (generic pl)))
352.           (setq pl3 (chkinters (foo pl1)))
353.           (setq pl4 (chkinters (foo pl2)))
354.           (setq pl (car-sort (list pl1 pl2 pl3 pl4) (function (lambda ( a b ) (< (apply (function +) (mapcar (function distance) a (append (cdr a) (list (car a))))) (apply (function +) (mapcar (function distance) b (append (cdr b) (list (car b))))))))))
355.         )
356.       )
357.       (entmake
358.         (append
359.           (list '(0 . "LWPOLYLINE")
360.                 '(100 . "AcDbEntity")
361.                 '(100 . "AcDbPolyline")
362.                 (cons 90 (length pl))
363.                 (cons 70 (1+ (* 128 (getvar 'plinegen))))
364.                 '(38 . 0.0)
365.           )
366.           (mapcar (function (lambda ( x ) (cons 10 (trans x 1 0)))) pl)
367.           '((210 0.0 0.0 1.0))
368.         )
369.       )
370.       (prompt "\nDistance : ") (princ (rtos (get-closedpolygon-length pl) 2 20))
371.       (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
372.     )
373.   )
374.   (princ)
375. )
376.  

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on October 10, 2020, 01:39:39 PM

Record is broken, but in a 50 min. on my slow PC - on Laptop for 35 min. Routine is somewhat modified version of TSP-FAST.LSP...
Previous record time was about 10 min. with somewhat modified version of TSP-depth-fast.LSP...
Competition is still open for some new records - bear in mind that timings should be reasonable - so I guess that limit of 10 hours is good enough... Still I am not sure if distance is the shortest and can't be beaten, so have in mind that info also...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on October 11, 2020, 12:59:06 PM

New record at about the same time as previous one...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on October 12, 2020, 08:24:33 AM

Here are my compiled files : protected VLX for ACAD and DES file for BCAD...
These files are only for you to have testing opportunity to compare results with your versions... You can though use them for your job, but I would be pleased if you try to beat those results with your own programming skills... And maybe some day if you feel generous enough maybe you share your achievement either in compiled versions like I did or even *.lsp who knows...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on October 14, 2020, 02:19:34 AM

TSP-FAST should now work well with rotated UCS - for greedy - GRID points must be aligned with UCS (if GRID is rotated, so must be UCS and X axis must match rotation)...
Attachments updated...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on October 14, 2020, 08:06:50 AM

It seems that there is no rule... I changed UCS randomly and TSP-FAST did the job with new record... Attached is PNG and DWG with UCS...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on October 15, 2020, 06:29:57 AM

It should be just slightly faster, but every improvement is welcomed...

Attachments updated here :
http://www.theswamp.org/index.php?topic=30434.msg601911#msg601911

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: adincer on October 29, 2020, 02:14:00 AM

I am trying to create left, right and midle axis of a road with taken 3 point with some interval. Example picture as below.
(https://ibb.co/hxNkgbr)

Is it possible to do this with your lisp to define an initial direction, maximum deflection angle, minimum and maximum segment lenght variables?

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: d2010 on October 29, 2020, 07:23:53 AM

I need help,, I translate your-source(only-half) to C+L
 If you interested , I need help,
  then I can not fix then script-errors
 :idea:

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on November 03, 2020, 07:03:57 AM

New record... What I did is used the same algorithm just mod. to accept selection of mutation LWPOLYLINE calculated for previous record and I used now depth = 8... It took about 6 hours for my Laptop which is faster than my PC - of course on BricsCAD...
Now I am starting to believe that much shorter than this is impossible - path is strengthen visually at maximum... But who knows records are to be beaten, but at what cost? My all resources are used to do it, although I have computers from previous millenia or around 2000~... (20 years old)

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: d2010 on November 03, 2020, 08:00:15 PM

I research  ObjectArx for (kpi, pi+pi, pi/2,pi*05)
Please for more speed , you replace (pi+pi) with kTwoPi 
Even the greatest  ObjectARX-autocad2018 , do not use (pi+pi) and
you  KTwoPi for more-speed.You must use KTwOpil KHalfPi,...

Code: [Select]

(defun con_kpi(/ )
   (setq;|a25930|;
kpi 3.14159265358979323846
kHalfPi 1.57079632679489661923
kTwoPi 6.28318530717958647692
kpi_max 3.14159265358979323846264338327950288
con_kpi kpi
con_kpi2 6.2831853071795865
)

Quote from: ribarm on October 15, 2020, 06:29:57 AM

It should be just slightly faster, but every improvement is welcomed...
Attachments updated here :

I compile your 'program (Greedy) to three-versions.(attached here).

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on November 12, 2021, 02:07:42 PM

Hi there...
I know this is old topic, but we don't want to leave it without any new fresh thoughts added...
So recently, I played with TSP again and I coded simple and fast straight forward genetic version in my interpretation...
I know that many tried to code for solving TSP and as far as I can see some success is gained - I don't know for other approaches by using different languages than LISP as I mainly work with codes that I can quickly test and debug...

Here is my new genetic approach :

Code - Auto/Visual Lisp: [Select]

1. (defun c:TSP-main-unlimited-pts-fastest ( / MR:ConvexHull-ptsonHull LM:ConvexHull-ptsonHull LM:Clockwise-p unique car-sort _vl-sort chkinters chkinters-p foo1 foo2 foo3 foo4 processfoos ss ti i pl p plst inpl in inn epl e lil d dd1 dd2 rr1 rr2 pp p1 p2 xx )
2.  
3.   ;; Convex Hull  -  Lee Mac
4.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
5.   ;; Mod by M.R.  -  uses (car-sort) and (_vl-sort) subs...
6.  
7.   (defun MR:ConvexHull-ptsonHull ( lst / ch p0 lstl )
8.     (cond
9.       ( (< (length lst) 4) (_vl-sort lst (function (lambda ( a b ) (if (= (cadr a) (cadr b)) (< (car a) (car b)) (< (cadr a) (cadr b)))))) )
10.       ( (setq p0 (car lst))
11.         (foreach p1 (cdr lst)
12.           (if (or (< (cadr p1) (cadr p0)) (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0))))
13.             (setq p0 p1)
14.           )
15.         )
16.         (setq lst (vl-remove p0 lst))
17.         (setq lst (append (list p0) lst))
18.         (setq lst
19.           (_vl-sort lst
20.             (function
21.               (lambda ( a b / c d )
22.                 (if (or (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8) (and (or (equal c 0.0 1e-8) (equal c (* 2 pi) 1e-8)) (or (equal d 0.0 1e-8) (equal d (* 2 pi) 1e-8))))
23.                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
24.                   (< c d)
25.                 )
26.               )
27.             )
28.           )
29.         )
30.         (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
31.         (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
32.         (setq lstl (_vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
33.         (setq lst (append lst lstl))
34.         (setq ch (list (cadr lst) (car lst)))
35.         (foreach pt (cddr lst)
36.           (if (equal pt (last lst))
37.             (setq ch (cons pt ch))
38.             (if (or (equal (angle (car ch) pt) (car-sort (mapcar (function (lambda ( x ) (angle (car ch) x))) (member pt lst)) (function <)) 1e-6) (equal (distance pt (cadr ch)) (+ (distance pt (car ch)) (distance (car ch) (cadr ch))) 1e-6))
39.               (setq ch (cons pt ch))
40.             )
41.           )
42.         )
43.         (reverse ch)
44.       )
45.     )
46.   )
47.  
48.   ;; Convex Hull  -  Lee Mac
49.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
50.  
51.   (defun LM:ConvexHull-ptsonHull ( lst / ch p0 lstl )
52.     (cond
53.       ( (< (length lst) 4) lst)
54.       ( (setq p0 (car lst))
55.         (foreach p1 (cdr lst)
56.           (if (or (< (cadr p1) (cadr p0)) (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0))))
57.             (setq p0 p1)
58.           )
59.         )
60.         (setq lst (vl-remove p0 lst))
61.         (setq lst (append (list p0) lst))
62.         (setq lst
63.           (_vl-sort lst
64.             (function
65.               (lambda ( a b / c d )
66.                 (if (or (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8) (and (or (equal c 0.0 1e-8) (equal c (* 2 pi) 1e-8)) (or (equal d 0.0 1e-8) (equal d (* 2 pi) 1e-8))))
67.                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
68.                   (< c d)
69.                 )
70.               )
71.             )
72.           )
73.         )
74.         (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
75.         (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
76.         (setq lstl (_vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
77.         (setq lst (append lst lstl))
78.         (setq ch (list (cadr lst) (car lst)))
79.         (foreach pt (cddr lst)
80.           (setq ch (cons pt ch))
81.           (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt) (not (equal (distance (caddr ch) pt) (+ (distance (caddr ch) (cadr ch)) (distance (cadr ch) pt)) 1e-8)))
82.             (setq ch (cons pt (cddr ch)))
83.           )
84.         )
85.         (reverse ch)
86.       )
87.     )
88.   )
89.  
90.   ;; Clockwise-p  -  Lee Mac
91.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
92.  
93.   (defun LM:Clockwise-p ( p1 p2 p3 )
94.     (minusp (- (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1))) (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))))
95.   )
96.  
97.   (defun unique ( l / a ll )
98.     (while (setq a (car l))
99.       (if (vl-some (function (lambda ( x ) (equal x a 1e-6))) (cdr l))
100.         (setq ll (cons a ll) l (vl-remove-if (function (lambda ( x ) (equal x a 1e-6))) (cdr l)))
101.         (setq ll (cons a ll) l (cdr l))
102.       )
103.     )
104.     (reverse ll)
105.   )
106.  
107.   (defun car-sort ( lst cmp / rtn )
108.     (setq rtn (car lst))
109.     (foreach itm (cdr lst)
110.       (if (apply cmp (list itm rtn))
111.         (setq rtn itm)
112.       )
113.     )
114.     rtn
115.   )
116.  
117.   (defun _vl-sort ( l f / *q* ll ff gg )
118.     (if (= (type f) 'sym)
119.       (setq f (eval f))
120.     )
121.     (while (setq *q* (car l))
122.       (setq ll
123.         (if (null ll)
124.           (cons *q* ll)
125.           (cond
126.             ( (apply f (list (last ll) *q*))
127.               (append ll (list *q*))
128.             )
129.             ( (apply f (list *q* (car ll)))
130.               (cons *q* ll)
131.             )
132.             ( t
133.               (setq ff nil)
134.               (setq gg (apply (function append) (append (mapcar (function (lambda ( *xxx* *yyy* ) (if (null ff) (if (apply f (list *q* *yyy*)) (progn (setq ff t) (list *xxx* *q*)) (list *xxx*)) (list *xxx*)))) ll (cdr ll)) (list (list (last ll))))))
135.               (if (null ff)
136.                 (append ll (list *q*))
137.                 gg
138.               )
139.             )
140.           )
141.         )
142.       )
143.       (setq l (cdr l))
144.     )
145.     ll
146.   )
147.  
148.   (defun chkinters ( pl / lil k a ilil pre mid suf )
149.     (setq lil (mapcar (function list) pl (append (cdr pl) (list (car pl)))))
150.     (setq k -1)
151.     (while (and (< (setq k (1+ k)) (length lil)) (setq a (nth k lil)))
152.       (setq ilil (vl-some (function (lambda ( b / ip ) (if (and (setq ip (inters (car a) (cadr a) (car b) (cadr b))) (not (equal ip (car a) 1e-6)) (not (equal ip (cadr a) 1e-6)) (not (equal ip (car b) 1e-6)) (not (equal ip (cadr b) 1e-6))) (list a b)))) (vl-remove a lil)))
153.       (if ilil
154.         (progn
155.           (setq pre (reverse (cdr (member (car ilil) (reverse lil)))))
156.           (setq mid (cdr (member (car ilil) lil)))
157.           (setq mid (cdr (member (cadr ilil) (reverse mid))))
158.           (setq mid (mapcar (function reverse) mid))
159.           (setq suf (cdr (member (cadr ilil) lil)))
160.           (setq lil (append pre (list (list (car (car ilil)) (car (cadr ilil)))) mid (list (list (cadr (car ilil)) (cadr (cadr ilil)))) suf))
161.           (setq pre nil mid nil suf nil)
162.           (setq ilil nil k -1)
163.         )
164.       )
165.     )
166.     (mapcar (function car) lil)
167.   )
168.  
169.   (defun chkinters-p ( l / lil )
170.     (setq lil (mapcar (function list) l (append (cdr l) (list (car l)))))
171.     (vl-some (function (lambda ( x ) (vl-some (function (lambda ( y ) (inters (car x) (cadr x) (car y) (cadr y)))) (vl-remove (if (= (vl-position x lil) 0) (last lil) (nth (1- (vl-position x lil)) lil)) (vl-remove (if (= (vl-position x lil) (1- (length lil))) (car lil) (nth (1+ (vl-position x lil)) lil)) (vl-remove x lil)))))) lil)
172.   )
173.  
174.   (defun foo1 ( plst / l )
175.     (setq l plst)
176.     (while (and (null xxx1) (vl-some (function (lambda ( a b / l1 l2 c ) (setq l1 l c (vl-some (function (lambda ( x ) (if (< (distance a x) (distance a b)) x))) (vl-remove a (vl-remove b l)))) (if c (setq l2 (append (reverse (member a (reverse (vl-remove c l)))) (list c) (if (/= (vl-position a l) (1- (length l))) (member b (vl-remove c l))))) (setq l2 nil)) (if (and l2 (or (< (length (unique l2)) (length l2)) (< (length l2) (length l1)))) (setq xxx1 (list l1 l2 c (list a b)))) (if (and l2 (not (chkinters-p l2)) (> (apply (function +) (mapcar (function distance) l1 (append (cdr l1) (list (car l1))))) (apply (function +) (mapcar (function distance) l2 (append (cdr l2) (list (car l2))))))) (setq l l2) (if l2 (progn (setq l (append (cdr l) (list (car l)))) nil))))) l (append (cdr l) (list (car l))))))
177.     l
178.   )
179.  
180.   (defun foo2 ( plst / l )
181.     (setq l plst)
182.     (while (and (null xxx2) (vl-some (function (lambda ( a b / l1 l2 c d e ) (setq l1 l c (vl-some (function (lambda ( x ) (if (< (- (+ (distance a x) (distance x b)) (distance a b)) (- (+ (distance (setq d (if (= (vl-position x l) 0) (last l) (nth (1- (vl-position x l)) l))) x) (distance x (setq e (if (= (vl-position x l) (1- (length l))) (car l) (nth (1+ (vl-position x l)) l))))) (distance d e))) x))) (vl-remove a (vl-remove b l)))) (if c (setq l2 (append (reverse (member a (reverse (vl-remove c l)))) (list c) (if (/= (vl-position a l) (1- (length l))) (vl-remove c (member b l))))) (setq l2 nil)) (if (and l2 (or (< (length (unique l2)) (length l2)) (< (length l2) (length l1)))) (setq xxx2 (list l1 l2 c d e (list a b)))) (if (and l2 (not (chkinters-p l2)) (> (apply (function +) (mapcar (function distance) l1 (append (cdr l1) (list (car l1))))) (apply (function +) (mapcar (function distance) l2 (append (cdr l2) (list (car l2))))))) (setq l l2) (if l2 (progn (setq l (append (cdr l) (list (car l)))) nil))))) l (append (cdr l) (list (car l))))))
183.     l
184.   )
185.  
186.   (defun foo3 ( plst / l )
187.     (setq l plst)
188.     (while (and (null xxx3) (vl-some (function (lambda ( a b c / l1 l2 ) (setq l1 l l2 (append (cond ( (= (vl-position a l) (- (length l) 2)) (cdr (reverse (member (cdr (reverse l))))) ) ( (= (vl-position a l) (1- (length l))) (cddr l) ) ( t (reverse (member a (reverse l))) )) (list c b) (cdddr (member a l)))) (if (or (< (length (unique l2)) (length l2)) (< (length l2) (length l1))) (setq xxx3 (list l1 l2 (list a b c)))) (if (and (not (chkinters-p l2)) (> (apply (function +) (mapcar (function distance) l1 (append (cdr l1) (list (car l1))))) (apply (function +) (mapcar (function distance) l2 (append (cdr l2) (list (car l2))))))) (setq l l2) (progn (setq l (append (cdr l) (list (car l)))) nil)))) l (append (cdr l) (list (car l))) (append (cddr l) (list (car l) (cadr l))))))
189.     l
190.   )
191.  
192.   (defun foo4 ( plst / l )
193.     (setq l plst)
194.     (while (and (null xxx4) (vl-some (function (lambda ( a b c / l1 l2 edge ) (setq l1 l edge (vl-some (function (lambda ( x ) (if (< (- (+ (distance (car x) b) (distance b (cadr x))) (distance (car x) (cadr x))) (- (+ (distance a b) (distance b c)) (distance a c))) x))) (vl-remove (list a b) (vl-remove (list b c) (mapcar (function list) (append l l) (append (append (cdr l) (list (car l))) (append (cdr l) (list (car l))))))))) (if edge (setq l2 (append (if (= (vl-position (car edge) l) (1- (length l))) (cdr (vl-remove b l)) (reverse (member (car edge) (reverse (vl-remove b l))))) (list b) (if (= (vl-position (car edge) l) (1- (length l))) (list (cadr edge)) (member (cadr edge) (vl-remove b l))))) (setq l2 nil)) (if (and l2 (or (< (length (unique l2)) (length l2)) (< (length l2) (length l1)))) (setq xxx4 (list l1 l2 edge (list a b c)))) (if (and l2 (not (chkinters-p l2)) (> (apply (function +) (mapcar (function distance) l1 (append (cdr l1) (list (car l1))))) (apply (function +) (mapcar (function distance) l2 (append (cdr l2) (list (car l2))))))) (setq l l2) (if l2 (progn (setq l (append (cdr l) (list (car l)))) nil))))) l (append (cdr l) (list (car l))) (append (cddr l) (list (car l) (cadr l))))))
195.     l
196.   )
197.  
198.   (defun processfoos ( plst / d dd ddd plst1 plst2 plst3 plst4 d1 d2 d3 d4 )
199.     (if (< (length (unique plst)) (length plst))
200.       (progn
201.         (prompt "\nError in reference list for processing (foo) subs - it contains duplicate points... Quitting...")
202.         (exit)
203.       )
204.     )
205.     (setq d 1e+99 dd 0)
206.     (while (> d dd)
207.       (setq plst1 (foo1 plst))
208.       (if (or (< (length (unique plst1)) (length plst1)) (< (length plst1) (length plst)))
209.         (progn
210.           (prompt "\nError in (foo1) - return list has less points than reference one or output list contains duplicate points... Quitting...")
211.           (exit)
212.         )
213.       )
214.       (if (chkinters-p plst1)
215.         (setq plst1 (chkinters plst1))
216.       )
217.       (setq d1 (apply (function +) (mapcar (function distance) plst1 (append (cdr plst1) (list (car plst1))))))
218.       (setq plst2 (foo2 plst))
219.       (if (or (< (length (unique plst2)) (length plst2)) (< (length plst2) (length plst)))
220.         (progn
221.           (prompt "\nError in (foo2) - return list has less points than reference one or output list contains duplicate points... Quitting...")
222.           (exit)
223.         )
224.       )
225.       (if (chkinters-p plst2)
226.         (setq plst2 (chkinters plst2))
227.       )
228.       (setq d2 (apply (function +) (mapcar (function distance) plst2 (append (cdr plst2) (list (car plst2))))))
229.       (setq plst3 (foo3 plst))
230.       (if (or (< (length (unique plst3)) (length plst3)) (< (length plst3) (length plst)))
231.         (progn
232.           (prompt "\nError in (foo3) - return list has less points than reference one or output list contains duplicate points... Quitting...")
233.           (exit)
234.         )
235.       )
236.       (if (chkinters-p plst3)
237.         (setq plst3 (chkinters plst3))
238.       )
239.       (setq d3 (apply (function +) (mapcar (function distance) plst3 (append (cdr plst3) (list (car plst3))))))
240.       (setq plst4 (foo4 plst))
241.       (if (or (< (length (unique plst4)) (length plst4)) (< (length plst4) (length plst)))
242.         (progn
243.           (prompt "\nError in (foo4) - return list has less points than reference one or output list contains duplicate points... Quitting...")
244.           (exit)
245.         )
246.       )
247.       (if (chkinters-p plst4)
248.         (setq plst4 (chkinters plst4))
249.       )
250.       (setq d4 (apply (function +) (mapcar (function distance) plst4 (append (cdr plst4) (list (car plst4))))))
251.       (setq dd (min d1 d2 d3 d4))
252.       (cond
253.         ( (= dd d1)
254.           (setq plst plst1)
255.         )
256.         ( (= dd d2)
257.           (setq plst plst2)
258.         )
259.         ( (= dd d3)
260.           (setq plst plst3)
261.         )
262.         ( (= dd d4)
263.           (setq plst plst4)
264.         )
265.       )
266.       (if (equal ddd dd 1e-6)
267.         (setq d dd)
268.         (setq ddd dd)
269.       )
270.     )
271.     plst
272.   )
273.  
274.   (prompt "\nSelect 2D points...")
275.   (if (setq ss (ssget (list (cons 0 "POINT"))))
276.     (progn
277.       (setq ti (car (_vl-times)))
278.       (repeat (setq i (sslength ss))
279.         (setq pl (cons (mapcar (function +) (list 0.0 0.0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
280.       )
281.       (setq pl (_vl-sort pl (function (lambda ( a b ) (if (= (cadr a) (cadr b)) (< (car a) (car b)) (< (cadr a) (cadr b)))))))
282.       (setq plst (MR:ConvexHull-ptsonHull (unique pl)))
283.       (if (caddr pl)
284.         (progn
285.           (setq pp (car plst))
286.           (foreach x plst
287.             (if (or (> (car x) (car pp)) (and (= (car x) (car pp)) (< (cadr x) (cadr pp))))
288.               (setq pp x)
289.             )
290.           )
291.           (if (> (vl-position (setq p (car-sort (cdr pl) (function (lambda ( a b ) (< (distance (car pl) a) (distance (car pl) b)))))) pl) (vl-position (car-sort (vl-remove p (cdr pl)) (function (lambda ( a b ) (< (distance (car pl) a) (distance (car pl) b))))) pl))
292.             (setq p1 (mapcar (function +) (car pl) (list 0.0 5e-2)) p2 (mapcar (function +) (last pl) (list 0.0 5e-2)))
293.             (setq plst (append (member pp plst) (reverse (cdr (member pp (reverse plst))))) p1 (mapcar (function +) (list (car (last pl)) (cadar pl)) (list -5e-2 0.0)) p2 (mapcar (function +) (list (caar pl) (cadr (last pl))) (list -5e-2 0.0)))
294.           )
295.           (setq inpl (vl-remove-if (function (lambda ( x ) (vl-position x plst))) pl))
296.           (setq in inpl)
297.           (setq inpl nil)
298.           (while in
299.             (setq inn (MR:ConvexHull-ptsonHull in))
300.             (setq in (vl-remove-if (function (lambda ( x ) (vl-position x inn))) in))
301.             (setq inpl (append inn inpl))
302.           )
303.           (while inpl
304.             (setq epl nil)
305.             (setq lil (mapcar (function list) plst (append (cdr plst) (list (car plst)))))
306.             (foreach e lil
307.               (setq epl (cons (list (car e) (car-sort inpl (function (lambda ( a b ) (if (equal (- (+ (distance (car e) a) (distance (cadr e) a)) (distance (car e) (cadr e))) (- (+ (distance (car e) b) (distance (cadr e) b)) (distance (car e) (cadr e))) 1e-3) (< (vl-position a inpl) (vl-position b inpl)) (< (- (+ (distance (car e) a) (distance (cadr e) a)) (distance (car e) (cadr e))) (- (+ (distance (car e) b) (distance (cadr e) b)) (distance (car e) (cadr e)))))))) (cadr e)) epl))
308.             )
309.             (setq epl (reverse epl))
310.             (setq e (car-sort (if (setq xx (vl-remove-if (function (lambda ( x ) (or (inters (car x) (cadr x) p1 p2) (inters (cadr x) (caddr x) p1 p2)))) epl)) xx epl) (function (lambda ( a b ) (if (equal (- (+ (distance (car a) (cadr a)) (distance (cadr a) (caddr a))) (distance (car a) (caddr a))) (- (+ (distance (car b) (cadr b)) (distance (cadr b) (caddr b))) (distance (car b) (caddr b))) 1e-3) (< (vl-position (car a) plst) (vl-position (car b) plst)) (< (- (+ (distance (car a) (cadr a)) (distance (cadr a) (caddr a))) (distance (car a) (caddr a))) (- (+ (distance (car b) (cadr b)) (distance (cadr b) (caddr b))) (distance (car b) (caddr b)))))))))
311.             (setq inpl (vl-remove (cadr e) inpl))
312.             (setq plst (apply (function append) (mapcar (function (lambda ( x ) (if (equal (car e) x) (list (car e) (cadr e)) (list x)))) plst)))
313.             (setq plst (append (member (caddr e) plst) (reverse (cdr (member (caddr e) (reverse plst))))))
314.             (setq plst (append (cdr plst) (list (car plst))))
315.             ;|
316.             (progn
317.               (redraw)
318.               (mapcar (function (lambda ( a b ) (grdraw a b 2 0))) plst (append (cdr plst) (list (car plst))))
319.               (getstring "\nENTER TO CONTINUE...")
320.             )
321.             |;
322.             ;;; debugging...
323.           )
324.           (setq rr1 (unique plst) dd1 (apply (function +) (mapcar (function distance) plst (append (cdr plst) (list (car plst))))))
325.           (setq plst (reverse plst))
326.           (setq rr2 (unique plst) dd2 (apply (function +) (mapcar (function distance) plst (append (cdr plst) (list (car plst))))))
327.           (if (< dd1 dd2)
328.             (setq plst rr1)
329.             (setq plst rr2)
330.           )
331.           (if (chkinters-p plst)
332.             (setq plst (processfoos (chkinters plst)))
333.             (setq plst (processfoos plst))
334.           )
335.         )
336.       )
337.       (setq d (apply (function +) (mapcar (function distance) plst (append (cdr plst) (list (car plst))))))
338.       (entmake
339.         (append
340.           (list
341.             (cons 0 "LWPOLYLINE")
342.             (cons 100 "AcDbEntity")
343.             (cons 100 "AcDbPolyline")
344.             (cons 90 (length plst))
345.             (cons 70 (1+ (* 128 (getvar 'plinegen))))
346.             (cons 38 0.0)
347.           )
348.           (mapcar (function (lambda ( p ) (cons 10 p))) plst)
349.           (list (list 210 0.0 0.0 1.0))
350.         )
351.       )
352.       (prompt "\nPath length : ") (princ (rtos d 2 20))
353.       (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
354.     )
355.   )
356.   (princ)
357. )
358.  

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on November 12, 2021, 02:08:20 PM

And also I want to post and mention for my triangulation implementation that differs from Delaunay as it creates concave hull instead of convex like Delaunay version... I don't want to place it in triangulation topic as this is far more challenging and brings many questions for which no real good answers exist... Evgeniy's version gives almost the same results like my above genetic version, but who knows maybe this different implementation of triangulation gives more insights about solving difficult TSP... Main difference from Delaunay is that it starts with smallest triangle somewhere and then it builds concave triangulation from which path is extracted as solution... I didn't formed any decent theoretical assumptions than doing straight forward solving the task as quickly as possible... The code is also very concise and beside its relatively good speed, that's its another benefit...
So no circumcirles and other points of views, but I suppose that it can bring attention for building theory on its basis...

Code - Auto/Visual Lisp: [Select]

1. (defun c:TSP-triangulate-MMR-old ( / car-sort _vl-sort ptinsidetriangle-p triangulate-MR ss ti i pl trl el e d )
2.  
3.   (defun car-sort ( lst cmp / rtn )
4.     (setq rtn (car lst))
5.     (foreach itm (cdr lst)
6.       (if (apply cmp (list itm rtn))
7.         (setq rtn itm)
8.       )
9.     )
10.     rtn
11.   )
12.  
13.   (defun _vl-sort ( l f / *q* ll ff gg )
14.     (if (= (type f) 'sym)
15.       (setq f (eval f))
16.     )
17.     (while (setq *q* (car l))
18.       (setq ll
19.         (if (null ll)
20.           (cons *q* ll)
21.           (cond
22.             ( (apply f (list (last ll) *q*))
23.               (append ll (list *q*))
24.             )
25.             ( (apply f (list *q* (car ll)))
26.               (cons *q* ll)
27.             )
28.             ( t
29.               (setq ff nil)
30.               (setq gg (apply (function append) (append (mapcar (function (lambda ( *xxx* *yyy* ) (if (null ff) (if (apply f (list *q* *yyy*)) (progn (setq ff t) (list *xxx* *q*)) (list *xxx*)) (list *xxx*)))) ll (cdr ll)) (list (list (last ll))))))
31.               (if (null ff)
32.                 (append ll (list *q*))
33.                 gg
34.               )
35.             )
36.           )
37.         )
38.       )
39.       (setq l (cdr l))
40.     )
41.     ll
42.   )
43.  
44.   (defun ptinsidetriangle-p ( pt p1 p2 p3 )
45.     (and
46.       (not
47.         (or
48.           (inters pt p1 p2 p3)
49.           (inters pt p2 p1 p3)
50.           (inters pt p3 p1 p2)
51.         )
52.       )
53.       (and
54.         (< (+ (distance pt p1) (distance pt p2)) (+ (distance p3 p1) (distance p3 p2)))
55.         (< (+ (distance pt p2) (distance pt p3)) (+ (distance p1 p2) (distance p1 p3)))
56.         (< (+ (distance pt p3) (distance pt p1)) (+ (distance p2 p3) (distance p2 p1)))
57.       )
58.       (not
59.         (or
60.           (equal (distance p1 p2) (+ (distance p1 pt) (distance pt p2)) 1e-6) ;; not on boundary
61.           (equal (distance p2 p3) (+ (distance p2 pt) (distance pt p3)) 1e-6) ;; not on boundary
62.           (equal (distance p3 p1) (+ (distance p3 pt) (distance pt p1)) 1e-6) ;; not on boundary
63.         )
64.       )
65.     )
66.   )
67.  
68.   (defun triangulate-MR ( pl / la lb lc d dd el trl q qq ell e )
69.     (setq d (+ (distance (car pl) (cadr pl)) (distance (cadr pl) (caddr pl)) (distance (caddr pl) (car pl))))
70.     (setq la pl)
71.     (foreach a la
72.       (setq lb (member a la))
73.       (foreach b (setq lb (cdr lb))
74.         (setq lc (member b lb))
75.         (foreach c (setq lc (cdr lc))
76.           (if (or (< (setq dd (+ (distance a b) (distance b c) (distance c a))) d) (equal dd d 1e-6))
77.             (setq trl (list (list a b c)) el (list (list a b) (list b c) (list c a)) d dd)
78.           )
79.         )
80.       )
81.     )
82.     (while (setq q (vl-remove-if (function (lambda ( x ) (vl-position x (apply (function append) trl)))) pl))
83.       (setq ell (mapcar (function (lambda ( x ) (list x (_vl-sort (vl-remove-if-not (function (lambda ( y ) (equal (min (distance (car x) (setq qq (car-sort q (function (lambda ( a b ) (if (equal (min (distance (car x) a) (distance a (cadr x))) (min (distance (car x) b) (distance b (cadr x))) 1e-6) (< (distance a (cadr x)) (distance b (cadr x))) (< (min (distance (car x) a) (distance a (cadr x))) (min (distance (car x) b) (distance b (cadr x)))))))))) (distance (cadr x) qq)) (min (distance (car x) y) (distance (cadr x) y)) 1e-6))) q) (function (lambda ( j k ) (< (distance (car x) j) (distance (car x) k)))))))) el))
84.       (if (setq q (vl-remove-if (function (lambda ( x ) (or (vl-some (function (lambda ( y ) (ptinsidetriangle-p y (caar x) (cadar x) (caadr x)))) (vl-remove (caar x) (vl-remove (cadar x) (vl-remove (caadr x) pl)))) (vl-some (function (lambda ( y / ip ) (or (and (setq ip (inters (caar x) (caadr x) (car y) (cadr y))) (not (equal ip (caar x) 1e-6)) (not (equal ip (car y) 1e-6)) (not (equal ip (cadr y) 1e-6))) (and (setq ip (inters (caar x) (caadr x) (cadr y) (caddr y))) (not (equal ip (caar x) 1e-6)) (not (equal ip (cadr y) 1e-6)) (not (equal ip (caddr y) 1e-6))) (and (setq ip (inters (caar x) (caadr x) (caddr y) (car y))) (not (equal ip (caar x) 1e-6)) (not (equal ip (caddr y) 1e-6)) (not (equal ip (car y) 1e-6))) (and (setq ip (inters (cadar x) (caadr x) (car y) (cadr y))) (not (equal ip (cadar x) 1e-6)) (not (equal ip (car y) 1e-6)) (not (equal ip (cadr y) 1e-6))) (and (setq ip (inters (cadar x) (caadr x) (cadr y) (caddr y))) (not (equal ip (cadar x) 1e-6)) (not (equal ip (cadr y) 1e-6)) (not (equal ip (caddr y) 1e-6))) (and (setq ip (inters (cadar x) (caadr x) (caddr y) (car y))) (not (equal ip (cadar x) 1e-6)) (not (equal ip (caddr y) 1e-6)) (not (equal ip (car y) 1e-6)))))) trl)))) ell))
85.         (progn
86.           (setq e (car-sort (_vl-sort (reverse q) (function (lambda ( x y ) (> (length (cadr x)) (length (cadr y)))))) (function (lambda ( x y ) (if (equal (min (distance (caar x) (caadr x)) (distance (cadar x) (caadr x))) (min (distance (caar y) (caadr y)) (distance (cadar y) (caadr y))) 1e-6) (< (+ (distance (caar x) (cadar x)) (distance (caar x) (caadr x)) (distance (cadar x) (caadr x))) (+ (distance (caar y) (cadar y)) (distance (caar y) (caadr y)) (distance (cadar y) (caadr y)))) (< (min (distance (caar x) (caadr x)) (distance (cadar x) (caadr x))) (min (distance (caar y) (caadr y)) (distance (cadar y) (caadr y)))))))))
87.           (setq el (vl-remove (car e) el) el (cons (list (caar e) (caadr e)) el) el (cons (list (cadar e) (caadr e)) el))
88.           (setq trl (cons (list (caar e) (caadr e) (cadar e)) trl))
89.         )
90.       )
91.     )
92.     (list trl el)
93.   )
94.  
95.   (prompt "\nSelect points...")
96.   (if (setq ss (ssget (list (cons 0 "POINT"))))
97.     (progn
98.       (setq ti (car (_vl-times)))
99.       (repeat (setq i (sslength ss))
100.         (setq pl (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) pl))
101.       )
102.       (setq trl (triangulate-MR pl))
103.       (setq el (cadr trl) trl (car trl))
104.       (setq pl nil)
105.       (setq pl (cons (caar el) pl))
106.       (while (vl-remove-if (function (lambda ( x ) (vl-position x pl))) (apply (function append) el))
107.         (setq pl (cons (car (vl-remove (car pl) (setq e (vl-some (function (lambda ( x ) (if (vl-position (car pl) x) x))) el)))) pl))
108.         (setq el (vl-remove e el))
109.       )
110.       (foreach tr (reverse trl)
111.         (entmake
112.           (list
113.             (cons 0 "3DFACE")
114.             (cons 100 "AcDbEntity")
115.             (cons 100 "AcDbFace")
116.             (cons 10 (car tr))
117.             (cons 11 (car tr))
118.             (cons 12 (cadr tr))
119.             (cons 13 (caddr tr))
120.           )
121.         )
122.       )
123.       (setq d (apply (function +) (mapcar (function distance) pl (append (cdr pl) (list (car pl))))))
124.       (entmake
125.         (append
126.           (list
127.             (cons 0 "LWPOLYLINE")
128.             (cons 100 "AcDbEntity")
129.             (cons 100 "AcDbPolyline")
130.             (cons 90 (length pl))
131.             (cons 70 (1+ (* 128 (getvar 'plinegen))))
132.             (cons 38 0.0)
133.           )
134.           (mapcar (function (lambda ( p ) (cons 10 p))) pl)
135.           (list
136.             (list 210 0.0 0.0 1.0)
137.             (cons 62 1)
138.           )
139.         )
140.       )
141.       (prompt "\nPath length : ") (princ (rtos d 2 20))
142.       (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
143.     )
144.   )
145.   (princ)
146. )
147.  

New variant :

Code - Auto/Visual Lisp: [Select]

1. (defun c:TSP-triangulate-MMR ( / car-sort _vl-sort ptinsidetriangle-p triangulate-MR ss ti i pl trl el e d )
2.  
3.   (defun car-sort ( lst cmp / rtn )
4.     (setq rtn (car lst))
5.     (foreach itm (cdr lst)
6.       (if (apply cmp (list itm rtn))
7.         (setq rtn itm)
8.       )
9.     )
10.     rtn
11.   )
12.  
13.   (defun _vl-sort ( l f / *q* ll ff gg )
14.     (if (= (type f) 'sym)
15.       (setq f (eval f))
16.     )
17.     (while (setq *q* (car l))
18.       (setq ll
19.         (if (null ll)
20.           (cons *q* ll)
21.           (cond
22.             ( (apply f (list (last ll) *q*))
23.               (append ll (list *q*))
24.             )
25.             ( (apply f (list *q* (car ll)))
26.               (cons *q* ll)
27.             )
28.             ( t
29.               (setq ff nil)
30.               (setq gg (apply (function append) (append (mapcar (function (lambda ( *xxx* *yyy* ) (if (null ff) (if (apply f (list *q* *yyy*)) (progn (setq ff t) (list *xxx* *q*)) (list *xxx*)) (list *xxx*)))) ll (cdr ll)) (list (list (last ll))))))
31.               (if (null ff)
32.                 (append ll (list *q*))
33.                 gg
34.               )
35.             )
36.           )
37.         )
38.       )
39.       (setq l (cdr l))
40.     )
41.     ll
42.   )
43.  
44.   (defun ptinsidetriangle-p ( pt p1 p2 p3 )
45.     (and
46.       (not
47.         (or
48.           (inters pt p1 p2 p3)
49.           (inters pt p2 p1 p3)
50.           (inters pt p3 p1 p2)
51.         )
52.       )
53.       (and
54.         (< (+ (distance pt p1) (distance pt p2)) (+ (distance p3 p1) (distance p3 p2)))
55.         (< (+ (distance pt p2) (distance pt p3)) (+ (distance p1 p2) (distance p1 p3)))
56.         (< (+ (distance pt p3) (distance pt p1)) (+ (distance p2 p3) (distance p2 p1)))
57.       )
58.       (not
59.         (or
60.           (equal (distance p1 p2) (+ (distance p1 pt) (distance pt p2)) 1e-6) ;; not on boundary
61.           (equal (distance p2 p3) (+ (distance p2 pt) (distance pt p3)) 1e-6) ;; not on boundary
62.           (equal (distance p3 p1) (+ (distance p3 pt) (distance pt p1)) 1e-6) ;; not on boundary
63.         )
64.       )
65.     )
66.   )
67.  
68.   (defun triangulate-MR ( pl / la lb lc d dd el trl q qq ell e )
69.     (setq d (+ (distance (car pl) (cadr pl)) (distance (cadr pl) (caddr pl)) (distance (caddr pl) (car pl))))
70.     (setq la pl)
71.     (foreach a la
72.       (setq lb (member a la))
73.       (foreach b (setq lb (cdr lb))
74.         (setq lc (member b lb))
75.         (foreach c (setq lc (cdr lc))
76.           (if (or (< (setq dd (+ (distance a b) (distance b c) (distance c a))) d) (equal dd d 1e-6))
77.             (setq trl (list (list a b c)) el (list (list a b) (list b c) (list c a)) d dd)
78.           )
79.         )
80.       )
81.     )
82.     (while (setq q (vl-remove-if (function (lambda ( x ) (vl-position x (apply (function append) trl)))) pl))
83.       (setq ell (mapcar (function (lambda ( x ) (list x (_vl-sort (vl-remove-if-not (function (lambda ( y ) (equal (+ (distance (car x) (setq qq (car-sort q (function (lambda ( a b ) (if (equal (+ (distance (car x) a) (distance a (cadr x))) (+ (distance (car x) b) (distance b (cadr x))) 1e-6) (< (distance a (cadr x)) (distance b (cadr x))) (< (+ (distance (car x) a) (distance a (cadr x))) (+ (distance (car x) b) (distance b (cadr x)))))))))) (distance (cadr x) qq)) (+ (distance (car x) y) (distance (cadr x) y)) 1e-6))) q) (function (lambda ( j k ) (< (distance (car x) j) (distance (car x) k)))))))) el))
84.       (if (setq q (vl-remove-if (function (lambda ( x ) (or (vl-some (function (lambda ( y ) (ptinsidetriangle-p y (caar x) (cadar x) (caadr x)))) (vl-remove (caar x) (vl-remove (cadar x) (vl-remove (caadr x) pl)))) (vl-some (function (lambda ( y / ip ) (or (and (setq ip (inters (caar x) (caadr x) (car y) (cadr y))) (not (equal ip (caar x) 1e-6)) (not (equal ip (car y) 1e-6)) (not (equal ip (cadr y) 1e-6))) (and (setq ip (inters (caar x) (caadr x) (cadr y) (caddr y))) (not (equal ip (caar x) 1e-6)) (not (equal ip (cadr y) 1e-6)) (not (equal ip (caddr y) 1e-6))) (and (setq ip (inters (caar x) (caadr x) (caddr y) (car y))) (not (equal ip (caar x) 1e-6)) (not (equal ip (caddr y) 1e-6)) (not (equal ip (car y) 1e-6))) (and (setq ip (inters (cadar x) (caadr x) (car y) (cadr y))) (not (equal ip (cadar x) 1e-6)) (not (equal ip (car y) 1e-6)) (not (equal ip (cadr y) 1e-6))) (and (setq ip (inters (cadar x) (caadr x) (cadr y) (caddr y))) (not (equal ip (cadar x) 1e-6)) (not (equal ip (cadr y) 1e-6)) (not (equal ip (caddr y) 1e-6))) (and (setq ip (inters (cadar x) (caadr x) (caddr y) (car y))) (not (equal ip (cadar x) 1e-6)) (not (equal ip (caddr y) 1e-6)) (not (equal ip (car y) 1e-6)))))) trl)))) ell))
85.         (progn
86.           (setq e (car-sort (_vl-sort (reverse q) (function (lambda ( x y ) (> (length (cadr x)) (length (cadr y)))))) (function (lambda ( x y ) (if (equal (+ (distance (caar x) (caadr x)) (distance (cadar x) (caadr x))) (+ (distance (caar y) (caadr y)) (distance (cadar y) (caadr y))) 1e-6) (< (+ (distance (caar x) (cadar x)) (distance (caar x) (caadr x)) (distance (cadar x) (caadr x))) (+ (distance (caar y) (cadar y)) (distance (caar y) (caadr y)) (distance (cadar y) (caadr y)))) (< (+ (distance (caar x) (caadr x)) (distance (cadar x) (caadr x))) (+ (distance (caar y) (caadr y)) (distance (cadar y) (caadr y)))))))))
87.           (setq el (vl-remove (car e) el) el (cons (list (caar e) (caadr e)) el) el (cons (list (cadar e) (caadr e)) el))
88.           (setq trl (cons (list (caar e) (caadr e) (cadar e)) trl))
89.         )
90.       )
91.     )
92.     (list trl el)
93.   )
94.  
95.   (prompt "\nSelect points...")
96.   (if (setq ss (ssget (list (cons 0 "POINT"))))
97.     (progn
98.       (setq ti (car (_vl-times)))
99.       (repeat (setq i (sslength ss))
100.         (setq pl (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) pl))
101.       )
102.       (setq trl (triangulate-MR pl))
103.       (setq el (cadr trl) trl (car trl))
104.       (setq pl nil)
105.       (setq pl (cons (caar el) pl))
106.       (while (vl-remove-if (function (lambda ( x ) (vl-position x pl))) (apply (function append) el))
107.         (setq pl (cons (car (vl-remove (car pl) (setq e (vl-some (function (lambda ( x ) (if (vl-position (car pl) x) x))) el)))) pl))
108.         (setq el (vl-remove e el))
109.       )
110.       (foreach tr (reverse trl)
111.         (entmake
112.           (list
113.             (cons 0 "3DFACE")
114.             (cons 100 "AcDbEntity")
115.             (cons 100 "AcDbFace")
116.             (cons 10 (car tr))
117.             (cons 11 (car tr))
118.             (cons 12 (cadr tr))
119.             (cons 13 (caddr tr))
120.           )
121.         )
122.       )
123.       (setq d (apply (function +) (mapcar (function distance) pl (append (cdr pl) (list (car pl))))))
124.       (entmake
125.         (append
126.           (list
127.             (cons 0 "LWPOLYLINE")
128.             (cons 100 "AcDbEntity")
129.             (cons 100 "AcDbPolyline")
130.             (cons 90 (length pl))
131.             (cons 70 (1+ (* 128 (getvar 'plinegen))))
132.             (cons 38 0.0)
133.           )
134.           (mapcar (function (lambda ( p ) (cons 10 p))) pl)
135.           (list
136.             (list 210 0.0 0.0 1.0)
137.             (cons 62 1)
138.           )
139.         )
140.       )
141.       (prompt "\nPath length : ") (princ (rtos d 2 20))
142.       (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
143.     )
144.   )
145.   (princ)
146. )
147.  

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on November 12, 2021, 02:09:10 PM

And also not pretty, but based on Delaunay and Djikstra algorithm - there is no any reasonably well results, but just for completness :

Code - Auto/Visual Lisp: [Select]

1. (defun c:TSP-Delaunay-Dijkstra ( / *error* *adoc* -pi/2 3D->2D sortxy remduppoint RemoveIDDup unique triangulate minpath shortpath-refine-no-int ss ti i pl trl edges nodes g f gg ggg ff fff n pll dijkstra path plst lw d )
2.  
3.   (vl-load-com)
4.  
5.   (defun *error* ( m )
6.     (vla-endundomark *adoc*)
7.     (if m
8.       (prompt m)
9.     )
10.     (princ)
11.   )
12.  
13.   (setq -pi/2 -1.5707963267948966192313216916398)
14.  
15.   ;; 3D to 2D point  -  M.R.
16.   ;; Returns 2D point list from supplied 3D point list or returns supplied argument if it isn't 3D point list
17.  
18.   (defun 3D->2D ( p )
19.     (if (and (listp p) (vl-every (function (lambda ( x ) (eq (type x) 'REAL))) p) (eq (length p) 3))
20.       (list (car p) (cadr p))
21.       p
22.     )
23.   )
24.  
25.   ;;                                                                            ;
26.   ;; sortxy                                                                     ;
27.   ;;                                                                            ;
28.   ;; Sorts a list of points on Increasing X order and Increasing Y              ;
29.   ;;                                                                            ;
30.  
31.   (defun sortxy ( l )
32.     (vl-sort l
33.       (function
34.         (lambda ( a b )
35.           (if (= (car a) (car b))
36.             (< (cadr a) (cadr b))
37.             (< (car  a) (car  b))
38.           )
39.         )
40.       )  
41.     )
42.   )
43.  
44.   ;;                                                                            ;
45.   ;; remduppoint       by Joe Burke                                             ;
46.   ;;                                                                            ;
47.   ;; Remove Duplicate Adjacent Points from Point List with Fuzz Factor          ;
48.   ;; Point List Needs to be Sorted Prior to Calling this Function               ;
49.   ;; Modified by ymg to operate on 2d points. (3D->2D p)                        ;
50.   ;; Modified again by M.R.                                                     ;
51. ;|
52.   (defun remduppoint ( l fuzz / rtn p )
53.     (repeat (1- (length l))
54.       (setq p (car l))
55.       (if (> (distance (3D->2D p) (cadr l)) fuzz)
56.         (setq rtn (cons p rtn))
57.       )
58.       (setq l (cdr l))
59.     )
60.     (reverse (cons (car l) rtn))
61.   )
62. |;
63.   (defun remduppoint ( l fuzz / l1 )
64.     (setq l (vl-sort l (function (lambda ( a b ) (< (caddr a) (caddr b))))))
65.     (while (car l)
66.       (setq l1 (cons (car l) (vl-remove-if (function (lambda ( x ) (equal (list (car x) (cadr x)) (list (caar l) (cadar l)) fuzz))) l1)))
67.       (setq l (cdr l))
68.     )
69.     l1
70.   )
71.  
72.   (defun RemoveIDDup ( l )
73.     (if l
74.       (cons (car l)
75.         (RemoveIDDup
76.           (vl-remove-if
77.             (function (lambda ( x )
78.                 (or (and (= (car x) (caar l))
79.                          (= (cadr x) (cadar l))
80.                     )
81.                     (and (= (car x) (cadar l))
82.                          (= (cadr x) (caar l))
83.                     )
84.                 )
85.               )
86.             )
87.             (cdr l)
88.           )
89.         )
90.       )
91.     )
92.   )
93.  
94.   (defun unique ( l fuzz / a ll )
95.     (while (setq a (car l))
96.       (if (vl-some (function (lambda ( x ) (equal x a fuzz))) (cdr l))
97.         (setq ll (cons a ll) l (vl-remove-if (function (lambda ( x ) (equal x a fuzz))) (cdr l)))
98.         (setq ll (cons a ll) l (cdr l))
99.       )
100.     )
101.     (reverse ll)
102.   )
103.  
104.   ;; Triangulate - subfunction for drawing Delunay triangulation from specified list of points with provided factor for checking weather calcualted triangulation is convex hull boundary triangulation
105.   ;; Returns list of 2 elements - first element is list of triangles defined by 3 points forming triangle and second element is calculated factor for forming supertriangle for next call of triangulate function for gathering correct convex hull boundary of triangulation triangles
106.  
107.   (defun triangulate ( pl / tl xmin xmax ymin ymax cs pmin pmax t1 t2 t3 n str rs np al p el tr l a b c vll cp r )
108.  
109.     (setq xmin (caar pl)) ;;; Sorted pl by X ;;;
110.     (setq xmax (caar (vl-sort pl (function (lambda ( a b ) (> (car a) (car b)))))))
111.     (setq ymin (cadar (vl-sort pl (function (lambda ( a b ) (< (cadr a) (cadr b)))))))
112.     (setq ymax (cadar (vl-sort pl (function (lambda ( a b ) (> (cadr a) (cadr b)))))))
113.     (setq cs (list (+ xmin (/ (- xmax xmin) 2.0)) (+ ymin (/ (- ymax ymin) 2.0))))
114.     (setq pmin (list xmin ymin) pmax (list xmax ymax))
115.     (setq t1 (polar cs (/ pi 12.0) (if (setq n (atoi (substr (setq str (rtos (distance pmin cs) 1 0)) (- (strlen str) 2)))) (setq rs (expt 50.0 (+ n 2))))))
116.     (setq t2 (polar cs (+ (/ pi 12.0) (/ (* 2.0 pi) 3.0)) rs))
117.     (setq t3 (polar cs (+ (/ pi 12.0) (/ (* 4.0 pi) 3.0)) rs))
118.     (setq np (length pl))
119.     (setq pl (append pl (list (list (car t1) (cadr t1) 0.0) (list (car t2) (cadr t2) 0.0) (list (car t3) (cadr t3) 0.0))))
120.     (setq al (list (list (car t1) cs rs (list np (+ 1 np) (+ 2 np)))))
121.     (setq n -1)
122.     (repeat np
123.       (setq n (1+ n))
124.       (setq p (nth n pl))
125.       (setq el nil)
126.       (repeat (length al)
127.         (setq tr (car al))
128.         (setq al (cdr al))
129.         (cond
130.           ( (< (car tr) (car p)) ;;; Comparison of X values ;;;
131.             (setq tl (cons (cadddr tr) tl))
132.           )
133.           ( (< (distance p (cadr tr)) (caddr tr))
134.             (setq a (car (cadddr tr))
135.                   b (cadr (cadddr tr))
136.                   c (caddr (cadddr tr))
137.                   el (vl-list* (list a b) (list b c) (list c a) el)
138.             )
139.           )
140.           ( t (setq l (cons tr l)) )
141.         )
142.       )
143.       (setq al l l nil)
144.       (while el ;;; el - edge list = ((a b) (b c) (c a) (d e) (e f) (f d) ... )
145.         (if (or (vl-position (reverse (car el)) el)
146.                 (vl-position (car el) (cdr el))
147.             )
148.             (setq el (vl-remove (reverse (car el)) el)
149.                   el (vl-remove (car el) el)
150.             )
151.             (progn  ; This replaces call to getcircumcircle function     ;
152.               (setq p (nth n pl)
153.                     b (nth (caar el) pl)
154.                     c (nth (cadar el) pl)
155.                     vll (list n (caar el) (cadar el))
156.               )
157.               (if (not (zerop (setq ang (- (angle b c) (angle b p)))))
158.                 (setq cp (polar (3D->2D c) (+ -pi/2 (angle c p) ang) (setq r (/ (distance (3D->2D p) (3D->2D c)) (sin ang) 2.0)))
159.                       al (cons (list (+ (car cp) (abs r)) cp (abs r) vll) al)
160.                       el (cdr el)
161.                 )
162.                 (progn
163.                   (prompt "\nZero angle difference occurrence... Can't triangulate - quitting...")
164.                   (exit)
165.                 )
166.               )
167.             )
168.         )
169.       )
170.     )
171.     (foreach tr al (setq tl (cons (cadddr tr) tl)))
172.     (setq tl (vl-remove-if-not
173.       (function
174.         (lambda ( x ) (and (< (car x) np) (< (cadr x) np) (< (caddr x) np)))
175.       )
176.       tl
177.       )
178.     )
179.     tl
180.   ) ;;; end of triangulate
181.  
182.   ;; minpath - Dijkstra algorithm by ymg...
183.  
184.   (defun minpath ( g f nodes edges / brname clnodes closedl go new nodname old openl totdist ppath )
185.     (setq nodes (vl-remove g nodes))
186.     (setq openl (list (list g 0 nil)))
187.     (setq closedl nil)
188.     (setq go t)
189.     (foreach n nodes
190.       (setq nodes (subst (list n 0 nil) n nodes))
191.     )
192.     (while (and go (not (= (caar closedl) f)))
193.       (setq nodname (caar openl))
194.       (setq totdist (cadar openl))
195.       (setq closedl (cons (car openl) closedl))
196.       (setq openl (cdr openl))
197.       (setq clnodes (mapcar (function car) closedl))
198.       (foreach e edges
199.         (setq brname nil)
200.         (cond
201.           ( (= (car e) nodname)
202.             (setq brname (cadr e))
203.           )
204.           ( (= (cadr e) nodname)
205.             (setq brname (car e))
206.           )
207.         )
208.         (if brname
209.           (progn
210.             (setq new (list brname (+ (caddr e) totdist) nodname))
211.             (cond
212.               ( (member brname clnodes) )
213.               ( (setq old (vl-some (function (lambda ( x ) (if (= brname (car x)) x))) openl))
214.                 (if (< (cadr new) (cadr old))
215.                   (setq openl (subst new old openl))
216.                 )
217.               )
218.               ( t (setq openl (cons new openl)) )
219.             )
220.           )
221.         )
222.       )
223.       (setq openl (vl-sort openl (function (lambda ( a b ) (< (cadr a) (cadr b))))))
224.       (and (null openl) (null (caar closedl)) (setq go nil))
225.     )
226.     (setq ppath (list (car closedl)))
227.     (foreach n closedl
228.       (if (= (car n) (caddr (car ppath)))
229.         (setq ppath (cons n ppath))
230.       )
231.     )
232.     ppath
233.   )
234.  
235.   (defun shortpath-refine-no-int ( lw / pl lil lii1 lii2 lil1 lil2 ip pln d )
236.     (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget lw))))
237.     (setq lil (mapcar (function (lambda ( a b ) (list a b))) pl (append (cdr pl) (list (car pl)))))
238.     (while (vl-some (function (lambda ( li1 ) (vl-some (function (lambda ( li2 ) (if (and (setq ip (inters (car li1) (cadr li1) (car li2) (cadr li2))) (not (equal ip (car li1) 1e-8)) (not (equal ip (cadr li1) 1e-8)) (not (equal ip (car li2) 1e-8)) (not (equal ip (cadr li2) 1e-8))) (setq lii1 li1 lii2 li2)))) (vl-remove li1 lil)))) lil)
239.       (setq lil1 (if (member lii2 (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil))))))) (reverse (cdr (member lii2 (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil))))))))) (reverse (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil)))))))))
240.       (setq lil2 (if (member lii1 (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil))))))) (cdr (member lii1 (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil)))))))) (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil))))))))
241.       (setq lil (append lil1 (list (list (cadr (last lil1)) (cadr (car lil2)))) (mapcar (function reverse) lil2) (list (list (car (last lil2)) (car (car lil1))))))
242.     )
243.     (setq pln (mapcar (function car) lil))
244.     (setq d (apply (function +) (mapcar '(lambda ( a b ) (distance a b)) pln (append (cdr pln) (list (car pln))))))
245.     (entmake
246.       (append
247.         (list
248.           (cons 0 "LWPOLYLINE")
249.           (cons 100 "AcDbEntity")
250.           (cons 100 "AcDbPolyline")
251.           (cons 90 (length pln))
252.           (cons 70 (1+ (* (getvar 'plinegen) 128)))
253.           (cons 38 0.0)
254.         )
255.         (mapcar (function (lambda ( p ) (cons 10 p))) pln)
256.         (list
257.           (assoc 210 (entget lw))
258.           (cons 62 1)
259.         )
260.       )
261.     )
262.     (entdel lw)
263.     d
264.   )
265.  
266.   (vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
267.   (prompt "\nSelect 2D points...")
268.   (if (setq ss (ssget (list (cons 0 "POINT"))))
269.     (progn
270.       (setq ti (car (_vl-times)))
271.       (repeat (setq i (sslength ss))
272.         (setq pl (cons (trans (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) 0 1) pl))
273.       )
274.       (setq trl (triangulate (setq pl (sortxy (remduppoint pl 1e-6)))))
275.       (setq edges (RemoveIDDup (apply (function append) (mapcar (function (lambda ( x ) (list (list (car x) (cadr x) (distance (nth (car x) pl) (nth (cadr x) pl))) (list (cadr x) (caddr x) (distance (nth (cadr x) pl) (nth (caddr x) pl))) (list (caddr x) (car x) (distance (nth (caddr x) pl) (nth (car x) pl)))))) trl))))
276.       (setq nodes (mapcar (function (lambda ( x ) (vl-position x pl))) pl))
277.       (setq g (car nodes) f (last nodes))
278.       (setq edges (vl-remove-if (function (lambda ( x ) (or (and (= (car x) g) (= (cadr x) f)) (and (= (cadr x) g) (= (car x) f))))) edges))
279.       (while (/= (length nodes) 2)
280.         (setq gg f ff g)
281.         (setq dijkstra (mapcar (function car) (minpath g f nodes edges)))
282.         (setq path (append path (mapcar (function (lambda ( x ) (if (null pll) (trans (nth x pl) 1 0) (trans (nth x pll) 1 0)))) dijkstra)))
283.         (setq nodes (vl-remove-if (function (lambda ( x ) (vl-position x dijkstra))) nodes))
284.         (setq nodes (cons gg nodes) nodes (cons ff nodes))
285.         (setq ggg (if (null pll) (nth gg pl) (nth gg pll)) fff (if (null pll) (nth ff pl) (nth ff pll)))
286.         (setq trl (triangulate (setq pll (sortxy (remduppoint (mapcar (function (lambda ( x ) (if (null pll) (nth x pl) (nth x pll)))) nodes) 1e-6)))))
287.         (setq nodes (mapcar (function (lambda ( x ) (vl-position x pll))) pll))
288.         (setq edges (RemoveIDDup (apply (function append) (mapcar (function (lambda ( x ) (list (list (car x) (cadr x) (distance (nth (car x) pll) (nth (cadr x) pll))) (list (cadr x) (caddr x) (distance (nth (cadr x) pll) (nth (caddr x) pll))) (list (caddr x) (car x) (distance (nth (caddr x) pll) (nth (car x) pll)))))) trl))))
289.         (setq n -1 g (vl-some (function (lambda ( x ) (setq n (1+ n)) (if (equal x ggg 1e-6) n))) pll) n -1 f (vl-some (function (lambda ( x ) (setq n (1+ n)) (if (equal x fff 1e-6) n))) pll))
290.         (setq edges (vl-remove-if (function (lambda ( x ) (or (and (= (car x) g) (= (cadr x) f)) (and (= (cadr x) g) (= (car x) f))))) edges))
291.       )
292.  
293.       (setq plst (unique path 1e-6))
294.       ;(setq plst path)
295.  
296.       (setq lw
297.         (entmakex
298.           (append
299.             (list
300.               (cons 0 "LWPOLYLINE")
301.               (cons 100 "AcDbEntity")
302.               (cons 100 "AcDbPolyline")
303.               (cons 90 (length plst))
304.               (cons 70 (1+ (* 128 (getvar 'plinegen))))
305.               (cons 38 0.0)
306.             )
307.             (mapcar (function (lambda ( p ) (cons 10 p))) plst)
308.             (list (list 210 0.0 0.0 1.0))
309.             (list (cons 62 1))
310.           )
311.         )
312.       )
313.  
314.       (setq d (shortpath-refine-no-int lw))
315.       ;(setq d (vlax-curve-getdistatparam lw (vlax-curve-getendparam lw)))
316.  
317.       (prompt "\nPath length : ") (princ (rtos d 2 50))
318.       (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 50)) (prompt " milliseconds...")
319.     )
320.   )
321.   (*error* nil)
322. )
323.  

Regards, M.R.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: It's Alive! on November 12, 2021, 06:46:02 PM

Quote from: ribarm on November 12, 2021, 02:08:20 PM

And also I want to post and mention for my triangulation implementation that differs from Delaunay as it creates concave hull instead of convex like Delaunay version... I don't want to place it in triangulation topic as this is far more

Need a concave hull for this https://www.theswamp.org/index.php?topic=57094.30
I tried here https://www.theswamp.org/index.php?topic=57135.0, using https://github.com/sadaszewski/concaveman-cpp, which is a port from, JS https://github.com/mapbox/concaveman

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on November 13, 2021, 03:47:46 AM

Daniel, that post :
http://www.theswamp.org/index.php?topic=30434.msg607043#msg607043
and code in it had some lacks, but it gives concave hull as well good... It was late yesterday, so I've just put what I pulled that day as soon as possible... Lacks were in (_vl-sort) function - solved...; then in start of (trinagulate-MR) sub - triple (foreach) looping missed to find starting smallest triangle - I over programmed - solved...; at some point of routine - main (while) loop of (triangulate-MR), only very adjacent triangle was used for checking if next founded point with edge points (triangle to be created) intersects other triangles - previously was only adjacent triangle - solved...

As far as I can see, I think that there are no lacks now, so you can safely copy+paste it and save as *.lsp...
If you or someone else notice more than me - you know I am just the ordinary swamper... So your feedback would be very appreciated...

P.S. To my very brief observations - that routine strives to find smallest bounded area rather than perimeter if hull was to be created with some meanings (not just connections between points and returning back with the same path making invisible closure), though nowhere was pointed and searched and programmed for this - that's how it returned hull from adjacent triangles... So not original shortest TSP, but rather some different TSP task...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on November 13, 2021, 10:51:13 AM

I've added another variant of TSP-triangulate-MMR routine - look at link from previous post...

The only difference from "*-old.lsp" version is that all occurrences of (min) function is replaced with (+) function...
Perhaps, new version will yield more closer results to real TSP task... (but that's just perhaps...)

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on November 15, 2021, 04:40:42 AM

More variants...

Recursion - there is tree branching - terribly slow - even for 40 pts...

Code - Auto/Visual Lisp: [Select]

1. (defun c:TSP-recurse+foo-subs ( / MR:ConvexHull-ptsonHull LM:ConvexHull-ptsonHull LM:Clockwise-p car-sort _vl-sort unique chkinters chkinters-p foo1 foo2 foo3 foo4 processfoos process ss ti i pl plst inpl *return* d ) ;; *return* is processed through recursions - lexical global variable
2.  
3.   ;; Convex Hull  -  Lee Mac
4.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
5.   ;; Mod by M.R.  -  uses (car-sort) and (_vl-sort) subs...
6.  
7.   (defun MR:ConvexHull-ptsonHull ( lst / ch p0 lstl )
8.     (cond
9.       ( (< (length lst) 4) (_vl-sort lst (function (lambda ( a b ) (if (= (cadr a) (cadr b)) (< (car a) (car b)) (< (cadr a) (cadr b)))))) )
10.       ( (setq p0 (car lst))
11.         (foreach p1 (cdr lst)
12.           (if (or (< (cadr p1) (cadr p0)) (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0))))
13.             (setq p0 p1)
14.           )
15.         )
16.         (setq lst (vl-remove p0 lst))
17.         (setq lst (append (list p0) lst))
18.         (setq lst
19.           (_vl-sort lst
20.             (function
21.               (lambda ( a b / c d )
22.                 (if (or (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8) (and (or (equal c 0.0 1e-8) (equal c (* 2 pi) 1e-8)) (or (equal d 0.0 1e-8) (equal d (* 2 pi) 1e-8))))
23.                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
24.                   (< c d)
25.                 )
26.               )
27.             )
28.           )
29.         )
30.         (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
31.         (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
32.         (setq lstl (_vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
33.         (setq lst (append lst lstl))
34.         (setq ch (list (cadr lst) (car lst)))
35.         (foreach pt (cddr lst)
36.           (if (equal pt (last lst))
37.             (setq ch (cons pt ch))
38.             (if (or (equal (angle (car ch) pt) (car-sort (mapcar (function (lambda ( x ) (angle (car ch) x))) (member pt lst)) (function <)) 1e-6) (equal (distance pt (cadr ch)) (+ (distance pt (car ch)) (distance (car ch) (cadr ch))) 1e-6))
39.               (setq ch (cons pt ch))
40.             )
41.           )
42.         )
43.         (reverse ch)
44.       )
45.     )
46.   )
47.  
48.   ;; Convex Hull  -  Lee Mac
49.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
50.  
51.   (defun LM:ConvexHull-ptsonHull ( lst / ch p0 lstl )
52.     (cond
53.       ( (< (length lst) 4) lst)
54.       ( (setq p0 (car lst))
55.         (foreach p1 (cdr lst)
56.           (if (or (< (cadr p1) (cadr p0)) (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0))))
57.             (setq p0 p1)
58.           )
59.         )
60.         (setq lst (vl-remove p0 lst))
61.         (setq lst (append (list p0) lst))
62.         (setq lst
63.           (_vl-sort lst
64.             (function
65.               (lambda ( a b / c d )
66.                 (if (or (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8) (and (or (equal c 0.0 1e-8) (equal c (* 2 pi) 1e-8)) (or (equal d 0.0 1e-8) (equal d (* 2 pi) 1e-8))))
67.                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
68.                   (< c d)
69.                 )
70.               )
71.             )
72.           )
73.         )
74.         (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
75.         (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
76.         (setq lstl (_vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
77.         (setq lst (append lst lstl))
78.         (setq ch (list (cadr lst) (car lst)))
79.         (foreach pt (cddr lst)
80.           (setq ch (cons pt ch))
81.           (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt) (not (equal (distance (caddr ch) pt) (+ (distance (caddr ch) (cadr ch)) (distance (cadr ch) pt)) 1e-8)))
82.             (setq ch (cons pt (cddr ch)))
83.           )
84.         )
85.         (reverse ch)
86.       )
87.     )
88.   )
89.  
90.   ;; Clockwise-p  -  Lee Mac
91.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
92.  
93.   (defun LM:Clockwise-p ( p1 p2 p3 )
94.     (minusp (- (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1))) (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))))
95.   )
96.  
97.   (defun car-sort ( lst cmp / rtn )
98.     (setq rtn (car lst))
99.     (foreach itm (cdr lst)
100.       (if (apply cmp (list itm rtn))
101.         (setq rtn itm)
102.       )
103.     )
104.     rtn
105.   )
106.  
107.   (defun _vl-sort ( l f / *q* ll ff gg )
108.     (if (= (type f) 'sym)
109.       (setq f (eval f))
110.     )
111.     (while (setq *q* (car l))
112.       (setq ll
113.         (if (null ll)
114.           (cons *q* ll)
115.           (cond
116.             ( (apply f (list (last ll) *q*))
117.               (append ll (list *q*))
118.             )
119.             ( (apply f (list *q* (car ll)))
120.               (cons *q* ll)
121.             )
122.             ( t
123.               (setq ff nil)
124.               (setq gg (apply (function append) (append (mapcar (function (lambda ( *xxx* *yyy* ) (if (null ff) (if (apply f (list *q* *yyy*)) (progn (setq ff t) (list *xxx* *q*)) (list *xxx*)) (list *xxx*)))) ll (cdr ll)) (list (list (last ll))))))
125.               (if (null ff)
126.                 (append ll (list *q*))
127.                 gg
128.               )
129.             )
130.           )
131.         )
132.       )
133.       (setq l (cdr l))
134.     )
135.     ll
136.   )
137.  
138.   (defun unique ( l / a ll )
139.     (while (setq a (car l))
140.       (if (vl-some (function (lambda ( x ) (equal x a 1e-6))) (cdr l))
141.         (setq ll (cons a ll) l (vl-remove-if (function (lambda ( x ) (equal x a 1e-6))) (cdr l)))
142.         (setq ll (cons a ll) l (cdr l))
143.       )
144.     )
145.     (reverse ll)
146.   )
147.  
148.   (defun chkinters ( pl / lil k a ilil pre mid suf )
149.     (setq lil (mapcar (function list) pl (append (cdr pl) (list (car pl)))))
150.     (setq k -1)
151.     (while (and (< (setq k (1+ k)) (length lil)) (setq a (nth k lil)))
152.       (setq ilil (vl-some (function (lambda ( b / ip ) (if (and (setq ip (inters (car a) (cadr a) (car b) (cadr b))) (not (equal ip (car a) 1e-6)) (not (equal ip (cadr a) 1e-6)) (not (equal ip (car b) 1e-6)) (not (equal ip (cadr b) 1e-6))) (list a b)))) (vl-remove a lil)))
153.       (if ilil
154.         (progn
155.           (setq pre (reverse (cdr (member (car ilil) (reverse lil)))))
156.           (setq mid (cdr (member (car ilil) lil)))
157.           (setq mid (cdr (member (cadr ilil) (reverse mid))))
158.           (setq mid (mapcar (function reverse) mid))
159.           (setq suf (cdr (member (cadr ilil) lil)))
160.           (setq lil (append pre (list (list (car (car ilil)) (car (cadr ilil)))) mid (list (list (cadr (car ilil)) (cadr (cadr ilil)))) suf))
161.           (setq pre nil mid nil suf nil)
162.           (setq ilil nil k -1)
163.         )
164.       )
165.     )
166.     (mapcar (function car) lil)
167.   )
168.  
169.   (defun chkinters-p ( l / lil )
170.     (setq lil (mapcar (function list) l (append (cdr l) (list (car l)))))
171.     (vl-some (function (lambda ( x ) (vl-some (function (lambda ( y ) (inters (car x) (cadr x) (car y) (cadr y)))) (vl-remove (if (= (vl-position x lil) 0) (last lil) (nth (1- (vl-position x lil)) lil)) (vl-remove (if (= (vl-position x lil) (1- (length lil))) (car lil) (nth (1+ (vl-position x lil)) lil)) (vl-remove x lil)))))) lil)
172.   )
173.  
174.   (defun foo1 ( plst / l )
175.     (setq l plst)
176.     (while (and (null xxx1) (vl-some (function (lambda ( a b / l1 l2 c ) (setq l1 l c (vl-some (function (lambda ( x ) (if (< (distance a x) (distance a b)) x))) (vl-remove a (vl-remove b l)))) (if c (setq l2 (append (reverse (member a (reverse (vl-remove c l)))) (list c) (if (/= (vl-position a l) (1- (length l))) (member b (vl-remove c l))))) (setq l2 nil)) (if (and l2 (or (< (length (unique l2)) (length l2)) (< (length l2) (length l1)))) (setq xxx1 (list l1 l2 c (list a b)))) (if (and l2 (not (chkinters-p l2)) (> (apply (function +) (mapcar (function distance) l1 (append (cdr l1) (list (car l1))))) (apply (function +) (mapcar (function distance) l2 (append (cdr l2) (list (car l2))))))) (setq l l2) (if l2 (progn (setq l (append (cdr l) (list (car l)))) nil))))) l (append (cdr l) (list (car l))))))
177.     l
178.   )
179.  
180.   (defun foo2 ( plst / l )
181.     (setq l plst)
182.     (while (and (null xxx2) (vl-some (function (lambda ( a b / l1 l2 c d e ) (setq l1 l c (vl-some (function (lambda ( x ) (if (< (- (+ (distance a x) (distance x b)) (distance a b)) (- (+ (distance (setq d (if (= (vl-position x l) 0) (last l) (nth (1- (vl-position x l)) l))) x) (distance x (setq e (if (= (vl-position x l) (1- (length l))) (car l) (nth (1+ (vl-position x l)) l))))) (distance d e))) x))) (vl-remove a (vl-remove b l)))) (if c (setq l2 (append (reverse (member a (reverse (vl-remove c l)))) (list c) (if (/= (vl-position a l) (1- (length l))) (vl-remove c (member b l))))) (setq l2 nil)) (if (and l2 (or (< (length (unique l2)) (length l2)) (< (length l2) (length l1)))) (setq xxx2 (list l1 l2 c d e (list a b)))) (if (and l2 (not (chkinters-p l2)) (> (apply (function +) (mapcar (function distance) l1 (append (cdr l1) (list (car l1))))) (apply (function +) (mapcar (function distance) l2 (append (cdr l2) (list (car l2))))))) (setq l l2) (if l2 (progn (setq l (append (cdr l) (list (car l)))) nil))))) l (append (cdr l) (list (car l))))))
183.     l
184.   )
185.  
186.   (defun foo3 ( plst / l )
187.     (setq l plst)
188.     (while (and (null xxx3) (vl-some (function (lambda ( a b c / l1 l2 ) (setq l1 l l2 (append (cond ( (= (vl-position a l) (- (length l) 2)) (cdr (reverse (member (cdr (reverse l))))) ) ( (= (vl-position a l) (1- (length l))) (cddr l) ) ( t (reverse (member a (reverse l))) )) (list c b) (cdddr (member a l)))) (if (or (< (length (unique l2)) (length l2)) (< (length l2) (length l1))) (setq xxx3 (list l1 l2 (list a b c)))) (if (and (not (chkinters-p l2)) (> (apply (function +) (mapcar (function distance) l1 (append (cdr l1) (list (car l1))))) (apply (function +) (mapcar (function distance) l2 (append (cdr l2) (list (car l2))))))) (setq l l2) (progn (setq l (append (cdr l) (list (car l)))) nil)))) l (append (cdr l) (list (car l))) (append (cddr l) (list (car l) (cadr l))))))
189.     l
190.   )
191.  
192.   (defun foo4 ( plst / l )
193.     (setq l plst)
194.     (while (and (null xxx4) (vl-some (function (lambda ( a b c / l1 l2 edge ) (setq l1 l edge (vl-some (function (lambda ( x ) (if (< (- (+ (distance (car x) b) (distance b (cadr x))) (distance (car x) (cadr x))) (- (+ (distance a b) (distance b c)) (distance a c))) x))) (vl-remove (list a b) (vl-remove (list b c) (mapcar (function list) (append l l) (append (append (cdr l) (list (car l))) (append (cdr l) (list (car l))))))))) (if edge (setq l2 (append (if (= (vl-position (car edge) l) (1- (length l))) (cdr (vl-remove b l)) (reverse (member (car edge) (reverse (vl-remove b l))))) (list b) (if (= (vl-position (car edge) l) (1- (length l))) (list (cadr edge)) (member (cadr edge) (vl-remove b l))))) (setq l2 nil)) (if (and l2 (or (< (length (unique l2)) (length l2)) (< (length l2) (length l1)))) (setq xxx4 (list l1 l2 edge (list a b c)))) (if (and l2 (not (chkinters-p l2)) (> (apply (function +) (mapcar (function distance) l1 (append (cdr l1) (list (car l1))))) (apply (function +) (mapcar (function distance) l2 (append (cdr l2) (list (car l2))))))) (setq l l2) (if l2 (progn (setq l (append (cdr l) (list (car l)))) nil))))) l (append (cdr l) (list (car l))) (append (cddr l) (list (car l) (cadr l))))))
195.     l
196.   )
197.  
198.   (defun processfoos ( plst / d dd ddd plst1 plst2 plst3 plst4 d1 d2 d3 d4 )
199.     (if (< (length (unique plst)) (length plst))
200.       (progn
201.         (prompt "\nError in reference list for processing (foo) subs - it contains duplicate points... Quitting...")
202.         (exit)
203.       )
204.     )
205.     (setq d 1e+99 dd 0)
206.     (while (> d dd)
207.       (setq plst1 (foo1 plst))
208.       (if (or (< (length (unique plst1)) (length plst1)) (< (length plst1) (length plst)))
209.         (progn
210.           (prompt "\nError in (foo1) - return list has less points than reference one or output list contains duplicate points... Quitting...")
211.           (exit)
212.         )
213.       )
214.       (if (chkinters-p plst1)
215.         (setq plst1 (chkinters plst1))
216.       )
217.       (setq d1 (apply (function +) (mapcar (function distance) plst1 (append (cdr plst1) (list (car plst1))))))
218.       (setq plst2 (foo2 plst))
219.       (if (or (< (length (unique plst2)) (length plst2)) (< (length plst2) (length plst)))
220.         (progn
221.           (prompt "\nError in (foo2) - return list has less points than reference one or output list contains duplicate points... Quitting...")
222.           (exit)
223.         )
224.       )
225.       (if (chkinters-p plst2)
226.         (setq plst2 (chkinters plst2))
227.       )
228.       (setq d2 (apply (function +) (mapcar (function distance) plst2 (append (cdr plst2) (list (car plst2))))))
229.       (setq plst3 (foo3 plst))
230.       (if (or (< (length (unique plst3)) (length plst3)) (< (length plst3) (length plst)))
231.         (progn
232.           (prompt "\nError in (foo3) - return list has less points than reference one or output list contains duplicate points... Quitting...")
233.           (exit)
234.         )
235.       )
236.       (if (chkinters-p plst3)
237.         (setq plst3 (chkinters plst3))
238.       )
239.       (setq d3 (apply (function +) (mapcar (function distance) plst3 (append (cdr plst3) (list (car plst3))))))
240.       (setq plst4 (foo4 plst))
241.       (if (or (< (length (unique plst4)) (length plst4)) (< (length plst4) (length plst)))
242.         (progn
243.           (prompt "\nError in (foo4) - return list has less points than reference one or output list contains duplicate points... Quitting...")
244.           (exit)
245.         )
246.       )
247.       (if (chkinters-p plst4)
248.         (setq plst4 (chkinters plst4))
249.       )
250.       (setq d4 (apply (function +) (mapcar (function distance) plst4 (append (cdr plst4) (list (car plst4))))))
251.       (setq dd (min d1 d2 d3 d4))
252.       (cond
253.         ( (= dd d1)
254.           (setq plst plst1)
255.         )
256.         ( (= dd d2)
257.           (setq plst plst2)
258.         )
259.         ( (= dd d3)
260.           (setq plst plst3)
261.         )
262.         ( (= dd d4)
263.           (setq plst plst4)
264.         )
265.       )
266.       (if (equal ddd dd 1e-6)
267.         (setq d dd)
268.         (setq ddd dd)
269.       )
270.     )
271.     plst
272.   )
273.  
274.   (defun process ( pl inpl / dd lil li l lll lx ly d r rr ll r1 r2 lst )
275.     (if inpl
276.       (progn
277.         (setq dd 1e+99)
278.         (foreach p pl
279.           (foreach pp inpl
280.             (setq lil (cons (list p pp) lil))
281.           )
282.         )
283.         (setq l pl)
284.         (foreach li lil
285.           (if (< (apply (function +) (mapcar (function distance) (setq lx (append (reverse (member (car li) (reverse l))) (list (cadr li)) (cdr (member (car li) l)))) (append (cdr lx) (list (car lx))))) (apply (function +) (mapcar (function distance) (setq ly (append (reverse (cdr (member (car li) (reverse l)))) (list (cadr li)) (member (car li) l))) (append (cdr ly) (list (car ly))))))
286.             (setq lll lx)
287.             (setq lll ly)
288.           )
289.           (setq d (apply (function +) (mapcar (function distance) lll (append (cdr lll) (list (car lll))))))
290.           (if (< d dd)
291.             (setq r lll rr (cadr li) dd d)
292.           )
293.         )
294.         (setq ll (vl-remove rr inpl))
295.         (setq r1 (list r ll))
296.         (setq dd 1e+99)
297.         (setq lil (vl-remove-if-not (function (lambda ( x ) (equal (apply (function distance) (car-sort lil (function (lambda ( a b ) (< (distance (car a) (cadr a)) (distance (car b) (cadr b))))))) (distance (car x) (cadr x)) 1e-6))) lil))
298.         (setq l pl)
299.         (foreach li lil
300.           (if (< (apply (function +) (mapcar (function distance) (setq lx (append (reverse (member (car li) (reverse l))) (list (cadr li)) (cdr (member (car li) l)))) (append (cdr lx) (list (car lx))))) (apply (function +) (mapcar (function distance) (setq ly (append (reverse (cdr (member (car li) (reverse l)))) (list (cadr li)) (member (car li) l))) (append (cdr ly) (list (car ly))))))
301.             (setq lll lx)
302.             (setq lll ly)
303.           )
304.           (setq d (apply (function +) (mapcar (function distance) lll (append (cdr lll) (list (car lll))))))
305.           (if (< d dd)
306.             (setq r lll rr (cadr li) dd d)
307.           )
308.         )
309.         (setq ll (vl-remove rr inpl))
310.         (setq r2 (list r ll))
311.         (if (equal r1 r2 1e-6)
312.           (if (null (cadr r1))
313.             (if (null *return*)
314.               (setq *return* (processfoos (car r1)))
315.               (progn
316.                 (setq lst (processfoos (car r1)))
317.                 (setq d (apply (function +) (mapcar (function distance) lst (append (cdr lst) (list (car lst))))))
318.                 (if (< d (apply (function +) (mapcar (function distance) *return* (append (cdr *return*) (list (car *return*))))))
319.                   (setq *return* lst)
320.                 )
321.               )
322.             )
323.             (process (car r1) (cadr r1))
324.           )
325.           (foreach x (list r1 r2)
326.             (if (null (cadr x))
327.               (if (null *return*)
328.                 (setq *return* (processfoos (car x)))
329.                 (progn
330.                   (setq lst (processfoos (car x)))
331.                   (setq d (apply (function +) (mapcar (function distance) lst (append (cdr lst) (list (car lst))))))
332.                   (if (< d (apply (function +) (mapcar (function distance) *return* (append (cdr *return*) (list (car *return*))))))
333.                     (setq *return* lst)
334.                   )
335.                 )
336.               )
337.               (process (car x) (cadr x))
338.             )
339.           )
340.         )
341.       )
342.     )
343.   )
344.  
345.   (prompt "\nSelect 2D points...")
346.   (if (setq ss (ssget (list (cons 0 "POINT"))))
347.     (progn
348.       (setq ti (car (_vl-times)))
349.       (repeat (setq i (sslength ss))
350.         (setq pl (cons (mapcar (function +) (list 0.0 0.0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
351.       )
352.       (setq plst (MR:ConvexHull-ptsonHull (setq pl (unique pl))))
353.       (setq inpl (vl-remove-if (function (lambda ( x ) (vl-position x plst))) pl))
354.       (process plst inpl)
355.       (entmake
356.         (append
357.           (list
358.             (cons 0 "LWPOLYLINE")
359.             (cons 100 "AcDbEntity")
360.             (cons 100 "AcDbPolyline")
361.             (cons 90 (length *return*))
362.             (cons 70 (1+ (* 128 (getvar 'plinegen))))
363.             (cons 38 0.0)
364.           )
365.           (mapcar (function (lambda ( p ) (cons 10 p))) *return*)
366.           (list (list 210 0.0 0.0 1.0))
367.         )
368.       )
369.       (setq d (apply (function +) (mapcar (function distance) *return* (append (cdr *return*) (list (car *return*))))))
370.       (prompt "\nPath length : ") (princ (rtos d 2 20))
371.       (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
372.     )
373.   )
374.   (princ)
375. )
376.  

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on November 15, 2021, 04:42:46 AM

This one is fast, but result is pretty wrong...

Anyway some different approach - using multiple Convex Hulls and then solving from the most inside one to outside...

Code - Auto/Visual Lisp: [Select]

1. (defun c:TSP-mchulls ( / MR:ConvexHull-ptsonHull LM:ConvexHull-ptsonHull LM:Clockwise-p car-sort _vl-sort unique chkinters process1 process2 process3 ss ti i pl plst inpl chulls lst out r1 r2 r3 r11 r12 r21 r22 r31 r32 d11 d12 d21 d22 d31 d32 r d flag )
2.  
3.   ;; Convex Hull  -  Lee Mac
4.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
5.   ;; Mod by M.R.  -  uses (car-sort) and (_vl-sort) subs...
6.  
7.   (defun MR:ConvexHull-ptsonHull ( lst / ch p0 lstl )
8.     (cond
9.       ( (< (length lst) 4) (_vl-sort lst (function (lambda ( a b ) (if (= (cadr a) (cadr b)) (< (car a) (car b)) (< (cadr a) (cadr b)))))) )
10.       ( (setq p0 (car lst))
11.         (foreach p1 (cdr lst)
12.           (if (or (< (cadr p1) (cadr p0)) (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0))))
13.             (setq p0 p1)
14.           )
15.         )
16.         (setq lst (vl-remove p0 lst))
17.         (setq lst (append (list p0) lst))
18.         (setq lst
19.           (_vl-sort lst
20.             (function
21.               (lambda ( a b / c d )
22.                 (if (or (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8) (and (or (equal c 0.0 1e-8) (equal c (* 2 pi) 1e-8)) (or (equal d 0.0 1e-8) (equal d (* 2 pi) 1e-8))))
23.                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
24.                   (< c d)
25.                 )
26.               )
27.             )
28.           )
29.         )
30.         (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
31.         (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
32.         (setq lstl (_vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
33.         (setq lst (append lst lstl))
34.         (setq ch (list (caddr lst) (cadr lst) (car lst)))
35.         (foreach pt (cdddr lst)
36.           (if (equal pt (last lst))
37.             (setq ch (cons pt ch))
38.             (if (or (equal (angle (car ch) pt) (car-sort (mapcar (function (lambda ( x ) (angle (car ch) x))) (member pt lst)) (function <)) 1e-6) (equal (distance pt (cadr ch)) (+ (distance pt (car ch)) (distance (car ch) (cadr ch))) 1e-6))
39.               (setq ch (cons pt ch))
40.             )
41.           )
42.         )
43.         (reverse ch)
44.       )
45.     )
46.   )
47.  
48.   ;; Convex Hull  -  Lee Mac
49.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
50.  
51.   (defun LM:ConvexHull-ptsonHull ( lst / ch p0 lstl )
52.     (cond
53.       ( (< (length lst) 4) lst)
54.       ( (setq p0 (car lst))
55.         (foreach p1 (cdr lst)
56.           (if (or (< (cadr p1) (cadr p0)) (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0))))
57.             (setq p0 p1)
58.           )
59.         )
60.         (setq lst (vl-remove p0 lst))
61.         (setq lst (append (list p0) lst))
62.         (setq lst
63.           (_vl-sort lst
64.             (function
65.               (lambda ( a b / c d )
66.                 (if (or (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8) (and (or (equal c 0.0 1e-8) (equal c (* 2 pi) 1e-8)) (or (equal d 0.0 1e-8) (equal d (* 2 pi) 1e-8))))
67.                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
68.                   (< c d)
69.                 )
70.               )
71.             )
72.           )
73.         )
74.         (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
75.         (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
76.         (setq lstl (_vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
77.         (setq lst (append lst lstl))
78.         (setq ch (list (cadr lst) (car lst)))
79.         (foreach pt (cddr lst)
80.           (setq ch (cons pt ch))
81.           (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt) (not (equal (distance (caddr ch) pt) (+ (distance (caddr ch) (cadr ch)) (distance (cadr ch) pt)) 1e-8)))
82.             (setq ch (cons pt (cddr ch)))
83.           )
84.         )
85.         (reverse ch)
86.       )
87.     )
88.   )
89.  
90.   ;; Clockwise-p  -  Lee Mac
91.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
92.  
93.   (defun LM:Clockwise-p ( p1 p2 p3 )
94.     (minusp (- (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1))) (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))))
95.   )
96.  
97.   (defun car-sort ( lst cmp / rtn )
98.     (setq rtn (car lst))
99.     (foreach itm (cdr lst)
100.       (if (apply cmp (list itm rtn))
101.         (setq rtn itm)
102.       )
103.     )
104.     rtn
105.   )
106.  
107.   (defun _vl-sort ( l f / *q* ll ff gg )
108.     (if (= (type f) 'sym)
109.       (setq f (eval f))
110.     )
111.     (while (setq *q* (car l))
112.       (setq ll
113.         (if (null ll)
114.           (cons *q* ll)
115.           (cond
116.             ( (apply f (list (last ll) *q*))
117.               (append ll (list *q*))
118.             )
119.             ( (apply f (list *q* (car ll)))
120.               (cons *q* ll)
121.             )
122.             ( t
123.               (setq ff nil)
124.               (setq gg (apply (function append) (append (mapcar (function (lambda ( *xxx* *yyy* ) (if (null ff) (if (apply f (list *q* *yyy*)) (progn (setq ff t) (list *xxx* *q*)) (list *xxx*)) (list *xxx*)))) ll (cdr ll)) (list (list (last ll))))))
125.               (if (null ff)
126.                 (append ll (list *q*))
127.                 gg
128.               )
129.             )
130.           )
131.         )
132.       )
133.       (setq l (cdr l))
134.     )
135.     ll
136.   )
137.  
138.   (defun unique ( l / a ll )
139.     (while (setq a (car l))
140.       (if (vl-some (function (lambda ( x ) (equal x a 1e-6))) (cdr l))
141.         (setq ll (cons a ll) l (vl-remove-if (function (lambda ( x ) (equal x a 1e-6))) (cdr l)))
142.         (setq ll (cons a ll) l (cdr l))
143.       )
144.     )
145.     (reverse ll)
146.   )
147.  
148.   (defun chkinters ( pl / lil k a ilil pre mid suf )
149.     (setq lil (mapcar (function list) pl (append (cdr pl) (list (car pl)))))
150.     (setq k -1)
151.     (while (and (< (setq k (1+ k)) (length lil)) (setq a (nth k lil)))
152.       (setq ilil (vl-some (function (lambda ( b / ip ) (if (and (setq ip (inters (car a) (cadr a) (car b) (cadr b))) (not (equal ip (car a) 1e-6)) (not (equal ip (cadr a) 1e-6)) (not (equal ip (car b) 1e-6)) (not (equal ip (cadr b) 1e-6))) (list a b)))) (vl-remove a lil)))
153.       (if ilil
154.         (progn
155.           (setq pre (reverse (cdr (member (car ilil) (reverse lil)))))
156.           (setq mid (cdr (member (car ilil) lil)))
157.           (setq mid (cdr (member (cadr ilil) (reverse mid))))
158.           (setq mid (mapcar (function reverse) mid))
159.           (setq suf (cdr (member (cadr ilil) lil)))
160.           (setq lil (append pre (list (list (car (car ilil)) (car (cadr ilil)))) mid (list (list (cadr (car ilil)) (cadr (cadr ilil)))) suf))
161.           (setq pre nil mid nil suf nil)
162.           (setq ilil nil k -1)
163.         )
164.       )
165.     )
166.     (mapcar (function car) lil)
167.   )
168.  
169.   (defun process1 ( lst out / dd edgs edges edgesn1 edgesn2 lstt1 lstt2 lstt d r dd1 dd2 rr1 rr2 )
170.     (setq dd 1e+99)
171.     (foreach pedge (setq edgs (mapcar (function list) lst (append (cdr lst) (list (car lst)))))
172.       (foreach ppedge (setq edges (mapcar (function list) out (append (cdr out) (list (car out)))))
173.         (setq edgesn1 (subst pedge ppedge edges))
174.         (setq edgesn2 (subst (reverse pedge) ppedge edges))
175.         (setq edgesn1 (apply (function append) (mapcar (function (lambda ( x y ) (if (not (equal (cadr x) (car y) 1e-6)) (list x (list (cadr x) (car y))) (list x)))) edgesn1 (append (cdr edgesn1) (list (car edgesn1))))))
176.         (setq edgesn2 (apply (function append) (mapcar (function (lambda ( x y ) (if (not (equal (cadr x) (car y) 1e-6)) (list x (list (cadr x) (car y))) (list x)))) edgesn2 (append (cdr edgesn2) (list (car edgesn2))))))
177.         (if (and (or (cdr (member pedge edgs)) (cdr (member pedge (reverse edgs)))) (or (cdr (member pedge (reverse edgs))) (cdr (member pedge edgs))))
178.           (progn
179.             (setq edgesn1 (apply (function append) (mapcar (function (lambda ( x ) (if (equal x pedge 1e-6) (mapcar (function reverse) (append (cdr (member pedge edgs)) (cdr (member pedge (reverse edgs))))) (list x)))) edgesn1)))
180.             (setq edgesn2 (apply (function append) (mapcar (function (lambda ( x ) (if (equal x (reverse pedge) 1e-6) (append (cdr (member pedge (reverse edgs))) (cdr (member pedge edgs))) (list x)))) edgesn2)))
181.             (setq lstt1 (mapcar (function car) edgesn1))
182.             (setq lstt2 (mapcar (function car) edgesn2))
183.             (if (< (apply (function +) (mapcar (function distance) lstt1 (append (cdr lstt1) (list (car lstt1))))) (apply (function +) (mapcar (function distance) lstt2 (append (cdr lstt2) (list (car lstt2))))))
184.               (setq lstt lstt1)
185.               (setq lstt lstt2)
186.             )
187.             (if (< (setq d (apply (function +) (mapcar (function distance) lstt (append (cdr lstt) (list (car lstt)))))) dd)
188.               (setq r lstt dd d)
189.             )
190.           )
191.         )
192.       )
193.     )
194.     (setq dd1 (apply (function +) (mapcar (function distance) r (append (cdr r) (list (car r))))) rr1 (unique r))
195.     (setq r (reverse r))
196.     (setq dd2 (apply (function +) (mapcar (function distance) r (append (cdr r) (list (car r))))) rr2 (unique r))
197.     (if (< dd1 dd2)
198.       (setq r rr1)
199.       (setq r rr2)
200.     )
201.     r
202.   )
203.  
204.   (defun process2 ( lst out / q qq edgs qqq inpl singles xxx aaa ggg bbb gqqq dd edges edgesn1 edgesn2 lstt1 lstt2 lstt d r lil li dd1 dd2 rr1 rr2 )
205.     (setq q (MR:ConvexHull-ptsonHull lst))
206.     (setq qq (mapcar (function list) q (append (cdr q) (list (car q)))))
207.     (setq qqq (vl-remove-if (function (lambda ( x ) (or (vl-position x qq) (vl-position (reverse x) qq)))) (setq edgs (mapcar (function list) lst (append (cdr lst) (list (car lst)))))))
208.     (setq inpl (vl-remove-if (function (lambda ( x ) (vl-position x (apply (function append) qqq)))) q))
209.     (setq singles (vl-remove-if-not (function (lambda ( x ) (= (length (vl-remove-if (function (lambda ( y ) (equal x y 1e-6))) (apply (function append) qqq))) (1- (length (apply (function append) qqq)))))) (apply (function append) qqq)))
210.     (foreach x singles
211.       (setq xxx x)
212.       (if (setq aaa (vl-some (function (lambda ( y ) (if (vl-position x y) y))) qqq))
213.         (progn
214.           (setq ggg (cons aaa ggg))
215.           (while (setq bbb (vl-some (function (lambda ( y ) (if (vl-position (setq xxx (car (vl-remove xxx aaa))) y) y))) (setq qqq (vl-remove aaa qqq))))
216.             (setq ggg (cons bbb ggg))
217.             (setq aaa bbb)
218.           )
219.           (setq gqqq (cons (reverse ggg) gqqq))
220.           (setq ggg nil)
221.         )
222.       )
223.     )
224.     (setq gqqq (reverse gqqq))
225.     (setq outlst out)
226.     (if gqqq
227.       (repeat (length gqqq)
228.         (setq dd 1e+99)
229.         (foreach g gqqq
230.           (foreach ppedge (setq edges (mapcar (function list) outlst (append (cdr outlst) (list (car outlst)))))
231.             (setq edgesn1 (append (reverse (cdr (member ppedge (reverse edges)))) g (cdr (member ppedge edges))))
232.             (setq edgesn2 (append (reverse (cdr (member ppedge (reverse edges)))) (reverse (mapcar (function reverse) g)) (cdr (member ppedge edges))))
233.             (setq edgesn1 (apply (function append) (mapcar (function (lambda ( x y ) (if (not (equal (cadr x) (car y) 1e-6)) (list x (list (cadr x) (car y))) (list x)))) edgesn1 (append (cdr edgesn1) (list (car edgesn1))))))
234.             (setq edgesn2 (apply (function append) (mapcar (function (lambda ( x y ) (if (not (equal (cadr x) (car y) 1e-6)) (list x (list (cadr x) (car y))) (list x)))) edgesn2 (append (cdr edgesn2) (list (car edgesn2))))))
235.             (setq lstt1 (mapcar (function car) edgesn1))
236.             (setq lstt2 (mapcar (function car) edgesn2))
237.             (if (< (apply (function +) (mapcar (function distance) lstt1 (append (cdr lstt1) (list (car lstt1))))) (apply (function +) (mapcar (function distance) lstt2 (append (cdr lstt2) (list (car lstt2))))))
238.               (setq lstt lstt1)
239.               (setq lstt lstt2)
240.             )
241.             (if (< (setq d (apply (function +) (mapcar (function distance) lstt (append (cdr lstt) (list (car lstt)))))) dd)
242.               (setq r lstt dd d)
243.             )
244.           )
245.         )
246.         (setq outlst r)
247.         (setq gqqq (vl-remove-if-not (function (lambda ( x ) (vl-some (function (lambda ( y ) (not (vl-position y r)))) (apply (function append) x)))) gqqq))
248.       )
249.     )
250.     (foreach pp inpl
251.       (if (null lil)
252.         (setq lil (mapcar (function list) outlst (append (cdr outlst) (list (car outlst)))))
253.       )
254.       (setq li (car-sort lil (function (lambda ( a b ) (< (- (+ (distance (car a) pp) (distance pp (cadr a))) (distance (car a) (cadr a))) (- (+ (distance (car b) pp) (distance pp (cadr b))) (distance (car b) (cadr b))))))))
255.       (setq lil (apply (function append) (mapcar (function (lambda ( x ) (if (equal x li 1e-6) (list (list (car li) pp) (list pp (cadr li))) (list x)))) lil)))
256.     )
257.     (if inpl
258.       (setq r (mapcar (function car) lil))
259.     )
260.     (setq dd1 (apply (function +) (mapcar (function distance) r (append (cdr r) (list (car r))))) rr1 (unique r))
261.     (setq r (reverse r))
262.     (setq dd2 (apply (function +) (mapcar (function distance) r (append (cdr r) (list (car r))))) rr2 (unique r))
263.     (if (< dd1 dd2)
264.       (setq r rr1)
265.       (setq r rr2)
266.     )
267.     r
268.   )
269.  
270.   (defun process3 ( lst out / lil li r dd1 dd2 rr1 rr2 )
271.     (foreach pp lst
272.       (if (null lil)
273.         (setq lil (mapcar (function list) out (append (cdr out) (list (car out)))))
274.       )
275.       (setq li (car-sort lil (function (lambda ( a b ) (< (- (+ (distance (car a) pp) (distance pp (cadr a))) (distance (car a) (cadr a))) (- (+ (distance (car b) pp) (distance pp (cadr b))) (distance (car b) (cadr b))))))))
276.       (setq lil (apply (function append) (mapcar (function (lambda ( x ) (if (equal x li 1e-6) (list (list (car li) pp) (list pp (cadr li))) (list x)))) lil)))
277.     )
278.     (setq r (mapcar (function car) lil))
279.     (setq dd1 (apply (function +) (mapcar (function distance) r (append (cdr r) (list (car r))))) rr1 (unique r))
280.     (setq r (reverse r))
281.     (setq dd2 (apply (function +) (mapcar (function distance) r (append (cdr r) (list (car r))))) rr2 (unique r))
282.     (if (< dd1 dd2)
283.       (setq r rr1)
284.       (setq r rr2)
285.     )
286.     r
287.   )
288.  
289.   (initget "Yes No")
290.   (if (= (setq flag (getkword "\nShow previews [Yes/No] <No> : ")) "Yes")
291.     (setq flag t)
292.     (setq flag nil)
293.   )
294.   (prompt "\nSelect 2D points...")
295.   (if (setq ss (ssget (list (cons 0 "POINT"))))
296.     (progn
297.       (setq ti (car (_vl-times)))
298.       (repeat (setq i (sslength ss))
299.         (setq pl (cons (mapcar (function +) (list 0.0 0.0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
300.       )
301.       (setq plst (MR:ConvexHull-ptsonHull (setq pl (unique pl))))
302.       (setq inpl (vl-remove-if (function (lambda ( x ) (vl-position x plst))) pl))
303.       (setq chulls (cons plst chulls))
304.       (while (and inpl (> (length inpl) 2))
305.         (setq plst (MR:ConvexHull-ptsonHull inpl))
306.         (setq inpl (vl-remove-if (function (lambda ( x ) (vl-position x plst))) inpl))
307.         (setq chulls (cons plst chulls))
308.       )
309.       (setq lst (car chulls))
310.       (if inpl
311.         (setq lst (process3 inpl lst))
312.       )
313.       (if flag
314.         (progn
315.           (redraw)
316.           (mapcar (function (lambda ( a b ) (grdraw a b 2 0))) lst (append (cdr lst) (list (car lst))))
317.           (getstring "\nENTER TO CONTINUE...")
318.         )
319.       )
320.       (setq chulls (subst lst (car chulls) chulls))
321.       (if (cadr chulls)
322.         (while (cadr chulls)
323.           (setq lst (car chulls) out (cadr chulls) chulls (cdr chulls))
324.           (setq r1 (chkinters (process1 lst out)))
325.           (setq r2 (chkinters (process2 lst out)))
326.           (setq r3 (chkinters (process3 lst out)))
327.           (setq r11 (unique r1) r12 (unique (reverse r1)) r21 (unique r2) r22 (unique (reverse r2)) r31 (unique r3) r32 (unique (reverse r3)))
328.           (if r11
329.             (setq d11 (apply (function +) (mapcar (function distance) r11 (append (cdr r11) (list (car r11))))))
330.           )
331.           (if r12
332.             (setq d12 (apply (function +) (mapcar (function distance) r12 (append (cdr r12) (list (car r12))))))
333.           )
334.           (if r21
335.             (setq d21 (apply (function +) (mapcar (function distance) r21 (append (cdr r21) (list (car r21))))))
336.           )
337.           (if r22
338.             (setq d22 (apply (function +) (mapcar (function distance) r22 (append (cdr r22) (list (car r22))))))
339.           )
340.           (if r31
341.             (setq d31 (apply (function +) (mapcar (function distance) r31 (append (cdr r31) (list (car r31))))))
342.           )
343.           (if r32
344.             (setq d32 (apply (function +) (mapcar (function distance) r32 (append (cdr r32) (list (car r32))))))
345.           )
346.           (setq d (min d11 d12 d21 d22 d31 d32))
347.           (setq r (nth (vl-position d (list d11 d12 d21 d22 d31 d32)) (vl-remove nil (list r11 r12 r21 r22 r31 r32))))
348.           (if flag
349.             (progn
350.               (redraw)
351.               (mapcar (function (lambda ( a b ) (grdraw a b 2 0))) r (append (cdr r) (list (car r))))
352.               (getstring "\nENTER TO CONTINUE...")
353.             )
354.           )
355.           (setq chulls (subst r (car chulls) chulls))
356.         )
357.         (setq r lst d (apply (function +) (mapcar (function distance) r (append (cdr r) (list (car r))))))
358.       )
359.       (entmake
360.         (append
361.           (list
362.             (cons 0 "LWPOLYLINE")
363.             (cons 100 "AcDbEntity")
364.             (cons 100 "AcDbPolyline")
365.             (cons 90 (length r))
366.             (cons 70 (1+ (* 128 (getvar 'plinegen))))
367.             (cons 38 0.0)
368.           )
369.           (mapcar (function (lambda ( p ) (cons 10 p))) r)
370.           (list (list 210 0.0 0.0 1.0))
371.         )
372.       )
373.       (redraw)
374.       (prompt "\nPath length : ") (princ (rtos d 2 20))
375.       (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
376.     )
377.   )
378.   (princ)
379. )
380.  

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: It's Alive! on November 16, 2021, 05:03:22 PM

can't even read lisp anymore  :mrgreen:

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on November 17, 2021, 05:13:14 AM

I've manged to improve further more - so many changes...
My last version lisp has over 30K and it's quite good - it works relatively fast (under BricsCAD of course, but you can use it also in AutoCAD... - just little slower - ...)
I've mod.-ed Lee's Convex Hull sub as in my testings, my newer version works better...
Also I've broke record on Evgeiny's example : look at DWG, or use my routine : TSP-mchulls+genetic.lsp (the biggest one in ZIP)...
I worked to implement half genetic algorithm - half greedy, so now it should work very well and with grid disposition of points - I've manged for X and Y directions - it gives the same result like Evgeniy's grid example... RND points are also processed very well - it gives the close to best solution in very short time - there is also option for previewing successive partial small TSP solutions from inside Convex Hulls to outside... So, all in all, I think that without permutations this is the best as I can make (for now)...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on November 18, 2021, 12:02:39 PM

It turns out that I accidently broke the record of Evgeniy's example...
I had an error in ConvexHull that I mod.-ed and exactly that turned in my testings to break record... So it was pure accident - in my different example, routne didn't worked well and I discovered what was wrong... In Convex Hull I've put 3 starting points directly from Graham scan and I should have coded that 2 starting points are begginning and already 3rd one is needed for checking of angle - (how I imagined my mod.) - that's all that should have been done correctly... But that mistake turned that record was broken - you'll never know with TSP!!!
I've added something new still - permutations - but that won't influence in the most cases on outcome result... (you should avoid to use big number - greater than 8...)
New file is called TSP-all.lsp - (I've corrected my bug in all files - MR:ConvexHull - after all still LM-version is good and it gives the same results like it should)... But who knows - maybe someone won't like to use LM:Clockwise-p sub (only - (vl-sort) and (car-sort) is needed)...

I've left my previous ZIP in previous post for you to see mistake in (MR:ConvexHull) that caused this confusion and DWG with record...
But I've tried differntly - from inside to outside, but we don't know - TSP is difficult task for solving... If you need quick response from PC, then you can always specify 1 as input number of point clouds processing - permutations won't be performed...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on November 19, 2021, 12:49:35 AM

Still, I regularily broke the record... I've mod.-ed my latest version and it did broke it - so it's regular (sooner or later...)...
So here is it :
TSP-all.lsp

Regards, M.R.

[EDIT : Added (foo5) and changed (foo) - now it's little slower, but it was necessity... There were 6 downloads till I reattached new TSP-all.lsp]

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: It's Alive! on November 19, 2021, 04:51:47 AM

awesome

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on November 21, 2021, 03:03:08 AM

For future develop, I just wanted to point to this qoute by master Evgeniy :

Quote from: ElpanovEvgeniy on February 20, 2016, 03:08:09 AM

To write fast code, it is necessary to solve two problems.
1. Do not use the code extra computing - to come up with an algorithm, from which there is nothing to remove.
2. Add in the code checks to interrupt the bad cycles. Complex calculations can be represented as a tree. Let's say we're looking for the shortest branch. Then when checking another branch if it is already longer than the previous one, so there is no reason to continue the calculation of its length!

And one more thing - TSP (Travelling Salesman Problem), although not entirely solvable in terms of freedom and resulting solution outcomes, from psyhological aspect of view, I must say that like all other problems - it's solvable in some reasonable limits of observation... We all know that we have short time here on planet... Some brilliant minds have already left us... And that same destiny will happen to all of us...

So, challenge is opened for future developing, but bear in mind that finding correct solutions are not really so important if you strive for exact results - here reasonable approach is very desired - so beside finding correct soutins as much as possible, time of computations is even more important... But all in all, you can live and without TSP, so there are no real reasons for even trying improvements if they are not based on really fundamental logic that were omitted in past...

Good luck and stay healthy and well...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ahsattarian on May 23, 2022, 12:02:00 AM

Have a look at this  :


 https://cadtips.cadalyst.com/linear-objects/tsp-problem?q=linear-objects/tsp-problem 

Code - Auto/Visual Lisp: [Select]

1. (defun c:tsp ()
2.   (setq ss (ssget '((0 . "point"))))
3.   (cond ((< (sslength ss) 2) (exit)))
4.   (setq li1 nil)
5.   (setq li2 nil)
6.   (setq k -1)
7.   (setq n (sslength ss))
8.   (repeat n
9.     (setq k (1+ k))
10.     (setq s (ssname ss k))
11.     (setq en (entget s))
12.     (setq po (cdr (assoc 10 en)))
13.     (if (< k 3)
14.       (setq li1 (append (list po) li1))
15.       (setq li2 (append (list po) li2))
16.     )
17.   )
18.   (foreach po li2
19.     (setq lii nil)
20.     (setq k -1)
21.     (setq n (length li1))
22.     (repeat n
23.       (setq k (1+ k))
24.       (setq po1 (nth k li1))
25.       (if (/= k (1- (length li1)))
26.         (setq po2 (nth (1+ k) li1))
27.         (progn (setq po1 (nth 0 li1)) (setq po2 (nth (1- (length li1)) li1)))
28.       )
29.       (setq lii (append (list (list po1 po po2)) lii))
30.     )
31.     (setq dili nil)
32.     (foreach a lii
33.       (setq po1 (nth 0 a))
34.       (setq po2 (nth 1 a))
35.       (setq po3 (nth 2 a))
36.       (setq d12 (distance po1 po2))
37.       (setq d23 (distance po2 po3))
38.       (setq d13 (distance po1 po3))
39.       (setq di (- (+ d12 d23) d13))
40.       (setq dili (append (list di) dili))
41.     )
42.     (setq dimin (apply 'min dili))
43.     (setq k 0)
44.     (while (< k (length dili))
45.       (cond ((= dimin (nth k dili)) (setq i k) (setq k (length dili))))
46.       (setq k (1+ k))
47.     )
48.     (setq li3 nil)
49.     (setq ii (1+ i))
50.     (if (< ii (length li1))
51.       (progn
52.         (setq k 0)
53.         (setq flag 0)
54.         (while (< k (length li1))
55.           (if (and (= k ii) (= flag 0))
56.             (progn (setq li3 (append (list po) li3)) (setq flag 1))
57.             (progn (setq li3 (append (list (nth k li1)) li3)) (setq k (1+ k)))
58.           )
59.         )
60.       )
61.       (setq li3 (append (list po) li1))
62.     )
63.     (setq li1 li3)
64.   )
65.   (command "pline")
66.   (foreach po li1 (command po))
67.   (command "close")
68.   (princ)
69. )

..

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on May 23, 2022, 12:30:06 AM

That's not quite it shoud be - have a look at Evgeniy's green shape...

Further more - considering E.T. possibility of watching - my solution involved physical aspect of overcoming exhaustive computational processings... On the other side, like I stated once - without help of PC (computer i.e.) - how would anyone be able to formulate TSP in terms of - solvable task for playing in spare time...

Here is one another extension - playing for - how E.T. looks to our PLANET - sphere (me, you, we, they, "reminds me on superheroes trying to save all that could be in daylight/midnight redemtion"...)

BTW... Routine not thouroughly tested - it may fail in some cases and BTW. - don't use more than 7-10 points for starting tests...

Code - Auto/Visual Lisp: [Select]

1.   ;; TSP - TRAVELLING SALESMAN PROBLEM - SPHERE BODY ASPECT ;;
2.  
3.   ;; First note : points can not form connections that may result in crossing vecors between 2 and 2 other points if 4 points are non coplanar - they are always in 3D space ;;
4.   ;; Second note : if middle point of 2 point vector is near center of sphere, then they are in opposition, so for better reasoning, those vectors should be considered lastly - if they are to be considered at all - TSP looks for shortest solution path finding ;;
5.   ;; Third note : if 4 points are still in plane - 2D space, then they follow the rule that proper array should be in form of forming ringular pathing, also demining possible crossing situations like ordinary 2D TSP relations - from this conclusion comes the rule considering the best approach to path finding is to gather points array such that each middle point of triangle forms angle bigger than 90 degree - obtuse angle - this relation ensures that ringing array is respected more than possible unnecessary sudden orientation jumping in directions not predictable for better TSP overall partial distances summarizing scoring propositions ;;
6.   ;; Fourth note : if taking RND (random) solution as starting proposition like 2D TSP reasoning, then maybe the best is to start from longest path - oppositions - middles of vectors are all very near center...; what should algorithm do? - well, if biggest vector is disconnected from solution, we have open shape - so, we should look for another disconnection with just a little smaller opposition (distance) - but with points near 2 previously disconnected ones; then this very reminds on crossing situation of 2D TSP - so just reconnect 2 and 2 vectors but now with much better - shorter relations like it should be - TSP path was improved... ;;
7.   ;; Fifth note : from fourth note we now can see approach and main procedure of algorithm, but what reasoning is better if 2 of biggest oppositions are very unlinearily oriented - approximatively orthogonal from 2D aspecting - following rule of biggest distances, or searching for less bigger and more linearility... of course - more linearility is good visualizing, but still not necessarily with the best judgement approval from aspect of what TSP stands for - the best possible solution : still we can't get and check for final gather resulting score... ;;
8.   ;; Sixth note : now let's consider that we must/should start from the most worse TSP connection - longest path...; how can we accomplish that (with full of points belonging all to the sphere body) and still preserve that TSP aspect is respected - closed path solution?...; do we have to set all to extreemely unbalanced starting situations so that we can computate on other direction (longest->shortest) ~ || ~ ""(shortest->longest)"" [!!! are we talking here ab TSP !!!] and do assumation that we are doing right thing from the beggining to the end - where is the end??? ;;
9.   ;; Seventh note : what could be termination treatment for exiting exhaustive computation - the best ballance between remedied 3D partial TSP shapening ;;
10.   ;; Eight note (FINAL CONCLUSION) : from deduction until now - I can only say that from reasonable standing, if 2 vectors disconnections and 2 reconnections (single pass) can't benefit to better next pass - routine should terminate; should the starting situation be the worst TSP connection - we can debate and have no real clue where would it lead us : to real TSP as singular the best connection with shortest pathing or not...; still we must always have in mind that we just can't check all possible permutations of 2 vectors disconnections and 2 reconnections, so what we should do is consider at what cost we should do disconnections and connections - with 3 points it is very easy - it's always triangle, no matter if smaller and further from center, or bigger with points as oppositions : here we can analyze - small ring - the best, but 2 other situations are the ones that glitch the mind in striving to determine what is better - if in 2D, we can see the center of shpere as center of circumscribed triangle - so what triangle is shorter : the one with the most further center, or the one with the most relatively closest relation between each of vertices - note radius of sphere/circle is const. - it means for all situations 2D and 3D (we can't fall to thoughts that one vertex is closer than other 2 - they are always with distance==radius)...; but what is better from those 2 - one with small connection and 2 oppositioning passing center almost at middles, or the one with like prettiest equal sided triangle with middle angles of 60 degree and center at exact gravity center/centroid of region/area...; if we are to summarize lengths : ~ 4*radius <???> ~ 3*radius*2cos30 : ~ 4*radius { < } 3*(sqrt 3)*radius...; so from triangles aspects in 2D, better is the one with ~ 4*radius, but from 3D perspective - those relations imply possible disconnections and reconnections 2 by 2 vectors and reforming situations more to closer to that one unwanted - all 60 degree angle relation...; still - what can we say overall : if triangles are references structures for reasonation for overall TSP sphere aspect research jurisdiction and we don't want to restructure our algorithm procedure already described, we should look to continue with processing all until we can say that all middle angles of each vertex connection reaches angle the most closer to 180 degree - sphere tangent; i.e. if in last pass smallest angle is above 60 degree (for ex. 135 degree) and in next pass if smallest angle can't reach 135.1 degree, no matter weather we disconnected and reconnected any of 2 vectors of our reference middle vertex with just a little happier middler one, lets say (for ex. 138 degree) and thereby we are spoiling things more (135->133.5)&&(138->139), we can see that we are in negative -1.5 degree + 1 degree = -0.5 degree ;; we must redo action and treminate routine... (and opposite - if sum of middles angles > 0.0 (positive - for ex. +0.5, or even +0.000001 degree), we can continue with processing)... ;;
11.  

Regards, M.R.

[EDIT : TSP-shortpath-arcs-sphere-pts-2.lsp - just slightly moded. for perhaps little better performance - sadly not fully true :( ]

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on May 25, 2022, 04:30:47 AM

I just want to add something that may occur and may be overlooked while programming...

*** if lines/arcs cross each other - if implementing Evgeniy's method of reassambling path by 2 disconnections and 2 reconnections, please be aware that there are 2 solutions from which only 1 is correct :

vector/arc1 (start1 end1); vector/arc2 (start2 end2)

* you disconnect them both :

* next reconnections :
- 1st : (start1 end2) + (start2 end1)
- 2nd : (start1 start2) + (end1 end2)

*** ONLY 1 of those is correct, as with the other, TSP - single path connections would break into 2 paths that are closed, but they are separated... Correct is only 1 path (single)...

And all in all, my last *.lsp posted was coded in relation to accounting this into postprocessing, but somehow in my testings it didn't actually worked (BricsCAD V21)... And further more with point(s) [ more than 10 ] : CAD(s) have memory issues and routine terminates with error(s) regarding failures not expected for this relatively simple task... Why it can't do on my PC with even 12 pts I can't really understand... With 10 pts - terribly slooow...

Anyway, for reasonable purposes, you can test it on your PC's and perhaps help us all to get better solutions [ TSP - sphere pts aspect ]...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on June 06, 2022, 06:59:24 AM

I've took some time to mod. Ahsattarian's code...

Regards...

Code - Auto/Visual Lisp: [Select]

1. (defun c:TSP-ahsattarian ( / AHS:TSP ss ti n pl d )
2.  
3.   (defun AHS:TSP ( pl / AHS:mainprocess AHS:subprocess1 AHS:subprocess2 k li1 li2 lii )
4.  
5.     (defun AHS:mainprocess ( li1 li2 )
6.       (foreach po li2
7.         (setq lii (append lii (AHS:subprocess1 po li1)))
8.       )
9.       (setq li1 (AHS:subprocess2 li1 lii))
10.     )
11.  
12.     (defun AHS:subprocess1 ( po li1 / k n po1 po2 lii )
13.       (setq k 0)
14.       (repeat (setq n (length li1))
15.         (setq po1 (nth k li1))
16.         (if (= k (1- n))
17.           (setq po2 (nth 0 li1))
18.           (setq po2 (nth (1+ k) li1))
19.         )
20.         (setq lii (append lii (list (list po1 po po2))))
21.         (setq k (1+ k))
22.       )
23.       lii
24.     )
25.  
26.     (defun AHS:subprocess2 ( li1 lii / n dili dimin k i a po li3 )
27.       (setq n (length li1))
28.       (setq dili (mapcar (function (lambda ( a ) (- (+ (distance (car a) (cadr a)) (distance (cadr a) (caddr a))) (distance (car a) (caddr a))))) lii))
29.       (setq dimin (apply (function min) dili))
30.       (setq k 0)
31.       (while (and (not i) (< k (length dili)))
32.         (if (equal dimin (nth k dili) 1e-6)
33.           (setq i k)
34.         )
35.         (setq k (1+ k))
36.       )
37.       (setq a (nth i lii) po (cadr a))
38.       (if (equal (car a) (last li1) 1e-6)
39.         (setq li1 (cons po li1))
40.         (progn
41.           (setq k 0)
42.           (while (< k n)
43.             (if (equal (nth k li1) (car a) 1e-6)
44.               (setq li3 (cons (nth k li1) li3) li3 (cons po li3))
45.               (setq li3 (cons (nth k li1) li3))
46.             )
47.             (setq k (1+ k))
48.           )
49.           (setq li1 (reverse li3))
50.         )
51.       )
52.       (if (or (equal (car a) (cadr a) 1e-6) (equal (cadr a) (caddr a) 1e-6) (equal (car a) (caddr a) 1e-6))
53.         (progn (prompt "\nDuplicate points detected... Quitting...") (exit))
54.       )
55.       li1
56.     )
57.  
58.     (setq k 0)
59.     (foreach po (setq pl (vl-sort pl (function (lambda ( a b ) (if (equal (cadr a) (cadr b) 1e-6) (< (car a) (car b)) (< (cadr a) (cadr b)))))))
60.       (setq k (1+ k))
61.       (if (< k 4)
62.         (setq li1 (append li1 (list po)))
63.         (setq li2 (append li2 (list po)))
64.       )
65.     )
66.     (if (> k 3)
67.       (progn
68.         (while (cadr li2)
69.           (setq lii nil)
70.           (setq li1 (AHS:mainprocess li1 li2))
71.           (setq li2 (vl-remove-if (function (lambda ( p1 ) (vl-some (function (lambda ( p2 ) (equal p1 p2 1e-6))) li1))) pl))
72.         )
73.         (setq lii nil)
74.         (setq lii (AHS:subprocess1 (car li2) li1))
75.         (setq li1 (AHS:subprocess2 li1 lii))
76.       )
77.     )
78.     li1
79.   )
80.  
81.   (prompt "\n")
82.   (prompt "\nSelect points...")
83.   (if (and (setq ss (ssget '((0 . "POINT")))) (> (setq n (sslength ss)) 1))
84.     (progn
85.       (setq ti (car (_vl-times)))
86.       (repeat n
87.         (setq pl (cons (mapcar (function +) (list 0.0 0.0) (trans (cdr (assoc 10 (entget (ssname ss (setq n (1- n)))))) 0 1)) pl))
88.       )
89.       (setq pl (AHS:TSP pl))
90.       (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pl (append (cdr pl) (list (car pl))))))
91.       (entmake
92.         (append
93.           (list
94.            '(0 . "LWPOLYLINE")
95.            '(100 . "AcDbEntity")
96.            '(100 . "AcDbPolyline")
97.             (cons 90 (length pl))
98.             (cons 70 (1+ (* 128 (getvar 'plinegen))))
99.            '(38 . 0.0)
100.           )
101.           (mapcar (function (lambda ( p ) (list 10 (car p) (cadr p)))) pl)
102.           (list
103.             (cons 210 (trans (list 0.0 0.0 1.0) 1 0 t))
104.            '(62 . 3)
105.           )
106.         )
107.       )
108.       (prompt "\nDistance - path length : ") (princ (rtos d 2 20))
109.       (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
110.     )
111.     (prompt "\nNo points selected, or selected/picked just single point...")
112.   )
113.   (princ)
114. )
115.  

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on June 06, 2022, 05:32:05 PM

I don't know weather I posted revised sub functions for checking intersections, but here they are - implemented into Ahsattarian's code...
BTW. In attachmment I'll post revision of TSP-all.lsp ...

Code - Auto/Visual Lisp: [Select]

1. (defun c:TSP-ahsattarian-chkinters ( / collinear-p chkinters-p chkinters AHS:TSP ss ti n pl d )
2.  
3.   (defun collinear-p ( p1 p p2 )
4.     (equal (distance p1 p2) (+ (distance p1 p) (distance p p2)) 1e-6)
5.   )
6.  
7.   (defun chkinters-p ( pl / r )
8.     (or lil (setq lil (mapcar (function list) pl (append (cdr pl) (list (car pl))))))
9.     (setq r (vl-some (function (lambda ( x ) (vl-some (function (lambda ( y ) (and (not (equal (car x) (car y) 1e-6)) (not (equal (car x) (cadr y) 1e-6)) (not (equal (cadr x) (car y) 1e-6)) (not (equal (cadr x) (cadr y) 1e-6)) (or (inters (car x) (cadr x) (car y) (cadr y)) (collinear-p (car x) (car y) (cadr x)) (collinear-p (car x) (cadr y) (cadr x)) (collinear-p (car y) (car x) (cadr y)) (collinear-p (car y) (cadr x) (cadr y)))))) (vl-remove (if (= (vl-position x lil) 0) (last lil) (nth (1- (vl-position x lil)) lil)) (vl-remove (if (= (vl-position x lil) (1- (length lil))) (car lil) (nth (1+ (vl-position x lil)) lil)) (vl-remove x lil)))))) lil))
10.     (setq lil nil)
11.     r
12.   )
13.  
14.   (defun chkinters ( pl / processlil done r lill ilil iip )
15.  
16.     (defun processlil ( ilil lil / pre mid suf ret )
17.       (setq pre (reverse (cdr (member (car ilil) (reverse lil)))))
18.       (setq mid (cdr (member (car ilil) lil)))
19.       (setq mid (cdr (member (cadr ilil) (reverse mid))))
20.       (setq mid (mapcar (function reverse) mid))
21.       (setq suf (cdr (member (cadr ilil) lil)))
22.       (setq ret (append pre (list (list (car (car ilil)) (car (cadr ilil)))) mid (list (list (cadr (car ilil)) (cadr (cadr ilil)))) suf))
23.       ret
24.     )
25.  
26.     (or lil (setq lil (mapcar (function list) pl (append (cdr pl) (list (car pl))))))
27.     (while (not done)
28.       (setq ilil (vl-some (function (lambda ( a ) (vl-some (function (lambda ( b / ip ) (progn (setq iip (inters (car a) (cadr a) (car b) (cadr b))) (if (and (not (equal (cadr a) (car b) 1e-6)) (not (equal (car a) (cadr b) 1e-6)) (not (or (and (collinear-p (car a) (car b) (cadr a)) (collinear-p (car a) (cadr b) (cadr a))) (and (collinear-p (car b) (car a) (cadr b)) (collinear-p (car b) (cadr a) (cadr b))))) (not (or (and (collinear-p (car a) (car b) (cadr a)) (collinear-p (car b) (cadr a) (cadr b))) (and (collinear-p (car b) (car a) (cadr b)) (collinear-p (car a) (cadr b) (cadr a)))))) (cond ( (collinear-p (car a) (car b) (cadr a)) (setq ip (car b)) ) ( (collinear-p (car a) (cadr b) (cadr a)) (setq ip (cadr b)) ) ( (collinear-p (car b) (car a) (cadr b)) (setq ip (car a)) ) ( (collinear-p (car b) (cadr a) (cadr b)) (setq ip (cadr a)) )) (setq iip nil)) (cond ( iip (list a b iip) ) ( ip (list a b ip) ))))) (vl-remove a lil)))) lil))
29.       (cond
30.         ( (and ilil (equal iip (caddr ilil) 1e-6))
31.           (setq lil (processlil ilil lil))
32.         )
33.         ( (and ilil (equal (caar ilil) (caddr ilil) 1e-6))
34.           (cond
35.             ( (and (not (equal (caar ilil) (caadr ilil) 1e-6)) (not (equal (caar ilil) (cadadr ilil) 1e-6)))
36.               (setq lil (processlil ilil lil))
37.             )
38.             ( (equal (caar ilil) (caadr ilil) 1e-6)
39.               (setq lil (processlil ilil lil))
40.             )
41.             ( (equal (caar ilil) (cadadr ilil) 1e-6)
42.               (setq ilil (subst (assoc (cadadr ilil) lil) (cadr ilil) ilil))
43.               (setq lil (processlil ilil lil))
44.             )
45.           )
46.         )
47.         ( (and ilil (equal (cadar ilil) (caddr ilil) 1e-6))
48.           (cond
49.             ( (and (not (equal (cadar ilil) (caadr ilil) 1e-6)) (not (equal (cadar ilil) (cadadr ilil) 1e-6)))
50.               (setq ilil (subst (assoc (cadar ilil) lil) (car ilil) ilil))
51.               (setq lil (processlil ilil lil))
52.             )
53.             ( (equal (cadar ilil) (caadr ilil) 1e-6)
54.               (setq ilil (subst (assoc (cadar ilil) lil) (car ilil) ilil))
55.               (setq lil (processlil ilil lil))
56.             )
57.             ( (equal (cadar ilil) (cadadr ilil) 1e-6)
58.               (setq ilil (subst (assoc (cadar ilil) lil) (car ilil) ilil))
59.               (setq ilil (subst (assoc (cadadr ilil) lil) (cadr ilil) ilil))
60.               (setq lil (processlil ilil lil))
61.             )
62.           )
63.         )
64.         ( (and ilil (equal (caadr ilil) (caddr ilil) 1e-6))
65.           (cond
66.             ( (and (not (equal (caadr ilil) (caar ilil) 1e-6)) (not (equal (caadr ilil) (cadar ilil) 1e-6)))
67.               (setq lil (processlil ilil lil))
68.             )
69.             ( (equal (caadr ilil) (caar ilil) 1e-6)
70.               (setq lil (processlil ilil lil))
71.             )
72.             ( (equal (caadr ilil) (cadar ilil) 1e-6)
73.               (setq ilil (subst (assoc (caadr ilil) lil) (car ilil) ilil))
74.               (setq lil (processlil ilil lil))
75.             )
76.           )
77.         )
78.         ( (and ilil (equal (cadadr ilil) (caddr ilil) 1e-6))
79.           (cond
80.             ( (and (not (equal (cadadr ilil) (caar ilil) 1e-6)) (not (equal (cadadr ilil) (cadar ilil) 1e-6)))
81.               (setq ilil (subst (assoc (cadadr ilil) lil) (cadr ilil) ilil))
82.               (setq lil (processlil ilil lil))
83.             )
84.             ( (equal (cadadr ilil) (caar ilil) 1e-6)
85.               (setq ilil (subst (assoc (cadadr ilil) lil) (cadr ilil) ilil))
86.               (setq lil (processlil ilil lil))
87.             )
88.             ( (equal (cadadr ilil) (cadar ilil) 1e-6)
89.               (setq ilil (subst (assoc (cadadr ilil) lil) (cadr ilil) ilil))
90.               (setq ilil (subst (assoc (cadar ilil) lil) (car ilil) ilil))
91.               (setq lil (processlil ilil lil))
92.             )
93.           )
94.         )
95.         ( t (setq done t) )
96.       )
97.     )
98.     (setq r (mapcar (function car) lil))
99.     (setq lil nil)
100.     r
101.   )
102.  
103.   (defun AHS:TSP ( pl / AHS:mainprocess AHS:subprocess1 AHS:subprocess2 k li1 li2 lii )
104.  
105.     (defun AHS:mainprocess ( li1 li2 )
106.       (foreach po li2
107.         (setq lii (append lii (AHS:subprocess1 po li1)))
108.       )
109.       (setq li1 (AHS:subprocess2 li1 lii))
110.     )
111.  
112.     (defun AHS:subprocess1 ( po li1 / k n po1 po2 lii )
113.       (setq k 0)
114.       (repeat (setq n (length li1))
115.         (setq po1 (nth k li1))
116.         (if (= k (1- n))
117.           (setq po2 (nth 0 li1))
118.           (setq po2 (nth (1+ k) li1))
119.         )
120.         (setq lii (append lii (list (list po1 po po2))))
121.         (setq k (1+ k))
122.       )
123.       lii
124.     )
125.  
126.     (defun AHS:subprocess2 ( li1 lii / n dili dimin k i a po li3 )
127.       (setq n (length li1))
128.       (setq dili (mapcar (function (lambda ( a ) (- (+ (distance (car a) (cadr a)) (distance (cadr a) (caddr a))) (distance (car a) (caddr a))))) lii))
129.       (setq dimin (apply (function min) dili))
130.       (setq k 0)
131.       (while (and (not i) (< k (length dili)))
132.         (if (equal dimin (nth k dili) 1e-6)
133.           (setq i k)
134.         )
135.         (setq k (1+ k))
136.       )
137.       (setq a (nth i lii) po (cadr a))
138.       (if (equal (car a) (last li1) 1e-6)
139.         (setq li1 (cons po li1))
140.         (progn
141.           (setq k 0)
142.           (while (< k n)
143.             (if (equal (nth k li1) (car a) 1e-6)
144.               (setq li3 (cons (nth k li1) li3) li3 (cons po li3))
145.               (setq li3 (cons (nth k li1) li3))
146.             )
147.             (setq k (1+ k))
148.           )
149.           (setq li1 (reverse li3))
150.         )
151.       )
152.       (if (or (equal (car a) (cadr a) 1e-6) (equal (cadr a) (caddr a) 1e-6) (equal (car a) (caddr a) 1e-6))
153.         (progn (prompt "\nDuplicate points detected... Quitting...") (exit))
154.       )
155.       li1
156.     )
157.  
158.     (setq k 0)
159.     (foreach po (setq pl (vl-sort pl (function (lambda ( a b ) (if (equal (cadr a) (cadr b) 1e-6) (< (car a) (car b)) (< (cadr a) (cadr b)))))))
160.       (setq k (1+ k))
161.       (if (< k 4)
162.         (setq li1 (append li1 (list po)))
163.         (setq li2 (append li2 (list po)))
164.       )
165.     )
166.     (if (> k 3)
167.       (progn
168.         (while (cadr li2)
169.           (setq lii nil)
170.           (setq li1 (AHS:mainprocess li1 li2))
171.           (setq li2 (vl-remove-if (function (lambda ( p1 ) (vl-some (function (lambda ( p2 ) (equal p1 p2 1e-6))) li1))) pl))
172.         )
173.         (setq lii nil)
174.         (setq lii (AHS:subprocess1 (car li2) li1))
175.         (setq li1 (AHS:subprocess2 li1 lii))
176.       )
177.     )
178.     li1
179.   )
180.  
181.   (prompt "\n")
182.   (prompt "\nSelect points...")
183.   (if (and (setq ss (ssget '((0 . "POINT")))) (> (setq n (sslength ss)) 1))
184.     (progn
185.       (setq ti (car (_vl-times)))
186.       (repeat n
187.         (setq pl (cons (mapcar (function +) (list 0.0 0.0) (trans (cdr (assoc 10 (entget (ssname ss (setq n (1- n)))))) 0 1)) pl))
188.       )
189.       (setq pl (AHS:TSP pl))
190.       (if (chkinters-p pl)
191.         (setq pl (chkinters pl))
192.       )
193.       (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pl (append (cdr pl) (list (car pl))))))
194.       (entmake
195.         (append
196.           (list
197.            '(0 . "LWPOLYLINE")
198.            '(100 . "AcDbEntity")
199.            '(100 . "AcDbPolyline")
200.             (cons 90 (length pl))
201.             (cons 70 (1+ (* 128 (getvar 'plinegen))))
202.            '(38 . 0.0)
203.           )
204.           (mapcar (function (lambda ( p ) (list 10 (car p) (cadr p)))) pl)
205.           (list
206.             (cons 210 (trans (list 0.0 0.0 1.0) 1 0 t))
207.            '(62 . 3)
208.           )
209.         )
210.       )
211.       (prompt "\nDistance - path length : ") (princ (rtos d 2 20))
212.       (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
213.     )
214.     (prompt "\nNo points selected, or selected/picked just single point...")
215.   )
216.   (princ)
217. )
218.  

Regards, M.R.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on July 28, 2022, 08:12:47 AM

Here is my revision for sphere body aspect...
Still it needs further debugging, but it's much better now then before... It should work faster and you can go and above 10 pts, but I am usually doing 10 and it may crash even then sometimes...

Regards, M.R.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on July 30, 2022, 05:21:14 PM

TSP - TRANSFORMATION SPHERE POINTS TO 2D PLANAR DIAGRAM

Firstly let's analyze something about SPHERE properties...
Let's say that we know area of sphere which is derived from integral calculus - it goes something if I can recall 2*2R*pi*int(cos x)|0->(pi/2)... When we compute we get 4*R^2*pi...
Now let's analyze something more visual about how equatorial distance shrinks from 2*r*pi to 0 all the way to the poles...
What would you say - it looks familiar to something like when r=R*cos(beta) goes from R to 0 => beta goes from 0 to pi/2; in the same time equatorial distance changes from 2*R*pi to 0, with the same relation as we wrote 2*r*pi...
So we can say it clearly that area of hemisphere is similar to half of ellipse with a=R*pi and b=R*4/pi... Can we assume that area of sphere is 2 areas of those half ellipses representing hemispheres, or just single ellipse area = a*b*pi = R*pi*R*4/pi*pi = 4*R^2*pi...
But can we see from that ellipse real longitude and latitude 2D diagram of points that are graphically identical to 3D sphere body... I don't really know, but it looks that that representation don't fulfill real spherical geometrical properties... Then what picture should be more appropriate... I am guessing something like circle, but with what radius? Let's see : area of circle = R^2*pi and area of sphere = 4*R^2*pi... Let's now say R of sphere is r... So we get R^2*pi=4*r^2*pi... From here we can say 4*r^2=R^2 and we have here R=2*r, so radius of circle is actually diameter of sphere... And that's it... That's the most appropriate picture... But now what? If we randomly place points on sphere what can we say about their transformation to diagram... Firstly for RND points on sphere we can say that the most appropriate representation of adequate coordinate system is not cartezian, but spherical, so we have angle in plane (along Z axis) - alpha and angle in vertical plane of sphere origin and first projection of 3D point - beta, last figure important and constant in relation of sphere origin and 3D point is their distance - R (radius)...
So we can say : pt=R*cos(beta)*cos(alpha),R*cos(beta)*sin(alpha),R*sin(beta)...
And on the 2D diagram we analyzed (r of diagram = 2R), so pt=r/2*cos(beta)*cos(alpha),r/2*cos(beta)*sin(alpha),r/2*sin(beta)...
Now let's analyze 2 RND points on 2D diagram : pt1 and pt2; we can see that :
delta X = abs(r/2*cos(beta1-beta2)*cos(alpha1-alpha2));
delta Y = abs(r/2*cos(beta1-beta2)*sin(alpha1-alpha2));
delta Z = abs(r/2*sin(beta1-beta2));
If we assume that in 2D diagram points represent spherical 3D points, we can say that if we solve TSP in 2D diagram it's not really fulfilling all relations that are correct in terms of areal relation... We can assume that if X axis of 2D diagram represent equatorial circular length, we should say that -X=>+X = 2*R*pi and in 2D diagram -X=>+X = 2*r = (4*R)!... So real 2D representation that is adequate for representing relations are not static, but dynamic; it references rotation along Y axis of 2D diagram in which all points rotate and change their positions assuming that rotational angle is something dynamic and goes from 0 to 2*pi radians... So if we say that 0 rotation is = +X axis, X=R*cos(beta)*cos(0) on sphere and it would be X=r/2*cos(beta)*cos(0) on diagram and if rotation angle is pi/2 then X=(R or r/2)*cos(beta)*cos(pi/2) = 0 [cos(pi/2)=0], meaning somewhere on Y axis points (from (-R or -r/2) to (R or r/2)) and so on, and so on... But when we say Y axis on 2D diagram, we are thinking on Z axis on sphere, so pt=X,Y on 2D diagram is actually pt=r/2*cos(beta)*cos(alpha),r/2*sin(beta) and on sphere already stated pt=X,Y,Z=R*cos(beta)*cos(alpha),R*cos(beta)*sin(alpha),R*sin(beta)...
Now let's see what real distance between 2 points are... D=sqrt[(delta X)^2+(delta Y)^2+(delta Z)^2], but this is somewhat not so elegant for thinking... Firstly, if we know delta elevation between 2 points, we can say that delta Z is dependable from delta beta angle, so delta beta = asin [(delta Z)/R]; now if we know delta beta, we can say delta alpha = acos [R*cos(delta beta)]... Now if we have delta alpha and delta beta, we can have delta gamma which is actually value of real 3D arc length times R... Simply by Pitagora : delta gamma ^2 = delta alpha ^2 + delta beta ^2; delta gamma = sqrt (delta alpha ^2 + delta beta ^2)... 3D arc length = ARC = R*sqrt[{acos[R*cos{asin[(delta Z)/R]}]}^2+{asin[(delta Z)/R]}^2]...
Now let's concentrate on real 2D situation that's not dependable of rotation around Y axis of 2D diagram or Z axis of 3D sphere...
So we have real arc lengths dependable of : gamma1 (p1-p2), gamma2 (p2-p3), gamma3 (p1-p3), ...
Actually we found combinations of all point pairs between each points without repetitions...
(foreach p1 plst
  (setq plst (cdr plst))
  (foreach p2 plst
    (setq p1p2arclenlst (cons (list p1 p2 (arclen p1 p2)) p1p2arclenlst))
  )
)
So we map points : p1, p2, p3, ... dependable of 2D triangulation diagram where all arcs lengths are real distances and neither of triangles must not cross previous triangle, or be inside possible larger one (we have 2 solutions of circle-circle intersections for constructing triangulations between 2 points...)...
Possible start p1=0,0; p2=arclen(p1,p2),0; p3=arclen(p1,p3)*cos(a),arclen(p1,p3)*sin(a) = ci(p1,arclen(p1,p3))Xci(p2,arclen(p2,p3)); p4= ci(p1,arclen(p1,p4))Xci(p3,arclen(p3,p4)) or ci(p2,arclen(p2,p4))Xci(p3,arclen(p3,p4)) -- already here we have branching and we must decide which path is better from p1 or p2 --; then for p5 branching through p1-p4 or p3-p4 or through p2-p4 or p3-p4 ...
We solve 2D TSP on triangulation and we remember correct order of point list...
That would be good only if triangulation would satisfy real disposition which would assume that all relations between points are compact and unique... According to branching, that would not be correct, so we still must go through 2D diagram and create rotational dynamic TSP solutions based on sample rotational angle incrementations from 0 to 2*pi radians...
Transformational formula for 3D sphere to 2D diagram is like already stated :
pt=X,Y=r/2*cos(beta)*cos(alpha),r/2*sin(beta); but let's say that rotational angle is theta, so :
pt=X*cos(theta),Y=r/2*cos(theta)*cos(beta)*cos(alpha),r/2*sin(beta)...
Now for theta1, theta2,..., theta11 ; we could have TSP1, TSP2,..., TSP11 with incremental rotational angle of 30 degree...
But could we use real distances for TSP algorithm instead of used (distance) function, something like :
(defun _distance ( p1 p2 / d R ) ;; used bp as lexical global as 3D sphere center ;;
  (setq R (distance bp p1))
  (setq d (* R (sqrt (+ (expt (acos (* R (cos (asin (/ (abs (cadr (mapcar (function -) p2 p1))) R))))) 2) (expt (asin (/ (abs (cadr (mapcar (function -) p2 p1))) R)) 2)))))
)
and just replace in the code of TSP : "(distance " with "(_distance "...
Finally, what should we do with different TSP mapped point lists if they differ...
Beside this, given the fact that projection have from elevation view of 2D diagram likewise TOP and BACK sides, we could have overlapping points that are opposed to each other... So each TSP solution is TOP+BACK (alpha(0,pi) and alpha(pi,2*pi))...
Final conclusion :
From complexity reasons, 2D TSP is not really useful in terms of transformations from 3D spherical points distribution, further more to dissect even more, when we assume that we dynamically watched rotational dispositions of points along Y axis - corresponding to Z rotation of sphere, we could say that we watched longitudinal section of sphere and we looked points only from projection of Z axis of 2D diagram or some axis in XY plane of 3D sphere; so here we could say that we could have rotational axis from any direction around Z of 2D diagram, meaning infinite number of axises but from only single longitudinal section/elevation plane of view, whereas we could also say that that 2D diagram could have also been viewed from any Y rotational angle of diagram / Z rotational angle of sphere, meaning infinite number of elevations times infinite number of axises of each elevation = infinite^2 number of TSP solutions all with (TOP+BACK) representations of point distributions...
This all is so sad, but true...

So long from me,
Regards, M.R.

[EDIT]
Fooling we around about 2D TSP algorithm, it simply states that just by changing point data from 2D to 3D, we are in condition to solve 3D TSP... Simply we replace Convex Hull with 3D Convex Hull, where we are using TOP projection and FRONT one in case that in first projection (TOP) we have overlappings of points with different elevation...

Now for spherical aspect - we use RND points on sphere, and for intersection checking, we have 2 vectors - 2 tetives of sphere, so we find plane 2 points + origin of sphere, and 2nd plane (similary) => we find vector of intersection of 2 planes with origin as origin of sphere and 2nd point with distance R... So if that line intersect both tetives, then it's crossing and we then continue with reconstructing, by taking 2 shortest tetives and removing 2 originals...

Sincerely, yours, M.R.
[/EDIT]



TSP – TAČKE TRANSFORMACIJE SFERE U 2D PLANARNI DIJAGRAM

Prvo hajde da analiziramo nešto o svojstvima SFERE...
Recimo da znamo površinu sfere koja je izvedena iz integralnog računa - nešto ide ako mogu da se setim 2*2R*pi*int(cos x)|0->(pi/2)... Kada izračunamo dobijamo 4*R^2*pi...
Hajde sada da analiziramo nešto vizuelnije o tome kako se ekvatorijalna udaljenost smanjuje sa 2*r*pi na 0 sve do polova...
Šta biste rekli - izgleda poznato kao kada r=R*cos(beta) ide od R do 0 => beta ide od 0 do pi/2; u isto vreme ekvatorijalna udaljenost se menja sa 2*R*pi na 0, sa istim odnosom kao što smo napisali 2*r*pi...
Dakle, možemo jasno reći da je oblast hemisfere slična polovini elipse sa a=R*pi i b=R*4/pi... Možemo li pretpostaviti da je površina sfere 2 oblasti tih poluelipsi koje predstavljaju hemisfere, ili samo jedna oblast elipse = a*b*pi = R*pi*R*4/pi*pi = 4*R^2*pi...
Ali da li možemo da vidimo iz te elipse stvarnu dužinu i širinu 2D dijagram tačaka koje su grafički identične telu 3D sfere... Ne znam zaista, ali izgleda da taj prikaz ne ispunjava stvarna sferna geometrijska svojstva... Koja bi onda slika bila prikladnija... Pretpostavljam nešto kao krug, ali sa kojim radijusom? Da vidimo: površina kruga = R^2*pi i površina sfere = 4*R^2*pi... Recimo sada da je R sfere r... Dakle, dobijamo R^2*pi=4*r ^2*pi... Odavde možemo reći 4*r^2=R^2 i imamo R=2*r, dakle poluprečnik kruga je zapravo prečnik sfere... I to je to... To je najprikladnija slika... Ali šta sad? Ako nasumično postavimo tačke na sferu, šta možemo reći o njihovoj transformaciji u dijagram...
Sada da vidimo koliko je stvarno rastojanje između 2 tačke... D=sqrt[(delta X)^2+(delta Y)^2+(delta Z)^2], ali ovo donekle nije tako elegantno za razmišljanje. Prvo, ako znamo delta elevaciju između 2 tačke, možemo reći da je delta Z zavisna od delta beta ugla, tako da je delta beta = asin [(delta Z)/R]; sada ako znamo delta beta, možemo reći delta alfa = acos [R*cos(delta beta)]... Sada ako imamo delta alfa i delta beta, možemo imati delta gama što je zapravo vrednost stvarne dužine 3D luka puta R... Jednostavno od Pitagore : delta gama ^2 = delta alfa ^2 + delta beta ^2; delta gama = sqrt (delta alfa ^2 + delta beta ^2)... 3D dužina luka = ARC = R*sqrt[{acos[R*cos{asin[(delta Z)/R]}]}^2+ {asin[(delta Z)/R]}^2]...
Sada hajde da se koncentrišemo na stvarnu 2D situaciju koja ne zavisi od rotacije oko Y ose 2D dijagrama ili Z ose 3D sfere...
Dakle, imamo stvarne dužine luka zavisne od: gamma1 (p1-p2), gamma2 (p2-p3), gamma3 (p1-p3), ...
Zapravo smo pronašli kombinacije svih parova tačaka između svake tačke bez ponavljanja...
(foreach p1 plst
  (setq plst (cdr plst))
  (foreach p2 plst
    (setq p1p2arclenlst (cons (lista p1 p2 (arclen p1 p2)) p1p2arclenlst))
  )
)
Dakle, mapiramo tačke: p1, p2, p3, ... zavisno od 2D triangulacionog dijagrama gde su sve dužine lukova realne udaljenosti i nijedan od trouglova ne sme da prelazi prethodni trougao, ili da bude unutar moguće većeg trougla (imamo 2 rešenja kružnice - kružne preseke za konstruisanje triangulacija između 2 tačke...)...
Mogući početak p1=0,0; p2=arclen(p1,p2),0; p3=arclen(p1,p3)*cos(a),arclen(p1,p3)*sin(a) = ci(p1,arclen(p1,p3))Xci(p2,arclen(p2,p3)); p4= ci(p1,arclen(p1,p4))Xci(p3,arclen(p3,p4)) ili ci(p2,arclen(p2,p4))Xci(p3,arclen(p3,p4)) -- već ovde imamo grananje i moramo odlučiti koji je put bolji od p1 ili p2 --; zatim za p5 grananje kroz p1-p4 ili p3-p4 ili kroz p2-p4 ili p3-p4 ...
Rešavamo 2D TSP na triangulaciji i pamtimo tačan redosled liste tačaka...
To bi bilo dobro samo ako bi triangulacija zadovoljila realnu dispoziciju koja bi pretpostavljala da su sve relacije između tačaka kompaktne i jedinstvene... Prema grananju, to ne bi bilo tačno, tako da ipak moramo proći kroz 2D dijagram i kreirati rotaciono dinamička TSP rešenja na osnovu povećanja ugla rotacije uzorka od 0 do 2*pi radijana...
Transformaciona formula za 3D sferu u 2D dijagram je kao što je već rečeno:
pt=X,Y=r/2*cos(beta)*cos(alfa),r/2*sin(beta); ali recimo da je rotacioni ugao teta, dakle:
pt=X*cos(teta),Y=r/2*cos(teta)*cos(beta)*cos(alfa),r/2*sin(beta)...
Sada za theta1, theta2,..., theta11; mogli bismo da imamo TSP1, TSP2,..., TSP11 sa inkrementalnim rotacionim uglom od 30 stepeni...
Ali da li bismo mogli da koristimo stvarne udaljenosti za TSP algoritam umesto korišćene funkcije (distance), nešto poput:
(defun _distance ( p1 p2 / d R ) ;; koristi se bp kao leksička globala kao centar 3D sfere ;;
  (setq R (distance bp p1))
  (setq d (* R (sqrt (+ (expt (acos (* R (cos (asin (/ (abs (cadr (mapcar (function -) p2 p1))) R))))) 2) (expt (asin (/ (abs (cadr (mapcar (function -) p2 p1))) R)) 2)))))
)
i samo zamenite u kodu TSP-a: "(distance " sa "(_distance "...
Konačno, šta da radimo sa različitim TSP mapiranim listama tačaka ako se razlikuju...
Osim toga, s obzirom na činjenicu da projekcije imaju sa visinskog pogleda 2D dijagrama isto tako GORNU i ZADNJU stranu, mogli bismo imati tačke preklapanja koje su suprotne jedna drugoj... Dakle, svako TSP rešenje je TOP+NAZAD (alfa(0,pi) i alfa(pi,2*pi))...
Konačan zaključak:
Iz razloga složenosti, 2D TSP nije baš koristan u smislu transformacija iz distribucije 3D sfernih tačaka, dalje da bi se secirao još više, kada pretpostavimo da smo dinamički posmatrali rotacione dispozicije tačaka duž Y ose – što odgovara Z rotaciji sfere, mi bi mogli reći da smo posmatrali uzdužni presek sfere i posmatrali tačke samo iz projekcije Z ose 2D dijagrama ili neke ose u XY ravni 3D sfere; tako da ovde možemo reći da bismo mogli da imamo ose rotacije iz bilo kog smera oko Z 2D dijagrama, što znači beskonačan broj osa, ali samo iz jednog uzdužnog preseka/visinske ravni, dok bismo takođe mogli reći da je taj 2D dijagram takođe mogao biti posmatran iz bilo kog Y rotacionog ugla dijagrama / Z rotacionog ugla sfere, što znači beskonačan broj elevacija puta beskonačan broj osa svake elevacije = beskonačan^2 broj TSP rešenja sva sa (TOP+NAZAD) prikazima tačaka distribucije...
Sve je ovo tužno, ali istinito...

Tako dugo od mene,
Pozdrav, M.R.

[EDIT]
Glupirali se mi oko 2D TSP algoritma, on jednostavno kaže da samo promenom podataka o tačkama iz 2D u 3D, mi smo u stanju da rešimo 3D TSP... Jednostavno zamenimo Convex Hull sa 3D Convex Hull, gde koristimo TOP projekciju i FRONTALNU u slučaju da u prvoj projekciji (TOP) imamo preklapanja tačaka sa različitim elevacijama...

Sada za sferni aspekt - koristimo RND tačke na sferi, a za proveru preseka imamo 2 vektora - 2 tetive sfere, tako da nalazimo ravan 2 tačke + centar sfere, i 2 ravan (slicno) => nalazimo vektor preseka od 2 ravni sa centrom sfere i drugom tačkom sa rastojanjem R... Dakle, ako ta linija seče obe tetive, onda se javlja ukrštanje i onda nastavljamo sa rekonstrukcijom, uzimajući 2 najkraće tetive i uklanjajući 2 originalne...

S poštovanjem, M.R.
[/EDIT]

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: VovKa on July 30, 2022, 05:29:19 PM

Quote from: ribarm on July 30, 2022, 05:21:14 PM

So long from me,

this might be the longest post here on theswamp :)

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on July 31, 2022, 08:20:38 AM

So, I've done everything based on TSP-all.lsp (2D algortihm)... It should work well now for every situation (2D, 3D space points, 3D spherical points) with RND points or selection set of points, blocks or circles...

So, it may occur something strange, like in my latest testings - on one place on sphere path crossed, and BTW. with some small arcs, it must skip them as (MR:3parc) can't always create ARC in 3D...

That's all...
So long from me...
Enjoy...
M.R.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on October 12, 2022, 04:10:54 AM

Interesting approach by CADaSchtroumpf at autodesk forums by using temporary ellipse entity for sorting points... It should be very fast... I'll see to implement intersections checking... It's not difficult - just use that what I posted for @ahsattarian...

https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/challenge-generate-n-closed-plines-from-n-groups-of-points/m-p/11476934/highlight/true#M437651

Regards, M.R.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ScottMC on October 12, 2022, 12:56:45 PM

Quote from: ribarm on October 12, 2022, 04:10:54 AM

Interesting approach by CADaSchtroumpf at autodesk forums by using temporary ellipse entity for sorting points... It should be very fast... I'll see to implement intersections checking... It's not difficult - just use that what I posted for @ahsattarian...

https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/challenge-generate-n-closed-plines-from-n-groups-of-points/m-p/11476934/highlight/true#M437651

Regards, M.R.

Excellent and fast! Also nice to include circles and blocks. Gonna speriment 3D as it's used the most. Only had to comment a few on the 'sysvarpreset' list.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on December 23, 2022, 12:59:19 PM

I don't know, but this option also exist... Something I called double greedy TSP...

Code - Auto/Visual Lisp: [Select]

1. (defun c:tsp-3d-space ( / *error* tttt car-sort collinear-p chkinters-p chkinters ss ti i pl c p1 p2 pp1 pp2 lst )
2.  
3.   (defun *error* ( m )
4.     (if wcs
5.       (if ucsf
6.         (exe (list "_.UCS" "_P"))
7.       )
8.     )
9.     (while (= 8 (logand 8 (getvar (quote undoctl))))
10.       (if (not (exe (list "_.UNDO" "_E")))
11.         (if doc
12.           (vla-endundomark doc)
13.         )
14.       )
15.     )
16.     (if initvalueslst
17.       (mapcar (function apply_cadr->car) initvalueslst)
18.     )
19.     (foreach fun (list (quote tttt) (quote vl-load) (quote exe) (quote cmdfun) (quote cmderr) (quote catch_cont) (quote apply_cadr->car) (quote ftoa))
20.       (setq fun nil)
21.     )
22.     (if doc
23.       (vla-regen doc acactiveviewport)
24.     )
25.     (if m
26.       (prompt m)
27.     )
28.     (princ)
29.   )
30.  
31.   (defun tttt ( wcs / sysvarpreset sysvarlst sysvarvals ) ;;; wcs (T/nil) ;;; cad, doc, alo, spc - global variables (Visual Lisp main VLA-OBJECT pointers) ;;; vl-load exe cmdfun cmderr catch_cont apply_cadr->car ftoa - library sub functions common for standard template initialization ;;;
32.  
33.     (defun vl-load nil
34.       (or cad
35.         (if vlax-get-acad-object
36.           (setq cad (vlax-get-acad-object))
37.           (progn
38.             (vl-load-com)
39.             (setq cad (vlax-get-acad-object))
40.           )
41.         )
42.       )
43.       (or doc (setq doc (vla-get-activedocument cad)))
44.       (or alo (setq alo (vla-get-activelayout doc)))
45.       (or spc (setq spc (vla-get-block alo)))
46.     )
47.  
48.     ;;; sometimes not needed to use/initialize AxiveX Visual Lisp extensions - (comment/uncomment) following line ;;;
49.     (or (and cad doc alo spc) (vl-load))
50.  
51.     (defun exe ( tokenslist )
52.       ( (lambda ( tokenslist / ctch )
53.           (if (vl-catch-all-error-p (setq ctch (cmdfun tokenslist t)))
54.             (progn
55.               (cmderr tokenslist)
56.               (catch_cont ctch)
57.             )
58.             (progn
59.               (while (< 0 (getvar (quote cmdactive)))
60.                 (vl-cmdf "")
61.               )
62.               t
63.             )
64.           )
65.         )
66.         tokenslist
67.       )
68.     )
69.  
70.     (defun cmdfun ( tokenslist flag / ctch ) ;;; tokenslist - command parameters list of strings ;;; flag - if "t" specified, upon successful execution returns t, otherwise if "nil" specified, return is always nil no matter what outcome of function execution is - it should be successful anyway if specified tokenslist was hardcoded correctly... ;;;
71.       (if command-s
72.         (if flag
73.           (if (not (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function command-s) tokenslist))))
74.             flag
75.             ctch
76.           )
77.           (if (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function command-s) tokenslist)))
78.             ctch
79.           )
80.         )
81.         (if flag
82.           (if (not (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function vl-cmdf) tokenslist))))
83.             flag
84.             ctch
85.           )
86.           (if (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function command) tokenslist)))
87.             ctch
88.           )
89.         )
90.       )
91.     )
92.  
93.     (defun cmderr ( tokenslist ) ;;; tokenslist - list of tokens representing command syntax at which used (cmdfun) failed with successful execution ;;;
94.       (prompt (strcat "\ncommand execution failure... error at used command tokenslist : " (vl-prin1-to-string tokenslist)))
95.     )
96.  
97.     (defun catch_cont ( ctch / gr )
98.       (prompt "\nleft mouse click to continue or enter to generate catch error - ESC to break...")
99.       (while
100.         (and
101.           (vl-catch-all-error-p (or ctch (setq ctch (vl-catch-all-apply (function /) (list 1 0)))))
102.           (setq gr (grread))
103.           (/= (car gr) 3)
104.           (not (equal gr (list 2 13)))
105.         )
106.       )
107.       (if (vl-catch-all-error-p ctch)
108.         ctch
109.       )
110.     )
111.  
112.     (defun apply_cadr->car ( sysvarvaluepair / ctch )
113.       (setq ctch (vl-catch-all-apply (function setvar) sysvarvaluepair))
114.       (if (vl-catch-all-error-p ctch)
115.         (progn
116.           (prompt (strcat "\ncatched error on setting system variable : " (vl-prin1-to-string (vl-symbol-name (car sysvarvaluepair))) " with value : " (vl-prin1-to-string (cadr sysvarvaluepair))))
117.           (catch_cont ctch)
118.         )
119.       )
120.     )
121.  
122.     (defun ftoa ( n / m a s b )
123.       (if (numberp n)
124.         (progn
125.           (setq m (fix ((if (< n 0) - +) n 1e-8)))
126.           (setq a (abs (- n m)))
127.           (setq m (itoa m))
128.           (setq s "")
129.           (while (and (not (equal a 0.0 1e-6)) (setq b (fix (* a 10.0))))
130.             (setq s (strcat s (itoa b)))
131.             (setq a (- (* a 10.0) b))
132.           )
133.           (if (= (type n) (quote int))
134.             m
135.             (if (= s "")
136.               m
137.               (if (and (= m "0") (< n 0))
138.                 (strcat "-" m "." s)
139.                 (strcat m "." s)
140.               )
141.             )
142.           )
143.         )
144.       )
145.     )
146.  
147.     (setq sysvarpreset
148.       (list
149.         (list (quote cmdecho) 0)
150.         (list (quote 3dosmode) 0)
151.         (list (quote osmode) 0)
152.         (list (quote unitmode) 0)
153.         (list (quote cmddia) 0)
154.         (list (quote ucsvp) 0)
155.         (list (quote ucsortho) 0)
156.         (list (quote projmode) 0)
157.         (list (quote orbitautotarget) 0)
158.         (list (quote insunits) 0)
159.         (list (quote hpseparate) 0)
160.         (list (quote hpgaptol) 0)
161.         (list (quote halogap) 0)
162.         (list (quote edgemode) 0)
163.         (list (quote pickdrag) 0)
164.         (list (quote qtextmode) 0)
165.         (list (quote dragsnap) 0)
166.         (list (quote angdir) 0)
167.         (list (quote aunits) 0)
168.         (list (quote limcheck) 0)
169.         (list (quote gridmode) 0)
170.         (list (quote nomutt) 0)
171.         (list (quote apbox) 0)
172.         (list (quote attdia) 0)
173.         (list (quote blipmode) 0)
174.         (list (quote copymode) 0)
175.         (list (quote circlerad) 0.0)
176.         (list (quote filletrad) 0.0)
177.         (list (quote filedia) 1)
178.         (list (quote autosnap) 1)
179.         (list (quote objectisolationmode) 1)
180.         (list (quote highlight) 1)
181.         (list (quote lispinit) 1)
182.         (list (quote layerpmode) 1)
183.         (list (quote fillmode) 1)
184.         (list (quote dragmodeinterrupt) 1)
185.         (list (quote dispsilh) 1)
186.         (list (quote fielddisplay) 1)
187.         (list (quote deletetool) 1)
188.         (list (quote delobj) 1)
189.         (list (quote dblclkedit) 1)
190.         (list (quote attreq) 1)
191.         (list (quote explmode) 1)
192.         (list (quote frameselection) 1)
193.         (list (quote ltgapselection) 1)
194.         (list (quote pickfirst) 1)
195.         (list (quote plinegen) 1)
196.         (list (quote plinetype) 1)
197.         (list (quote peditaccept) 1)
198.         (list (quote solidcheck) 1)
199.         (list (quote visretain) 1)
200.         (list (quote regenmode) 1)
201.         (list (quote celtscale) 1.0)
202.         (list (quote ltscale) 1.0)
203.         (list (quote osnapcoord) 2)
204.         (list (quote grips) 2)
205.         (list (quote dragmode) 2)
206.         (list (quote lunits) 2)
207.         (list (quote pickstyle) 3)
208.         (list (quote navvcubedisplay) 3)
209.         (list (quote pickauto) 3)
210.         (list (quote draworderctl) 3)
211.         (list (quote expert) 5)
212.         (list (quote auprec) 6)
213.         (list (quote luprec) 6)
214.         (list (quote pickbox) 6)
215.         (list (quote aperture) 6)
216.         (list (quote osoptions) 7)
217.         (list (quote dimzin) 8)
218.         (list (quote pdmode) 35)
219.         (list (quote pdsize) -1.5)
220.         (list (quote celweight) -1)
221.         (list (quote cecolor) "BYLAYER")
222.         (list (quote celtype) "ByLayer")
223.         (list (quote clayer) "0")
224.       )
225.     )
226.     (setq sysvarlst (mapcar (function car) sysvarpreset))
227.     (setq sysvarvals (mapcar (function cadr) sysvarpreset))
228.     (setq sysvarvals
229.       (vl-remove nil
230.         (mapcar
231.           (function (lambda ( x )
232.             (if (getvar x) (nth (vl-position x sysvarlst) sysvarvals))
233.           ))
234.           sysvarlst
235.         )
236.       )
237.     )
238.     (setq sysvarlst
239.       (vl-remove-if-not
240.         (function (lambda ( x )
241.           (getvar x)
242.         ))
243.         sysvarlst
244.       )
245.     )
246.     (setq initvalueslst
247.       (apply (function mapcar)
248.         (cons (function list)
249.           (list
250.             sysvarlst
251.             (mapcar (function getvar) sysvarlst)
252.           )
253.         )
254.       )
255.     )
256.     (apply (function mapcar)
257.       (cons (function setvar)
258.         (list
259.           sysvarlst
260.           sysvarvals
261.         )
262.       )
263.     )
264.     (while (= 8 (logand 8 (getvar (quote undoctl))))
265.       (if (not (exe (list "_.UNDO" "_E")))
266.         (if doc
267.           (vla-endundomark doc)
268.         )
269.       )
270.     )
271.     (if (not (exe (list "_.UNDO" "_M")))
272.       (if doc
273.         (vla-startundomark doc)
274.       )
275.     )
276.     (if wcs
277.       (if (= 0 (getvar (quote worlducs)))
278.         (progn
279.           (exe (list "_.UCS" "_W"))
280.           (setq ucsf t)
281.         )
282.       )
283.     )
284.     wcs
285.   )
286.  
287.   (defun car-sort ( lst cmp / rtn )
288.     (setq rtn (car lst))
289.     (foreach itm (cdr lst)
290.       (if (apply cmp (list itm rtn))
291.         (setq rtn itm)
292.       )
293.     )
294.     rtn
295.   )
296.  
297.   (defun collinear-p ( p1 p p2 )
298.     (equal (distance p1 p2) (+ (distance p1 p) (distance p p2)) 1e-6)
299.   )
300.  
301.   (defun chkinters-p ( pl / r )
302.     (or lil (setq lil (mapcar (function list) pl (append (cdr pl) (list (car pl))))))
303.     (setq r (vl-some (function (lambda ( x ) (vl-some (function (lambda ( y ) (and (not (equal (car x) (car y) 1e-6)) (not (equal (car x) (cadr y) 1e-6)) (not (equal (cadr x) (car y) 1e-6)) (not (equal (cadr x) (cadr y) 1e-6)) (or (inters (car x) (cadr x) (car y) (cadr y)) (collinear-p (car x) (car y) (cadr x)) (collinear-p (car x) (cadr y) (cadr x)) (collinear-p (car y) (car x) (cadr y)) (collinear-p (car y) (cadr x) (cadr y)))))) (vl-remove (if (= (vl-position x lil) 0) (last lil) (nth (1- (vl-position x lil)) lil)) (vl-remove (if (= (vl-position x lil) (1- (length lil))) (car lil) (nth (1+ (vl-position x lil)) lil)) (vl-remove x lil)))))) lil))
304.     (setq lil nil)
305.     r
306.   )
307.  
308.   (defun chkinters ( pl / processlil done r lill ilil iip )
309.  
310.     (defun processlil ( ilil lil / pre mid suf ret )
311.       (setq pre (reverse (cdr (member (car ilil) (reverse lil)))))
312.       (setq mid (cdr (member (car ilil) lil)))
313.       (setq mid (cdr (member (cadr ilil) (reverse mid))))
314.       (setq mid (mapcar (function reverse) mid))
315.       (setq suf (cdr (member (cadr ilil) lil)))
316.       (setq ret (append pre (list (list (car (car ilil)) (car (cadr ilil)))) mid (list (list (cadr (car ilil)) (cadr (cadr ilil)))) suf))
317.       ret
318.     )
319.  
320.     (or lil (setq lil (mapcar (function list) pl (append (cdr pl) (list (car pl))))))
321.     (while (not done)
322.       (setq ilil (vl-some (function (lambda ( a ) (vl-some (function (lambda ( b / ip ) (progn (setq iip (inters (car a) (cadr a) (car b) (cadr b))) (if (and (not (equal (cadr a) (car b) 1e-6)) (not (equal (car a) (cadr b) 1e-6)) (not (or (and (collinear-p (car a) (car b) (cadr a)) (collinear-p (car a) (cadr b) (cadr a))) (and (collinear-p (car b) (car a) (cadr b)) (collinear-p (car b) (cadr a) (cadr b))))) (not (or (and (collinear-p (car a) (car b) (cadr a)) (collinear-p (car b) (cadr a) (cadr b))) (and (collinear-p (car b) (car a) (cadr b)) (collinear-p (car a) (cadr b) (cadr a)))))) (cond ( (collinear-p (car a) (car b) (cadr a)) (setq ip (car b)) ) ( (collinear-p (car a) (cadr b) (cadr a)) (setq ip (cadr b)) ) ( (collinear-p (car b) (car a) (cadr b)) (setq ip (car a)) ) ( (collinear-p (car b) (cadr a) (cadr b)) (setq ip (cadr a)) )) (setq iip nil)) (cond ( iip (list a b iip) ) ( ip (list a b ip) ))))) (vl-remove a lil)))) lil))
323.       (cond
324.         ( (and ilil (equal iip (caddr ilil) 1e-6))
325.           (setq lil (processlil ilil lil))
326.         )
327.         ( (and ilil (equal (caar ilil) (caddr ilil) 1e-6))
328.           (cond
329.             ( (and (not (equal (caar ilil) (caadr ilil) 1e-6)) (not (equal (caar ilil) (cadadr ilil) 1e-6)))
330.               (setq lil (processlil ilil lil))
331.             )
332.             ( (equal (caar ilil) (caadr ilil) 1e-6)
333.               (setq lil (processlil ilil lil))
334.             )
335.             ( (equal (caar ilil) (cadadr ilil) 1e-6)
336.               (setq ilil (subst (assoc (cadadr ilil) lil) (cadr ilil) ilil))
337.               (setq lil (processlil ilil lil))
338.             )
339.           )
340.         )
341.         ( (and ilil (equal (cadar ilil) (caddr ilil) 1e-6))
342.           (cond
343.             ( (and (not (equal (cadar ilil) (caadr ilil) 1e-6)) (not (equal (cadar ilil) (cadadr ilil) 1e-6)))
344.               (setq ilil (subst (assoc (cadar ilil) lil) (car ilil) ilil))
345.               (setq lil (processlil ilil lil))
346.             )
347.             ( (equal (cadar ilil) (caadr ilil) 1e-6)
348.               (setq ilil (subst (assoc (cadar ilil) lil) (car ilil) ilil))
349.               (setq lil (processlil ilil lil))
350.             )
351.             ( (equal (cadar ilil) (cadadr ilil) 1e-6)
352.               (setq ilil (subst (assoc (cadar ilil) lil) (car ilil) ilil))
353.               (setq ilil (subst (assoc (cadadr ilil) lil) (cadr ilil) ilil))
354.               (setq lil (processlil ilil lil))
355.             )
356.           )
357.         )
358.         ( (and ilil (equal (caadr ilil) (caddr ilil) 1e-6))
359.           (cond
360.             ( (and (not (equal (caadr ilil) (caar ilil) 1e-6)) (not (equal (caadr ilil) (cadar ilil) 1e-6)))
361.               (setq lil (processlil ilil lil))
362.             )
363.             ( (equal (caadr ilil) (caar ilil) 1e-6)
364.               (setq lil (processlil ilil lil))
365.             )
366.             ( (equal (caadr ilil) (cadar ilil) 1e-6)
367.               (setq ilil (subst (assoc (caadr ilil) lil) (car ilil) ilil))
368.               (setq lil (processlil ilil lil))
369.             )
370.           )
371.         )
372.         ( (and ilil (equal (cadadr ilil) (caddr ilil) 1e-6))
373.           (cond
374.             ( (and (not (equal (cadadr ilil) (caar ilil) 1e-6)) (not (equal (cadadr ilil) (cadar ilil) 1e-6)))
375.               (setq ilil (subst (assoc (cadadr ilil) lil) (cadr ilil) ilil))
376.               (setq lil (processlil ilil lil))
377.             )
378.             ( (equal (cadadr ilil) (caar ilil) 1e-6)
379.               (setq ilil (subst (assoc (cadadr ilil) lil) (cadr ilil) ilil))
380.               (setq lil (processlil ilil lil))
381.             )
382.             ( (equal (cadadr ilil) (cadar ilil) 1e-6)
383.               (setq ilil (subst (assoc (cadadr ilil) lil) (cadr ilil) ilil))
384.               (setq ilil (subst (assoc (cadar ilil) lil) (car ilil) ilil))
385.               (setq lil (processlil ilil lil))
386.             )
387.           )
388.         )
389.         ( t (setq done t) )
390.       )
391.     )
392.     (setq r (mapcar (function car) lil))
393.     (setq lil nil)
394.     r
395.   )
396.  
397.   (tttt t) ;;; initializing default error handler and setting of system variables ;;;
398.   (prompt "\nSelect 3d points, blocks or circles...")
399.   (if (setq ss (ssget (list (cons 0 "POINT,INSERT,CIRCLE"))))
400.     (progn
401.       (setq ti (car (_vl-times)))
402.       (repeat (setq i (sslength ss))
403.         (setq pl (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) pl))
404.       )
405.       (setq pl (vl-sort pl (function (lambda ( a b ) (if (= (car a) (car b)) (if (= (cadr a) (cadr b)) (> (caddr a) (caddr b)) (> (cadr a) (cadr b))) (> (car a) (car b)))))))
406.       (if (vl-every (function (lambda ( x ) (equal (caddr x) 0.0 1e-6))) pl)
407.         (setq c (list (car-sort (mapcar (function car) pl) (function >)) (car-sort (mapcar (function cadr) pl) (function >))) pl (mapcar (function (lambda ( p ) (list (car p) (cadr p)))) pl))
408.         (setq c (list (car-sort (mapcar (function car) pl) (function >)) (car-sort (mapcar (function cadr) pl) (function >)) (car-sort (mapcar (function caddr) pl) (function >))))
409.       )
410.       (setq p1 c)
411.       (setq p2 (car-sort (vl-remove p1 pl) (function (lambda ( q p ) (< (distance p1 q) (distance p1 p))))))
412.       (setq lst (cons p2 lst))
413.       (setq p1 p2)
414.       (setq p2 (car-sort (vl-remove p1 pl) (function (lambda ( q p ) (< (distance p1 q) (distance p1 p))))))
415.       (setq lst (cons p2 lst))
416.       (setq pl (vl-remove p1 pl) pl (vl-remove p2 pl))
417.       (while pl
418.         (setq pp1 (car-sort pl (function (lambda ( q p ) (< (distance p1 q) (distance p1 p))))))
419.         (setq pp2 (car-sort pl (function (lambda ( q p ) (< (distance p2 q) (distance p2 p))))))
420.         (if (< (distance p1 pp1) (distance p2 pp2))
421.           (progn
422.             (setq lst (append lst (list pp1)))
423.             (setq pl (vl-remove pp1 pl))
424.             (setq p1 pp1)
425.           )
426.           (progn
427.             (setq lst (cons pp2 lst))
428.             (setq pl (vl-remove pp2 pl))
429.             (setq p2 pp2)
430.           )
431.         )
432.       )
433.       (if (chkinters-p lst)
434.         (setq lst (chkinters lst))
435.       )
436.       (entmake
437.         (list
438.           (cons 0 "POLYLINE")
439.           (cons 100 "AcDbEntity")
440.           (cons 100 "AcDb3dPolyline")
441.           (cons 66 1)
442.           (list 10 0.0 0.0 0.0)
443.           (cons 70 9)
444.           (list 210 0.0 0.0 1.0)
445.         )
446.       )
447.       (foreach pt lst
448.         (entmake
449.           (list
450.             (cons 0 "VERTEX")
451.             (cons 100 "AcDbEntity")
452.             (cons 100 "AcDbVertex")
453.             (cons 100 "AcDb3dPolylineVertex")
454.             (cons 10 pt)
455.             (cons 70 32)
456.           )
457.         )
458.       )
459.       (entmake
460.         (list
461.           (cons 0 "SEQEND")
462.           (cons 100 "AcDbEntity")
463.         )
464.       )
465.       (prompt "\nPath length : ") (princ (atof (ftoa (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) lst (cdr lst))))))
466.       (prompt "\nElapsed time : ") (princ (atof (ftoa (- (car (_vl-times)) ti)))) (prompt " milliseconds...")
467.     )
468.     (prompt "\nEmpty selection set... Better luck next time...")
469.   )
470.   (*error* nil)
471. )
472.  

Just for compare :

: TSP-3D-SPACE

Select 3d points, blocks or circles...
Select entities:all
Entities in set: 10000
Select entities:

Path length : 3726908.34978218
Elapsed time : 22659563.0 milliseconds...

https://www.theswamp.org/index.php?topic=30434.msg591329#msg591329

HTH.
M.R.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on December 30, 2022, 04:09:43 PM

This is for faster computing by using DOUBLE GREEDY and AHS:TSP algorithm...

So long from me for now...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on January 02, 2023, 03:08:46 PM

I need help in optimizing those 2 lisps attached here :
https://www.theswamp.org/index.php?topic=30434.msg610920#msg610920

I am afraid I can't quite get how record was beaten to be in shorter time difference...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on January 03, 2023, 11:54:43 AM

I've hardcoded some starting inputs and summarize 2D solution to just TSP.lsp file...
Please, do not choose more than 200 pts... For large amount of points 10000 - use TSP-3D-space.lsp posted previously...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on January 05, 2023, 10:14:36 AM

TSP.lsp is written, but I need help to make it work faster... Can someone with more experiences step in and try to investigate - perhaps create *.vlx, *.brx, *.arx, *.des, *.dll...
Not sure if Bricscad have NETLOAD command for *.dll (if someone convert successfully that TSP.lsp)...

[EDIT] : Yes Bricscad has implemented NETLOAD command... So C# and *.dll would be the most appropriate file after *.lsp I and others wrote... [/EDIT]

Thanks, M.R.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on January 08, 2023, 11:59:26 AM

@gile

Can you try to convert lastly posted TSP.lsp to some kind of faster routine (TSP.dll)... What can we do when it's so slooow...

Anyway, I programmed it and it works well for me, it's just that it don't quite meet expectation time difference after finish...

Regards, M.R.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on January 22, 2023, 01:39:21 PM

Quote from: ribarm on January 08, 2023, 11:59:26 AM

@gile

Can you try to convert lastly posted TSP.lsp to some kind of faster routine (TSP.dll)... What can we do when it's so slooow...

Anyway, I programmed it and it works well for me, it's just that it don't quite meet expectation time difference after finish...

Regards, M.R.

@Gilles
Are you OK?

@Daniel
OK?

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: It's Alive! on January 22, 2023, 06:16:23 PM

Can’t read lisp anymore, all I see is ilil ilil

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: It's Alive! on January 22, 2023, 10:06:11 PM

Here’s one to try

Code: [Select]

(vlce_cheapestpath Strategy Scale points)

Strategy
UNSET = 0; for the next add one, i'm too lazy
AUTOMATIC
PATH_CHEAPEST_ARC
PATH_MOST_CONSTRAINED_ARC
EVALUATOR_STRATEGY
SAVINGS
SWEEP
CHRISTOFIDES
ALL_UNPERFORMED
BEST_INSERTION
BEST_INSERTION
PARALLEL_CHEAPEST_INSERTION
SEQUENTIAL_CHEAPEST_INSERTION
LOCAL_CHEAPEST_INSERTION
LOCAL_CHEAPEST_COST_INSERTION
GLOBAL_CHEAPEST_ARC
LOCAL_CHEAPEST_ARC
FIRST_UNBOUND_MIN_VALUE

Scale = the library I used uses integers for distances, use the scale if working with small distances.

Points is your list of points, returns list pf points on success, otherwise your cpu will melt and bore a hole through the earth

ARX,BRX,GRX,ZRX... only tested with arx
 

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: It's Alive! on January 22, 2023, 10:10:47 PM

result from the original test

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: It's Alive! on January 22, 2023, 10:44:17 PM

added all the Strategies available in the library, some don't seem to work, most do

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: It's Alive! on January 22, 2023, 10:50:41 PM

this is what I used, I'll post the source later
https://developers.google.com/optimization/routing/tsp#circuit_solution_one

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: kdub_nz on January 23, 2023, 01:46:33 AM

Great link Dan !

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: It's Alive! on January 23, 2023, 02:56:17 AM

Quote from: kdub on January 23, 2023, 01:46:33 AM

Great link Dan !

Right? The library is HUGE, some of the static .libs are 200 megabytes. I’ll put the lisp wrapper source in a convenient area as I’m sure there’s other useful goodies in OR-Tools

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on January 23, 2023, 03:03:28 AM

Quote from: beck's bolero on January 22, 2023, 10:10:47 PM

result from the original test

Evgeniy's is : 3709.0141

http://www.theswamp.org/index.php?topic=30434.msg360448#msg360448

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on January 23, 2023, 03:08:41 AM

I suggest that you use this one (TSP-chlh-greedy-grid.lsp) : http://www.theswamp.org/index.php?topic=30434.msg612620#msg612620
, as it's very fast, but results are not always the best - there are no bigger permutation parameters like "depth" from TSP-A.lsp...

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: It's Alive! on January 23, 2023, 03:23:08 AM

Quote from: ribarm on January 23, 2023, 03:03:28 AM

Quote from: beck's bolero on January 22, 2023, 10:10:47 PM

result from the original test

Evgeniy's is : 3709.0141

http://www.theswamp.org/index.php?topic=30434.msg360448#msg360448

He’s an awesome programmer  :-o

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on January 23, 2023, 05:08:49 AM

Quote from: ribarm on January 23, 2023, 03:08:41 AM

I suggest that you use this one (TSP-chlh-greedy.lsp) : http://www.theswamp.org/index.php?topic=30434.msg612620#msg612620
, as it's very fast, but results are not always the best - there are no bigger permutation parameters like "depth" from TSP-A.lsp...

I forgot to say that grid like situations are solved in both TSP-A.lsp and TSP-chlh-greedy-grid.lsp... You can download them to see solution, if you're stuck like I see...

[EDIT]
I've found some lacks with GRID disposition situations - newly fixed *.lsp attached here :
https://www.theswamp.org/index.php?topic=58049.msg612855#msg612855
[/EDIT]

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: It's Alive! on January 23, 2023, 05:32:48 AM

The docs even talk about optimal vs performance, here’s one that’s shorter, but there’s a time penalty.
There’s one setting where you specify “find the best solution in a given amount of time”
FirstSolutionStrategy can probably handle 10,000 to 100,000 points in under a second
LocalSearchMetaheuristic you have to set a time limit.

This library is available to other languages, if there’s a better set of instructions found, I can add them here

Here’s a shorter one, I had to let it run for a few seconds.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: It's Alive! on January 23, 2023, 06:13:13 AM

Help me with names  :uglystupid2:

(vlce_cheapestpathfss Stratagy Scale Points); calls solveFirstSolutionStrategyLispFunc
(vlce_cheapestpathlsm Stratagy TimeLimitInSeconds Scale Points); solveLocalSearchMetaheuristicStrategy

(make-lwpolyline (vlce_cheapestpathlsm 4 1 1000 lst-a));  SIMULATED_ANNEALING , 1 second, scale… length 3714.7559

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: It's Alive! on January 23, 2023, 08:40:46 AM

posted the source and binaries here.. https://www.theswamp.org/index.php?topic=58049

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on January 28, 2023, 10:51:22 AM

Latest *.lsp from me, posted here : https://www.theswamp.org/index.php?topic=58049.msg612970#msg612970
or here : https://www.cadtutor.net/forum/files/file/42-tspzip-travelling-salesman-problem-autolisp/

HTH.
M.R.

Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ribarm on February 04, 2023, 04:12:02 PM

I strongly believe that we should avoid permutations, if it is possible... Key here is in function (fff), but it does nothing - preliminary sort through (generic) has already defined final shape of path, which is wrong... If we solve (fff) correctly, then that would be a solution...

M.R.