Author Topic: Triangulation (re-visited)  (Read 246827 times)

0 Members and 2 Guests are viewing this topic.

ribarm

  • Gator
  • Posts: 2780
  • Marko Ribar, architect
Re: Triangulation (re-visited)
« Reply #750 on: February 26, 2019, 11:01:31 AM »
I've noticed one more lack in my LISP routines... I should have added tolerance in remove duplicate points sub function here :

Quote
  (defun remove-dupl-points ( l / l1 )
    (setq l (vl-sort l (function (lambda ( a b ) (< (caddr a) (caddr b))))))
    (while (car l)
      (setq l1 (cons (car l) (vl-remove-if (function (lambda ( x ) (equal (list (car x) (cadr x)) (list (caar l) (cadar l)) 1e-8))) l1)))
      (setq l (cdr l))
    )
    l1
  )

LISP routines reattached once again...
P.S. I've changed this also in (c:triangulate-UCS) posted in topic with reverse link - I used the same sub function...

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

:)

M.R. on Youtube

sanju2323

  • Newt
  • Posts: 68
Re: Triangulation (re-visited)
« Reply #751 on: February 26, 2019, 11:24:14 AM »
ribarm,
 Can you upload revised "Triang" lisp?

ribarm

  • Gator
  • Posts: 2780
  • Marko Ribar, architect
Re: Triangulation (re-visited)
« Reply #752 on: February 26, 2019, 11:58:00 AM »
ribarm,
 Can you upload revised "Triang" lisp?

There is no need if you think on my version... Everything is the same except those minor things I pointed like in my last post... If you think on ymg's version, then I have the same as it's uploaded here and I can't help... Only ymg who is author would be able to modify his version, but I am afraid that I like most of people don't know what is with ymg... I have no info ab him, I'd like to believe that he retired from CAD and forums, but I don't know, hope that he is well... My hopes are with each new day smaller though...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

sanju2323

  • Newt
  • Posts: 68
Re: Triangulation (re-visited)
« Reply #753 on: February 26, 2019, 12:15:32 PM »
We are eagerly waiting for all the ymg, except this, the topic has got stuck, we hope they will come back soon...

ribarm

  • Gator
  • Posts: 2780
  • Marko Ribar, architect
Re: Triangulation (re-visited)
« Reply #754 on: February 27, 2019, 03:39:20 AM »
Had some lacks in dtr-while.html (dtr-while.lsp)... Reattached file again...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 2780
  • Marko Ribar, architect
Re: Triangulation (re-visited)
« Reply #755 on: February 27, 2019, 05:59:50 AM »
There is even slower version of (dtr-while.lsp)... I suppose that's because of even more checks that are performed while iteration in process... I'll attach it here just for reasons of understanding of what's going on... The main problem is that (founded point inside circle can be but not necessarily point candidate for correct 3rd point of triangle with selected edge which won't find any point inside that triangles circumcircle)... So all this is just avoiding optimization in speed including all checks that are processed... But nevertheless it works - but slower than (dtr-vl-some.lsp)...

[EDIT : dtr-while-even slower more.lsp is mod. of dtr-while-even slower.lsp - latest intervention described in (dtr-vl-some.lsp) is implemented here, but strange execution occurs with even more slower timings...]

[EDIT : dtr-while-even slower more-chk pt in tiang.lsp is mod. of previous mod. - changed sub function (ptincirc) to reflect checking of point inside triangle formed by (car e) (cadr e) and x points... Then if rtn is point, this is passed to adequate processing in portion of code where point p was checking as candidate for next smaller triangle with selected edge e - candidate triangle (car e) (cadr e) p is checked and if triangle list is populated (depending on other checks) routine proceeds to next edge e from edge list el...]

P.S. This last file is reattached as I forgot one more (inters) check and also added (mapcar '+ '(0 0) pt) so that all points inside inters are treated as 2D not 3D - previously there were 3D points which may not bring desired check - inters may be nil and actually if in 2D lines cross each other check should give point (2D)... This is just for (ptincirc) sub function - Triangulation is considered 3D algorithm with 3D points picked in desired UCS...
« Last Edit: March 01, 2019, 08:46:39 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 2780
  • Marko Ribar, architect
Re: Triangulation (re-visited)
« Reply #756 on: February 27, 2019, 06:04:01 AM »
And dtr-vl-some.lsp for those that don't want *.html version... It's shorter so it can fit inside code tags...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:dtr ( / LM:ConvexHull-ptsonHull LM:Clockwise-p remove-dupl-points circum ptincir *adoc* ss ti i pl ch el trl xx len qq ell )
  2.  
  3.   ;;; Delaunay Triangulation ALISP by M.R. ( Marko Ribar, d.i.a. - architect )
  4.   ;;; Example without supertriangle and with convex hull triangles - optimized as possible - using (vl-some) loops extensively...
  5.  
  6.  
  7.   ;; Convex Hull  -  Lee Mac
  8.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
  9.   ;; Mod. by M.R.
  10.  
  11.   (defun LM:ConvexHull-ptsonHull ( lst / ch p0 lstl )
  12.       (cond
  13.           (   (< (length lst) 4) lst)
  14.           (   (setq p0 (car lst))
  15.               (foreach p1 (cdr lst)
  16.                   (if (or (< (cadr p1) (cadr p0))
  17.                           (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
  18.                       )
  19.                       (setq p0 p1)
  20.                   )
  21.               )
  22.               (setq lst (vl-remove p0 lst))
  23.               (setq lst (append (list p0) lst))
  24.               (setq lst
  25.                   (vl-sort lst
  26.                       (function
  27.                           (lambda ( a b / c d )
  28.                               (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))))
  29.                                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
  30.                                   (< c d)
  31.                               )
  32.                           )
  33.                       )
  34.                   )
  35.               )
  36.               (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  37.               (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  38.               (setq lstl (vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
  39.               (setq lst (append lst lstl))
  40.               (setq ch (list (cadr lst) (car lst)))
  41.               (foreach pt (cddr lst)
  42.                   (setq ch (cons pt ch))
  43.                   (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
  44.                       (setq ch (cons pt (cddr ch)))
  45.                   )
  46.               )
  47.               (reverse ch)
  48.           )
  49.       )
  50.   )
  51.  
  52.   ;; Clockwise-p  -  Lee Mac
  53.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
  54.   ;; Mod. by M.R.
  55.  
  56.   (defun LM:Clockwise-p ( p1 p2 p3 )
  57.       (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
  58.               (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
  59.           )
  60.           0.0
  61.       )
  62.   )
  63.  
  64.   (defun remove-dupl-points ( l / l1 )
  65.     (setq l (vl-sort l (function (lambda ( a b ) (< (caddr a) (caddr b))))))
  66.     (while (car l)
  67.       (setq l1 (cons (car l) (vl-remove-if (function (lambda ( x ) (equal (list (car x) (cadr x)) (list (caar l) (cadar l)) 1e-8))) l1)))
  68.       (setq l (cdr l))
  69.     )
  70.     l1
  71.   )
  72.  
  73.   ;; Evgeniy Elpanov optimized (circumcircle) sub function
  74.  
  75.   (defun circum ( p1 p2 p3 / ang c r )
  76.     (if (not (zerop (setq ang (- (angle p2 p3) (angle p2 p1)))))
  77.       (setq c (polar p3 (+ -1.570796326794896 (angle p3 p1) ang) (setq r (/ (distance (mapcar '+ '(0.0 0.0) p1) p3) (sin ang) 2.0)))
  78.            r (abs r)
  79.       )
  80.     )
  81.     (list (if c (list (car c) (cadr c))) r)
  82.   )
  83.  
  84.   ;; Point inside circle sub function - returns t or nil if out of radius-fuzz range - by M.R.
  85.  
  86.   (defun ptincir ( orig rad-fuzz ptlst / rtn p )
  87.     (while (setq p (car ptlst))
  88.       (if (<= (distance orig p) rad-fuzz)
  89.         (setq rtn t ptlst nil)
  90.         (setq ptlst (cdr ptlst))
  91.       )
  92.     )
  93.     rtn
  94.   )
  95.  
  96.   (if (= 8 (logand 8 (getvar 'undoctl)))
  97.     (vla-endundomark *adoc*)
  98.   )
  99.   (vla-startundomark *adoc*)
  100.   (prompt "\nSelect points in desired UCS...")
  101.   (if (setq ss (ssget '((0 . "POINT"))))
  102.     (progn
  103.       (setq ti (car (_vl-times)))
  104.       (repeat (setq i (sslength ss))
  105.         (setq pl (cons (trans (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) 0 1) pl))
  106.       )
  107.       (princ (strcat "\n" (itoa (length pl)) " points collected at : " (rtos (- (car (_vl-times)) ti) 2 50) " milliseconds..."))
  108.       (setq pl (remove-dupl-points pl))
  109.       (princ (strcat "\n" (itoa (length pl)) " unique points (removed duplicates) at : " (rtos (- (car (_vl-times)) ti) 2 50) " milliseconds..."))
  110.       (setq ch (LM:ConvexHull-ptsonHull pl))
  111.       (setq ch (mapcar (function (lambda ( a b ) (list a b))) ch (append (cdr ch) (list (car ch)))))
  112.       (setq el (list (car ch)) ell el)
  113.       (while
  114.         (vl-some (function (lambda ( e )
  115.           (vl-some (function (lambda ( x / q )
  116.             (if
  117.               (and
  118.                 (setq q (circum (car e) (cadr e) x))
  119.                 (car q)
  120.                 (not (ptincir (car q) (cadr q) (vl-remove (car e) (vl-remove (cadr e) (vl-remove x (append xx pl))))))
  121.                 (not (vl-some (function (lambda ( tr ) (and (vl-position (car e) tr) (vl-position (cadr e) tr) (vl-position x tr)))) trl))
  122.               )
  123.               (progn
  124.                 (setq trl (cons (list (car e) (cadr e) x) trl))
  125.                 (if (not (or (vl-position (list (cadr e) x) el) (vl-position (list x (cadr e)) el)))
  126.                   (setq el (cons (list (cadr e) x) el))
  127.                   (setq el (vl-remove-if (function (lambda ( ee ) (or (equal (list (cadr e) x) ee) (equal (list x (cadr e)) ee)))) el))
  128.                 )
  129.                 (setq ell (cons (list (cadr e) x) ell))
  130.                 (if (not (or (vl-position (list (car e) x) el) (vl-position (list x (car e)) el)))
  131.                   (setq el (cons (list (car e) x) el))
  132.                   (setq el (vl-remove-if (function (lambda ( ee ) (or (equal (list (car e) x) ee) (equal (list x (car e)) ee)))) el))
  133.                 )
  134.                 (setq ell (cons (list (car e) x) ell))
  135.                 (setq len (length xx))
  136.                 (if (not (vl-position (car e) xx))
  137.                   (setq xx (cons (car e) xx))
  138.                 )
  139.                 t
  140.               )
  141.             )
  142.             )) (vl-sort (vl-remove (car (vl-remove (car e) (vl-remove (cadr e) (vl-some (function (lambda ( tr ) (if (and (vl-position (car e) tr) (vl-position (cadr e) tr)) tr))) trl)))) (vl-remove (car e) (vl-remove (cadr e) pl))) (function (lambda ( a b ) (< (distance (list (caar e) (cadar e)) a) (distance (list (caar e) (cadar e)) b)))))
  143.           )
  144.           )) el
  145.         )
  146.         (if (and (cadr xx) (/= len (length xx)))
  147.           (setq pl (vl-remove (cadr xx) pl))
  148.         )
  149.       )
  150.       (while
  151.         (vl-some (function (lambda ( e )
  152.           (vl-some (function (lambda ( x / q )
  153.             (if
  154.               (and
  155.                 (setq q (circum (car e) (cadr e) x))
  156.                 (car q)
  157.                 (not (ptincir (car q) (cadr q) (vl-remove (car e) (vl-remove (cadr e) (vl-remove x (append xx pl))))))
  158.                 (not (vl-some (function (lambda ( tr ) (and (vl-position (car e) tr) (vl-position (cadr e) tr) (vl-position x tr)))) trl))
  159.               )
  160.               (progn
  161.                 (setq trl (cons (list (car e) (cadr e) x) trl))
  162.                 (if (not (or (vl-position (list (cadr e) x) el) (vl-position (list x (cadr e)) el)))
  163.                   (setq el (cons (list (cadr e) x) el))
  164.                   (setq el (vl-remove-if (function (lambda ( ee ) (or (equal (list (cadr e) x) ee) (equal (list x (cadr e)) ee)))) el))
  165.                 )
  166.                 (setq ell (cons (list (cadr e) x) ell))
  167.                 (if (not (or (vl-position (list (car e) x) el) (vl-position (list x (car e)) el)))
  168.                   (setq el (cons (list (car e) x) el))
  169.                   (setq el (vl-remove-if (function (lambda ( ee ) (or (equal (list (car e) x) ee) (equal (list x (car e)) ee)))) el))
  170.                 )
  171.                 (setq ell (cons (list (car e) x) ell))
  172.                 t
  173.               )
  174.             )
  175.             )) (vl-sort (vl-remove (car (vl-remove (car e) (vl-remove (cadr e) (vl-some (function (lambda ( tr ) (if (and (vl-position (car e) tr) (vl-position (cadr e) tr)) tr))) trl)))) (vl-remove (car e) (vl-remove (cadr e) (if (null qq) (setq qq (vl-remove-if (function (lambda ( y ) (vl-every (function (lambda ( ee / yy ) (and (vl-position y ee) (setq yy (car (vl-remove y ee))) (= (length (vl-remove-if (function (lambda ( eee ) (and (vl-position y eee) (vl-position yy eee)))) ell)) (- (length ell) 2))))) ell))) xx)) qq)))) (function (lambda ( a b ) (< (distance (list (caar e) (cadar e)) a) (distance (list (caar e) (cadar e)) b)))))
  176.           )
  177.           )) el
  178.         )
  179.       )
  180.       (princ (strcat "\n" (itoa (length trl)) " triangles calculated at : " (rtos (- (car (_vl-times)) ti) 2 50) " milliseconds..."))
  181.       (foreach tr trl
  182.         (entmake (list '(0 . "3DFACE") (cons 10 (trans (car tr) 1 0)) (cons 11 (trans (car tr) 1 0)) (cons 12 (trans (cadr tr) 1 0)) (cons 13 (trans (caddr tr) 1 0))))
  183.       )
  184.       (princ (strcat "\nTriangulation completed at : " (rtos (- (car (_vl-times)) ti) 2 50) " milliseconds..."))
  185.     )
  186.   )
  187.   (vla-endundomark *adoc*)
  188.   (princ)
  189. )
  190.  

Regards, M.R.
[EDIT : Code little changed from dtr-vl-some.html version... Gain in time is 1 sec. on 75 seconds...]
Change is referenced only on (vl-some) version in part where list of checking points is initiated for selected edge and now from point list both edge points and vertex (3rd triangle point) if triangle with selected edge is found are removed...
Change is highlighted in code (lines 144 and 177)...
« Last Edit: June 19, 2019, 12:36:24 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

sanju2323

  • Newt
  • Posts: 68
Re: Triangulation (re-visited)
« Reply #757 on: February 27, 2019, 06:31:09 AM »
ribarm,
Thanks for the code.. :-)

ribarm

  • Gator
  • Posts: 2780
  • Marko Ribar, architect
Re: Triangulation (re-visited)
« Reply #758 on: February 28, 2019, 09:50:34 AM »
I've changed a little dtr-vl-some.lsp routine... See my previous post...

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

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 2780
  • Marko Ribar, architect
Re: Triangulation (re-visited)
« Reply #759 on: March 01, 2019, 07:26:25 AM »
Some new mods. of (dtr-while.lsp) posted here :
http://www.theswamp.org/index.php?topic=9042.msg593217#msg593217

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

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 2780
  • Marko Ribar, architect
Re: Triangulation (re-visited)
« Reply #760 on: March 02, 2019, 09:49:21 AM »
Now when its all written I've noticed one more blunder...

This marked red, you should cut-paste as follows :
Quote
...
            (if
              (and
                (setq q (circum (car e) (cadr e) x))
                (car q)
                (not (ptincir (car q) (cadr q) (vl-remove (car e) (vl-remove (cadr e) (vl-remove x (append xx pl))))))
                (not (vl-some (function (lambda ( tr ) (and (vl-position (car e) tr) (vl-position (cadr e) tr) (vl-position x tr)))) trl))
              )
              (progn
                (setq trl (cons (list (car e) (cadr e) x) trl))
                (if (not (or (vl-position (list (cadr e) x) el) (vl-position (list x (cadr e)) el)))
                  (setq el (cons (list (cadr e) x) el) ell (cons (list (cadr e) x) ell))
                  (setq el (vl-remove-if (function (lambda ( ee ) (or (equal (list (cadr e) x) ee) (equal (list x (cadr e)) ee)))) el))
                )
                (if (not (or (vl-position (list (car e) x) el) (vl-position (list x (car e)) el)))
                  (setq el (cons (list (car e) x) el) ell (cons (list (car e) x) ell))
                  (setq el (vl-remove-if (function (lambda ( ee ) (or (equal (list (car e) x) ee) (equal (list x (car e)) ee)))) el))
                )
...

Like this :
Quote
...
            (if
              (and
                (setq q (circum (car e) (cadr e) x))
                (car q)
                (not (ptincir (car q) (cadr q) (vl-remove (car e) (vl-remove (cadr e) (vl-remove x (append xx pl))))))
                (not (vl-some (function (lambda ( tr ) (and (vl-position (car e) tr) (vl-position (cadr e) tr) (vl-position x tr)))) trl))
              )
              (progn
                (setq trl (cons (list (car e) (cadr e) x) trl))
                (if (not (or (vl-position (list (cadr e) x) el) (vl-position (list x (cadr e)) el)))
                  (setq el (cons (list (cadr e) x) el))
                  (setq el (vl-remove-if (function (lambda ( ee ) (or (equal (list (cadr e) x) ee) (equal (list x (cadr e)) ee)))) el))
                )
                (setq ell (cons (list (cadr e) x) ell))
                (if (not (or (vl-position (list (car e) x) el) (vl-position (list x (car e)) el)))
                  (setq el (cons (list (car e) x) el))
                  (setq el (vl-remove-if (function (lambda ( ee ) (or (equal (list (car e) x) ee) (equal (list x (car e)) ee)))) el))
                )
                (setq ell (cons (list (car e) x) ell))
...

This blunder you should correct in all occurrences in all dtr.lsp posted codes by me... (dtr-while.lsp versions have more this places, so just take your patience and fix this...) Hopefully this is such mistake that is easy to correct, only thing is that you'll save just few milliseconds in routine execution which is ALISP codes that are terribly slow... But my part I did, hoping that Daniel or someone else that works in different languages will answer and reply, so I'll change just my last posted code in code tags (vl-some version) as its the fastest (best) till now...
Sorry, we are all humans and sometimes we make blunders, but in time those things are hopefully fixed over...
Regards, M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

VovKa

  • Swamp Rat
  • Posts: 1488
  • Ukraine
Re: Triangulation (re-visited)
« Reply #761 on: March 02, 2019, 03:47:49 PM »
which is ALISP codes that are terribly slow...
yes it is significantly slower than compiled executables but much depends on algorithms and optimization
your code is quite long so it is not easy (especially for a stranger like me) to tell where's the flaw
but i'm sure there is a way to make the code run faster

ribarm

  • Gator
  • Posts: 2780
  • Marko Ribar, architect
Re: Triangulation (re-visited)
« Reply #762 on: March 03, 2019, 08:09:23 AM »
which is ALISP codes that are terribly slow...
yes it is significantly slower than compiled executables but much depends on algorithms and optimization
your code is quite long so it is not easy (especially for a stranger like me) to tell where's the flaw
but i'm sure there is a way to make the code run faster

Look VovKa, or anyone who is reading...
Yes, you can say always that there is for sure way to make the code run faster, but I am pretty sure that without initial sorting of points and without using supertriangle in start and as premise, that my version (vl-some) is optimized as much as possible and is running as fast as possible... My version of Deluneay is as I can say basic algorithm for it and my wish is to make that version be translated to faster executable dll/arx version as I guess that version Daniel posted here : https://www.theswamp.org/index.php?topic=28889.msg593095#msg593095  is using supertriangle - there are no convex hull triangles processed... Beside all of this there is ALISP version by Evgeniy's algorithm that uses big supertriangle and is getting convex hull triangles and all that very fast : http://www.theswamp.org/index.php?topic=15784.msg593121#msg593121 , but I still think that that method can sometime be unreliable, so I am sticking with basic version without supertriangle... I know that this is inevitably going to be much slower than already created arx by Daniel, but my intention is to collect all versions as in practice I may never face with 1000000 pts (that amount of points), but I may need to have it correctly done some reasonably smaller number of points but in correct manner with convex hull triangles processed and in relatively fast timings... My LISP (vl-some) is already doing that as I wanted, but I am pretty sure that with exact translation of code into dll/arx timings could be much better, meaning that this could cover and more complex requirements in terms of amount of points processed...

I hope you understand my intentions and beside all this I am not professional programmer, just an architect...
M.R.
« Last Edit: March 03, 2019, 08:13:13 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 2780
  • Marko Ribar, architect
Re: Triangulation (re-visited)
« Reply #763 on: March 03, 2019, 11:57:41 AM »
There was a lack in (LM:ConvexHull-ptsonHull) sub function... I know - modifications have to be made in all routines, but I'll leave that to you... This mod that I did in code tag where (vl-some) version is posted should be made also in all codes I posted with that sub - I mean on topic with TSP problem started by Evgeniy... Sorry, who knows what I'll catch too in future...

OK., I corrected my inputs here : http://www.theswamp.org/index.php?topic=30434.0

M.R.
« Last Edit: March 03, 2019, 12:12:02 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1569
  • Moscow (Russia)
Re: Triangulation (re-visited)
« Reply #764 on: March 04, 2019, 03:38:09 AM »
What should the triangles look like for these four points?
« Last Edit: March 04, 2019, 04:23:49 AM by ElpanovEvgeniy »