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

0 Members and 1 Guest are viewing this topic.

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1542
  • Moscow (Russia)
Re: (Challenge) To draw the shortest lwpolyline
« Reply #15 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.
Stay home. Stay safe. Save lives.

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1542
  • Moscow (Russia)
Re: (Challenge) To draw the shortest lwpolyline
« Reply #16 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!
Stay home. Stay safe. Save lives.

Lee Mac

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

  • Swamp Rat
  • Posts: 1274
  • Ukraine
Re: (Challenge) To draw the shortest lwpolyline
« Reply #18 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: 1542
  • Moscow (Russia)
Re: (Challenge) To draw the shortest lwpolyline
« Reply #19 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
Stay home. Stay safe. Save lives.

It's Alive!

  • BricsCAD
  • Needs a day job
  • Posts: 7045
  • AKA Daniel
Re: (Challenge) To draw the shortest lwpolyline
« Reply #20 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: 7185
Re: (Challenge) To draw the shortest lwpolyline
« Reply #21 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 10 x64 - AutoCAD /C3D 2020

Custom Build PC

Lee Mac

  • Seagull
  • Posts: 12397
  • London, England
Re: (Challenge) To draw the shortest lwpolyline
« Reply #22 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: 1542
  • Moscow (Russia)
Stay home. Stay safe. Save lives.

VovKa

  • Swamp Rat
  • Posts: 1274
  • Ukraine
Re: (Challenge) To draw the shortest lwpolyline
« Reply #24 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: 1542
  • Moscow (Russia)
Re: (Challenge) To draw the shortest lwpolyline
« Reply #25 on: September 26, 2009, 05:42:36 AM »
Has come to give time the first help...
Each self-crossing, increases length of a contour!

Stay home. Stay safe. Save lives.

Lee Mac

  • Seagull
  • Posts: 12397
  • London, England
Re: (Challenge) To draw the shortest lwpolyline
« Reply #26 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: 12397
  • London, England
Re: (Challenge) To draw the shortest lwpolyline
« Reply #27 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: 1542
  • Moscow (Russia)
Re: (Challenge) To draw the shortest lwpolyline
« Reply #28 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.
Stay home. Stay safe. Save lives.

Lee Mac

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