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

0 Members and 2 Guests are viewing this topic.

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #165 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

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #166 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

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #167 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

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #168 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

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #169 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

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #170 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

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #171 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

adincer

  • Mosquito
  • Posts: 1
Re: (Challenge) To draw the shortest lwpolyline
« Reply #172 on: October 29, 2020, 02:14:00 AM »
I am trying to create left, right and midle axis of a road with taken 3 point with some interval. Example picture as below.


Is it possible to do this with your lisp to define an initial direction, maximum deflection angle, minimum and maximum segment lenght variables?

d2010

  • Bull Frog
  • Posts: 323
Re: (Challenge) To draw the shortest lwpolyline
« Reply #173 on: October 29, 2020, 07:23:53 AM »
I need help,, I translate your-source(only-half) to C+L
 If you interested , I need help,
  then I can not fix then script-errors
 :idea:

« Last Edit: November 04, 2020, 03:00:32 AM by d2010 »

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #174 on: November 03, 2020, 07:03:57 AM »
New record... What I did is used the same algorithm just mod. to accept selection of mutation LWPOLYLINE calculated for previous record and I used now depth = 8... It took about 6 hours for my Laptop which is faster than my PC - of course on BricsCAD...
Now I am starting to believe that much shorter than this is impossible - path is strengthen visually at maximum... But who knows records are to be beaten, but at what cost? My all resources are used to do it, although I have computers from previous millenia or around 2000~... (20 years old)
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

d2010

  • Bull Frog
  • Posts: 323
Re: (Challenge) To draw the shortest lwpolyline
« Reply #175 on: November 03, 2020, 08:00:15 PM »
I research  ObjectArx for (kpi, pi+pi, pi/2,pi*05)
Please for more speed , you replace (pi+pi) with kTwoPi 
Even the greatest  ObjectARX-autocad2018 , do not use (pi+pi) and
you  KTwoPi for more-speed.You must use KTwOpil KHalfPi,...
Code: [Select]
(defun con_kpi(/ )
   (setq;|a25930|;
kpi 3.14159265358979323846
kHalfPi 1.57079632679489661923
kTwoPi 6.28318530717958647692
kpi_max 3.14159265358979323846264338327950288
con_kpi kpi
con_kpi2 6.2831853071795865
)

It should be just slightly faster, but every improvement is welcomed...
Attachments updated here :
I compile your 'program (Greedy) to three-versions.(attached here).
« Last Edit: November 05, 2020, 04:50:30 AM by d2010 »

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #176 on: November 12, 2021, 02:07:42 PM »
Hi there...
I know this is old topic, but we don't want to leave it without any new fresh thoughts added...
So recently, I played with TSP again and I coded simple and fast straight forward genetic version in my interpretation...
I know that many tried to code for solving TSP and as far as I can see some success is gained - I don't know for other approaches by using different languages than LISP as I mainly work with codes that I can quickly test and debug...

Here is my new genetic approach :

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-main-unlimited-pts-fastest ( / MR:ConvexHull-ptsonHull LM:ConvexHull-ptsonHull LM:Clockwise-p unique car-sort _vl-sort chkinters chkinters-p foo1 foo2 foo3 foo4 processfoos ss ti i pl p plst inpl in inn epl e lil d dd1 dd2 rr1 rr2 pp p1 p2 xx )
  2.  
  3.   ;; Convex Hull  -  Lee Mac
  4.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
  5.   ;; Mod by M.R.  -  uses (car-sort) and (_vl-sort) subs...
  6.  
  7.   (defun MR:ConvexHull-ptsonHull ( lst / ch p0 lstl )
  8.     (cond
  9.       ( (< (length lst) 4) (_vl-sort lst (function (lambda ( a b ) (if (= (cadr a) (cadr b)) (< (car a) (car b)) (< (cadr a) (cadr b)))))) )
  10.       ( (setq p0 (car lst))
  11.         (foreach p1 (cdr lst)
  12.           (if (or (< (cadr p1) (cadr p0)) (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0))))
  13.             (setq p0 p1)
  14.           )
  15.         )
  16.         (setq lst (vl-remove p0 lst))
  17.         (setq lst (append (list p0) lst))
  18.         (setq lst
  19.           (_vl-sort lst
  20.             (function
  21.               (lambda ( a b / c d )
  22.                 (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))))
  23.                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
  24.                   (< c d)
  25.                 )
  26.               )
  27.             )
  28.           )
  29.         )
  30.         (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  31.         (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  32.         (setq lstl (_vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
  33.         (setq lst (append lst lstl))
  34.         (setq ch (list (cadr lst) (car lst)))
  35.         (foreach pt (cddr lst)
  36.           (if (equal pt (last lst))
  37.             (setq ch (cons pt ch))
  38.             (if (or (equal (angle (car ch) pt) (car-sort (mapcar (function (lambda ( x ) (angle (car ch) x))) (member pt lst)) (function <)) 1e-6) (equal (distance pt (cadr ch)) (+ (distance pt (car ch)) (distance (car ch) (cadr ch))) 1e-6))
  39.               (setq ch (cons pt ch))
  40.             )
  41.           )
  42.         )
  43.         (reverse ch)
  44.       )
  45.     )
  46.   )
  47.  
  48.   ;; Convex Hull  -  Lee Mac
  49.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
  50.  
  51.   (defun LM:ConvexHull-ptsonHull ( lst / ch p0 lstl )
  52.     (cond
  53.       ( (< (length lst) 4) lst)
  54.       ( (setq p0 (car lst))
  55.         (foreach p1 (cdr lst)
  56.           (if (or (< (cadr p1) (cadr p0)) (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0))))
  57.             (setq p0 p1)
  58.           )
  59.         )
  60.         (setq lst (vl-remove p0 lst))
  61.         (setq lst (append (list p0) lst))
  62.         (setq lst
  63.           (_vl-sort lst
  64.             (function
  65.               (lambda ( a b / c d )
  66.                 (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))))
  67.                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
  68.                   (< c d)
  69.                 )
  70.               )
  71.             )
  72.           )
  73.         )
  74.         (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  75.         (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  76.         (setq lstl (_vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
  77.         (setq lst (append lst lstl))
  78.         (setq ch (list (cadr lst) (car lst)))
  79.         (foreach pt (cddr lst)
  80.           (setq ch (cons pt ch))
  81.           (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt) (not (equal (distance (caddr ch) pt) (+ (distance (caddr ch) (cadr ch)) (distance (cadr ch) pt)) 1e-8)))
  82.             (setq ch (cons pt (cddr ch)))
  83.           )
  84.         )
  85.         (reverse ch)
  86.       )
  87.     )
  88.   )
  89.  
  90.   ;; Clockwise-p  -  Lee Mac
  91.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
  92.  
  93.   (defun LM:Clockwise-p ( p1 p2 p3 )
  94.     (minusp (- (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1))) (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))))
  95.   )
  96.  
  97.   (defun unique ( l / a ll )
  98.     (while (setq a (car l))
  99.       (if (vl-some (function (lambda ( x ) (equal x a 1e-6))) (cdr l))
  100.         (setq ll (cons a ll) l (vl-remove-if (function (lambda ( x ) (equal x a 1e-6))) (cdr l)))
  101.         (setq ll (cons a ll) l (cdr l))
  102.       )
  103.     )
  104.     (reverse ll)
  105.   )
  106.  
  107.   (defun car-sort ( lst cmp / rtn )
  108.     (setq rtn (car lst))
  109.     (foreach itm (cdr lst)
  110.       (if (apply cmp (list itm rtn))
  111.         (setq rtn itm)
  112.       )
  113.     )
  114.     rtn
  115.   )
  116.  
  117.   (defun _vl-sort ( l f / *q* ll ff gg )
  118.     (if (= (type f) 'sym)
  119.       (setq f (eval f))
  120.     )
  121.     (while (setq *q* (car l))
  122.       (setq ll
  123.         (if (null ll)
  124.           (cons *q* ll)
  125.           (cond
  126.             ( (apply f (list (last ll) *q*))
  127.               (append ll (list *q*))
  128.             )
  129.             ( (apply f (list *q* (car ll)))
  130.               (cons *q* ll)
  131.             )
  132.             ( t
  133.               (setq ff nil)
  134.               (setq gg (apply (function append) (append (mapcar (function (lambda ( *xxx* *yyy* ) (if (null ff) (if (apply f (list *q* *yyy*)) (progn (setq ff t) (list *xxx* *q*)) (list *xxx*)) (list *xxx*)))) ll (cdr ll)) (list (list (last ll))))))
  135.               (if (null ff)
  136.                 (append ll (list *q*))
  137.                 gg
  138.               )
  139.             )
  140.           )
  141.         )
  142.       )
  143.       (setq l (cdr l))
  144.     )
  145.     ll
  146.   )
  147.  
  148.   (defun chkinters ( pl / lil k a ilil pre mid suf )
  149.     (setq lil (mapcar (function list) pl (append (cdr pl) (list (car pl)))))
  150.     (setq k -1)
  151.     (while (and (< (setq k (1+ k)) (length lil)) (setq a (nth k lil)))
  152.       (setq ilil (vl-some (function (lambda ( b / ip ) (if (and (setq ip (inters (car a) (cadr a) (car b) (cadr b))) (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)))
  153.       (if ilil
  154.         (progn
  155.           (setq pre (reverse (cdr (member (car ilil) (reverse lil)))))
  156.           (setq mid (cdr (member (car ilil) lil)))
  157.           (setq mid (cdr (member (cadr ilil) (reverse mid))))
  158.           (setq mid (mapcar (function reverse) mid))
  159.           (setq suf (cdr (member (cadr ilil) lil)))
  160.           (setq lil (append pre (list (list (car (car ilil)) (car (cadr ilil)))) mid (list (list (cadr (car ilil)) (cadr (cadr ilil)))) suf))
  161.           (setq pre nil mid nil suf nil)
  162.           (setq ilil nil k -1)
  163.         )
  164.       )
  165.     )
  166.     (mapcar (function car) lil)
  167.   )
  168.  
  169.   (defun chkinters-p ( l / lil )
  170.     (setq lil (mapcar (function list) l (append (cdr l) (list (car l)))))
  171.     (vl-some (function (lambda ( x ) (vl-some (function (lambda ( y ) (inters (car x) (cadr x) (car y) (cadr y)))) (vl-remove (if (= (vl-position x lil) 0) (last lil) (nth (1- (vl-position x lil)) lil)) (vl-remove (if (= (vl-position x lil) (1- (length lil))) (car lil) (nth (1+ (vl-position x lil)) lil)) (vl-remove x lil)))))) lil)
  172.   )
  173.  
  174.   (defun foo1 ( plst / l )
  175.     (setq l plst)
  176.     (while (and (null xxx1) (vl-some (function (lambda ( a b / l1 l2 c ) (setq l1 l c (vl-some (function (lambda ( x ) (if (< (distance a x) (distance a b)) x))) (vl-remove a (vl-remove b l)))) (if c (setq l2 (append (reverse (member a (reverse (vl-remove c l)))) (list c) (if (/= (vl-position a l) (1- (length l))) (member b (vl-remove c l))))) (setq l2 nil)) (if (and l2 (or (< (length (unique l2)) (length l2)) (< (length l2) (length l1)))) (setq xxx1 (list l1 l2 c (list a b)))) (if (and l2 (not (chkinters-p l2)) (> (apply (function +) (mapcar (function distance) l1 (append (cdr l1) (list (car l1))))) (apply (function +) (mapcar (function distance) l2 (append (cdr l2) (list (car l2))))))) (setq l l2) (if l2 (progn (setq l (append (cdr l) (list (car l)))) nil))))) l (append (cdr l) (list (car l))))))
  177.     l
  178.   )
  179.  
  180.   (defun foo2 ( plst / l )
  181.     (setq l plst)
  182.     (while (and (null xxx2) (vl-some (function (lambda ( a b / l1 l2 c d e ) (setq l1 l c (vl-some (function (lambda ( x ) (if (< (- (+ (distance a x) (distance x b)) (distance a b)) (- (+ (distance (setq d (if (= (vl-position x l) 0) (last l) (nth (1- (vl-position x l)) l))) x) (distance x (setq e (if (= (vl-position x l) (1- (length l))) (car l) (nth (1+ (vl-position x l)) l))))) (distance d e))) x))) (vl-remove a (vl-remove b l)))) (if c (setq l2 (append (reverse (member a (reverse (vl-remove c l)))) (list c) (if (/= (vl-position a l) (1- (length l))) (vl-remove c (member b l))))) (setq l2 nil)) (if (and l2 (or (< (length (unique l2)) (length l2)) (< (length l2) (length l1)))) (setq xxx2 (list l1 l2 c d e (list a b)))) (if (and l2 (not (chkinters-p l2)) (> (apply (function +) (mapcar (function distance) l1 (append (cdr l1) (list (car l1))))) (apply (function +) (mapcar (function distance) l2 (append (cdr l2) (list (car l2))))))) (setq l l2) (if l2 (progn (setq l (append (cdr l) (list (car l)))) nil))))) l (append (cdr l) (list (car l))))))
  183.     l
  184.   )
  185.  
  186.   (defun foo3 ( plst / l )
  187.     (setq l plst)
  188.     (while (and (null xxx3) (vl-some (function (lambda ( a b c / l1 l2 ) (setq l1 l l2 (append (cond ( (= (vl-position a l) (- (length l) 2)) (cdr (reverse (member (cdr (reverse l))))) ) ( (= (vl-position a l) (1- (length l))) (cddr l) ) ( t (reverse (member a (reverse l))) )) (list c b) (cdddr (member a l)))) (if (or (< (length (unique l2)) (length l2)) (< (length l2) (length l1))) (setq xxx3 (list l1 l2 (list a b c)))) (if (and (not (chkinters-p l2)) (> (apply (function +) (mapcar (function distance) l1 (append (cdr l1) (list (car l1))))) (apply (function +) (mapcar (function distance) l2 (append (cdr l2) (list (car l2))))))) (setq l l2) (progn (setq l (append (cdr l) (list (car l)))) nil)))) l (append (cdr l) (list (car l))) (append (cddr l) (list (car l) (cadr l))))))
  189.     l
  190.   )
  191.  
  192.   (defun foo4 ( plst / l )
  193.     (setq l plst)
  194.     (while (and (null xxx4) (vl-some (function (lambda ( a b c / l1 l2 edge ) (setq l1 l edge (vl-some (function (lambda ( x ) (if (< (- (+ (distance (car x) b) (distance b (cadr x))) (distance (car x) (cadr x))) (- (+ (distance a b) (distance b c)) (distance a c))) x))) (vl-remove (list a b) (vl-remove (list b c) (mapcar (function list) (append l l) (append (append (cdr l) (list (car l))) (append (cdr l) (list (car l))))))))) (if edge (setq l2 (append (if (= (vl-position (car edge) l) (1- (length l))) (cdr (vl-remove b l)) (reverse (member (car edge) (reverse (vl-remove b l))))) (list b) (if (= (vl-position (car edge) l) (1- (length l))) (list (cadr edge)) (member (cadr edge) (vl-remove b l))))) (setq l2 nil)) (if (and l2 (or (< (length (unique l2)) (length l2)) (< (length l2) (length l1)))) (setq xxx4 (list l1 l2 edge (list a b c)))) (if (and l2 (not (chkinters-p l2)) (> (apply (function +) (mapcar (function distance) l1 (append (cdr l1) (list (car l1))))) (apply (function +) (mapcar (function distance) l2 (append (cdr l2) (list (car l2))))))) (setq l l2) (if l2 (progn (setq l (append (cdr l) (list (car l)))) nil))))) l (append (cdr l) (list (car l))) (append (cddr l) (list (car l) (cadr l))))))
  195.     l
  196.   )
  197.  
  198.   (defun processfoos ( plst / d dd ddd plst1 plst2 plst3 plst4 d1 d2 d3 d4 )
  199.     (if (< (length (unique plst)) (length plst))
  200.       (progn
  201.         (prompt "\nError in reference list for processing (foo) subs - it contains duplicate points... Quitting...")
  202.         (exit)
  203.       )
  204.     )
  205.     (setq d 1e+99 dd 0)
  206.     (while (> d dd)
  207.       (setq plst1 (foo1 plst))
  208.       (if (or (< (length (unique plst1)) (length plst1)) (< (length plst1) (length plst)))
  209.         (progn
  210.           (prompt "\nError in (foo1) - return list has less points than reference one or output list contains duplicate points... Quitting...")
  211.           (exit)
  212.         )
  213.       )
  214.       (if (chkinters-p plst1)
  215.         (setq plst1 (chkinters plst1))
  216.       )
  217.       (setq d1 (apply (function +) (mapcar (function distance) plst1 (append (cdr plst1) (list (car plst1))))))
  218.       (setq plst2 (foo2 plst))
  219.       (if (or (< (length (unique plst2)) (length plst2)) (< (length plst2) (length plst)))
  220.         (progn
  221.           (prompt "\nError in (foo2) - return list has less points than reference one or output list contains duplicate points... Quitting...")
  222.           (exit)
  223.         )
  224.       )
  225.       (if (chkinters-p plst2)
  226.         (setq plst2 (chkinters plst2))
  227.       )
  228.       (setq d2 (apply (function +) (mapcar (function distance) plst2 (append (cdr plst2) (list (car plst2))))))
  229.       (setq plst3 (foo3 plst))
  230.       (if (or (< (length (unique plst3)) (length plst3)) (< (length plst3) (length plst)))
  231.         (progn
  232.           (prompt "\nError in (foo3) - return list has less points than reference one or output list contains duplicate points... Quitting...")
  233.           (exit)
  234.         )
  235.       )
  236.       (if (chkinters-p plst3)
  237.         (setq plst3 (chkinters plst3))
  238.       )
  239.       (setq d3 (apply (function +) (mapcar (function distance) plst3 (append (cdr plst3) (list (car plst3))))))
  240.       (setq plst4 (foo4 plst))
  241.       (if (or (< (length (unique plst4)) (length plst4)) (< (length plst4) (length plst)))
  242.         (progn
  243.           (prompt "\nError in (foo4) - return list has less points than reference one or output list contains duplicate points... Quitting...")
  244.           (exit)
  245.         )
  246.       )
  247.       (if (chkinters-p plst4)
  248.         (setq plst4 (chkinters plst4))
  249.       )
  250.       (setq d4 (apply (function +) (mapcar (function distance) plst4 (append (cdr plst4) (list (car plst4))))))
  251.       (setq dd (min d1 d2 d3 d4))
  252.       (cond
  253.         ( (= dd d1)
  254.           (setq plst plst1)
  255.         )
  256.         ( (= dd d2)
  257.           (setq plst plst2)
  258.         )
  259.         ( (= dd d3)
  260.           (setq plst plst3)
  261.         )
  262.         ( (= dd d4)
  263.           (setq plst plst4)
  264.         )
  265.       )
  266.       (if (equal ddd dd 1e-6)
  267.         (setq d dd)
  268.         (setq ddd dd)
  269.       )
  270.     )
  271.     plst
  272.   )
  273.  
  274.   (prompt "\nSelect 2D points...")
  275.   (if (setq ss (ssget (list (cons 0 "POINT"))))
  276.     (progn
  277.       (setq ti (car (_vl-times)))
  278.       (repeat (setq i (sslength ss))
  279.         (setq pl (cons (mapcar (function +) (list 0.0 0.0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
  280.       )
  281.       (setq pl (_vl-sort pl (function (lambda ( a b ) (if (= (cadr a) (cadr b)) (< (car a) (car b)) (< (cadr a) (cadr b)))))))
  282.       (setq plst (MR:ConvexHull-ptsonHull (unique pl)))
  283.       (if (caddr pl)
  284.         (progn
  285.           (setq pp (car plst))
  286.           (foreach x plst
  287.             (if (or (> (car x) (car pp)) (and (= (car x) (car pp)) (< (cadr x) (cadr pp))))
  288.               (setq pp x)
  289.             )
  290.           )
  291.           (if (> (vl-position (setq p (car-sort (cdr pl) (function (lambda ( a b ) (< (distance (car pl) a) (distance (car pl) b)))))) pl) (vl-position (car-sort (vl-remove p (cdr pl)) (function (lambda ( a b ) (< (distance (car pl) a) (distance (car pl) b))))) pl))
  292.             (setq p1 (mapcar (function +) (car pl) (list 0.0 5e-2)) p2 (mapcar (function +) (last pl) (list 0.0 5e-2)))
  293.             (setq plst (append (member pp plst) (reverse (cdr (member pp (reverse plst))))) p1 (mapcar (function +) (list (car (last pl)) (cadar pl)) (list -5e-2 0.0)) p2 (mapcar (function +) (list (caar pl) (cadr (last pl))) (list -5e-2 0.0)))
  294.           )
  295.           (setq inpl (vl-remove-if (function (lambda ( x ) (vl-position x plst))) pl))
  296.           (setq in inpl)
  297.           (setq inpl nil)
  298.           (while in
  299.             (setq inn (MR:ConvexHull-ptsonHull in))
  300.             (setq in (vl-remove-if (function (lambda ( x ) (vl-position x inn))) in))
  301.             (setq inpl (append inn inpl))
  302.           )
  303.           (while inpl
  304.             (setq epl nil)
  305.             (setq lil (mapcar (function list) plst (append (cdr plst) (list (car plst)))))
  306.             (foreach e lil
  307.               (setq epl (cons (list (car e) (car-sort inpl (function (lambda ( a b ) (if (equal (- (+ (distance (car e) a) (distance (cadr e) a)) (distance (car e) (cadr e))) (- (+ (distance (car e) b) (distance (cadr e) b)) (distance (car e) (cadr e))) 1e-3) (< (vl-position a inpl) (vl-position b inpl)) (< (- (+ (distance (car e) a) (distance (cadr e) a)) (distance (car e) (cadr e))) (- (+ (distance (car e) b) (distance (cadr e) b)) (distance (car e) (cadr e)))))))) (cadr e)) epl))
  308.             )
  309.             (setq epl (reverse epl))
  310.             (setq e (car-sort (if (setq xx (vl-remove-if (function (lambda ( x ) (or (inters (car x) (cadr x) p1 p2) (inters (cadr x) (caddr x) p1 p2)))) epl)) xx epl) (function (lambda ( a b ) (if (equal (- (+ (distance (car a) (cadr a)) (distance (cadr a) (caddr a))) (distance (car a) (caddr a))) (- (+ (distance (car b) (cadr b)) (distance (cadr b) (caddr b))) (distance (car b) (caddr b))) 1e-3) (< (vl-position (car a) plst) (vl-position (car b) plst)) (< (- (+ (distance (car a) (cadr a)) (distance (cadr a) (caddr a))) (distance (car a) (caddr a))) (- (+ (distance (car b) (cadr b)) (distance (cadr b) (caddr b))) (distance (car b) (caddr b)))))))))
  311.             (setq inpl (vl-remove (cadr e) inpl))
  312.             (setq plst (apply (function append) (mapcar (function (lambda ( x ) (if (equal (car e) x) (list (car e) (cadr e)) (list x)))) plst)))
  313.             (setq plst (append (member (caddr e) plst) (reverse (cdr (member (caddr e) (reverse plst))))))
  314.             (setq plst (append (cdr plst) (list (car plst))))
  315.             ;|
  316.             (progn
  317.               (redraw)
  318.               (mapcar (function (lambda ( a b ) (grdraw a b 2 0))) plst (append (cdr plst) (list (car plst))))
  319.               (getstring "\nENTER TO CONTINUE...")
  320.             )
  321.             |;
  322.             ;;; debugging...
  323.           )
  324.           (setq rr1 (unique plst) dd1 (apply (function +) (mapcar (function distance) plst (append (cdr plst) (list (car plst))))))
  325.           (setq plst (reverse plst))
  326.           (setq rr2 (unique plst) dd2 (apply (function +) (mapcar (function distance) plst (append (cdr plst) (list (car plst))))))
  327.           (if (< dd1 dd2)
  328.             (setq plst rr1)
  329.             (setq plst rr2)
  330.           )
  331.           (if (chkinters-p plst)
  332.             (setq plst (processfoos (chkinters plst)))
  333.             (setq plst (processfoos plst))
  334.           )
  335.         )
  336.       )
  337.       (setq d (apply (function +) (mapcar (function distance) plst (append (cdr plst) (list (car plst))))))
  338.       (entmake
  339.         (append
  340.           (list
  341.             (cons 0 "LWPOLYLINE")
  342.             (cons 100 "AcDbEntity")
  343.             (cons 100 "AcDbPolyline")
  344.             (cons 90 (length plst))
  345.             (cons 70 (1+ (* 128 (getvar 'plinegen))))
  346.             (cons 38 0.0)
  347.           )
  348.           (mapcar (function (lambda ( p ) (cons 10 p))) plst)
  349.           (list (list 210 0.0 0.0 1.0))
  350.         )
  351.       )
  352.       (prompt "\nPath length : ") (princ (rtos d 2 20))
  353.       (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
  354.     )
  355.   )
  356.   (princ)
  357. )
  358.  
« Last Edit: November 18, 2021, 11:40:46 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #177 on: November 12, 2021, 02:08:20 PM »
And also I want to post and mention for my triangulation implementation that differs from Delaunay as it creates concave hull instead of convex like Delaunay version... I don't want to place it in triangulation topic as this is far more challenging and brings many questions for which no real good answers exist... Evgeniy's version gives almost the same results like my above genetic version, but who knows maybe this different implementation of triangulation gives more insights about solving difficult TSP... Main difference from Delaunay is that it starts with smallest triangle somewhere and then it builds concave triangulation from which path is extracted as solution... I didn't formed any decent theoretical assumptions than doing straight forward solving the task as quickly as possible... The code is also very concise and beside its relatively good speed, that's its another benefit...
So no circumcirles and other points of views, but I suppose that it can bring attention for building theory on its basis...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-triangulate-MMR-old ( / car-sort _vl-sort ptinsidetriangle-p triangulate-MR ss ti i pl trl el e d )
  2.  
  3.   (defun car-sort ( lst cmp / rtn )
  4.     (setq rtn (car lst))
  5.     (foreach itm (cdr lst)
  6.       (if (apply cmp (list itm rtn))
  7.         (setq rtn itm)
  8.       )
  9.     )
  10.     rtn
  11.   )
  12.  
  13.   (defun _vl-sort ( l f / *q* ll ff gg )
  14.     (if (= (type f) 'sym)
  15.       (setq f (eval f))
  16.     )
  17.     (while (setq *q* (car l))
  18.       (setq ll
  19.         (if (null ll)
  20.           (cons *q* ll)
  21.           (cond
  22.             ( (apply f (list (last ll) *q*))
  23.               (append ll (list *q*))
  24.             )
  25.             ( (apply f (list *q* (car ll)))
  26.               (cons *q* ll)
  27.             )
  28.             ( t
  29.               (setq ff nil)
  30.               (setq gg (apply (function append) (append (mapcar (function (lambda ( *xxx* *yyy* ) (if (null ff) (if (apply f (list *q* *yyy*)) (progn (setq ff t) (list *xxx* *q*)) (list *xxx*)) (list *xxx*)))) ll (cdr ll)) (list (list (last ll))))))
  31.               (if (null ff)
  32.                 (append ll (list *q*))
  33.                 gg
  34.               )
  35.             )
  36.           )
  37.         )
  38.       )
  39.       (setq l (cdr l))
  40.     )
  41.     ll
  42.   )
  43.  
  44.   (defun ptinsidetriangle-p ( pt p1 p2 p3 )
  45.     (and
  46.       (not
  47.         (or
  48.           (inters pt p1 p2 p3)
  49.           (inters pt p2 p1 p3)
  50.           (inters pt p3 p1 p2)
  51.         )
  52.       )
  53.       (and
  54.         (< (+ (distance pt p1) (distance pt p2)) (+ (distance p3 p1) (distance p3 p2)))
  55.         (< (+ (distance pt p2) (distance pt p3)) (+ (distance p1 p2) (distance p1 p3)))
  56.         (< (+ (distance pt p3) (distance pt p1)) (+ (distance p2 p3) (distance p2 p1)))
  57.       )
  58.       (not
  59.         (or
  60.           (equal (distance p1 p2) (+ (distance p1 pt) (distance pt p2)) 1e-6) ;; not on boundary
  61.           (equal (distance p2 p3) (+ (distance p2 pt) (distance pt p3)) 1e-6) ;; not on boundary
  62.           (equal (distance p3 p1) (+ (distance p3 pt) (distance pt p1)) 1e-6) ;; not on boundary
  63.         )
  64.       )
  65.     )
  66.   )
  67.  
  68.   (defun triangulate-MR ( pl / la lb lc d dd el trl q qq ell e )
  69.     (setq d (+ (distance (car pl) (cadr pl)) (distance (cadr pl) (caddr pl)) (distance (caddr pl) (car pl))))
  70.     (setq la pl)
  71.     (foreach a la
  72.       (setq lb (member a la))
  73.       (foreach b (setq lb (cdr lb))
  74.         (setq lc (member b lb))
  75.         (foreach c (setq lc (cdr lc))
  76.           (if (or (< (setq dd (+ (distance a b) (distance b c) (distance c a))) d) (equal dd d 1e-6))
  77.             (setq trl (list (list a b c)) el (list (list a b) (list b c) (list c a)) d dd)
  78.           )
  79.         )
  80.       )
  81.     )
  82.     (while (setq q (vl-remove-if (function (lambda ( x ) (vl-position x (apply (function append) trl)))) pl))
  83.       (setq ell (mapcar (function (lambda ( x ) (list x (_vl-sort (vl-remove-if-not (function (lambda ( y ) (equal (min (distance (car x) (setq qq (car-sort q (function (lambda ( a b ) (if (equal (min (distance (car x) a) (distance a (cadr x))) (min (distance (car x) b) (distance b (cadr x))) 1e-6) (< (distance a (cadr x)) (distance b (cadr x))) (< (min (distance (car x) a) (distance a (cadr x))) (min (distance (car x) b) (distance b (cadr x)))))))))) (distance (cadr x) qq)) (min (distance (car x) y) (distance (cadr x) y)) 1e-6))) q) (function (lambda ( j k ) (< (distance (car x) j) (distance (car x) k)))))))) el))
  84.       (if (setq q (vl-remove-if (function (lambda ( x ) (or (vl-some (function (lambda ( y ) (ptinsidetriangle-p y (caar x) (cadar x) (caadr x)))) (vl-remove (caar x) (vl-remove (cadar x) (vl-remove (caadr x) pl)))) (vl-some (function (lambda ( y / ip ) (or (and (setq ip (inters (caar x) (caadr x) (car y) (cadr y))) (not (equal ip (caar x) 1e-6)) (not (equal ip (car y) 1e-6)) (not (equal ip (cadr y) 1e-6))) (and (setq ip (inters (caar x) (caadr x) (cadr y) (caddr y))) (not (equal ip (caar x) 1e-6)) (not (equal ip (cadr y) 1e-6)) (not (equal ip (caddr y) 1e-6))) (and (setq ip (inters (caar x) (caadr x) (caddr y) (car y))) (not (equal ip (caar x) 1e-6)) (not (equal ip (caddr y) 1e-6)) (not (equal ip (car y) 1e-6))) (and (setq ip (inters (cadar x) (caadr x) (car y) (cadr y))) (not (equal ip (cadar x) 1e-6)) (not (equal ip (car y) 1e-6)) (not (equal ip (cadr y) 1e-6))) (and (setq ip (inters (cadar x) (caadr x) (cadr y) (caddr y))) (not (equal ip (cadar x) 1e-6)) (not (equal ip (cadr y) 1e-6)) (not (equal ip (caddr y) 1e-6))) (and (setq ip (inters (cadar x) (caadr x) (caddr y) (car y))) (not (equal ip (cadar x) 1e-6)) (not (equal ip (caddr y) 1e-6)) (not (equal ip (car y) 1e-6)))))) trl)))) ell))
  85.         (progn
  86.           (setq e (car-sort (_vl-sort (reverse q) (function (lambda ( x y ) (> (length (cadr x)) (length (cadr y)))))) (function (lambda ( x y ) (if (equal (min (distance (caar x) (caadr x)) (distance (cadar x) (caadr x))) (min (distance (caar y) (caadr y)) (distance (cadar y) (caadr y))) 1e-6) (< (+ (distance (caar x) (cadar x)) (distance (caar x) (caadr x)) (distance (cadar x) (caadr x))) (+ (distance (caar y) (cadar y)) (distance (caar y) (caadr y)) (distance (cadar y) (caadr y)))) (< (min (distance (caar x) (caadr x)) (distance (cadar x) (caadr x))) (min (distance (caar y) (caadr y)) (distance (cadar y) (caadr y)))))))))
  87.           (setq el (vl-remove (car e) el) el (cons (list (caar e) (caadr e)) el) el (cons (list (cadar e) (caadr e)) el))
  88.           (setq trl (cons (list (caar e) (caadr e) (cadar e)) trl))
  89.         )
  90.       )
  91.     )
  92.     (list trl el)
  93.   )
  94.  
  95.   (prompt "\nSelect points...")
  96.   (if (setq ss (ssget (list (cons 0 "POINT"))))
  97.     (progn
  98.       (setq ti (car (_vl-times)))
  99.       (repeat (setq i (sslength ss))
  100.         (setq pl (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) pl))
  101.       )
  102.       (setq trl (triangulate-MR pl))
  103.       (setq el (cadr trl) trl (car trl))
  104.       (setq pl nil)
  105.       (setq pl (cons (caar el) pl))
  106.       (while (vl-remove-if (function (lambda ( x ) (vl-position x pl))) (apply (function append) el))
  107.         (setq pl (cons (car (vl-remove (car pl) (setq e (vl-some (function (lambda ( x ) (if (vl-position (car pl) x) x))) el)))) pl))
  108.         (setq el (vl-remove e el))
  109.       )
  110.       (foreach tr (reverse trl)
  111.         (entmake
  112.           (list
  113.             (cons 0 "3DFACE")
  114.             (cons 100 "AcDbEntity")
  115.             (cons 100 "AcDbFace")
  116.             (cons 10 (car tr))
  117.             (cons 11 (car tr))
  118.             (cons 12 (cadr tr))
  119.             (cons 13 (caddr tr))
  120.           )
  121.         )
  122.       )
  123.       (setq d (apply (function +) (mapcar (function distance) pl (append (cdr pl) (list (car pl))))))
  124.       (entmake
  125.         (append
  126.           (list
  127.             (cons 0 "LWPOLYLINE")
  128.             (cons 100 "AcDbEntity")
  129.             (cons 100 "AcDbPolyline")
  130.             (cons 90 (length pl))
  131.             (cons 70 (1+ (* 128 (getvar 'plinegen))))
  132.             (cons 38 0.0)
  133.           )
  134.           (mapcar (function (lambda ( p ) (cons 10 p))) pl)
  135.           (list
  136.             (list 210 0.0 0.0 1.0)
  137.             (cons 62 1)
  138.           )
  139.         )
  140.       )
  141.       (prompt "\nPath length : ") (princ (rtos d 2 20))
  142.       (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
  143.     )
  144.   )
  145.   (princ)
  146. )
  147.  

New variant :

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-triangulate-MMR ( / car-sort _vl-sort ptinsidetriangle-p triangulate-MR ss ti i pl trl el e d )
  2.  
  3.   (defun car-sort ( lst cmp / rtn )
  4.     (setq rtn (car lst))
  5.     (foreach itm (cdr lst)
  6.       (if (apply cmp (list itm rtn))
  7.         (setq rtn itm)
  8.       )
  9.     )
  10.     rtn
  11.   )
  12.  
  13.   (defun _vl-sort ( l f / *q* ll ff gg )
  14.     (if (= (type f) 'sym)
  15.       (setq f (eval f))
  16.     )
  17.     (while (setq *q* (car l))
  18.       (setq ll
  19.         (if (null ll)
  20.           (cons *q* ll)
  21.           (cond
  22.             ( (apply f (list (last ll) *q*))
  23.               (append ll (list *q*))
  24.             )
  25.             ( (apply f (list *q* (car ll)))
  26.               (cons *q* ll)
  27.             )
  28.             ( t
  29.               (setq ff nil)
  30.               (setq gg (apply (function append) (append (mapcar (function (lambda ( *xxx* *yyy* ) (if (null ff) (if (apply f (list *q* *yyy*)) (progn (setq ff t) (list *xxx* *q*)) (list *xxx*)) (list *xxx*)))) ll (cdr ll)) (list (list (last ll))))))
  31.               (if (null ff)
  32.                 (append ll (list *q*))
  33.                 gg
  34.               )
  35.             )
  36.           )
  37.         )
  38.       )
  39.       (setq l (cdr l))
  40.     )
  41.     ll
  42.   )
  43.  
  44.   (defun ptinsidetriangle-p ( pt p1 p2 p3 )
  45.     (and
  46.       (not
  47.         (or
  48.           (inters pt p1 p2 p3)
  49.           (inters pt p2 p1 p3)
  50.           (inters pt p3 p1 p2)
  51.         )
  52.       )
  53.       (and
  54.         (< (+ (distance pt p1) (distance pt p2)) (+ (distance p3 p1) (distance p3 p2)))
  55.         (< (+ (distance pt p2) (distance pt p3)) (+ (distance p1 p2) (distance p1 p3)))
  56.         (< (+ (distance pt p3) (distance pt p1)) (+ (distance p2 p3) (distance p2 p1)))
  57.       )
  58.       (not
  59.         (or
  60.           (equal (distance p1 p2) (+ (distance p1 pt) (distance pt p2)) 1e-6) ;; not on boundary
  61.           (equal (distance p2 p3) (+ (distance p2 pt) (distance pt p3)) 1e-6) ;; not on boundary
  62.           (equal (distance p3 p1) (+ (distance p3 pt) (distance pt p1)) 1e-6) ;; not on boundary
  63.         )
  64.       )
  65.     )
  66.   )
  67.  
  68.   (defun triangulate-MR ( pl / la lb lc d dd el trl q qq ell e )
  69.     (setq d (+ (distance (car pl) (cadr pl)) (distance (cadr pl) (caddr pl)) (distance (caddr pl) (car pl))))
  70.     (setq la pl)
  71.     (foreach a la
  72.       (setq lb (member a la))
  73.       (foreach b (setq lb (cdr lb))
  74.         (setq lc (member b lb))
  75.         (foreach c (setq lc (cdr lc))
  76.           (if (or (< (setq dd (+ (distance a b) (distance b c) (distance c a))) d) (equal dd d 1e-6))
  77.             (setq trl (list (list a b c)) el (list (list a b) (list b c) (list c a)) d dd)
  78.           )
  79.         )
  80.       )
  81.     )
  82.     (while (setq q (vl-remove-if (function (lambda ( x ) (vl-position x (apply (function append) trl)))) pl))
  83.       (setq ell (mapcar (function (lambda ( x ) (list x (_vl-sort (vl-remove-if-not (function (lambda ( y ) (equal (+ (distance (car x) (setq qq (car-sort q (function (lambda ( a b ) (if (equal (+ (distance (car x) a) (distance a (cadr x))) (+ (distance (car x) b) (distance b (cadr x))) 1e-6) (< (distance a (cadr x)) (distance b (cadr x))) (< (+ (distance (car x) a) (distance a (cadr x))) (+ (distance (car x) b) (distance b (cadr x)))))))))) (distance (cadr x) qq)) (+ (distance (car x) y) (distance (cadr x) y)) 1e-6))) q) (function (lambda ( j k ) (< (distance (car x) j) (distance (car x) k)))))))) el))
  84.       (if (setq q (vl-remove-if (function (lambda ( x ) (or (vl-some (function (lambda ( y ) (ptinsidetriangle-p y (caar x) (cadar x) (caadr x)))) (vl-remove (caar x) (vl-remove (cadar x) (vl-remove (caadr x) pl)))) (vl-some (function (lambda ( y / ip ) (or (and (setq ip (inters (caar x) (caadr x) (car y) (cadr y))) (not (equal ip (caar x) 1e-6)) (not (equal ip (car y) 1e-6)) (not (equal ip (cadr y) 1e-6))) (and (setq ip (inters (caar x) (caadr x) (cadr y) (caddr y))) (not (equal ip (caar x) 1e-6)) (not (equal ip (cadr y) 1e-6)) (not (equal ip (caddr y) 1e-6))) (and (setq ip (inters (caar x) (caadr x) (caddr y) (car y))) (not (equal ip (caar x) 1e-6)) (not (equal ip (caddr y) 1e-6)) (not (equal ip (car y) 1e-6))) (and (setq ip (inters (cadar x) (caadr x) (car y) (cadr y))) (not (equal ip (cadar x) 1e-6)) (not (equal ip (car y) 1e-6)) (not (equal ip (cadr y) 1e-6))) (and (setq ip (inters (cadar x) (caadr x) (cadr y) (caddr y))) (not (equal ip (cadar x) 1e-6)) (not (equal ip (cadr y) 1e-6)) (not (equal ip (caddr y) 1e-6))) (and (setq ip (inters (cadar x) (caadr x) (caddr y) (car y))) (not (equal ip (cadar x) 1e-6)) (not (equal ip (caddr y) 1e-6)) (not (equal ip (car y) 1e-6)))))) trl)))) ell))
  85.         (progn
  86.           (setq e (car-sort (_vl-sort (reverse q) (function (lambda ( x y ) (> (length (cadr x)) (length (cadr y)))))) (function (lambda ( x y ) (if (equal (+ (distance (caar x) (caadr x)) (distance (cadar x) (caadr x))) (+ (distance (caar y) (caadr y)) (distance (cadar y) (caadr y))) 1e-6) (< (+ (distance (caar x) (cadar x)) (distance (caar x) (caadr x)) (distance (cadar x) (caadr x))) (+ (distance (caar y) (cadar y)) (distance (caar y) (caadr y)) (distance (cadar y) (caadr y)))) (< (+ (distance (caar x) (caadr x)) (distance (cadar x) (caadr x))) (+ (distance (caar y) (caadr y)) (distance (cadar y) (caadr y)))))))))
  87.           (setq el (vl-remove (car e) el) el (cons (list (caar e) (caadr e)) el) el (cons (list (cadar e) (caadr e)) el))
  88.           (setq trl (cons (list (caar e) (caadr e) (cadar e)) trl))
  89.         )
  90.       )
  91.     )
  92.     (list trl el)
  93.   )
  94.  
  95.   (prompt "\nSelect points...")
  96.   (if (setq ss (ssget (list (cons 0 "POINT"))))
  97.     (progn
  98.       (setq ti (car (_vl-times)))
  99.       (repeat (setq i (sslength ss))
  100.         (setq pl (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) pl))
  101.       )
  102.       (setq trl (triangulate-MR pl))
  103.       (setq el (cadr trl) trl (car trl))
  104.       (setq pl nil)
  105.       (setq pl (cons (caar el) pl))
  106.       (while (vl-remove-if (function (lambda ( x ) (vl-position x pl))) (apply (function append) el))
  107.         (setq pl (cons (car (vl-remove (car pl) (setq e (vl-some (function (lambda ( x ) (if (vl-position (car pl) x) x))) el)))) pl))
  108.         (setq el (vl-remove e el))
  109.       )
  110.       (foreach tr (reverse trl)
  111.         (entmake
  112.           (list
  113.             (cons 0 "3DFACE")
  114.             (cons 100 "AcDbEntity")
  115.             (cons 100 "AcDbFace")
  116.             (cons 10 (car tr))
  117.             (cons 11 (car tr))
  118.             (cons 12 (cadr tr))
  119.             (cons 13 (caddr tr))
  120.           )
  121.         )
  122.       )
  123.       (setq d (apply (function +) (mapcar (function distance) pl (append (cdr pl) (list (car pl))))))
  124.       (entmake
  125.         (append
  126.           (list
  127.             (cons 0 "LWPOLYLINE")
  128.             (cons 100 "AcDbEntity")
  129.             (cons 100 "AcDbPolyline")
  130.             (cons 90 (length pl))
  131.             (cons 70 (1+ (* 128 (getvar 'plinegen))))
  132.             (cons 38 0.0)
  133.           )
  134.           (mapcar (function (lambda ( p ) (cons 10 p))) pl)
  135.           (list
  136.             (list 210 0.0 0.0 1.0)
  137.             (cons 62 1)
  138.           )
  139.         )
  140.       )
  141.       (prompt "\nPath length : ") (princ (rtos d 2 20))
  142.       (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
  143.     )
  144.   )
  145.   (princ)
  146. )
  147.  
« Last Edit: November 13, 2021, 10:45:19 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #178 on: November 12, 2021, 02:09:10 PM »
And also not pretty, but based on Delaunay and Djikstra algorithm - there is no any reasonably well results, but just for completness :

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-Delaunay-Dijkstra ( / *error* *adoc* -pi/2 3D->2D sortxy remduppoint RemoveIDDup unique triangulate minpath shortpath-refine-no-int ss ti i pl trl edges nodes g f gg ggg ff fff n pll dijkstra path plst lw d )
  2.  
  3.  
  4.   (defun *error* ( m )
  5.     (vla-endundomark *adoc*)
  6.     (if m
  7.       (prompt m)
  8.     )
  9.     (princ)
  10.   )
  11.  
  12.   (setq -pi/2 -1.5707963267948966192313216916398)
  13.  
  14.   ;; 3D to 2D point  -  M.R.
  15.   ;; Returns 2D point list from supplied 3D point list or returns supplied argument if it isn't 3D point list
  16.  
  17.   (defun 3D->2D ( p )
  18.     (if (and (listp p) (vl-every (function (lambda ( x ) (eq (type x) 'REAL))) p) (eq (length p) 3))
  19.       (list (car p) (cadr p))
  20.       p
  21.     )
  22.   )
  23.  
  24.   ;;                                                                            ;
  25.   ;; sortxy                                                                     ;
  26.   ;;                                                                            ;
  27.   ;; Sorts a list of points on Increasing X order and Increasing Y              ;
  28.   ;;                                                                            ;
  29.  
  30.   (defun sortxy ( l )
  31.     (vl-sort l
  32.       (function
  33.         (lambda ( a b )
  34.           (if (= (car a) (car b))
  35.             (< (cadr a) (cadr b))
  36.             (< (car  a) (car  b))
  37.           )
  38.         )
  39.       )  
  40.     )
  41.   )
  42.  
  43.   ;;                                                                            ;
  44.   ;; remduppoint       by Joe Burke                                             ;
  45.   ;;                                                                            ;
  46.   ;; Remove Duplicate Adjacent Points from Point List with Fuzz Factor          ;
  47.   ;; Point List Needs to be Sorted Prior to Calling this Function               ;
  48.   ;; Modified by ymg to operate on 2d points. (3D->2D p)                        ;
  49.   ;; Modified again by M.R.                                                     ;
  50. ;|
  51.   (defun remduppoint ( l fuzz / rtn p )
  52.     (repeat (1- (length l))
  53.       (setq p (car l))
  54.       (if (> (distance (3D->2D p) (cadr l)) fuzz)
  55.         (setq rtn (cons p rtn))
  56.       )
  57.       (setq l (cdr l))
  58.     )
  59.     (reverse (cons (car l) rtn))
  60.   )
  61. |;
  62.   (defun remduppoint ( l fuzz / l1 )
  63.     (setq l (vl-sort l (function (lambda ( a b ) (< (caddr a) (caddr b))))))
  64.     (while (car l)
  65.       (setq l1 (cons (car l) (vl-remove-if (function (lambda ( x ) (equal (list (car x) (cadr x)) (list (caar l) (cadar l)) fuzz))) l1)))
  66.       (setq l (cdr l))
  67.     )
  68.     l1
  69.   )
  70.  
  71.   (defun RemoveIDDup ( l )
  72.     (if l
  73.       (cons (car l)
  74.         (RemoveIDDup
  75.           (vl-remove-if
  76.             (function (lambda ( x )
  77.                 (or (and (= (car x) (caar l))
  78.                          (= (cadr x) (cadar l))
  79.                     )
  80.                     (and (= (car x) (cadar l))
  81.                          (= (cadr x) (caar l))
  82.                     )
  83.                 )
  84.               )
  85.             )
  86.             (cdr l)
  87.           )
  88.         )
  89.       )
  90.     )
  91.   )
  92.  
  93.   (defun unique ( l fuzz / a ll )
  94.     (while (setq a (car l))
  95.       (if (vl-some (function (lambda ( x ) (equal x a fuzz))) (cdr l))
  96.         (setq ll (cons a ll) l (vl-remove-if (function (lambda ( x ) (equal x a fuzz))) (cdr l)))
  97.         (setq ll (cons a ll) l (cdr l))
  98.       )
  99.     )
  100.     (reverse ll)
  101.   )
  102.  
  103.   ;; Triangulate - subfunction for drawing Delunay triangulation from specified list of points with provided factor for checking weather calcualted triangulation is convex hull boundary triangulation
  104.   ;; Returns list of 2 elements - first element is list of triangles defined by 3 points forming triangle and second element is calculated factor for forming supertriangle for next call of triangulate function for gathering correct convex hull boundary of triangulation triangles
  105.  
  106.   (defun triangulate ( pl / tl xmin xmax ymin ymax cs pmin pmax t1 t2 t3 n str rs np al p el tr l a b c vll cp r )
  107.  
  108.     (setq xmin (caar pl)) ;;; Sorted pl by X ;;;
  109.     (setq xmax (caar (vl-sort pl (function (lambda ( a b ) (> (car a) (car b)))))))
  110.     (setq ymin (cadar (vl-sort pl (function (lambda ( a b ) (< (cadr a) (cadr b)))))))
  111.     (setq ymax (cadar (vl-sort pl (function (lambda ( a b ) (> (cadr a) (cadr b)))))))
  112.     (setq cs (list (+ xmin (/ (- xmax xmin) 2.0)) (+ ymin (/ (- ymax ymin) 2.0))))
  113.     (setq pmin (list xmin ymin) pmax (list xmax ymax))
  114.     (setq t1 (polar cs (/ pi 12.0) (if (setq n (atoi (substr (setq str (rtos (distance pmin cs) 1 0)) (- (strlen str) 2)))) (setq rs (expt 50.0 (+ n 2))))))
  115.     (setq t2 (polar cs (+ (/ pi 12.0) (/ (* 2.0 pi) 3.0)) rs))
  116.     (setq t3 (polar cs (+ (/ pi 12.0) (/ (* 4.0 pi) 3.0)) rs))
  117.     (setq np (length pl))
  118.     (setq pl (append pl (list (list (car t1) (cadr t1) 0.0) (list (car t2) (cadr t2) 0.0) (list (car t3) (cadr t3) 0.0))))
  119.     (setq al (list (list (car t1) cs rs (list np (+ 1 np) (+ 2 np)))))
  120.     (setq n -1)
  121.     (repeat np
  122.       (setq n (1+ n))
  123.       (setq p (nth n pl))
  124.       (setq el nil)
  125.       (repeat (length al)
  126.         (setq tr (car al))
  127.         (setq al (cdr al))
  128.         (cond
  129.           ( (< (car tr) (car p)) ;;; Comparison of X values ;;;
  130.             (setq tl (cons (cadddr tr) tl))
  131.           )
  132.           ( (< (distance p (cadr tr)) (caddr tr))
  133.             (setq a (car (cadddr tr))
  134.                   b (cadr (cadddr tr))
  135.                   c (caddr (cadddr tr))
  136.                   el (vl-list* (list a b) (list b c) (list c a) el)
  137.             )
  138.           )
  139.           ( t (setq l (cons tr l)) )
  140.         )
  141.       )
  142.       (setq al l l nil)
  143.       (while el ;;; el - edge list = ((a b) (b c) (c a) (d e) (e f) (f d) ... )
  144.         (if (or (vl-position (reverse (car el)) el)
  145.                 (vl-position (car el) (cdr el))
  146.             )
  147.             (setq el (vl-remove (reverse (car el)) el)
  148.                   el (vl-remove (car el) el)
  149.             )
  150.             (progn  ; This replaces call to getcircumcircle function     ;
  151.               (setq p (nth n pl)
  152.                     b (nth (caar el) pl)
  153.                     c (nth (cadar el) pl)
  154.                     vll (list n (caar el) (cadar el))
  155.               )
  156.               (if (not (zerop (setq ang (- (angle b c) (angle b p)))))
  157.                 (setq cp (polar (3D->2D c) (+ -pi/2 (angle c p) ang) (setq r (/ (distance (3D->2D p) (3D->2D c)) (sin ang) 2.0)))
  158.                       al (cons (list (+ (car cp) (abs r)) cp (abs r) vll) al)
  159.                       el (cdr el)
  160.                 )
  161.                 (progn
  162.                   (prompt "\nZero angle difference occurrence... Can't triangulate - quitting...")
  163.                   (exit)
  164.                 )
  165.               )
  166.             )
  167.         )
  168.       )
  169.     )
  170.     (foreach tr al (setq tl (cons (cadddr tr) tl)))
  171.     (setq tl (vl-remove-if-not
  172.       (function
  173.         (lambda ( x ) (and (< (car x) np) (< (cadr x) np) (< (caddr x) np)))
  174.       )
  175.       tl
  176.       )
  177.     )
  178.     tl
  179.   ) ;;; end of triangulate
  180.  
  181.   ;; minpath - Dijkstra algorithm by ymg...
  182.  
  183.   (defun minpath ( g f nodes edges / brname clnodes closedl go new nodname old openl totdist ppath )
  184.     (setq nodes (vl-remove g nodes))
  185.     (setq openl (list (list g 0 nil)))
  186.     (setq closedl nil)
  187.     (setq go t)
  188.     (foreach n nodes
  189.       (setq nodes (subst (list n 0 nil) n nodes))
  190.     )
  191.     (while (and go (not (= (caar closedl) f)))
  192.       (setq nodname (caar openl))
  193.       (setq totdist (cadar openl))
  194.       (setq closedl (cons (car openl) closedl))
  195.       (setq openl (cdr openl))
  196.       (setq clnodes (mapcar (function car) closedl))
  197.       (foreach e edges
  198.         (setq brname nil)
  199.         (cond
  200.           ( (= (car e) nodname)
  201.             (setq brname (cadr e))
  202.           )
  203.           ( (= (cadr e) nodname)
  204.             (setq brname (car e))
  205.           )
  206.         )
  207.         (if brname
  208.           (progn
  209.             (setq new (list brname (+ (caddr e) totdist) nodname))
  210.             (cond
  211.               ( (member brname clnodes) )
  212.               ( (setq old (vl-some (function (lambda ( x ) (if (= brname (car x)) x))) openl))
  213.                 (if (< (cadr new) (cadr old))
  214.                   (setq openl (subst new old openl))
  215.                 )
  216.               )
  217.               ( t (setq openl (cons new openl)) )
  218.             )
  219.           )
  220.         )
  221.       )
  222.       (setq openl (vl-sort openl (function (lambda ( a b ) (< (cadr a) (cadr b))))))
  223.       (and (null openl) (null (caar closedl)) (setq go nil))
  224.     )
  225.     (setq ppath (list (car closedl)))
  226.     (foreach n closedl
  227.       (if (= (car n) (caddr (car ppath)))
  228.         (setq ppath (cons n ppath))
  229.       )
  230.     )
  231.     ppath
  232.   )
  233.  
  234.   (defun shortpath-refine-no-int ( lw / pl lil lii1 lii2 lil1 lil2 ip pln d )
  235.     (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget lw))))
  236.     (setq lil (mapcar (function (lambda ( a b ) (list a b))) pl (append (cdr pl) (list (car pl)))))
  237.     (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)
  238.       (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)))))))))
  239.       (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))))))))
  240.       (setq lil (append lil1 (list (list (cadr (last lil1)) (cadr (car lil2)))) (mapcar (function reverse) lil2) (list (list (car (last lil2)) (car (car lil1))))))
  241.     )
  242.     (setq pln (mapcar (function car) lil))
  243.     (setq d (apply (function +) (mapcar '(lambda ( a b ) (distance a b)) pln (append (cdr pln) (list (car pln))))))
  244.     (entmake
  245.       (append
  246.         (list
  247.           (cons 0 "LWPOLYLINE")
  248.           (cons 100 "AcDbEntity")
  249.           (cons 100 "AcDbPolyline")
  250.           (cons 90 (length pln))
  251.           (cons 70 (1+ (* (getvar 'plinegen) 128)))
  252.           (cons 38 0.0)
  253.         )
  254.         (mapcar (function (lambda ( p ) (cons 10 p))) pln)
  255.         (list
  256.           (assoc 210 (entget lw))
  257.           (cons 62 1)
  258.         )
  259.       )
  260.     )
  261.     (entdel lw)
  262.     d
  263.   )
  264.  
  265.   (prompt "\nSelect 2D points...")
  266.   (if (setq ss (ssget (list (cons 0 "POINT"))))
  267.     (progn
  268.       (setq ti (car (_vl-times)))
  269.       (repeat (setq i (sslength ss))
  270.         (setq pl (cons (trans (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) 0 1) pl))
  271.       )
  272.       (setq trl (triangulate (setq pl (sortxy (remduppoint pl 1e-6)))))
  273.       (setq edges (RemoveIDDup (apply (function append) (mapcar (function (lambda ( x ) (list (list (car x) (cadr x) (distance (nth (car x) pl) (nth (cadr x) pl))) (list (cadr x) (caddr x) (distance (nth (cadr x) pl) (nth (caddr x) pl))) (list (caddr x) (car x) (distance (nth (caddr x) pl) (nth (car x) pl)))))) trl))))
  274.       (setq nodes (mapcar (function (lambda ( x ) (vl-position x pl))) pl))
  275.       (setq g (car nodes) f (last nodes))
  276.       (setq edges (vl-remove-if (function (lambda ( x ) (or (and (= (car x) g) (= (cadr x) f)) (and (= (cadr x) g) (= (car x) f))))) edges))
  277.       (while (/= (length nodes) 2)
  278.         (setq gg f ff g)
  279.         (setq dijkstra (mapcar (function car) (minpath g f nodes edges)))
  280.         (setq path (append path (mapcar (function (lambda ( x ) (if (null pll) (trans (nth x pl) 1 0) (trans (nth x pll) 1 0)))) dijkstra)))
  281.         (setq nodes (vl-remove-if (function (lambda ( x ) (vl-position x dijkstra))) nodes))
  282.         (setq nodes (cons gg nodes) nodes (cons ff nodes))
  283.         (setq ggg (if (null pll) (nth gg pl) (nth gg pll)) fff (if (null pll) (nth ff pl) (nth ff pll)))
  284.         (setq trl (triangulate (setq pll (sortxy (remduppoint (mapcar (function (lambda ( x ) (if (null pll) (nth x pl) (nth x pll)))) nodes) 1e-6)))))
  285.         (setq nodes (mapcar (function (lambda ( x ) (vl-position x pll))) pll))
  286.         (setq edges (RemoveIDDup (apply (function append) (mapcar (function (lambda ( x ) (list (list (car x) (cadr x) (distance (nth (car x) pll) (nth (cadr x) pll))) (list (cadr x) (caddr x) (distance (nth (cadr x) pll) (nth (caddr x) pll))) (list (caddr x) (car x) (distance (nth (caddr x) pll) (nth (car x) pll)))))) trl))))
  287.         (setq n -1 g (vl-some (function (lambda ( x ) (setq n (1+ n)) (if (equal x ggg 1e-6) n))) pll) n -1 f (vl-some (function (lambda ( x ) (setq n (1+ n)) (if (equal x fff 1e-6) n))) pll))
  288.         (setq edges (vl-remove-if (function (lambda ( x ) (or (and (= (car x) g) (= (cadr x) f)) (and (= (cadr x) g) (= (car x) f))))) edges))
  289.       )
  290.  
  291.       (setq plst (unique path 1e-6))
  292.       ;(setq plst path)
  293.  
  294.       (setq lw
  295.         (entmakex
  296.           (append
  297.             (list
  298.               (cons 0 "LWPOLYLINE")
  299.               (cons 100 "AcDbEntity")
  300.               (cons 100 "AcDbPolyline")
  301.               (cons 90 (length plst))
  302.               (cons 70 (1+ (* 128 (getvar 'plinegen))))
  303.               (cons 38 0.0)
  304.             )
  305.             (mapcar (function (lambda ( p ) (cons 10 p))) plst)
  306.             (list (list 210 0.0 0.0 1.0))
  307.             (list (cons 62 1))
  308.           )
  309.         )
  310.       )
  311.  
  312.       (setq d (shortpath-refine-no-int lw))
  313.       ;(setq d (vlax-curve-getdistatparam lw (vlax-curve-getendparam lw)))
  314.  
  315.       (prompt "\nPath length : ") (princ (rtos d 2 50))
  316.       (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 50)) (prompt " milliseconds...")
  317.     )
  318.   )
  319.   (*error* nil)
  320. )
  321.  

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

:)

M.R. on Youtube

It's Alive!

  • Retired
  • Needs a day job
  • Posts: 8661
  • AKA Daniel
Re: (Challenge) To draw the shortest lwpolyline
« Reply #179 on: November 12, 2021, 06:46:02 PM »
And also I want to post and mention for my triangulation implementation that differs from Delaunay as it creates concave hull instead of convex like Delaunay version... I don't want to place it in triangulation topic as this is far more

Need a concave hull for this https://www.theswamp.org/index.php?topic=57094.30
I tried here https://www.theswamp.org/index.php?topic=57135.0, using https://github.com/sadaszewski/concaveman-cpp, which is a port from, JS https://github.com/mapbox/concaveman