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

0 Members and 1 Guest are viewing this topic.

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1535
  • Moscow (Russia)
Re: (Challenge) To draw the shortest lwpolyline
« Reply #30 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.
蝸牛そろそろ登れ富士の山 /Kobayashi Issa/

Lee Mac

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

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1535
  • Moscow (Russia)
Re: (Challenge) To draw the shortest lwpolyline
« Reply #32 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...
蝸牛そろそろ登れ富士の山 /Kobayashi Issa/

Lee Mac

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

  • Swamp Rat
  • Posts: 1045
  • Ukraine
Re: (Challenge) To draw the shortest lwpolyline
« Reply #35 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: 12109
  • London, England
Re: (Challenge) To draw the shortest lwpolyline
« Reply #36 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

  • Swamp Rat
  • Posts: 1045
  • Ukraine
Re: (Challenge) To draw the shortest lwpolyline
« Reply #37 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: 1535
  • Moscow (Russia)
Re: (Challenge) To draw the shortest lwpolyline
« Reply #38 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...
蝸牛そろそろ登れ富士の山 /Kobayashi Issa/

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1535
  • Moscow (Russia)
Re: (Challenge) To draw the shortest lwpolyline
« Reply #39 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... :-)
蝸牛そろそろ登れ富士の山 /Kobayashi Issa/

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1535
  • Moscow (Russia)
Re: (Challenge) To draw the shortest lwpolyline
« Reply #40 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
蝸牛そろそろ登れ富士の山 /Kobayashi Issa/

Lee Mac

  • Seagull
  • Posts: 12109
  • London, England
Re: (Challenge) To draw the shortest lwpolyline
« Reply #41 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: 1535
  • Moscow (Russia)
Re: (Challenge) To draw the shortest lwpolyline
« Reply #42 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.
蝸牛そろそろ登れ富士の山 /Kobayashi Issa/

Lee Mac

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

Lee Mac

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