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

0 Members and 1 Guest are viewing this topic.

ribarm

  • Water Moccasin
  • Posts: 2401
  • Marko Ribar, architect
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2401
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #166 on: October 07, 2020, 02:01:34 PM »
Here is my fastest short general solution... So for those that can't wait and in pure ALisp - no VLisp...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-FAST ( / foo f1 ins-lst get-closest-i get-closedpolygon-length car-sort chkinters LM:ConvexHull-ptsonHull LM:Clockwise-p greedy unique generic ss ch ti i pl pl1 pl2 pl3 pl4 )
  2.  
  3.   (defun foo ( l / d d0 d1 )
  4.     (setq l0 (mapcar (function list) (cons (last l) l) l))
  5.     (setq d0 (get-closedpolygon-length l))
  6.     (while
  7.       (> d0
  8.         (progn
  9.           (foreach a l0
  10.             (setq d (get-closedpolygon-length l))
  11.             (setq l1 (vl-remove (car a) (vl-remove (cadr a) l)))
  12.             (setq l1 (f1 (car a) l1))
  13.             (setq l1 (f1 (cadr a) l1))
  14.             (if (> d (setq d1 (get-closedpolygon-length l1)))
  15.               (setq d d1
  16.                     l l1
  17.               )
  18.             )
  19.             (setq l1 (vl-remove (car a) (vl-remove (cadr a) l)))
  20.             (setq l1 (f1 (cadr a) l1))
  21.             (setq l1 (f1 (car a) l1))
  22.             (if (> d (setq d1 (get-closedpolygon-length l1)))
  23.               (setq d d1
  24.                     l l1
  25.               )
  26.             )
  27.           )
  28.           d
  29.         )
  30.       )
  31.       (setq d0 d)
  32.     )  
  33.     (setq d (get-closedpolygon-length l))  
  34.     l
  35.   )
  36.  
  37.   (defun f1 ( a l )
  38.     (ins-lst a (get-closest-i l a) l)
  39.   )
  40.  
  41.   (defun ins-lst ( new i lst / len fst )
  42.     (setq len (length lst))
  43.     (cond
  44.       ( (= i 0)
  45.         (cons new lst)
  46.       )
  47.       ( (> i (/ len 2))
  48.         (reverse (ins-lst new (- len i) (reverse lst)))
  49.       )
  50.       ( t
  51.         (append
  52.           (progn
  53.             (setq fst nil)
  54.             (repeat (rem i 4)
  55.               (setq fst (cons (car lst) fst)
  56.                     lst (cdr lst)
  57.               )
  58.             )
  59.             (repeat (/ i 4)
  60.               (setq fst
  61.                 (cons (cadddr lst)
  62.                   (cons (caddr lst)
  63.                     (cons (cadr lst)
  64.                       (cons (car lst)
  65.                             fst
  66.                       )
  67.                     )
  68.                   )
  69.                 )
  70.                 lst (cddddr lst)
  71.               )
  72.             )
  73.             (reverse fst)
  74.           )
  75.           (list new)
  76.           lst
  77.         )
  78.       )
  79.     )
  80.   )
  81.  
  82.   (defun get-closest-i ( lst p )
  83.     (car
  84.       (vl-sort-i
  85.         (mapcar
  86.           (function
  87.             (lambda ( p1 p2 / pt d d1 d2 )
  88.               (setq pt (inters p (polar p (+ (/ pi 2.0) (angle p1 p2)) 1.0) p1 p2 nil)
  89.                     d  (distance p1 p2)
  90.                     d1 (distance p p1)
  91.                     d2 (distance p p2)
  92.               )
  93.               (if pt
  94.                 (if (equal (+ (distance pt p1) (distance pt p2)) d 1e-8)
  95.                   (distance p pt)
  96.                   d2
  97.                 )
  98.                 1e+99
  99.               )
  100.             )
  101.           )
  102.           (cons (last lst) lst)
  103.           lst
  104.         )
  105.         (function <)
  106.       )
  107.     )
  108.   )
  109.  
  110.   (defun get-closedpolygon-length ( l )
  111.     (apply (function +) (mapcar (function distance) (cons (last l) l) l))
  112.   )
  113.  
  114.   (defun car-sort ( lst cmp / rtn )
  115.     (setq rtn (car lst))
  116.     (foreach itm (cdr lst)
  117.       (if (apply cmp (list itm rtn))
  118.         (setq rtn itm)
  119.       )
  120.     )
  121.     rtn
  122.   )
  123.  
  124.   (defun chkinters ( pl / lil k a ilil pre mid suf )
  125.     (setq lil (mapcar (function list) pl (append (cdr pl) (list (car pl)))))
  126.     (setq k -1)
  127.     (while (and (< (setq k (1+ k)) (length lil)) (setq a (nth k lil)))
  128.       (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)))
  129.       (if ilil
  130.         (progn
  131.           (setq pre (reverse (cdr (member (car ilil) (reverse lil)))))
  132.           (setq mid (cdr (member (car ilil) lil)))
  133.           (setq mid (cdr (member (cadr ilil) (reverse mid))))
  134.           (setq mid (mapcar (function reverse) mid))
  135.           (setq suf (cdr (member (cadr ilil) lil)))
  136.           (setq lil (append pre (list (list (car (car ilil)) (car (cadr ilil)))) mid (list (list (cadr (car ilil)) (cadr (cadr ilil)))) suf))
  137.           (setq pre nil mid nil suf nil)
  138.           (setq ilil nil k -1)
  139.         )
  140.       )
  141.     )
  142.     (mapcar (function car) lil)
  143.   )
  144.  
  145.   ;; Convex Hull  -  Lee Mac
  146.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
  147.  
  148.   (defun LM:ConvexHull-ptsonHull ( lst / ch p0 lstl )
  149.       (cond
  150.           (   (< (length lst) 4) lst)
  151.           (   (setq p0 (car lst))
  152.               (foreach p1 (cdr lst)
  153.                   (if (or (< (cadr p1) (cadr p0))
  154.                           (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
  155.                       )
  156.                       (setq p0 p1)
  157.                   )
  158.               )
  159.               (setq lst (vl-remove p0 lst))
  160.               (setq lst (append (list p0) lst))
  161.               (setq lst
  162.                   (vl-sort lst
  163.                       (function
  164.                           (lambda ( a b / c d )
  165.                               (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))))
  166.                                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
  167.                                   (< c d)
  168.                               )
  169.                           )
  170.                       )
  171.                   )
  172.               )
  173.               (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  174.               (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  175.               (setq lstl (vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
  176.               (setq lst (append lst lstl))
  177.               (setq ch (list (cadr lst) (car lst)))
  178.               (foreach pt (cddr lst)
  179.                   (setq ch (cons pt ch))
  180.                   (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
  181.                       (setq ch (cons pt (cddr ch)))
  182.                   )
  183.               )
  184.               (reverse ch)
  185.           )
  186.       )
  187.   )
  188.  
  189.   ;; Clockwise-p  -  Lee Mac
  190.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
  191.  
  192.   (defun LM:Clockwise-p ( p1 p2 p3 )
  193.       (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
  194.               (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
  195.           )
  196.           0.0
  197.       )
  198.   )
  199.  
  200.   (defun greedy ( l / a b bb d1 d2 a1 a2 e ll p pl an f )
  201.     (setq l (vl-sort l (function (lambda ( a b ) (if (equal (car a) (car b) 1e-6) (< (cadr a) (cadr b)) (< (car a) (car b)))))))
  202.     (setq ll (last l))
  203.     (setq an 0.0)
  204.     (setq p  (car l)
  205.           pl (list p)
  206.           l  (cdr l)
  207.     )
  208.     (while l
  209.       (setq l (vl-sort l (function (lambda ( a b ) (< (distance p a) (distance p b))))))
  210.       (setq a1 (car l) a2 (cadr l))
  211.       (setq d1 (distance p a1) d2 (if a2 (distance p a2)))
  212.       (if (and d2 (equal d1 d2 1e-6))
  213.         (if (and an (or (equal (angle p a1) an 1e-6) (equal (angle p a1) (rem (+ pi an) (+ pi pi)) 1e-6) (if (or (equal an 0.0 1e-6) (equal an (* 2 pi) 1e-6)) (equal (angle p a1) (* 2 pi) 1e-6))))
  214.           (setq a a1)
  215.           (setq a a2)
  216.         )
  217.         (setq a a1)
  218.       )
  219.       (if (and an (or (equal (angle p a) an 1e-6) (equal (angle p a) (rem (+ pi an) (+ pi pi)) 1e-6) (if (or (equal an 0.0 1e-6) (equal an (* 2 pi) 1e-6)) (equal (angle p a) (* 2 pi) 1e-6))))
  220.         (setq bb a)
  221.         (setq b a)
  222.       )
  223.       (if bb
  224.         (setq b bb)
  225.       )
  226.       (cond
  227.         ( (equal a1 ll 1e-6)
  228.           (setq a a1 b a an (* 0.5 pi) f t)
  229.         )
  230.         ( (equal a2 ll 1e-6)
  231.           (setq a a2 b a an (* 0.5 pi) f t)
  232.         )
  233.       )
  234.       (setq pl (cons b pl)
  235.             l  (vl-remove b l)
  236.             p  b
  237.             b  nil
  238.             bb nil
  239.       )
  240.       (if f
  241.         (cond
  242.           ( (= an 0.0)
  243.             (setq an (* 0.5 pi))
  244.           )
  245.           ( t
  246.             (setq an 0.0)
  247.           )
  248.         )
  249.         (cond
  250.           ( (and (= an 0.0) (equal (car p) (car ll) 1e-6))
  251.             (setq an (* 0.5 pi))
  252.           )
  253.           ( (and (= an (* 0.5 pi)) (equal (cadr p) (cadr ll) 1e-6))
  254.             (setq an 0.0)
  255.           )
  256.           ( (and (= an (* 0.5 pi)) (equal (car p) (car ll) 1e-6))
  257.             (setq an 0.0)
  258.           )
  259.           ( (and (= an 0.0) (equal (cadr p) (cadr ll) 1e-6))
  260.             (setq an (* 0.5 pi))
  261.           )
  262.         )
  263.       )
  264.     )
  265.     (setq pl (reverse pl))
  266.     (setq e  nil
  267.           l  pl
  268.           ll l
  269.     )
  270.     (while (and (not e) ll)
  271.       (setq e  t
  272.             ll l
  273.       )
  274.       (while (and e ll)
  275.         (setq ll (if (listp (caar ll))
  276.                   ll
  277.                   (mapcar (function list) (cons (last ll) ll) ll)
  278.                  )
  279.               a  (car ll)
  280.               pl (vl-remove-if (function (lambda ( b ) (or (member (car a) b) (member (cadr a) b))))
  281.                                (cdr ll)
  282.                  )
  283.               ll (cdr ll)
  284.         )
  285.         (while (and pl (setq b (car pl)) (not (inters (car a) (cadr a) (car b) (cadr b))))
  286.           (setq pl (cdr pl))
  287.         )
  288.         (if pl
  289.           (progn (setq l (append (member (car a) l) (reverse (cdr (member (car a) (reverse l))))) ;;; [(car a) (cadr a) ... ->end] + ((car b) (cadr b)) - in middle of concatenated l + [start ... ->] ... (car a) - don't exist - it was (cdr-ed)
  290.                        l (append (list (car a)) (member (car b) (reverse (cdr l))) (member (cadr b) l)) ;;; [(car a)] + [(car b) + end<- ... (cadr a)] + [(cadr b) + start ... ->]
  291.                        e nil
  292.                  )
  293.           )
  294.         )
  295.       )
  296.     )
  297.     l
  298.   )
  299.  
  300.   (defun unique ( l )
  301.     (if l
  302.       (cons (car l)
  303.         (unique (vl-remove (car l) l))
  304.       )
  305.     )
  306.   )
  307.  
  308.   (defun generic ( l / ch inpts lil d p lilp lip )
  309.     (setq ch (LM:ConvexHull-ptsonHull l))
  310.     (setq inpts (vl-remove-if (function (lambda ( x ) (vl-position x ch))) l))
  311.     (while inpts
  312.       (setq lil (mapcar (function list) ch (append (cdr ch) (list (car ch)))))
  313.       (foreach li lil
  314.         (setq d (distance (car li) (cadr li)))
  315.         (setq p (car-sort inpts (function (lambda ( a b ) (< (- (+ (distance (car li) a) (distance a (cadr li))) d) (- (+ (distance (car li) b) (distance b (cadr li))) d))))))
  316.         (setq lilp (cons (list li p) lilp))
  317.       )
  318.       (setq lip (car-sort lilp (function (lambda ( a b ) (< (- (+ (distance (caar a) (cadr a)) (distance (cadr a) (cadar a))) (distance (caar a) (cadar a))) (- (+ (distance (caar b) (cadr b)) (distance (cadr b) (cadar b))) (distance (caar b) (cadar b))))))))
  319.       (setq lil (subst (list (caar lip) (cadr lip) (cadar lip)) (car lip) lil))
  320.       (setq ch (unique (apply (function append) lil)))
  321.       (setq inpts (vl-remove (cadr lip) inpts))
  322.       (setq lilp nil)
  323.     )
  324.     ch
  325.   )
  326.  
  327.   (prompt "\nSelect 2D points, inserts or circles...")
  328.   (if (setq ss (ssget '((0 . "POINT,INSERT,CIRCLE"))))
  329.     (progn
  330.       (initget "1 2 3 4 All")
  331.       (setq ch (getkword "\nDo you want computation by [1.greedy/2.generic/3.greedy+foo/4.generic+foo/All] <All - slower> : "))
  332.       (setq ti (car (_vl-times)))
  333.       (repeat (setq i (sslength ss))
  334.         (setq pl (cons (mapcar (function +) '(0 0) (trans (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) 0 1)) pl))
  335.       )
  336.       (cond
  337.         ( (= ch "1")
  338.           (setq pl (greedy pl))
  339.         )
  340.         ( (= ch "2")
  341.           (setq pl (chkinters (generic pl)))
  342.         )
  343.         ( (= ch "3")
  344.           (setq pl (chkinters (foo (greedy pl))))
  345.         )
  346.         ( (= ch "4")
  347.           (setq pl (chkinters (foo (chkinters (generic pl)))))
  348.         )
  349.         ( t
  350.           (setq pl1 (greedy pl))
  351.           (setq pl2 (chkinters (generic pl)))
  352.           (setq pl3 (chkinters (foo pl1)))
  353.           (setq pl4 (chkinters (foo pl2)))
  354.           (setq pl (car-sort (list pl1 pl2 pl3 pl4) (function (lambda ( a b ) (< (apply (function +) (mapcar (function distance) a (append (cdr a) (list (car a))))) (apply (function +) (mapcar (function distance) b (append (cdr b) (list (car b))))))))))
  355.         )
  356.       )
  357.       (entmake
  358.         (append
  359.           (list '(0 . "LWPOLYLINE")
  360.                 '(100 . "AcDbEntity")
  361.                 '(100 . "AcDbPolyline")
  362.                 (cons 90 (length pl))
  363.                 (cons 70 (1+ (* 128 (getvar 'plinegen))))
  364.                 '(38 . 0.0)
  365.           )
  366.           (mapcar (function (lambda ( x ) (cons 10 (trans x 1 0)))) pl)
  367.           '((210 0.0 0.0 1.0))
  368.         )
  369.       )
  370.       (prompt "\nDistance : ") (princ (rtos (get-closedpolygon-length pl) 2 20))
  371.       (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
  372.     )
  373.   )
  374.   (princ)
  375. )
  376.  
« Last Edit: October 14, 2020, 01:58:09 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2401
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #167 on: October 10, 2020, 01:39:39 PM »
Record is broken, but in a 50 min. on my slow PC - on Laptop for 35 min. Routine is somewhat modified version of TSP-FAST.LSP...
Previous record time was about 10 min. with somewhat modified version of TSP-depth-fast.LSP...
Competition is still open for some new records - bear in mind that timings should be reasonable - so I guess that limit of 10 hours is good enough... Still I am not sure if distance is the shortest and can't be beaten, so have in mind that info also...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2401
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #168 on: October 11, 2020, 12:59:06 PM »
New record at about the same time as previous one...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2401
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #169 on: October 12, 2020, 08:24:33 AM »
Here are my compiled files : protected VLX for ACAD and DES file for BCAD...
These files are only for you to have testing opportunity to compare results with your versions... You can though use them for your job, but I would be pleased if you try to beat those results with your own programming skills... And maybe some day if you feel generous enough maybe you share your achievement either in compiled versions like I did or even *.lsp who knows...
« Last Edit: October 16, 2020, 12:12:34 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2401
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #170 on: October 14, 2020, 02:19:34 AM »
TSP-FAST should now work well with rotated UCS - for greedy - GRID points must be aligned with UCS (if GRID is rotated, so must be UCS and X axis must match rotation)...
Attachments updated...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2401
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #171 on: October 14, 2020, 08:06:50 AM »
It seems that there is no rule... I changed UCS randomly and TSP-FAST did the job with new record... Attached is PNG and DWG with UCS...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2401
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #172 on: October 15, 2020, 06:29:57 AM »
It should be just slightly faster, but every improvement is welcomed...

Attachments updated here :
http://www.theswamp.org/index.php?topic=30434.msg601911#msg601911
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube