TheSwamp

Code Red => AutoLISP (Vanilla / Visual) => Topic started by: mailmaverick on April 01, 2015, 11:30:26 AM

Title: Challenge : Contour to Elevation Points
Post by: mailmaverick on April 01, 2015, 11:30:26 AM

Dear All,

We have seen many threads / posts such as Triangulation and others where we try to make contours from Points or Elevations Text.

Can anyone do reverse of the same i.e. we have got contours and we wish to get corresponding points such that when we again draw the contours from these points, they exactly match the original contours.

Now for the challenge :- Challenge is to achieve it with minimum number of elevation points.

I am attaching a sample Contours File. The contours have been drawn using Civil 3D. Let us see who achieves minimum number of elevation points.

Title: Re: Challenge : Contour to Levels Text / Points
Post by: ribarm on April 01, 2015, 11:36:58 AM

I don't understand... Any 3 points obtained from such contours define its plane and elevation, so if you have contour, you just have to choose any 3 to satisfy such challenge - you can do this with (vlax-curve-getpointatparam) or (vlax-curve-getpointatdist)...

Title: Re: Challenge : Contour to Levels Text / Points
Post by: mailmaverick on April 01, 2015, 12:35:24 PM

Dear Marko

I think you have misunderstood the problem.

Kindly see the attached AutoCAD file where I have given contour polylines.

These have been generated from a set of points (having elevations) using Civil 3D.

Now using these contours, how can we generate the original set of points ?

I am attaching my original set of points too in this post.

Title: Re: Challenge : Contour to Levels Text / Points
Post by: tombu on April 01, 2015, 12:44:39 PM

Not possible! You'd be better off using those contours for the surface than points from them.  The quality of the surface data goes down with every conversion.

Title: Re: Challenge : Contour to Levels Text / Points
Post by: mailmaverick on April 01, 2015, 12:46:19 PM

I know that it is better to use contours for surface than points.

But this problem is more of a challenge than actual use.

Title: Re: Challenge : Contour to Levels Text / Points
Post by: ymg on April 01, 2015, 12:50:57 PM

mailmawerick,

What you are after is simply not possible.

The closest you can get is to use all contours as breaklines
and generate a TIN from this.

Your original points are loss, but you have a more or less
equivalent surface.

Maybe knowing the algo used to generate the contours,
we could reverse it some.  But that would be a very
intensive task.

ymg

Title: Re: Challenge : Contour to Levels Text / Points
Post by: mailmaverick on April 01, 2015, 01:00:04 PM

Dear ymg

I agree to what you are saying. But I dont want the TIN surface.

I want the original points.

And, if not original points, minimum number of points which can generate same contours.

Title: Re: Challenge : Contour to Levels Text / Points
Post by: ymg on April 01, 2015, 01:14:19 PM

mailmaverick,

Are your contours smoothed ?

If not finding sets of points that are parrallels
would certainly hint that that they were in
the same triangle.

If you use the contour segments instead of points
the problem is easier.

Say you are on contour x , look to contour x + interval
and find the parallel segment.

The 4 endpoints of those two segments are lying on
two edges of the triangle that generated it.

Then keep going and do intersections to get
the original points.

ymg

Title: Re: Challenge : Contour to Levels Text / Points
Post by: mailmaverick on April 01, 2015, 01:18:04 PM

Dear ymg

As I told you I am not looking into any particular problem. It is just academics / learning / fun.

Regarding smoothening of contours, let us start by assuming that they are not smoothened.

Title: Re: Challenge : Contour to Levels Text / Points
Post by: ymg on April 01, 2015, 01:28:25 PM

maimaverick,

Post the contour, instead of the point
and see the edit in above post.

Marko's point is also valid, we can do
a bunch of plane intersections we will generates
the edges of the original triangulation.

ymg

Title: Re: Challenge : Contour to Levels Text / Points
Post by: mailmaverick on April 01, 2015, 01:29:41 PM

Dear ymg

Contours have been posted in my first post i.e. Post No 1.

Title: Re: Challenge : Contour to Levels Text / Points
Post by: ymg on April 01, 2015, 01:42:14 PM

here what I mean:

Title: Re: Challenge : Contour to Levels Text / Points
Post by: mailmaverick on April 01, 2015, 01:58:54 PM

Quote from: ymg on April 01, 2015, 01:14:19 PM

mailmaverick,

Are your contours smoothed ?

If not finding sets of points that are parrallels
would certainly hint that that they were in
the same triangle.

If you use the contour segments instead of points
the problem is easier.

Say you are on contour x , look to contour x + interval
and find the parallel segment.

The 4 endpoints of those two segments are lying on
two edges of the triangle that generated it.

Then keep going and do intersections to get
the original points.

ymg

Quote from: ymg on April 01, 2015, 01:42:14 PM

here what I mean:

Dear ymg,

I have studied your posts in detail.

But I dont know how to do it in LISP.

Whenever you have time, please do the same.

Thanks in advance..

Title: Re: Challenge : Contour to Elevation Points
Post by: ymg on April 01, 2015, 04:17:00 PM

mailmaverick,

I have other things to do.

My point is that it is feasible,
but the Devil is in the details...

ymg

Title: Re: Challenge : Contour to Elevation Points
Post by: ymg on April 01, 2015, 07:10:09 PM

mailmaverick,

For a low-tech solution just draw lines that
seems to be side of a triangle.

Then fillet with zero radius.  With patience
you can reconstruct the whole triangulation.

See a partial reconstruction:

Title: Re: Challenge : Contour to Elevation Points
Post by: mailmaverick on April 02, 2015, 04:24:21 AM

Dear ymg

What you are saying can be done manually. But how to do through LISP ?

Title: Re: Challenge : Contour to Elevation Points
Post by: ribarm on April 02, 2015, 01:57:08 PM

mailmaverick, try this code, totally untested - first draft so you probably need to debug it...

[EDIT : I've debugged it, but it isn't match with original points... Maybe CAD miscalculated something...]

Code - Auto/Visual Lisp: [Select]

1. (defun c:cont2pts ( / unit unique ss i lw ellw lwpts lworts lwptsorts orts lwsptsorts ptortptl p1 p2 p3 pl )
2.  
3.   (defun unit ( v )
4.     (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
5.   )
6.  
7.   (defun unique ( l )
8.     (if l (cons (car l) (vl-remove-if '(lambda ( x ) (equal x (car l) 1e-6)) (unique (cdr l)))))
9.   )
10.  
11.   (setq ss (ssget '((0 . "LWPOLYLINE"))))
12.   (repeat (setq i (sslength ss))
13.     (setq lw (ssname ss (setq i (1- i))))
14.     (setq ellw (cdr (assoc 38 (entget lw))))
15.     (setq lwpts (mapcar '(lambda ( p ) (list (car p) (cadr p) ellw)) (unique (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= (car x) 10)) (entget lw))))))
16.     (if (eq 1 (logand 1 (cdr (assoc 70 (entget lw)))))
17.       (progn
18.         (setq lworts (mapcar 'unit (mapcar '(lambda ( a b ) (mapcar '- b a)) lwpts (cdr (reverse (cons (car lwpts) (reverse lwpts)))))))
19.         (setq lwptsorts (mapcar '(lambda ( a b c ) (list a b c)) lwpts lworts (cdr (reverse (cons (car lwpts) (reverse lwpts))))))
20.       )
21.       (progn
22.         (setq lworts (mapcar 'unit (mapcar '(lambda ( a b ) (mapcar '- b a)) lwpts (cdr lwpts))))
23.         (setq lwptsorts (mapcar '(lambda ( a b c ) (list a b c)) lwpts lworts (cdr lwpts)))
24.       )
25.     )
26.     (setq orts (append lworts orts))
27.     (setq lwsptsorts (cons (list ellw lwptsorts) lwsptsorts))
28.   )
29.   (setq lwsptsorts (vl-sort lwsptsorts '(lambda ( a b ) (< (car a) (car b)))))
30.   (setq orts (unique orts))
31.   (foreach ort orts
32.     (setq ptortptl (vl-remove nil (mapcar '(lambda ( x / z ) (if (setq z (vl-remove-if-not '(lambda ( y ) (equal ort (cadr y) 1e-6)) (cadr x))) (apply 'append z))) lwsptsorts)))
33.     (if (> (length ptortptl) 1)
34.       (progn
35.         (setq p1 (inters (caar ptortptl) (caadr ptortptl) (caddar ptortptl) (caddr (cadr ptortptl)) nil))
36.         (setq p2 (inters (car (last ptortptl)) (car (car (cdr (reverse ptortptl)))) (caddr (last ptortptl)) (caddr (car (cdr (reverse ptortptl)))) nil))
37.         (if (equal p1 p2 1e-6)
38.           (setq p3 (caar ptortptl) p2 (caddar ptortptl))
39.           (cond
40.             ( (equal (unit (mapcar '- (caadr ptortptl) (caar ptortptl))) (unit (mapcar '- (car (last ptortptl)) (car (car (cdr (reverse ptortptl)))))) 1e-6)
41.               (setq p3 (inters (caddar ptortptl) (caddr (cadr ptortptl)) (caddr (last ptortptl)) (caddr (car (cdr (reverse ptortptl)))) nil))
42.             )
43.             ( (equal (unit (mapcar '- (caddr (cadr ptortptl)) (caddar ptortptl))) (unit (mapcar '- (caddr (last ptortptl)) (caddr (car (cdr (reverse ptortptl)))))) 1e-6)
44.               (setq p3 (inters (caar ptortptl) (caadr ptortptl) (car (last ptortptl)) (car (car (cdr (reverse ptortptl)))) nil))
45.             )
46.             ( t (setq p3 nil) )
47.           )
48.         )
49.         (setq pl (cons p1 pl) pl (cons p2 pl) pl (cons p3 pl))
50.       )
51.     )
52.   )
53.   (setq pl (vl-remove nil (unique pl)))
54.   (foreach p pl
55.     (entmake (list '(0 . "POINT") (cons 10 p)))
56.   )
57.   (princ)
58. )
59.  

M.R.

Title: Re: Challenge : Contour to Elevation Points
Post by: mailmaverick on April 02, 2015, 10:31:33 PM

Thanks Marco for your initiative.

I hope lot many more people contribute to this thread and improve the routine.

Title: Re: Challenge : Contour to Elevation Points
Post by: ribarm on July 25, 2015, 11:43:26 AM

My name is Marko and this version is maybe and I said maybe just a little better than previous code...

Code - Auto/Visual Lisp: [Select]

1. (defun c:cont2pts ( / unit unique ss i lw ellw lwpts lworts lwptsorts orts lwsptsorts ptortptl p1 p2 p3 pl pll pxx1 pxx2 pyy1 pyy2 )
2.  
3.   (defun unit ( v )
4.     (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
5.   )
6.  
7.   (defun unique ( l )
8.     (if l (cons (car l) (vl-remove-if '(lambda ( x ) (equal x (car l) 1e-6)) (unique (cdr l)))))
9.   )
10.  
11.   (setq ss (ssget '((0 . "LWPOLYLINE"))))
12.   (repeat (setq i (sslength ss))
13.     (setq lw (ssname ss (setq i (1- i))))
14.     (setq ellw (cdr (assoc 38 (entget lw))))
15.     (setq lwpts (mapcar '(lambda ( p ) (list (car p) (cadr p) ellw)) (unique (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= (car x) 10)) (entget lw))))))
16.     (if (eq 1 (logand 1 (cdr (assoc 70 (entget lw)))))
17.       (progn
18.         (setq lworts (mapcar 'unit (mapcar '(lambda ( a b ) (mapcar '- b a)) lwpts (cdr (reverse (cons (car lwpts) (reverse lwpts)))))))
19.         (setq lwptsorts (mapcar '(lambda ( a b c ) (list a b c)) lwpts lworts (cdr (reverse (cons (car lwpts) (reverse lwpts))))))
20.       )
21.       (progn
22.         (setq lworts (mapcar 'unit (mapcar '(lambda ( a b ) (mapcar '- b a)) lwpts (cdr lwpts))))
23.         (setq lwptsorts (mapcar '(lambda ( a b c ) (list a b c)) lwpts lworts (cdr lwpts)))
24.       )
25.     )
26.     (setq orts (append lworts orts))
27.     (setq lwsptsorts (cons (list ellw lwptsorts) lwsptsorts))
28.   )
29.   (setq lwsptsorts (vl-sort lwsptsorts '(lambda ( a b ) (< (car a) (car b)))))
30.   (setq orts (unique orts))
31.   (foreach ort orts
32.     (setq ptortptl (vl-remove nil (mapcar '(lambda ( x / z ) (if (setq z (vl-remove-if-not '(lambda ( y ) (equal ort (cadr y) 1e-6)) (cadr x))) (apply 'append z))) lwsptsorts)))
33.     (if (> (length ptortptl) 1)
34.       (progn
35.         (setq p1 (inters (caar ptortptl) (caadr ptortptl) (caddar ptortptl) (caddr (cadr ptortptl)) nil))
36.         (setq p2 (inters (car (last ptortptl)) (car (car (cdr (reverse ptortptl)))) (caddr (last ptortptl)) (caddr (car (cdr (reverse ptortptl)))) nil))
37.         (if (equal p1 p2 1e-6)
38.           (setq p3 (caar ptortptl) p2 (caddar ptortptl))
39.           (cond
40.             ( (equal (unit (mapcar '- (caadr ptortptl) (caar ptortptl))) (unit (mapcar '- (car (last ptortptl)) (car (car (cdr (reverse ptortptl)))))) 1e-6)
41.               (setq p3 (inters (caddar ptortptl) (caddr (cadr ptortptl)) (caddr (last ptortptl)) (caddr (car (cdr (reverse ptortptl)))) nil))
42.             )
43.             ( (equal (unit (mapcar '- (caddr (cadr ptortptl)) (caddar ptortptl))) (unit (mapcar '- (caddr (last ptortptl)) (caddr (car (cdr (reverse ptortptl)))))) 1e-6)
44.               (setq p3 (inters (caar ptortptl) (caadr ptortptl) (car (last ptortptl)) (car (car (cdr (reverse ptortptl)))) nil))
45.             )
46.             ( t (setq p3 nil) )
47.           )
48.         )
49.         (setq pl (cons (list p1 (list p2 p3)) pl))
50.       )
51.     )
52.   )
53.   (setq pl (vl-remove-if '(lambda ( x ) (or (< (caddr (car x)) (caddr (car (cadr x)))) (< (caddr (car x)) (caddr (cadr (cadr x)))))) pl))
54.   (foreach px pl
55.     (setq pll (cons (car px) pll))
56.     (setq pxx1 (cadr (vl-sort pl '(lambda ( a b ) (< (distance (caadr a) (caadr px)) (distance (caadr b) (caadr px)))))))
57.     (setq pxx2 (car (vl-sort pl '(lambda ( a b ) (< (distance (cadadr a) (caadr px)) (distance (cadadr b) (caadr px)))))))
58.     (if (caadr px)
59.       (setq p2 (if (and (inters (car px) (caadr px) (car pxx1) (caadr pxx1) nil) (inters (car px) (caadr px) (car pxx2) (cadadr pxx2) nil))
60.                  (if (< (distance (inters (car px) (caadr px) (car pxx1) (caadr pxx1) nil) (caadr px)) (distance (inters (car px) (caadr px) (car pxx2) (cadadr pxx2) nil) (caadr px)))
61.                    (inters (car px) (caadr px) (car pxx1) (caadr pxx1) nil)
62.                    (inters (car px) (caadr px) (car pxx2) (cadadr pxx2) nil)
63.                  )
64.                  nil
65.                )
66.       )
67.       (setq p2 nil)
68.     )
69.     (setq pyy1 (cadr (vl-sort pl '(lambda ( a b ) (< (distance (cadadr a) (cadadr px)) (distance (cadadr b) (cadadr px)))))))
70.     (setq pyy2 (car (vl-sort pl '(lambda ( a b ) (< (distance (caadr a) (cadadr px)) (distance (caadr b) (cadadr px)))))))
71.     (if (cadadr px)
72.       (setq p3 (if (and (inters (car px) (cadadr px) (car pyy1) (cadadr pyy1) nil) (inters (car px) (cadadr px) (car pyy2) (caadr pyy2) nil))
73.                  (if (< (distance (inters (car px) (cadadr px) (car pyy1) (cadadr pyy1) nil) (cadadr px)) (distance (inters (car px) (cadadr px) (car pyy2) (caadr pyy2) nil) (cadadr px)))
74.                    (inters (car px) (cadadr px) (car pyy1) (cadadr pyy1) nil)
75.                    (inters (car px) (cadadr px) (car pyy2) (caadr pyy2) nil)
76.                  )
77.                  nil
78.                )
79.       )
80.       (setq p3 nil)
81.     )
82.     (if p2 (setq pll (cons p2 pll)))
83.     (if p3 (setq pll (cons p3 pll)))
84.   )
85.   (setq pll (vl-remove nil (unique pll)))
86.   (foreach p pll
87.     (entmake (list '(0 . "POINT") (cons 10 p)))
88.   )
89.   (princ)
90. )
91.  

HTH, M.R.

Title: Re: Challenge : Contour to Elevation Points
Post by: ribarm on July 25, 2015, 02:41:58 PM

I had a small mistake in my last code - now fixed... Regards...

Title: Re: Challenge : Contour to Elevation Points
Post by: ribarm on July 26, 2015, 03:35:15 AM

Here is another variant, better than previous, but still there are lacks...

Code - Auto/Visual Lisp: [Select]

1. (defun c:cont2pts ( / unit unique plremnonunique ss i lw ellw lwpts lworts lwptsorts orts lwsptsorts ptortptl p1 p2 p3 pl pll pxx pxx1 pxx2 pyy pyy1 pyy2 )
2.  
3.   (defun unit ( v )
4.     (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
5.   )
6.  
7.   (defun unique ( l )
8.     (if l (cons (car l) (vl-remove-if '(lambda ( x ) (equal x (car l) 1e-6)) (unique (cdr l)))))
9.   )
10.  
11.   (defun plremnonunique ( l )
12.     (foreach el l
13.       (if (eq (length (vl-remove-if-not '(lambda ( x ) (equal (car x) (car el) 1e-6)) l)) 1)
14.         (setq l (vl-remove el l))
15.       )
16.     )
17.     l
18.   )
19.  
20.   (setq ss (ssget '((0 . "LWPOLYLINE"))))
21.   (repeat (setq i (sslength ss))
22.     (setq lw (ssname ss (setq i (1- i))))
23.     (setq ellw (cdr (assoc 38 (entget lw))))
24.     (setq lwpts (mapcar '(lambda ( p ) (list (car p) (cadr p) ellw)) (unique (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= (car x) 10)) (entget lw))))))
25.     (if (eq 1 (logand 1 (cdr (assoc 70 (entget lw)))))
26.       (progn
27.         (setq lworts (mapcar 'unit (mapcar '(lambda ( a b ) (mapcar '- b a)) lwpts (cdr (reverse (cons (car lwpts) (reverse lwpts)))))))
28.         (setq lwptsorts (mapcar '(lambda ( a b c ) (list a b c)) lwpts lworts (cdr (reverse (cons (car lwpts) (reverse lwpts))))))
29.       )
30.       (progn
31.         (setq lworts (mapcar 'unit (mapcar '(lambda ( a b ) (mapcar '- b a)) lwpts (cdr lwpts))))
32.         (setq lwptsorts (mapcar '(lambda ( a b c ) (list a b c)) lwpts lworts (cdr lwpts)))
33.       )
34.     )
35.     (setq orts (append lworts orts))
36.     (setq lwsptsorts (cons (list ellw lwptsorts) lwsptsorts))
37.   )
38.   (setq lwsptsorts (vl-sort lwsptsorts '(lambda ( a b ) (< (car a) (car b)))))
39.   (setq orts (unique orts))
40.   (foreach ort orts
41.     (setq ptortptl (vl-remove nil (mapcar '(lambda ( x / z ) (if (setq z (vl-remove-if-not '(lambda ( y ) (equal ort (cadr y) 1e-6)) (cadr x))) (apply 'append z))) lwsptsorts)))
42.     (while (> (length ptortptl) 1)
43.       (progn
44.         (setq p1 (inters (caar ptortptl) (caadr ptortptl) (caddar ptortptl) (caddr (cadr ptortptl)) nil))
45.         (setq p2 (caar ptortptl) p3 (caddar ptortptl))
46.         (if (and p1 (> (caddr p1) (caddr p2)) (> (caddr p1) (caddr p3)))
47.           (setq pl (cons (list p1 (list p2 p3)) pl))
48.         )
49.         (setq ptortptl (cdr ptortptl))
50.       )
51.     )
52.   )
53.   (setq pl (plremnonunique pl))
54.   (foreach px pl
55.     (setq pll (cons (car px) pll))
56.     (setq pxx1 (cadr (vl-sort pl '(lambda ( a b ) (< (distance (caadr a) (caadr px)) (distance (caadr b) (caadr px)))))))
57.     (setq pxx2 (if (equal (car (setq pxx (vl-sort pl '(lambda ( a b ) (< (distance (cadadr a) (caadr px)) (distance (cadadr b) (caadr px))))))) px 1e-6) (cadr pxx) (car pxx)))
58.     (if (caadr px)
59.       (setq p2 (if (and (inters (car px) (caadr px) (car pxx1) (caadr pxx1) nil) (inters (car px) (caadr px) (car pxx2) (cadadr pxx2) nil))
60.                  (if (< (distance (inters (car px) (caadr px) (car pxx1) (caadr pxx1) nil) (caadr px)) (distance (inters (car px) (caadr px) (car pxx2) (cadadr pxx2) nil) (caadr px)))
61.                    (inters (car px) (caadr px) (car pxx1) (caadr pxx1) nil)
62.                    (inters (car px) (caadr px) (car pxx2) (cadadr pxx2) nil)
63.                  )
64.                  nil
65.                )
66.       )
67.       (setq p2 nil)
68.     )
69.     (setq pyy1 (cadr (vl-sort pl '(lambda ( a b ) (< (distance (cadadr a) (cadadr px)) (distance (cadadr b) (cadadr px)))))))
70.     (setq pyy2 (if (equal (car (setq pyy (vl-sort pl '(lambda ( a b ) (< (distance (caadr a) (cadadr px)) (distance (caadr b) (cadadr px))))))) px 1e-6) (cadr pyy) (car pyy)))
71.     (if (cadadr px)
72.       (setq p3 (if (and (inters (car px) (cadadr px) (car pyy1) (cadadr pyy1) nil) (inters (car px) (cadadr px) (car pyy2) (caadr pyy2) nil))
73.                  (if (< (distance (inters (car px) (cadadr px) (car pyy1) (cadadr pyy1) nil) (cadadr px)) (distance (inters (car px) (cadadr px) (car pyy2) (caadr pyy2) nil) (cadadr px)))
74.                    (inters (car px) (cadadr px) (car pyy1) (cadadr pyy1) nil)
75.                    (inters (car px) (cadadr px) (car pyy2) (caadr pyy2) nil)
76.                  )
77.                  nil
78.                )
79.       )
80.       (setq p3 nil)
81.     )
82.     (if p2 (setq pll (cons p2 pll)))
83.     (if p3 (setq pll (cons p3 pll)))
84.   )
85.   (setq pll (vl-remove nil (unique pll)))
86.   (foreach p pll
87.     (entmake (list '(0 . "POINT") (cons 10 p)))
88.   )
89.   (princ)
90. )
91.  

Regards, M.R.

Title: Re: Challenge : Contour to Elevation Points
Post by: ribarm on July 26, 2015, 02:38:25 PM

This is how far I went... I'll rest now as I don't see how should I continue... Maybe someone sees something I don't... M.R.

Code - Auto/Visual Lisp: [Select]

1. (defun c:cont2pts ( / unit unique plremnonunique collinear-p ss i lw ellw lwpts lworts lwptsorts orts lwsptsorts ptortptl p1s p1 p2 p3 pl pll d pxx pxx1 pxx2 pyy pyy1 pyy2 )
2.  
3.   (defun unit ( v )
4.     (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
5.   )
6.  
7.   (defun unique ( l )
8.     (if l (cons (car l) (vl-remove-if '(lambda ( x ) (equal x (car l) 1e-6)) (unique (cdr l)))))
9.   )
10.  
11.   (defun plremnonunique ( l )
12.     (foreach el l
13.       (if (eq (length (vl-remove-if-not '(lambda ( x ) (equal (car x) (car el) 1e-6)) l)) 1)
14.         (setq l (vl-remove el l))
15.       )
16.     )
17.     l
18.   )
19.  
20.   (defun collinear-p ( p1 p p2 )
21.     (equal (distance p1 p2) (+ (distance p1 p) (distance p p2)) 1e-6)
22.   )
23.  
24.   (setq ss (ssget '((0 . "LWPOLYLINE"))))
25.   (repeat (setq i (sslength ss))
26.     (setq lw (ssname ss (setq i (1- i))))
27.     (setq ellw (cdr (assoc 38 (entget lw))))
28.     (setq lwpts (mapcar '(lambda ( p ) (list (car p) (cadr p) ellw)) (unique (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= (car x) 10)) (entget lw))))))
29.     (if (eq 1 (logand 1 (cdr (assoc 70 (entget lw)))))
30.       (progn
31.         (setq lworts (mapcar 'unit (mapcar '(lambda ( a b ) (mapcar '- b a)) lwpts (cdr (reverse (cons (car lwpts) (reverse lwpts)))))))
32.         (setq lwptsorts (mapcar '(lambda ( a b c ) (list a b c)) lwpts lworts (cdr (reverse (cons (car lwpts) (reverse lwpts))))))
33.       )
34.       (progn
35.         (setq lworts (mapcar 'unit (mapcar '(lambda ( a b ) (mapcar '- b a)) lwpts (cdr lwpts))))
36.         (setq lwptsorts (mapcar '(lambda ( a b c ) (list a b c)) lwpts lworts (cdr lwpts)))
37.       )
38.     )
39.     (setq orts (append lworts orts))
40.     (setq lwsptsorts (cons (list ellw lwptsorts) lwsptsorts))
41.   )
42.   (setq lwsptsorts (vl-sort lwsptsorts '(lambda ( a b ) (< (car a) (car b)))))
43.   (setq orts (unique orts))
44.   (foreach ort orts
45.     (setq ptortptl (vl-remove nil (mapcar '(lambda ( x / z ) (if (setq z (vl-remove-if-not '(lambda ( y ) (equal ort (cadr y) 1e-6)) (cadr x))) (apply 'append z))) lwsptsorts)))
46.     (while (> (length ptortptl) 1)
47.       (progn
48.         (setq p1 (inters (caar ptortptl) (caadr ptortptl) (caddar ptortptl) (caddr (cadr ptortptl)) nil))
49.         (setq p2 (caar ptortptl) p3 (caddar ptortptl))
50.         (if (and p1 p2 p3) (setq pl (cons (list p1 (list p2 p3)) pl)))
51.         (setq ptortptl (cdr ptortptl))
52.       )
53.     )
54.   )
55.   ;(setq pl (plremnonunique pl))
56.   (setq p1s (unique (mapcar 'car pl)))
57.   ;|
58.   (foreach px pl
59.     (setq pll (cons (car px) pll))
60.     (setq pxx1 (cadr (vl-sort pl '(lambda ( a b ) (< (distance (caadr a) (caadr px)) (distance (caadr b) (caadr px)))))))
61.     (setq pxx2 (if (equal (car (setq pxx (vl-sort pl '(lambda ( a b ) (< (distance (cadadr a) (caadr px)) (distance (cadadr b) (caadr px))))))) px 1e-6) (cadr pxx) (car pxx)))
62.     (if (caadr px)
63.       (setq p2 (if (and (inters (car px) (caadr px) (car pxx1) (caadr pxx1) nil) (inters (car px) (caadr px) (car pxx2) (cadadr pxx2) nil))
64.                  (if (< (distance (inters (car px) (caadr px) (car pxx1) (caadr pxx1) nil) (caadr px)) (distance (inters (car px) (caadr px) (car pxx2) (cadadr pxx2) nil) (caadr px)))
65.                    (inters (car px) (caadr px) (car pxx1) (caadr pxx1) nil)
66.                    (inters (car px) (caadr px) (car pxx2) (cadadr pxx2) nil)
67.                  )
68.                  (cond
69.                    ( (and (inters (car px) (caadr px) (car pxx1) (caadr pxx1) nil) (not (inters (car px) (caadr px) (car pxx2) (cadadr pxx2) nil)))
70.                      (inters (car px) (caadr px) (car pxx1) (caadr pxx1) nil)
71.                    )
72.                    ( (and (inters (car px) (caadr px) (car pxx2) (cadadr pxx2) nil) (not (inters (car px) (caadr px) (car pxx1) (caadr pxx1) nil)))
73.                      (inters (car px) (caadr px) (car pxx2) (cadadr pxx2) nil)
74.                    )
75.                    ( t nil )
76.                  )
77.                )
78.       )
79.       (setq p2 nil)
80.     )
81.     (setq pyy1 (cadr (vl-sort pl '(lambda ( a b ) (< (distance (cadadr a) (cadadr px)) (distance (cadadr b) (cadadr px)))))))
82.     (setq pyy2 (if (equal (car (setq pyy (vl-sort pl '(lambda ( a b ) (< (distance (caadr a) (cadadr px)) (distance (caadr b) (cadadr px))))))) px 1e-6) (cadr pyy) (car pyy)))
83.     (if (cadadr px)
84.       (setq p3 (if (and (inters (car px) (cadadr px) (car pyy1) (cadadr pyy1) nil) (inters (car px) (cadadr px) (car pyy2) (caadr pyy2) nil))
85.                  (if (< (distance (inters (car px) (cadadr px) (car pyy1) (cadadr pyy1) nil) (cadadr px)) (distance (inters (car px) (cadadr px) (car pyy2) (caadr pyy2) nil) (cadadr px)))
86.                    (inters (car px) (cadadr px) (car pyy1) (cadadr pyy1) nil)
87.                    (inters (car px) (cadadr px) (car pyy2) (caadr pyy2) nil)
88.                  )
89.                  (cond
90.                    ( (and (inters (car px) (cadadr px) (car pyy1) (cadadr pyy1) nil) (not (inters (car px) (cadadr px) (car pyy2) (caadr pyy2) nil)))
91.                      (inters (car px) (cadadr px) (car pyy1) (cadadr pyy1) nil)
92.                    )
93.                    ( (and (inters (car px) (cadadr px) (car pyy2) (caadr pyy2) nil) (not (inters (car px) (cadadr px) (car pyy1) (cadadr pyy1) nil)))
94.                      (inters (car px) (cadadr px) (car pyy2) (caadr pyy2) nil)
95.                    )
96.                    ( t nil )
97.                  )
98.                )
99.       )
100.       (setq p3 nil)
101.     )
102.     (if p2 (setq pll (cons p2 pll)))
103.     (if p3 (setq pll (cons p3 pll)))
104.   )
105.   |;
106.   (foreach px pl
107.     (setq pll (cons (car px) pll))
108.     (if (vl-some '(lambda ( x ) (collinear-p (car px) (caadr px) x)) p1s)
109.       (setq p2 nil)
110.       (vl-some '(lambda ( x ) (cond ((setq p2 (inters (car px) (caadr px) (car x) (caadr x) nil))) ((setq p2 (inters (car px) (caadr px) (car x) (cadadr x) nil))))) pl)
111.     )
112.     (if (and p2 (collinear-p (caadr px) p2 (car px))) (setq p2 nil))
113.     (if (vl-some '(lambda ( x ) (collinear-p (car px) (cadadr px) x)) p1s)
114.       (setq p3 nil)
115.       (vl-some '(lambda ( x ) (cond ((setq p3 (inters (car px) (cadadr px) (car x) (caadr x) nil))) ((setq p3 (inters (car px) (cadadr px) (car x) (cadadr x) nil))))) pl)
116.     )
117.     (if (and p3 (collinear-p (cadadr px) p3 (car px))) (setq p3 nil))
118.     (if p2 (setq pll (cons p2 pll)))
119.     (if p3 (setq pll (cons p3 pll)))
120.   )
121.   ;|
122.   (foreach p1 p1s
123.     (setq d 0.0)
124.     (foreach px (vl-remove-if-not '(lambda ( x ) (equal (car x) p1 1e-6)) pl)
125.       (if (> (distance (caadr px) (car px)) d) (setq p (caadr px) d (distance (caadr px) (car px))))
126.     )
127.     (if (not (vl-member-if '(lambda ( x ) (equal p x 1e-6)) pll))
128.       (setq pll (cons p pll))
129.     )
130.     (setq d 0.0)
131.     (foreach px (vl-remove-if-not '(lambda ( x ) (equal (car x) p1 1e-6)) pl)
132.       (if (> (distance (cadadr px) (car px)) d) (setq p (cadadr px) d (distance (cadadr px) (car px))))
133.     )
134.     (if (not (vl-member-if '(lambda ( x ) (equal p x 1e-6)) pll))
135.       (setq pll (cons p pll))
136.     )
137.   )
138.   |;
139.   (setq pll (vl-remove nil (unique pll)))
140.   (foreach p pll
141.     (entmake (list '(0 . "POINT") (cons 10 p)))
142.   )
143.   (princ)
144. )
145.  

 :-(

Title: Re: Challenge : Contour to Elevation Points
Post by: ribarm on July 26, 2015, 09:24:27 PM

Only thing I could think of more is ConvexHull, but it's only tricky solution... So here is my final code up to now and I don't think I am going to continue further more unless something much smarter comes to my mind...

Code - Auto/Visual Lisp: [Select]

1. (defun c:cont2pts ( / unit unique collinear-p plremnonunique LM:Clockwise-p LM:ConvexHull ss i lw ellw lwpts lwspts lworts lwptsorts orts lwsptsorts ptortptl p1s p1 p2 p3 pl pll chpts )
2.  
3.   (defun unit ( v )
4.     (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
5.   )
6.  
7.   (defun unique ( l )
8.     (if l (cons (car l) (vl-remove-if '(lambda ( x ) (equal x (car l) 1e-6)) (unique (cdr l)))))
9.   )
10.  
11.   (defun collinear-p ( p1 p p2 )
12.     (equal (distance p1 p2) (+ (distance p1 p) (distance p p2)) 1e-6)
13.   )
14.  
15.   (defun plremnonunique ( l )
16.     (foreach el l
17.       (if (eq (length (vl-remove-if-not '(lambda ( x ) (equal (car x) (car el) 1e-6)) l)) 1)
18.         (setq l (vl-remove el l))
19.       )
20.     )
21.     l
22.   )
23.  
24.   ;; Clockwise-p  -  Lee Mac
25.   ;; Returns T if p1,p2,p3 are clockwise oriented or collinear
26.  
27.   (defun LM:Clockwise-p ( p1 p2 p3 )
28.       (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
29.               (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
30.           )
31.           1e-8
32.       )
33.   )
34.  
35.   ;; Convex Hull  -  Lee Mac
36.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
37.  
38.   (defun LM:ConvexHull ( lst / ch p0 )
39.       (cond
40.           (   (< (length lst) 4) lst)
41.           (   (setq p0 (car lst))
42.               (foreach p1 (cdr lst)
43.                   (if (or (< (cadr p1) (cadr p0))
44.                           (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
45.                       )
46.                       (setq p0 p1)
47.                   )
48.               )
49.               (setq lst
50.                   (vl-sort lst
51.                       (function
52.                           (lambda ( a b / c d )
53.                               (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))))
54.                                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
55.                                   (< c d)
56.                               )
57.                           )
58.                       )
59.                   )
60.               )
61.               (setq ch (list (caddr lst) (cadr lst) (car lst)))
62.               (foreach pt (cdddr lst)
63.                   (setq ch (cons pt ch))
64.                   (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
65.                       (setq ch (cons pt (cddr ch)))
66.                   )
67.               )
68.               ch
69.           )
70.       )
71.   )
72.  
73.   (setq ss (ssget '((0 . "LWPOLYLINE"))))
74.   (repeat (setq i (sslength ss))
75.     (setq lw (ssname ss (setq i (1- i))))
76.     (setq ellw (cdr (assoc 38 (entget lw))))
77.     (setq lwpts (mapcar '(lambda ( p ) (list (car p) (cadr p) ellw)) (unique (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= (car x) 10)) (entget lw))))))
78.     (if (eq 1 (logand 1 (cdr (assoc 70 (entget lw)))))
79.       (progn
80.         (setq lworts (mapcar 'unit (mapcar '(lambda ( a b ) (mapcar '- b a)) lwpts (cdr (reverse (cons (car lwpts) (reverse lwpts)))))))
81.         (setq lwptsorts (mapcar '(lambda ( a b c ) (list a b c)) lwpts lworts (cdr (reverse (cons (car lwpts) (reverse lwpts))))))
82.       )
83.       (progn
84.         (setq lworts (mapcar 'unit (mapcar '(lambda ( a b ) (mapcar '- b a)) lwpts (cdr lwpts))))
85.         (setq lwptsorts (mapcar '(lambda ( a b c ) (list a b c)) lwpts lworts (cdr lwpts)))
86.       )
87.     )
88.     (setq orts (append lworts orts))
89.     (setq lwsptsorts (cons (list ellw lwptsorts) lwsptsorts))
90.     (setq lwspts (append lwpts lwspts))
91.   )
92.   (setq lwsptsorts (vl-sort lwsptsorts '(lambda ( a b ) (< (car a) (car b)))))
93.   (setq orts (unique orts))
94.   (foreach ort orts
95.     (setq ptortptl (vl-remove nil (mapcar '(lambda ( x / z ) (if (setq z (vl-remove-if-not '(lambda ( y ) (equal ort (cadr y) 1e-6)) (cadr x))) (apply 'append z))) lwsptsorts)))
96.     (while (> (length ptortptl) 1)
97.       (progn
98.         (setq p1 (inters (caar ptortptl) (caadr ptortptl) (caddar ptortptl) (caddr (cadr ptortptl)) nil))
99.         (setq p2 (caar ptortptl) p3 (caddar ptortptl))
100.         (if (and p1 p2 p3) (setq pl (cons (list p1 (list p2 p3)) pl)))
101.         (setq ptortptl (cdr ptortptl))
102.       )
103.     )
104.   )
105.   (setq pl (plremnonunique pl))
106.   (setq p1s (unique (mapcar 'car pl)))
107.   (foreach px pl
108.     (setq pll (cons (car px) pll))
109.     (if (vl-some '(lambda ( x ) (collinear-p (car px) (caadr px) x)) p1s)
110.       (setq p2 nil)
111.       (vl-some '(lambda ( x ) (cond ((setq p2 (inters (car px) (caadr px) (car x) (caadr x) nil))) ((setq p2 (inters (car px) (caadr px) (car x) (cadadr x) nil))))) pl)
112.     )
113.     (if (and p2 (collinear-p (caadr px) p2 (car px))) (setq p2 nil))
114.     (if (vl-some '(lambda ( x ) (collinear-p (car px) (cadadr px) x)) p1s)
115.       (setq p3 nil)
116.       (vl-some '(lambda ( x ) (cond ((setq p3 (inters (car px) (cadadr px) (car x) (caadr x) nil))) ((setq p3 (inters (car px) (cadadr px) (car x) (cadadr x) nil))))) pl)
117.     )
118.     (if (and p3 (collinear-p (cadadr px) p3 (car px))) (setq p3 nil))
119.     (if p2 (setq pll (cons p2 pll)))
120.     (if p3 (setq pll (cons p3 pll)))
121.   )
122.   (setq pll (vl-remove nil (unique pll)))
123.   (setq chpts (LM:ConvexHull (append lwspts pll)))
124.   (foreach chpt chpts
125.     (if (not (vl-member-if '(lambda ( x ) (equal chpt x 1e-6)) pll))
126.       (setq pll (cons chpt pll))
127.     )
128.   )
129.   (foreach p pll
130.     (entmake (list '(0 . "POINT") (cons 10 p)))
131.   )
132.   (princ)
133. )
134.  

Regards, M.R.
 8-) :wink: