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

0 Members and 2 Guests are viewing this topic.

ElpanovEvgeniy

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

Lee Mac

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

VovKa

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

ElpanovEvgeniy

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

It's Alive!

  • Retired
  • Needs a day job
  • Posts: 8659
  • AKA Daniel
Re: (Challenge) To draw the shortest lwpolyline
« Reply #19 on: September 25, 2009, 01:13:05 PM »
I'm also getting the same result as Ron when I return the end point

ronjonp

  • Needs a day job
  • Posts: 7526
Re: (Challenge) To draw the shortest lwpolyline
« Reply #20 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.

Windows 11 x64 - AutoCAD /C3D 2023

Custom Build PC

Lee Mac

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

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1569
  • Moscow (Russia)

VovKa

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

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1569
  • Moscow (Russia)
Re: (Challenge) To draw the shortest lwpolyline
« Reply #24 on: September 26, 2009, 05:42:36 AM »
Has come to give time the first help...
Each self-crossing, increases length of a contour!


Lee Mac

  • Seagull
  • Posts: 12905
  • London, England
Re: (Challenge) To draw the shortest lwpolyline
« Reply #25 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))
« Last Edit: September 26, 2009, 08:51:44 AM by Lee Mac »

Lee Mac

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

ElpanovEvgeniy

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

Lee Mac

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