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
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: Lee Mac on September 25, 2009, 11:55:35 AM
Nice challenge Evgeniy - I doubt my code will be a match for you guru's but I'll happily take up the challenge  :evil:
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: Lee Mac on September 25, 2009, 12:27:45 PM
This probably isn't worth posting, but my first feeble attempt:

Code: [Select]
(defun mkPoly (lst / lst tmp ply)
  (setq tmp (car lst))

  (setq lst
    (mapcar
      (function
        (lambda (x)
          (cons 10 x)))
      (cons tmp
        (vl-sort (cdr lst)
          (function
            (lambda (a b)
              (< (distance tmp a)
                   (distance tmp b))))))))


  (setq ply
    (entmakex
      (append (list (cons 0 "LWPOLYLINE")
                    (cons 100 "AcDbEntity")
                    (cons 100 "AcDbPolyline")
                    (cons 90 (length lst))
                    (cons 70 1))
              lst)))

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

Code: [Select]
lst-a : Polyline Length: 18161.6874 mm.

lst-b : Polyline Length: 5383.8140 mm.

 
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
Hello Ron.
I liked your code!
My code, much more long...

Thanks ElpanovEvgeniy  :oops:
Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: It's Alive! on September 25, 2009, 12:54:04 PM
My code is slightly long

Code: [Select]
#pragma once
#include <set>
#include <vector>
#include <algorithm>

class CDPoint
{
public:
  double x,y,z,w;
  __forceinline CDPoint(void) : x(0.0),y(0.0),z(0.0),w(0.0){}

  __forceinline CDPoint(double X,double Y, double Z,double dist)
    : x(X),y(Y),z(Z),w(dist){}

  __forceinline CDPoint(const AcGePoint3d &p,double dist)
    : x(p.x),y(p.y),z(p.z),w(dist){}

   static bool byZ (const CDPoint &pt1, const CDPoint &pt2) {
    return (pt1.z > pt2.z);
  }
   double distanceTo(const CDPoint &pt) const
  {
    double dx = x - pt.x;
    double dy = y - pt.y;
    double dz = z - pt.z;
    return sqrt(dx*dx + dy*dy + dz*dz);
  }
   double distanceTo(const AcGePoint3d &pt) const
  {
    double dx = x - pt.x;
    double dy = y - pt.y;
    double dz = z - pt.z;
    return sqrt(dx*dx + dy*dy + dz*dz);
  }
   AcGePoint3d toPoint3d() const
  {
    return AcGePoint3d(x,y,z);
  }
  bool operator == (const CDPoint &pt) const{
    return (w == pt.w);
  }
  bool operator < (const CDPoint &pt) const{
    if(w == pt.w){ return ( z < pt.z); }
    return ( w > pt.w);
  }
};

typedef std::set<CDPoint> sDPoints;
typedef std::vector<CDPoint> vDPoints;
typedef std::vector<AcGeLine3d> vLines;

inline static void addPoint(sDPoints &points, const CDPoint &p)
{
  points.insert(p);
}

static void sortPoints(vDPoints &sPoints)
  {
    sort( sPoints.begin(), sPoints.end());
  }

  static void setPointDist(const AcGePoint3d &basePt, vDPoints &sPoints)
  {
    for(int i = 0; i < sPoints.size();i++)
    {
      sPoints[i].w = sPoints[i].distanceTo(basePt);
    }
  }

  static int fillPoints(vDPoints &sPoints)
  {
    int cnt = 0;
    AcDbDatabase *pDb = acdbHostApplicationServices()->workingDatabase();
    AcDbBlockTableRecord *pRec;
    if(acdbOpenAcDbObject((AcDbObject *&) pRec,
        pDb->currentSpaceId(), AcDb::kForRead) == Acad::eOk)
    {
      AcDbBlockTableRecordIterator *pIter;
      if(pRec->newIterator(pIter) == Acad::eOk) {
        for(pIter->start(); !pIter->done(); pIter->step()) {
          AcDbObjectId objId;
          AcDbEntity *pEnt;
          if(pIter->getEntity(pEnt, AcDb::kForRead) == Acad::eOk){
            AcDbPoint *pPoint = AcDbPoint::cast(pEnt);
            if(pPoint) {
              CDPoint p(pPoint->position(),0);
              sPoints.push_back(p);
              cnt++;
            }
            pEnt->close();
          }
        }
        delete pIter;
      }
      pRec->close();
    }
    return cnt;
  }

  static void ArxShortestPl_doit(void)
  {
    AcDbObjectId plid;
    vDPoints sPoints;
    vDPoints::const_iterator sIter;
    vLines lineVec;
    int cnt = fillPoints(sPoints);
    sortPoints(sPoints);

    if (cnt < 2)
      return;

    AcDbPolyline *pl = new AcDbPolyline(cnt);
    AcGePoint3d basePt(0.0,0.0,0.0);
    AcGePoint3d lastpt = basePt;
    for(int i = 0 ; i < cnt ; i++)
    {
      unsigned int last = sPoints.size() -1;
      setPointDist(basePt,sPoints);
      sortPoints(sPoints);
      lastpt = sPoints[last].toPoint3d();
      pl->addVertexAt(pl->numVerts(),AcGePoint2d(lastpt.x,lastpt.y));
      basePt = lastpt;
      sPoints.pop_back();
    }
    pl->setClosed(Adesk::kTrue);
    double dist,endparam;
    pl->getEndParam(endparam);
    pl->getDistAtParam(endparam,dist);
    acutPrintf(_T("Length = %g"), dist);
    AddEntityToDataBase(pl,plid);
  }

  static void
   AddEntityToDataBase(AcDbEntity *pEnt, AcDbObjectId &pOutputId,
                                         Adesk::UInt16 color = 7)
  {
    pOutputId = AcDbObjectId::kNull;
    AcDbDatabase* pDb = acdbHostApplicationServices()->workingDatabase();
    AcDbBlockTableRecordPointer pBTR(pDb->currentSpaceId(), AcDb::kForWrite);
    if (pEnt && Acad::eOk == pBTR.openStatus())
    {
      pEnt->setDatabaseDefaults();
      pEnt->setColorIndex(color);
      pBTR->appendAcDbEntity(pOutputId, pEnt);
      pEnt->close();
    }
  }
Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: ElpanovEvgeniy on September 25, 2009, 12:57:10 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
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
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
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
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
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
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
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
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


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
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
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
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.

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

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
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
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
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
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
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
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

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: Lee Mac on September 29, 2009, 05:34:54 PM
Quote
Where your variant?  :police:

Hehe cheeky  ^-^
Title: Re: (Challenge) To draw the shortest lwpolyline
Post by: VovKa on September 29, 2009, 06:06:54 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
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
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
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
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
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
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:
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
'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
'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 .
 
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
Daniel, chlh_jd's code is more accurate
Doh! crushed

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
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
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
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 (equal (cadr p1) (cadr p0) 1e-8) (< (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.    (append
  86.      (list
  87.        '(0 . "LWPOLYLINE")
  88.        '(100 . "AcDbEntity")
  89.        '(100 . "AcDbPolyline")
  90.        (cons 90 (length pln))
  91.        (cons 70 (1+ (* (getvar 'plinegen) 128)))
  92.        '(38 . 0.0)
  93.      )
  94.      (mapcar '(lambda ( x ) (cons 10 x)) pln)
  95.      (list
  96.        '(210 0.0 0.0 1.0)
  97.        '(62 . 1)
  98.      )
  99.    )
  100.  )
  101.  (prompt "\nDistance : ") (princ (rtos dmin 2 50))
  102.  (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds...")
  103.  (princ)
  104. )
  105.  

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 (equal (cadr p1) (cadr p0) 1e-8) (< (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.    (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...
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 (equal (cadr p1) (cadr p0) 1e-8) (< (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.    (append
  141.      (list
  142.        '(0 . "LWPOLYLINE")
  143.        '(100 . "AcDbEntity")
  144.        '(100 . "AcDbPolyline")
  145.        (cons 90 (length pln))
  146.        (cons 70 (1+ (* (getvar 'plinegen) 128)))
  147.        '(38 . 0.0)
  148.      )
  149.      (mapcar (function (lambda ( x ) (cons 10 x))) pln)
  150.      (list
  151.        '(210 0.0 0.0 1.0)
  152.        '(62 . 1)
  153.      )
  154.    )
  155.  )
  156.  (prompt "\nDistance : ") (princ (rtos d 2 50))
  157.  (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds...")
  158.  (princ)
  159. )
  160.  

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 (equal (cadr p1) (cadr p0) 1e-8) (< (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.    (append
  132.      (list
  133.        '(0 . "LWPOLYLINE")
  134.        '(100 . "AcDbEntity")
  135.        '(100 . "AcDbPolyline")
  136.        (cons 90 (length pln))
  137.        (cons 70 (1+ (* (getvar 'plinegen) 128)))
  138.        '(38 . 0.0)
  139.      )
  140.      (mapcar (function (lambda ( x ) (cons 10 x))) pln)
  141.      (list
  142.        '(210 0.0 0.0 1.0)
  143.        '(62 . 1)
  144.      )
  145.    )
  146.  )
  147.  (prompt "\nDistance : ") (princ (rtos d 2 50))
  148.  (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds...")
  149.  (princ)
  150. )
  151.  

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 (equal (cadr p1) (cadr p0) 1e-8) (< (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.  &#