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

0 Members and 2 Guests are viewing this topic.

Lee Mac

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

ElpanovEvgeniy

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

VovKa

  • Swamp Rat
  • Posts: 1282
  • Ukraine
Re: (Challenge) To draw the shortest lwpolyline
« Reply #62 on: September 28, 2009, 02:35:13 PM »
Evgeniy, as Lee've already guessed it is (vlax-put 'Coordinates ...) that issues the error.

Lee Mac

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

VovKa

  • Swamp Rat
  • Posts: 1282
  • Ukraine
Re: (Challenge) To draw the shortest lwpolyline
« Reply #64 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 :)

Lee Mac

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

ElpanovEvgeniy

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

VovKa

  • Swamp Rat
  • Posts: 1282
  • Ukraine
Re: (Challenge) To draw the shortest lwpolyline
« Reply #67 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

ElpanovEvgeniy

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

Lee Mac

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


ElpanovEvgeniy

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

ElpanovEvgeniy

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

VovKa

  • Swamp Rat
  • Posts: 1282
  • Ukraine
Re: (Challenge) To draw the shortest lwpolyline
« Reply #72 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

ElpanovEvgeniy

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

ElpanovEvgeniy

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