Author Topic: Challenge : Contour to Elevation Points  (Read 6241 times)

0 Members and 1 Guest are viewing this topic.

mailmaverick

  • Bull Frog
  • Posts: 494
Re: Challenge : Contour to Elevation Points
« Reply #15 on: April 02, 2015, 04:24:21 AM »
Dear ymg

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

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Challenge : Contour to Elevation Points
« Reply #16 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.
« Last Edit: April 03, 2015, 08:49:38 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

mailmaverick

  • Bull Frog
  • Posts: 494
Re: Challenge : Contour to Elevation Points
« Reply #17 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.


ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Challenge : Contour to Elevation Points
« Reply #18 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.
« Last Edit: July 25, 2015, 02:25:24 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 : Contour to Elevation Points
« Reply #19 on: July 25, 2015, 02:41:58 PM »
I had a small mistake in my last code - now fixed... Regards...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Challenge : Contour to Elevation Points
« Reply #20 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.
« Last Edit: July 26, 2015, 11:18:37 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 : Contour to Elevation Points
« Reply #21 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.  

 :-(
« Last Edit: July 26, 2015, 11:19:44 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 : Contour to Elevation Points
« Reply #22 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:
« Last Edit: June 19, 2019, 12:55:43 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube