Author Topic: (Challenge) To draw the shortest lwpolyline  (Read 125130 times)

0 Members and 1 Guest are viewing this topic.

Lee Mac

  • Seagull
  • Posts: 12905
  • London, England
Re: (Challenge) To draw the shortest lwpolyline
« Reply #30 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.




Lee Mac

  • Seagull
  • Posts: 12905
  • London, England
Re: (Challenge) To draw the shortest lwpolyline
« Reply #31 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.



VovKa

  • Water Moccasin
  • Posts: 1626
  • Ukraine
Re: (Challenge) To draw the shortest lwpolyline
« Reply #32 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

Lee Mac

  • Seagull
  • Posts: 12905
  • London, England
Re: (Challenge) To draw the shortest lwpolyline
« Reply #33 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...

VovKa

  • Water Moccasin
  • Posts: 1626
  • Ukraine
Re: (Challenge) To draw the shortest lwpolyline
« Reply #34 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 :)

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1569
  • Moscow (Russia)
Re: (Challenge) To draw the shortest lwpolyline
« Reply #35 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...

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1569
  • Moscow (Russia)
Re: (Challenge) To draw the shortest lwpolyline
« Reply #36 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... :-)

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1569
  • Moscow (Russia)
Re: (Challenge) To draw the shortest lwpolyline
« Reply #37 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

Lee Mac

  • Seagull
  • Posts: 12905
  • London, England
Re: (Challenge) To draw the shortest lwpolyline
« Reply #38 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

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1569
  • Moscow (Russia)
Re: (Challenge) To draw the shortest lwpolyline
« Reply #39 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.

Lee Mac

  • Seagull
  • Posts: 12905
  • London, England
Re: (Challenge) To draw the shortest lwpolyline
« Reply #40 on: September 28, 2009, 06:41:21 AM »
Genius  :-)

Lee Mac

  • Seagull
  • Posts: 12905
  • London, England
Re: (Challenge) To draw the shortest lwpolyline
« Reply #41 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.
« Last Edit: March 02, 2010, 10:51:07 AM by Lee Mac »

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1569
  • Moscow (Russia)
Re: (Challenge) To draw the shortest lwpolyline
« Reply #42 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.

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1569
  • Moscow (Russia)
Re: (Challenge) To draw the shortest lwpolyline
« Reply #43 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.

Lee Mac

  • Seagull
  • Posts: 12905
  • London, England
Re: (Challenge) To draw the shortest lwpolyline
« Reply #44 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.