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

0 Members and 1 Guest are viewing this topic.

ribarm

  • Water Moccasin
  • Posts: 2412
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #120 on: January 04, 2019, 04:59:41 AM »
Hi again, my latest revision... I returned back to slow but perhaps more reliable coding... Although its maximum is about 20 points for factor 2, that's also better than brute force... For 3, 4, ... don't even think you'll see the result - its computing large lists and may never finish... So I suggest default 1 and hope that result will be optimal as much as possible, if not then you are practically doomed like with brute force... I'll also input version for start-end in the topic by user @handasa - there is link for it when I compete with @nullptr - Daniel - I post it somewhere in the middle when it was started...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-2D-MR ( / LM:ConvexHull-ptsonHull LM:Clockwise-p car-sort plstdiff processrs ss ti i pl pln k plp pld pll d r rr ppp lil lii1 lii2 lil1 lil2 ip f kk n )
  2.  
  3.   ;; Convex Hull  -  Lee Mac
  4.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
  5.  
  6.   (defun LM:ConvexHull-ptsonHull ( lst / ch p0 lstl )
  7.       (cond
  8.           (   (< (length lst) 4) lst)
  9.           (   (setq p0 (car lst))
  10.               (foreach p1 (cdr lst)
  11.                   (if (or (< (cadr p1) (cadr p0))
  12.                           (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
  13.                       )
  14.                       (setq p0 p1)
  15.                   )
  16.               )
  17.               (setq lst (vl-remove p0 lst))
  18.               (setq lst (append (list p0) lst))
  19.               (setq lst
  20.                   (vl-sort lst
  21.                       (function
  22.                           (lambda ( a b / c d )
  23.                               (if (or (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8) (and (or (equal c 0.0 1e-8) (equal c (* 2 pi) 1e-8)) (or (equal d 0.0 1e-8) (equal d (* 2 pi) 1e-8))))
  24.                                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
  25.                                   (< c d)
  26.                               )
  27.                           )
  28.                       )
  29.                   )
  30.               )
  31.               (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  32.               (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  33.               (setq lstl (vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
  34.               (setq lst (append lst lstl))
  35.               (setq ch (list (cadr lst) (car lst)))
  36.               (foreach pt (cddr lst)
  37.                   (setq ch (cons pt ch))
  38.                   (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
  39.                       (setq ch (cons pt (cddr ch)))
  40.                   )
  41.               )
  42.               (reverse ch)
  43.           )
  44.       )
  45.   )
  46.  
  47.   ;; Clockwise-p  -  Lee Mac
  48.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
  49.  
  50.   (defun LM:Clockwise-p ( p1 p2 p3 )
  51.       (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
  52.               (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
  53.           )
  54.           0.0
  55.       )
  56.   )
  57.  
  58.   ;;; (car-sort '(2 4 1 3 5 1) '<) => nil
  59.   ;;; (car-sort '(2 4 1 3 5 1) '<=) => 1
  60.   (defun car-sort ( l f / removenth r k )
  61.  
  62.     (defun removenth ( l n / k )
  63.       (setq k -1)
  64.       (vl-remove-if (function (lambda ( x ) (= (setq k (1+ k)) n))) l)
  65.     )
  66.  
  67.     (setq k -1)
  68.     (vl-some (function (lambda ( a ) (setq k (1+ k)) (if (vl-every (function (lambda ( x ) (apply f (list a x)))) (removenth l k)) (setq r a)))) l)
  69.     r
  70.   )
  71.  
  72.   (defun plstdiff ( l1 l2 )
  73.     (foreach p l1
  74.       (setq l2 (vl-remove p l2))
  75.     )
  76.     l2
  77.   )
  78.  
  79.   (defun processrs ( r / rr )
  80.     (foreach xx r
  81.       (if (and (null f) (if (equal xx pln) (setq ppp pl) (setq ppp (plstdiff xx pl))))
  82.         (foreach p ppp
  83.           (setq k -1)
  84.           (repeat (length xx)
  85.             (setq k (1+ k))
  86.             (setq plp (reverse (member (nth k xx) (reverse xx))))
  87.             (setq pls (cdr (member (nth k xx) xx)))
  88.             (setq pll (append plp (list p) pls))
  89.             (setq rr (cons pll rr))
  90.           )
  91.         )
  92.         (setq f t)
  93.       )
  94.     )
  95.     (if f
  96.       (progn
  97.         (setq pl nil)
  98.         r
  99.       )
  100.       (if (= kk n)
  101.         (progn
  102.           (setq kk 0)
  103.           (setq rr (mapcar (function (lambda ( x ) (list (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) x (append (cdr x) (list (car x))))) x))) rr))
  104.           (setq rr (list (cadr (car-sort rr (function (lambda ( a b ) (<= (car a) (car b))))))))
  105.         )
  106.         rr
  107.       )
  108.     )
  109.   )
  110.  
  111.   (setq ss (ssget '((0 . "POINT"))))
  112.   (repeat (setq i (sslength ss))
  113.     (setq pl (cons (mapcar (function +) '(0 0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
  114.   )
  115.   (initget 6)
  116.   (setq n (getint "\nSpecify speed factor - reliability - [1-fast/2-slow] <1> : "))
  117.   (if (null n)
  118.     (setq n 1)
  119.   )
  120.   (setq ti (car (_vl-times)))
  121.   (setq pln (LM:ConvexHull-ptsonHull pl))
  122.   (foreach p pln
  123.     (setq pl (vl-remove p pl))
  124.   )
  125.   (setq kk 0)
  126.   (while pl
  127.     (setq kk (1+ kk))
  128.     (if (null rr)
  129.       (setq rr (processrs (list pln)))
  130.       (setq rr (processrs rr))
  131.     )
  132.   )
  133.   (setq rr (mapcar (function (lambda ( x ) (list (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) x (append (cdr x) (list (car x))))) x))) rr))
  134.   (setq pln (cadr (car-sort rr (function (lambda ( a b ) (<= (car a) (car b)))))))
  135.   (setq lil (mapcar (function (lambda ( a b ) (list a b))) pln (append (cdr pln) (list (car pln)))))
  136.   (while (vl-some (function (lambda ( li1 ) (vl-some (function (lambda ( li2 ) (if (and (setq ip (inters (car li1) (cadr li1) (car li2) (cadr li2))) (not (equal ip (car li1) 1e-8)) (not (equal ip (cadr li1) 1e-8)) (not (equal ip (car li2) 1e-8)) (not (equal ip (cadr li2) 1e-8))) (setq lii1 li1 lii2 li2)))) (vl-remove li1 lil)))) lil)
  137.     (setq lil1 (if (member lii2 (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil))))))) (reverse (cdr (member lii2 (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil))))))))) (reverse (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil)))))))))
  138.     (setq lil2 (if (member lii1 (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil))))))) (cdr (member lii1 (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil)))))))) (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil))))))))
  139.     (setq lil (append lil1 (list (list (cadr (last lil1)) (cadr (car lil2)))) (mapcar (function reverse) lil2) (list (list (car (last lil2)) (car (car lil1))))))
  140.   )
  141.   (setq pln (mapcar (function car) lil))
  142.   (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pln (append (cdr pln) (list (car pln))))))
  143.     (append
  144.       (list
  145.         '(0 . "LWPOLYLINE")
  146.         '(100 . "AcDbEntity")
  147.         '(100 . "AcDbPolyline")
  148.         (cons 90 (length pln))
  149.         (cons 70 (1+ (* (getvar 'plinegen) 128)))
  150.         '(38 . 0.0)
  151.       )
  152.       (mapcar (function (lambda ( x ) (cons 10 x))) pln)
  153.       (list
  154.         '(210 0.0 0.0 1.0)
  155.         '(62 . 1)
  156.       )
  157.     )
  158.   )
  159.   (prompt "\nDistance : ") (princ (rtos d 2 50))
  160.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds...")
  161.   (princ)
  162. )
  163.  

P.S. If you are lucky enough that your points almost all form shape of ConvexHull then it will be fast and reliable, but if not, then you'll have to wait and only hope for correct result... So this is actually my remark to remove doubts that TSP can be solved, but never give up... chlh_jd's code is fast and superior to my versions, but still not full reliable answer, I mean, so what if it can finish in 1 second, when you don't get correct result, you can get only close to correct...

Regards, happy New Year holidays...
M.R.
« Last Edit: June 19, 2019, 12:47:03 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

mailmaverick

  • Bull Frog
  • Posts: 465
Re: (Challenge) To draw the shortest lwpolyline
« Reply #121 on: March 26, 2019, 07:43:15 AM »
Hi All

Out of the various routines given by various people, which one is the latest / fastest / best ?

ribarm

  • Water Moccasin
  • Posts: 2412
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #122 on: March 26, 2019, 08:20:25 AM »
Hi All

Out of the various routines given by various people, which one is the latest / fastest / best ?

Hi, I am finally using CADSTUDIO's SHORTPATH.VLX with my additional LISP that calls it and then checks for intersecting lines with Evgeniy's method and prompts total length of path in 15 decimal places precision...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ronjonp

  • Needs a day job
  • Posts: 7198
Re: (Challenge) To draw the shortest lwpolyline
« Reply #123 on: March 26, 2019, 08:23:38 AM »
Hi All

Out of the various routines given by various people, which one is the latest / fastest / best ?
The latest is right before your post  :-P .. the solutions in here vary based on the length of the list being processed. You'll have to test to see what works for you.

Windows 10 x64 - AutoCAD /C3D 2020

Custom Build PC

ribarm

  • Water Moccasin
  • Posts: 2412
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #124 on: May 22, 2020, 03:17:16 PM »
Hi there...
Long time I haven't played with TSP...
I decided to post my latest version to see if someone will reply and give me any comments... For now it proved the most comprehensive for me... Only problem I see is that it's slow with minimal input options... For example if you use depth 1 and 1 solution attempt per depth iteration it is still very slow... The point now is that if you input depth smaller than maximum (number of free points inside convex hull), you can watch lwpolyline changing its shape until routine finishes task... So for speed computation and with best quality/speed I still recommend shortpath.vlx... This is only if you have specific task to do and you must be sure result is perfect - so you specify maximal input options (greatest depth allowed and all solution attempts <all> and then <100%> as percentage of attempts per depth iterations)... If you have more than 10 free points inside convex hull, you'll have to wait for a very long time, but if you have less than 10, then I suggest depending on PC that you input maximal values and still wait until it finishes... This is very complex problem and it requires very long computations, so just for fun and experimentation you may use this code, but at your own risk that you'll loose el. energy and time if PC is with low performances like my PC (old over 20 years)...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-2D-MR-LATEST-NEW ( / LM:ConvexHull-ptsonHull LM:Clockwise-p sort processpt depth _do-events cmde ss n m j i p ppp pl pll plll pllll lw lwx lil k ilil pre mid suf dmin d ti )
  2.  
  3.   ;; Convex Hull  -  Lee Mac
  4.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
  5.  
  6.   (defun LM:ConvexHull-ptsonHull ( lst / ch p0 lstl )
  7.     (cond
  8.       ( (< (length lst) 4) lst)
  9.       ( (setq p0 (car lst))
  10.         (foreach p1 (cdr lst)
  11.           (if (or (< (cadr p1) (cadr p0))
  12.                   (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
  13.               )
  14.               (setq p0 p1)
  15.           )
  16.         )
  17.         (setq lst (vl-remove p0 lst))
  18.         (setq lst (append (list p0) lst))
  19.         (setq lst
  20.           (vl-sort lst
  21.             (function
  22.               (lambda ( a b / c d )
  23.                 (if (or (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8) (and (or (equal c 0.0 1e-8) (equal c (* 2 pi) 1e-8)) (or (equal d 0.0 1e-8) (equal d (* 2 pi) 1e-8))))
  24.                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
  25.                   (< c d)
  26.                 )
  27.               )
  28.             )
  29.           )
  30.         )
  31.         (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  32.         (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  33.         (setq lstl (vl-sort lstl (function (lambda ( a b ) (> (distance p0 a) (distance p0 b))))))
  34.         (setq lst (append lst lstl))
  35.         (setq ch (list (cadr lst) (car lst)))
  36.         (foreach pt (cddr lst)
  37.           (setq ch (cons pt ch))
  38.           (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
  39.             (setq ch (cons pt (cddr ch)))
  40.           )
  41.         )
  42.         (reverse ch)
  43.       )
  44.     )
  45.   )
  46.  
  47.   ;; Clockwise-p  -  Lee Mac
  48.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
  49.  
  50.   (defun LM:Clockwise-p ( p1 p2 p3 )
  51.     (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
  52.             (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
  53.         )
  54.         0.0
  55.     )
  56.   )
  57.  
  58.   (defun sort ( l )
  59.     (vl-sort l (function (lambda ( a b ) (< (apply (function +) (mapcar (function (lambda ( c d ) (distance c d))) a (append (cdr a) (list (car a))))) (apply (function +) (mapcar (function (lambda ( c d ) (distance c d))) b (append (cdr b) (list (car b)))))))))
  60.   )
  61.  
  62.   (defun processpt ( ppp p j / ppl pll plll pllll )
  63.     (gc)
  64.     (if j
  65.       (progn
  66.         (foreach pp ppp
  67.           (setq ppl (append (member pp ppp) (reverse (cdr (member pp (reverse ppp))))))
  68.           (setq pll (append (list pp) (list p) (cdr ppl)))
  69.           (setq plll (cons pll plll))
  70.         )
  71.         (setq plll (sort plll))
  72.         (repeat j
  73.           (if (car plll)
  74.             (setq pllll (cons (car plll) pllll))
  75.           )
  76.           (setq plll (cdr plll))
  77.         )
  78.       )
  79.       (progn
  80.         (foreach pp ppp
  81.           (setq ppl (append (member pp ppp) (reverse (cdr (member pp (reverse ppp))))))
  82.           (setq pll (append (list pp) (list p) (cdr ppl)))
  83.           (setq plll (cons pll plll))
  84.         )
  85.         (setq pllll plll)
  86.       )
  87.     )
  88.     pllll
  89.   )
  90.  
  91.   (defun depth ( plll m / unique trimbynum trimbyperc ff plr pllll )
  92.  
  93.     (defun unique ( l / x ll f1 f2 )
  94.  
  95.       (defun f1 ( a b ) (equal a b 1e-6))
  96.  
  97.       (defun f2 ( y ) (vl-every (function f1) y (member (car y) x)))
  98.  
  99.       (gc)
  100.       (while (setq x (car l))
  101.         (setq ll (cons x ll)
  102.               x  (append x x)
  103.               l  (vl-remove-if (function f2) (cdr l))
  104.         )
  105.       )
  106.       ll
  107.     )
  108.  
  109.     (defun trimbynum ( l m / ll )
  110.       (if (< m (length l))
  111.         (progn
  112.           (repeat m
  113.             (setq ll (cons (car l) ll))
  114.             (setq l (cdr l))
  115.           )
  116.           (setq ll (reverse ll))
  117.         )
  118.         (setq ll l)
  119.       )
  120.       ll
  121.     )
  122.  
  123.     (defun trimbyperc ( l m / ll )
  124.       (if (< m 100)
  125.         (progn
  126.           (repeat (fix (* (length l) (/ m 100.0)))
  127.             (setq ll (cons (car l) ll))
  128.             (setq l (cdr l))
  129.           )
  130.           (setq ll (reverse ll))
  131.         )
  132.         (setq ll l)
  133.       )
  134.       ll
  135.     )
  136.  
  137.     (defun ff ( x )
  138.       (vl-position x lww)
  139.     )
  140.  
  141.     (if m
  142.       (progn
  143.         (setq plll (unique plll))
  144.         (if (= (type m) 'INT)
  145.           (foreach lww (trimbynum (if (< m (length plll)) (sort plll) plll) m)
  146.             (setq plr (vl-remove-if (function ff) pl))
  147.             (foreach p plr
  148.               (setq pllll (append (processpt lww p j) pllll))
  149.             )
  150.           )
  151.           (foreach lww (trimbyperc (if (< m 100) (sort plll) plll) m)
  152.             (setq plr (vl-remove-if (function ff) pl))
  153.             (foreach p plr
  154.               (setq pllll (append (processpt lww p j) pllll))
  155.             )
  156.           )
  157.         )
  158.       )
  159.       (foreach lww (unique plll)
  160.         (setq plr (vl-remove-if (function ff) pl))
  161.         (foreach p plr
  162.           (setq pllll (append (processpt lww p j) pllll))
  163.         )
  164.       )
  165.     )
  166.     pllll
  167.   )
  168.  
  169.   (defun _do-events nil
  170.     (gc)
  171.     (repeat 2 (vl-cmdf "_.DELAY" 0) (princ ""))
  172.   )
  173.  
  174.   (setq cmde (getvar 'cmdecho))
  175.   (setvar 'cmdecho 0)
  176.   (if
  177.     (and
  178.       (princ "\nSelect points, blocks or circles in WCS...")
  179.       (setq ss (ssget '((0 . "POINT,CIRCLE,INSERT"))))
  180.     )
  181.     (progn
  182.       (repeat (setq i (sslength ss))
  183.         (setq p (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))))
  184.         (setq pl (cons (mapcar (function +) '(0 0) p) pl))
  185.       )
  186.       (setq pll (LM:ConvexHull-ptsonHull pl))
  187.       (setq lw
  188.         (entmakex
  189.           (append
  190.             (list
  191.               '(0 . "LWPOLYLINE")
  192.               '(100 . "AcDbEntity")
  193.               '(100 . "AcDbPolyline")
  194.               (cons 90 (length pll))
  195.               (cons 70 (1+ (* 128 (getvar 'plinegen))))
  196.               '(38 . 0.0)
  197.             )
  198.             (mapcar (function (lambda ( x ) (cons 10 x))) pll)
  199.             '((210 0.0 0.0 1.0))
  200.           )
  201.         )
  202.       )
  203.       (setq lwx (entget lw))
  204.       (setq pl (vl-remove-if (function (lambda ( x ) (vl-position x pll))) pl))
  205.       (initget 6)
  206.       (setq n (getint (strcat "\nSpecify depth number - positive integer - from 1 to " (itoa (length pl)) " - preferable 3 <" (itoa (length pl)) "> : ")))
  207.       (if (null n)
  208.         (setq n (length pl))
  209.       )
  210.       (while (> n (length pl))
  211.         (prompt "\nYou specified number greater than : ") (princ (length pl))
  212.         (initget 6)
  213.         (setq n (getint (strcat "\nSpecify depth number - positive integer - from 1 to " (itoa (length pl)) " - preferable 3 <" (itoa (length pl)) "> : ")))
  214.         (if (null n)
  215.           (setq n (length pl))
  216.         )
  217.       )
  218.       (if (/= n (length pl))
  219.         (progn
  220.           (initget 4)
  221.           (setq i (getreal "\nIncremental depth - preferable 0 <1> - you can specify 1.5, 0.5, 0.33333334, 0.25 : "))
  222.           (if (null i)
  223.             (setq i 1)
  224.           )
  225.           (while (or (and (minusp (- (length pl) n n)) (> i 0)) (> i (- (length pl) n n) 0))
  226.             (prompt "\nYou specified number greater than : ") (if (minusp (- (length pl) n n)) (prompt "0 - you must specify \"0\"") (princ (- (length pl) n n)))
  227.             (initget 4)
  228.             (setq i (getreal "\nIncremental depth - preferable 0 <1> - you can specify 1.5, 0.5, 0.33333334, 0.25 : "))
  229.             (if (null i)
  230.               (setq i 1)
  231.             )
  232.           )
  233.         )
  234.       )
  235.       (initget 6)
  236.       (setq m (getint (strcat "\nSpecify number of solution attempts per depth iteration - preferable " (itoa (fix (/ 1600.0 (length pl)))) " <all> : ")))
  237.       (if (null m)
  238.         (progn
  239.           (initget 6)
  240.           (setq m (getreal "\nSpecify percentage of solution attempts per depth iteration <100%> : "))
  241.           (while (and m (> m 100))
  242.             (prompt "\nYou specified number greater than 100...")
  243.             (initget 6)
  244.             (setq m (getreal "\nSpecify percentage of solution attempts per depth iteration <100%> : "))
  245.           )
  246.         )
  247.       )
  248.       (initget 6)
  249.       (setq j (getint "\nSpecify number of list length processed by (processpt) sub function - preferable 2 <all> : "))
  250.       (setq ti (car (_vl-times)))
  251.       (setq ppp pll)
  252.       (while pl
  253.         (if (not (equal ppp pll))
  254.           (setq n (+ n i))
  255.         )
  256.         (foreach p pl
  257.           (setq plll (append (processpt ppp p j) plll))
  258.         )
  259.         (setq pllll plll)
  260.         (repeat (if (<= (fix n) (length pl)) (1- (fix n)) (1- (length pl)))
  261.           (setq pllll (depth pllll m))
  262.         )
  263.         (setq dmin 1e+308)
  264.         (foreach xxx pllll
  265.           (if (and xxx (< (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) xxx (append (cdr xxx) (list (car xxx)))))) dmin))
  266.             (setq dmin d pllll xxx)
  267.           )
  268.         )
  269.         (entupd
  270.           (cdr
  271.             (assoc -1
  272.               (entmod
  273.                 (setq lwx
  274.                   (append
  275.                     (subst (cons 90 (length pllll)) (assoc 90 lwx) (reverse (cdr (member (assoc 10 lwx) (reverse lwx)))))
  276.                     (mapcar (function (lambda ( x ) (cons 10 x))) pllll)
  277.                   )
  278.                 )
  279.               )
  280.             )
  281.           )
  282.         )
  283.         (setq pl (vl-remove-if (function (lambda ( x ) (vl-position x pllll))) pl))
  284.         (setq ppp pllll)
  285.         (_do-events)
  286.         (redraw lw)
  287.         (setq plll nil pllll nil)
  288.       )
  289.       (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) lwx)))
  290.       (setq lil (mapcar (function list) pl (append (cdr pl) (list (car pl)))))
  291.       (setq k -1)
  292.       (while (and (< (setq k (1+ k)) (length lil)) (setq a (nth k lil)))
  293.         (setq ilil (vl-some (function (lambda ( b / ip ) (setq ip (inters (car a) (cadr a) (car b) (cadr b))) (if (and ip (setq ip (mapcar (function +) '(0 0) ip)) (or (and (or (equal ip (car a) 1e-6) (equal ip (cadr a) 1e-6)) (not (equal ip (car b) 1e-6)) (not (equal ip (cadr b) 1e-6))) (and (or (equal ip (car b) 1e-6) (equal ip (cadr b) 1e-6)) (not (equal ip (car a) 1e-6)) (not (equal ip (cadr a) 1e-6))) (and (not (equal ip (car a) 1e-6)) (not (equal ip (cadr a) 1e-6)) (not (equal ip (car b) 1e-6)) (not (equal ip (cadr b) 1e-6))))) (list a b)))) (vl-remove a lil)))
  294.         (if ilil
  295.           (progn
  296.             (setq pre (reverse (cdr (member (car ilil) (reverse lil)))))
  297.             (setq mid (cdr (member (car ilil) lil)))
  298.             (setq mid (cdr (member (cadr ilil) (reverse mid))))
  299.             (setq mid (mapcar (function reverse) mid))
  300.             (setq suf (cdr (member (cadr ilil) lil)))
  301.             (setq lil (append pre (list (list (car (car ilil)) (car (cadr ilil)))) mid (list (list (cadr (car ilil)) (cadr (cadr ilil)))) suf))
  302.             (setq pre nil mid nil suf nil)
  303.             (setq pl (mapcar (function car) lil))
  304.             (entupd
  305.               (cdr
  306.                 (assoc -1
  307.                   (entmod
  308.                     (append
  309.                       (reverse (cdr (member (assoc 10 lwx) (reverse lwx))))
  310.                       (mapcar (function (lambda ( x ) (cons 10 x))) pl)
  311.                     )
  312.                   )
  313.                 )
  314.               )
  315.             )
  316.             (_do-events)
  317.             (redraw lw)
  318.             (setq ilil nil k -1)
  319.           )
  320.         )
  321.       )
  322.     )
  323.   )
  324.   (setvar 'cmdecho cmde)
  325.   (prompt "\nDistance : ") (princ (rtos (apply (function +) (mapcar (function distance) pl (append (cdr pl) (list (car pl))))) 2 20))
  326.   (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
  327.   (princ)
  328. )
  329.  

Stay well and be healthy my friends...
M.R.
 :-) :wink:
« Last Edit: June 24, 2020, 10:03:40 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2412
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #125 on: May 26, 2020, 07:39:03 AM »
I see there is no comment for my code...
Just a thought, wouldn't be nice if someone would convert LISP into some faster language... I mean - this is TSP problem, so it needs boosting in speed of calculations... However I am not educated in other than LISP... Maybe if Daniel could see it, or Gilles (.NET)... But I need it for A2018, so maybe I am old with my wishes, but that's the problem with other languages (ObjectARX, C#, ... )... It would be the best if it could work faster than LISP, but compatible with all AutoCAD releases...

This is just my thought, no one replied, so I had to step in again...
Thanks for attention, M.R.

[EDIT : If someone succeds to translate LISP, just don't give some stupid command names for execution like : "DOIT", "TEST", ... It would be nice something like : "TSP-2D-LSP-CONVERTED" or similar...]
« Last Edit: May 26, 2020, 07:59:04 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

VovKa

  • Swamp Rat
  • Posts: 1280
  • Ukraine
Re: (Challenge) To draw the shortest lwpolyline
« Reply #126 on: May 26, 2020, 08:16:34 AM »
I see there is no comment for my code...
because the code is long and rather difficult to read and understand

i'm pretty sure it could be optimized more
at least some simple things as
Code: [Select]
(setq mid (reverse (cdr (member (cadr ilil) (reverse mid)))))
(setq mid (reverse mid))

ribarm

  • Water Moccasin
  • Posts: 2412
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #127 on: May 26, 2020, 11:29:10 AM »
i'm pretty sure it could be optimized more
at least some simple things as
Code: [Select]
(setq mid (reverse (cdr (member (cadr ilil) (reverse mid)))))
(setq mid (reverse mid))

I see...
So instead of those 2 lines, just replace them in my code (lastly portion - lines 298 and 299) with :
Code: [Select]
(setq mid (cdr (member (cadr ilil) (reverse mid))))

But this is really nothing in overall performance... I mean that we need boost in speed with *.arx or maybe *.dll that will replicate functionality of above posted LISP...

Thanks for reply, anyway...
[EDIT : Corrected my above posted code...]
« Last Edit: June 17, 2020, 07:51:21 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2412
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #128 on: May 26, 2020, 04:57:12 PM »
Just to inform...

I've changed (processpt) sub function to be more efficient... To me the code looks now without evident lacks and ready for further process of translating/converting into faster programming language...

Regards...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2412
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #129 on: May 28, 2020, 09:59:30 AM »
I have a problem LISP crashed in BricsCAD with this message :

Code: [Select]
; ----- LISP : Call Stack -----
; [0]...C:TSP-2D-MR-LATEST-NEW
; [1].....DEPTH
; [2].......UNIQUE # 1108 <<--
;
; ----- Error around expression -----
; (EQUAL A B 1.0e-06)
;
; error : out of LISP 'Heap' memory at [gc]

Then I've changed this portion :

Code - Auto/Visual Lisp: [Select]
  1. ...
  2.   (defun depth ( plll m / unique sort trimbynum trimbyperc plr pllll )
  3.  
  4.     (defun unique ( l )
  5.       (gc)
  6.       (if l (cons (car l) (unique (vl-remove-if (function (lambda ( x ) (vl-every (function (lambda ( a b ) (equal a b 1e-6))) x (member (car x) (append (car l) (car l)))))) l))))
  7.     )
  8. ...
  9.  

As you can see I've added (gc) in recursive sub function...
But still I run it and it crashes at about the same place with this error message :

Code: [Select]
: TSP-2D-MR-LATEST-NEW

Select points, blocks or circles in WCS...
Select entities:
Opposite Corner:
Entities in set: 40
Select entities:
Specify depth number - positive integer - from 0 to 32 <32> :
Specify number of solution attempts per depth iteration - preferable 50 <all> : 100
Specify number of list length processed by (processpt) sub function - preferable 2 <all> : 4

; ----- LISP : Call Stack -----
; [0]...C:TSP-2D-MR-LATEST-NEW
; [1].....DEPTH
; [2].......UNIQUE # 1130 <<--
;
; ----- Error around expression -----
; (CAR L)
;
; error : out of LISP 'Heap' memory at [gc]

So how can I fix it?
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2412
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #130 on: May 28, 2020, 10:13:13 AM »
Sorry it was my mistake, I forgot to owerwrite correct LISP which has (gc) added with old one which was loaded...
I am testing it again, we'll see how will it go...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2412
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #131 on: May 28, 2020, 10:31:36 AM »
No it won't pass...
Now I have this :

Code: [Select]
: TSP-2D-MR-LATEST-NEW

Select points, blocks or circles in WCS...
Select entities:
Opposite Corner:
Entities in set: 40
Select entities:
Specify depth number - positive integer - from 0 to 32 <32> :
Specify number of solution attempts per depth iteration - preferable 50 <all> : 100
Specify number of list length processed by (processpt) sub function - preferable 2 <all> : 4

; ----- LISP : Call Stack -----
; [0]...C:TSP-2D-MR-LATEST-NEW
; [1].....DEPTH
; [2].......UNIQUE # 897 <<--
;
; ----- Error around expression -----
; (GC)
;
; error : out of LISP 'Heap' memory at [gc]

Can someone fix it?
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2412
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #132 on: May 28, 2020, 01:43:53 PM »
It worked and in BricsCAD with those inputs... It looks like BricsCAD don't like recursions... So I've replaced (unique) with iterative version and it worked well...

Code - Auto/Visual Lisp: [Select]
  1. ...
  2.   (defun depth ( plll m / unique sort trimbynum trimbyperc plr pllll )
  3.  
  4.     (defun unique ( l / x ll )
  5.       (while (setq x (car l))
  6.         (setq ll (cons x ll))
  7.         (setq l (vl-remove-if (function (lambda ( y ) (vl-every (function (lambda ( a b ) (equal a b 1e-6))) y (member (car y) (append x x))))) l))
  8.       )
  9.       ll
  10.     )
  11. ...
  12.  

Regards, M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

VovKa

  • Swamp Rat
  • Posts: 1280
  • Ukraine
Re: (Challenge) To draw the shortest lwpolyline
« Reply #133 on: May 28, 2020, 07:40:27 PM »
But this is really nothing in overall performance...
this is true
but the devil is in the detail
i think you should spend more time on optimizing
Code: [Select]
(defun unique3 (l / x ll f1 f2)
  (defun f1 (a b) (equal a b 1e-6))
  (defun f2 (y) (vl-every 'f1 y (member (car y) x)))
  (while (setq x (car l))
    (setq ll (cons x ll)
  x  (append x x)
  l  (vl-remove-if 'f2 (cdr l))
    )
  )
  ll
)
your algorithm is unchanged but it is written in a more 'optimized' way
and i believe it will run a bit faster

ribarm

  • Water Moccasin
  • Posts: 2412
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #134 on: May 29, 2020, 01:16:24 AM »
But those are minimal improvements...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:test ( / l t0 t1 k f )
  2.   (repeat 10
  3.     (setq l (append l (atoms-family 1)))
  4.   )
  5.   (setq t0 (car (_vl-times)))
  6.   (foreach a l
  7.     (princ "")
  8.   )
  9.   (setq t1 (car (_vl-times)))
  10.   (prompt "\nElapsed time for (foreach a l) : ") (princ (rtos (- t1 t0) 2 20)) (prompt " milliseconds...")
  11.   (setq t0 (car (_vl-times)))
  12.   (while (setq a (car l))
  13.     (princ "")
  14.     (setq l (cdr l))
  15.   )
  16.   (setq t1 (car (_vl-times)))
  17.   (prompt "\nElapsed time for (while (setq a (car l))) : ") (princ (rtos (- t1 t0) 2 20)) (prompt " milliseconds...")
  18.   (repeat 10
  19.     (setq l (append l (atoms-family 1)))
  20.   )
  21.   (setq k -1)
  22.   (setq t0 (car (_vl-times)))
  23.   (while (and (setq k (1+ k)) (< k (length l)) (setq a (nth k l)))
  24.     (princ "")
  25.   )
  26.   (setq t1 (car (_vl-times)))
  27.   (prompt "\nElapsed time for (while (and (setq k (1+ k)) (< k (length l)) (setq a (nth k l)))) : ") (princ (rtos (- t1 t0) 2 20)) (prompt " milliseconds...")
  28.   (setq t0 (car (_vl-times)))
  29.   (mapcar (function (lambda ( x ) (princ ""))) l)
  30.   (setq t1 (car (_vl-times)))
  31.   (prompt "\nElapsed time for (mapcar (function (lambda ( x ) (princ \"\"))) l) : ") (princ (rtos (- t1 t0) 2 20)) (prompt " milliseconds...")
  32.   (setq t0 (car (_vl-times)))
  33.   (defun f ( x ) (princ ""))
  34.   (mapcar (function f) l)
  35.   (setq t1 (car (_vl-times)))
  36.   (prompt "\nElapsed time for (mapcar (function f) l) : ") (princ (rtos (- t1 t0) 2 20)) (prompt " milliseconds...")
  37.   (princ)
  38. )
  39.  
  40. ;;; On BricsCAD
  41. ;|
  42. : TEST
  43.  
  44. Elapsed time for (foreach a l) : 2187 milliseconds...
  45. Elapsed time for (while (setq a (car l))) : 2312 milliseconds...
  46. Elapsed time for (while (and (setq k (1+ k)) (< k (length l)) (setq a (nth k l)))) : 8219 milliseconds...
  47. Elapsed time for (mapcar (function (lambda ( x ) (princ ""))) l) : 2235 milliseconds...
  48. Elapsed time for (mapcar (function f) l) : 2219 milliseconds...
  49. |;
  50.  
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube