points density - dense.lsp - o

pBe · 发表于 2022-7-6 00:28:12

You catch on real fast . I knew you'll come through when push comes to shove

Cheers

marko_ribar · 发表于 2022-7-6 00:31:40

Here is slightly faster 2sec on 38sec from previous code (now is 36 sec)... Tested on only 50 3D points...

(defun averpttriang (p1 p2 p3) (mapcar '(lambda (a b c) (/ (+ a b c) 3.0)) p1 p2 p3))(defun mid (p1 p2) (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p2))(defun circumtriang (p1 p2 p3 / pp1 pp2 pp3 mp1p2 mp2p3 npmp1p2 npmp2p3 cen rad) (setq pp1 (list (car p1) (cadr p1))) (setq pp2 (list (car p2) (cadr p2))) (setq pp3 (list (car p3) (cadr p3))) (setq mp1p2 (mid pp1 pp2)) (setq mp2p3 (mid pp2 pp3)) (setq npmp1p2 (polar mp1p2 (+ (angle pp1 pp2) (/ pi 2.0)) 1.0)) (setq npmp2p3 (polar mp2p3 (+ (angle pp2 pp3) (/ pi 2.0)) 1.0)) (setq cen (inters mp1p2 npmp1p2 mp2p3 npmp2p3 nil)) (setq rad (distance cen p1)) (list cen rad))(defun ptinsidecir (pt circle) (setq pt (list (car pt) (cadr pt))) (> (cadr circle) (distance (car circle) pt)))(defun c:triangulate ( / ss n pt ptlst pttlst p1 p2 p3 circle tst lst avrpt avrlst triangles) (setq ss (ssget '((0 . "POINT")))) (repeat (setq n (sslength ss))   (setq pt (cdr (assoc 10 (entget (ssname ss (setq n (1- n)))))))   (setq ptlst (cons pt ptlst)) ) (setq pttlst ptlst) (while (> (length ptlst) 2)   (setq p1 (car ptlst))   (foreach p2 (cdr ptlst)     (foreach p3 (vl-remove p2 (cdr ptlst))       (setq circle (circumtriang p1 p2 p3))       (foreach pp (vl-remove p3 (vl-remove p2 (vl-remove p1 pttlst)))         (if (not (ptinsidecir pp circle)) (setq tst (cons T tst)) (setq tst (cons nil tst)))       )       (if (eval (cons 'and tst))          (progn           (setq lst (cons p1 lst) lst (cons p2 lst) lst (cons p3 lst))           (setq avrpt (averpttriang p1 p2 p3))         )         (setq avrpt nil)       )       (if (and avrpt (not (member avrpt avrlst)))          (progn            (setq avrlst (cons avrpt avrlst))            (setq triangles (cons lst triangles))         )       )       (setq lst nil)       (setq tst nil)       (setq ptlst (vl-remove p1 ptlst))       (setq ptlst (vl-remove p2 ptlst))       (setq ptlst (vl-remove p3 ptlst))       (setq ptlst (cons p3 ptlst))       (setq ptlst (cons p2 ptlst))     )   ) ) (foreach triangle triangles   (entmake (list (cons 0 "3DFACE")(cons 10 (car triangle))(cons 11 (cadr triangle))(cons 12 (caddr triangle))(cons 13 (caddr triangle)))) ) (princ))

M.R.

marko_ribar · 发表于 2022-7-6 00:33:44

Just sligthly more improvement in speed - on my other PC not netbook previous code did for 50 3d pts in 10 sec... Now it did in 8 sec...

copy

(defun nearest (pt lst / d1 d2 p1 p2) (setq lst (vl-remove pt lst)) (setq d1 (distance pt (car lst))       p1 (car lst) ) (foreach p2 (cdr lst)   (if (> d1 (setq d2 (distance pt p2)))     (setq d1 d2 p1 p2)   ) ) p1)(defun averpttriang (p1 p2 p3) (mapcar '(lambda (a b c) (/ (+ a b c) 3.0)) p1 p2 p3))(defun mid (p1 p2) (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p2))(defun circumtriang (p1 p2 p3 / pp1 pp2 pp3 mp1p2 mp2p3 npmp1p2 npmp2p3 cen rad) (setq pp1 (list (car p1) (cadr p1))) (setq pp2 (list (car p2) (cadr p2))) (setq pp3 (list (car p3) (cadr p3))) (setq mp1p2 (mid pp1 pp2)) (setq mp2p3 (mid pp2 pp3)) (setq npmp1p2 (polar mp1p2 (+ (angle pp1 pp2) (/ pi 2.0)) 1.0)) (setq npmp2p3 (polar mp2p3 (+ (angle pp2 pp3) (/ pi 2.0)) 1.0)) (setq cen (inters mp1p2 npmp1p2 mp2p3 npmp2p3 nil)) (setq rad (distance cen p1)) (list cen rad))(defun ptinsidecir (pt circle) (setq pt (list (car pt) (cadr pt))) (> (cadr circle) (distance (car circle) pt)))(defun c:triangulate ( / ss n pt ptlst pttlst p1 p2 p3 circle pp lst avrpt avrlst triangles) (setq ss (ssget '((0 . "POINT")))) (repeat (setq n (sslength ss))   (setq pt (cdr (assoc 10 (entget (ssname ss (setq n (1- n)))))))   (setq ptlst (cons pt ptlst)) ) (setq pttlst ptlst) (while (> (length ptlst) 2)   (setq p1 (car ptlst))   (foreach p2 (cdr ptlst)     (foreach p3 (vl-remove p2 (cdr ptlst))       (setq circle (circumtriang p1 p2 p3))       (setq pp (nearest (car circle) (vl-remove p1 (vl-remove p2 (vl-remove p3 pttlst)))))       (if (not (ptinsidecir pp circle))         (progn           (setq lst (cons p1 lst) lst (cons p2 lst) lst (cons p3 lst))           (setq avrpt (averpttriang p1 p2 p3))         )         (setq avrpt nil)       )       (if (and avrpt (not (member avrpt avrlst)))         (progn            (setq avrlst (cons avrpt avrlst))           (setq triangles (cons lst triangles))         )       )       (setq lst nil)       (if (equal p1 (car ptlst) 1e- (setq ptlst (cdr ptlst)))     )   ) ) (foreach triangle triangles   (entmake (list (cons 0 "3DFACE")(cons 10 (car triangle))(cons 11 (cadr triangle))(cons 12 (caddr triangle))(cons 13 (caddr triangle)))) ) (princ))

P.S. Checked again with 100 pts - previous code : 2min 35sec; this new code : 53sec
But for 200 pts, new code works for : 14min 12sec... So slow...

M.R.

marko_ribar · 发表于 2022-7-6 00:38:48

And here is slightly modified last code (while loops) instead of (foreach)... I thought this will be just slightly faster, but I was wrong - it's ab the same as previous code... Seems this is top of speed for this kind of algorithm based on logic by checking each point with each in loop2 with each in loop3...

copy

(defun nearest (pt lst / d1 d2 p1 p2) (setq lst (vl-remove pt lst)) (setq d1 (distance pt (car lst)) p1 (car lst)) (foreach p2 (cdr lst)   (if (> d1 (setq d2 (distance pt p2)))     (setq d1 d2 p1 p2)   ) ) p1)(defun averpttriang (p1 p2 p3) (mapcar '(lambda (a b c) (/ (+ a b c) 3.0)) p1 p2 p3))(defun mid (p1 p2) (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p2))(defun circumtriang (p1 p2 p3 / pp1 pp2 pp3 mp1p2 mp2p3 npmp1p2 npmp2p3 cen rad) (setq pp1 (list (car p1) (cadr p1))) (setq pp2 (list (car p2) (cadr p2))) (setq pp3 (list (car p3) (cadr p3))) (setq mp1p2 (mid pp1 pp2)) (setq mp2p3 (mid pp2 pp3)) (setq npmp1p2 (polar mp1p2 (+ (angle pp1 pp2) (/ pi 2.0)) 1.0)) (setq npmp2p3 (polar mp2p3 (+ (angle pp2 pp3) (/ pi 2.0)) 1.0)) (setq cen (inters mp1p2 npmp1p2 mp2p3 npmp2p3 nil)) (setq rad (distance cen p1)) (list cen rad))(defun ptinsidecir (pt circle) (setq pt (list (car pt) (cadr pt))) (> (cadr circle) (distance (car circle) pt)))(defun c:triangulate ( / ss n pt ptlst pttlst p1 p2 p3 p2lst p3lst loop2 loop3 k circle pp lst avrpt avrlst triangles) (setq ss (ssget '((0 . "POINT")))) (repeat (setq n (sslength ss))   (setq pt (cdr (assoc 10 (entget (ssname ss (setq n (1- n)))))))   (setq ptlst (cons pt ptlst)) ) (setq pttlst ptlst) (while (> (length ptlst) 2)   (setq p1 (car ptlst))   (setq p2lst (cdr ptlst))   (setq loop2 T)   (while loop2     (setq p2 (car p2lst))     (setq p2lst (cdr p2lst))     (setq p3lst (vl-remove p2 (cdr ptlst)))     (setq k 0)     (setq loop3 T)     (while loop3       (setq p3 (car p3lst))       (setq p3lst (cdr p3lst))       (setq circle (circumtriang p1 p2 p3))       (setq pp (nearest (car circle) (vl-remove p1 (vl-remove p2 (vl-remove p3 pttlst)))))       (if (not (ptinsidecir pp circle))         (progn           (setq lst (cons p1 lst) lst (cons p2 lst) lst (cons p3 lst))           (setq avrpt (averpttriang p1 p2 p3))           (setq k (1+ k))         )         (setq avrpt nil)       )       (if (and avrpt (not (member avrpt avrlst)))         (progn           (setq avrlst (cons avrpt avrlst))           (setq triangles (cons lst triangles))         )       )       (setq lst nil)       (if (equal p1 (car ptlst) 1e- (setq ptlst (cdr ptlst)))       (if (or (eq p3lst nil) (eq k 2)) (setq loop3 nil))       (if (or (= (length ptlst) 2) (eq p2lst nil)) (setq loop2 nil))     )   ) ) (foreach triangle triangles   (entmake (list (cons 0 "3DFACE")(cons 10 (car triangle))(cons 11 (cadr triangle))(cons 12 (caddr triangle))(cons 13 (caddr triangle)))) ) (princ))

Results are ab the same...
Regards, M.R.

marko_ribar · 发表于 2022-7-6 00:39:27

One more thing, I've noticed that this line isn't going to do the job

copy

(not (member avrpt avrlst))

so I've finally revised my last code - little bit slower, but better this :

copy

(defun averpttriang (triangle) (mapcar '(lambda (a b c) (/ (+ a b c) 3.0)) (car triangle) (cadr triangle) (caddr triangle)))(defun unique (lst) (if lst (cons (car lst) (unique (vl-remove (car lst) (cdr lst))))))(defun uniquetriangles (triangles / lst assoctriangles uniquetriangs) (foreach triangle triangles   (setq lst (cons (averpttriang triangle) lst)) ) (setq lst (unique lst)) (foreach triangle triangles   (setq assoctriangles (cons (cons (averpttriang triangle) triangle) assoctriangles)) ) (foreach averpt lst   (setq uniquetriangs (cons (cdr (assoc averpt assoctriangles)) uniquetriangs)) ) uniquetriangs)(defun nearest (pt lst / d1 d2 p1 p2) (setq lst (vl-remove pt lst)) (setq d1 (distance pt (car lst)) p1 (car lst)) (foreach p2 (cdr lst)   (if (> d1 (setq d2 (distance pt p2)))     (setq d1 d2 p1 p2)   ) ) p1)(defun mid (p1 p2) (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p2))(defun circumtriang (p1 p2 p3 / pp1 pp2 pp3 mp1p2 mp2p3 npmp1p2 npmp2p3 cen rad) (setq pp1 (list (car p1) (cadr p1))) (setq pp2 (list (car p2) (cadr p2))) (setq pp3 (list (car p3) (cadr p3))) (setq mp1p2 (mid pp1 pp2)) (setq mp2p3 (mid pp2 pp3)) (setq npmp1p2 (polar mp1p2 (+ (angle pp1 pp2) (/ pi 2.0)) 1.0)) (setq npmp2p3 (polar mp2p3 (+ (angle pp2 pp3) (/ pi 2.0)) 1.0)) (setq cen (inters mp1p2 npmp1p2 mp2p3 npmp2p3 nil)) (setq rad (distance cen p1)) (list cen rad))(defun ptinsidecir (pt circle) (setq pt (list (car pt) (cadr pt))) (> (cadr circle) (distance (car circle) pt)))(defun c:triangulate ( / ss n pt ptlst pttlst p1 p2 p3 p2lst p3lst loop2 loop3 k circle pp lst triangles) (setq ss (ssget '((0 . "POINT")))) (repeat (setq n (sslength ss))   (setq pt (cdr (assoc 10 (entget (ssname ss (setq n (1- n)))))))   (setq ptlst (cons pt ptlst)) ) (setq pttlst ptlst) (while (> (length ptlst) 2)   (setq p1 (car ptlst))   (setq p2lst (cdr ptlst))   (setq loop2 T)   (while loop2     (setq p2 (car p2lst))     (setq p2lst (cdr p2lst))     (setq p3lst (vl-remove p2 (cdr ptlst)))     (setq k 0)     (setq loop3 T)     (while loop3       (setq p3 (car p3lst))       (setq p3lst (cdr p3lst))       (setq circle (circumtriang p1 p2 p3))       (setq pp (nearest (car circle) (vl-remove p1 (vl-remove p2 (vl-remove p3 pttlst)))))       (if (not (ptinsidecir pp circle))         (progn           (setq lst (cons p1 lst) lst (cons p2 lst) lst (cons p3 lst))           (setq triangles (cons lst triangles))           (setq k (1+ k))         )       )       (setq lst nil)       (if (equal p1 (car ptlst) 1e- (setq ptlst (cdr ptlst)))       (if (or (eq p3lst nil) (eq k 2)) (setq loop3 nil))       (if (or (= (length ptlst) 2) (eq p2lst nil)) (setq loop2 nil))     )   ) ) (foreach triangle (uniquetriangles triangles)   (entmake (list (cons 0 "3DFACE")(cons 10 (car triangle))(cons 11 (cadr triangle))(cons 12 (caddr triangle))(cons 13 (caddr triangle)))) ) (princ))

than this slower variant :

copy

(defun nearest (pt lst / d1 d2 p1 p2) (setq lst (vl-remove pt lst)) (setq d1 (distance pt (car lst)) p1 (car lst)) (foreach p2 (cdr lst)   (if (> d1 (setq d2 (distance pt p2)))     (setq d1 d2 p1 p2)   ) ) p1)(defun averpttriang (p1 p2 p3) (mapcar '(lambda (a b c) (/ (+ a b c) 3.0)) p1 p2 p3))(defun mid (p1 p2) (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p2))(defun circumtriang (p1 p2 p3 / pp1 pp2 pp3 mp1p2 mp2p3 npmp1p2 npmp2p3 cen rad) (setq pp1 (list (car p1) (cadr p1))) (setq pp2 (list (car p2) (cadr p2))) (setq pp3 (list (car p3) (cadr p3))) (setq mp1p2 (mid pp1 pp2)) (setq mp2p3 (mid pp2 pp3)) (setq npmp1p2 (polar mp1p2 (+ (angle pp1 pp2) (/ pi 2.0)) 1.0)) (setq npmp2p3 (polar mp2p3 (+ (angle pp2 pp3) (/ pi 2.0)) 1.0)) (setq cen (inters mp1p2 npmp1p2 mp2p3 npmp2p3 nil)) (setq rad (distance cen p1)) (list cen rad))(defun ptinsidecir (pt circle) (setq pt (list (car pt) (cadr pt))) (> (cadr circle) (distance (car circle) pt)))(defun c:triangulate ( / ss n pt ptlst pttlst p1 p2 p3 p2lst p3lst loop2 loop3 k circle pp lst avrpt avrlst tst triangles) (setq ss (ssget '((0 . "POINT")))) (repeat (setq n (sslength ss))   (setq pt (cdr (assoc 10 (entget (ssname ss (setq n (1- n)))))))   (setq ptlst (cons pt ptlst)) ) (setq pttlst ptlst) (while (> (length ptlst) 2)   (setq p1 (car ptlst))   (setq p2lst (cdr ptlst))   (setq loop2 T)   (while loop2     (setq p2 (car p2lst))     (setq p2lst (cdr p2lst))     (setq p3lst (vl-remove p2 (cdr ptlst)))     (setq k 0)     (setq loop3 T)     (while loop3       (setq p3 (car p3lst))       (setq p3lst (cdr p3lst))       (setq circle (circumtriang p1 p2 p3))       (setq pp (nearest (car circle) (vl-remove p1 (vl-remove p2 (vl-remove p3 pttlst)))))       (if (not (ptinsidecir pp circle))         (progn           (setq lst (cons p1 lst) lst (cons p2 lst) lst (cons p3 lst))           (setq avrpt (averpttriang p1 p2 p3))           (setq k (1+ k))         )         (setq avrpt nil)       )       (if avrpt         (if avrlst           (foreach pt avrlst             (if (not (equal avrpt pt 1e-6)) (setq tst (cons T tst)) (setq tst (cons nil tst)))           )           (setq tst (cons T tst) tst (cons T tst))         )       )       (if tst         (if (eval (cons 'and tst))           (progn             (setq avrlst (cons avrpt avrlst))             (setq triangles (cons lst triangles))           )         )       )       (setq lst nil)       (setq tst nil)       (if (equal p1 (car ptlst) 1e- (setq ptlst (cdr ptlst)))       (if (or (eq p3lst nil) (eq k 2)) (setq loop3 nil))       (if (or (= (length ptlst) 2) (eq p2lst nil)) (setq loop2 nil))     )   ) ) (foreach triangle triangles   (entmake (list (cons 0 "3DFACE")(cons 10 (car triangle))(cons 11 (cadr triangle))(cons 12 (caddr triangle))(cons 13 (caddr triangle)))) ) (princ))

Still the best is DTM.vlx if it doesn't break...
My version can't break, but it's so slow, slow, slow... (200 pts approx 15min, and DTM 200 pts approx 5sec)
M.R.

marko_ribar · 发表于 2022-7-6 00:43:23

And this is quite a mess of 3DFACEs, but speed is acceptable for large number of points - more than 200 pts... It divides area by segments of 40 pts, and overlap this net with area net (n+1)x(n+1) with starting position displacement by (-dx/2 -dy/2)... All this speeds up whole process but it causes mess with faces... Still if DTM.vlx fails, and there are no other alternatives, this is some sort of solution (it's strongly recommended that final terrain model is generated after step 1 by processing next steps till final 3d solid terrain)... Follow this link : click here

copy

(defun averpttriang (triangle) (mapcar '(lambda (a b c) (/ (+ a b c) 3.0)) (car triangle) (cadr triangle) (caddr triangle)))(defun uniquetriangles (triangles / lst assoctriangles uniquetriangs) (foreach triangle triangles   (setq lst (cons (averpttriang triangle) lst)) ) (setq lst (unique lst)) (foreach triangle triangles   (setq assoctriangles (cons (cons (averpttriang triangle) triangle) assoctriangles)) ) (foreach averpt lst   (setq uniquetriangs (cons (cdr (assoc averpt assoctriangles)) uniquetriangs)) ) uniquetriangs)(defun flatten (lst / lstn) (foreach triangle (reverse lst)   (setq lstn (cons (caddr triangle) lstn) lstn (cons (cadr triangle) lstn) lstn (cons (car triangle) lstn)) ) (reverse lstn))(defun nearest (pt lst / d1 d2 p1 p2) (setq lst (vl-remove pt lst)) (setq d1 (distance pt (car lst)) p1 (car lst)) (foreach p2 (cdr lst)   (if (> d1 (setq d2 (distance pt p2)))     (setq d1 d2 p1 p2)   ) ) p1)(defun mid (p1 p2) (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p2))(defun circumtriang (p1 p2 p3 / pp1 pp2 pp3 mp1p2 mp2p3 npmp1p2 npmp2p3 cen rad) (setq pp1 (list (car p1) (cadr p1))) (setq pp2 (list (car p2) (cadr p2))) (setq pp3 (list (car p3) (cadr p3))) (setq mp1p2 (mid pp1 pp2)) (setq mp2p3 (mid pp2 pp3)) (setq npmp1p2 (polar mp1p2 (+ (angle pp1 pp2) (/ pi 2.0)) 1.0)) (setq npmp2p3 (polar mp2p3 (+ (angle pp2 pp3) (/ pi 2.0)) 1.0)) (setq cen (inters mp1p2 npmp1p2 mp2p3 npmp2p3 nil)) (setq rad (distance cen p1)) (list cen rad))(defun ptinsidecir (pt circle) (setq pt (list (car pt) (cadr pt))) (> (cadr circle) (distance (car circle) pt)))(defun areatriangulate (ptlst / pttlst p1 p2 p3 p2lstt p2lst p3lst loop2 loop3 k circle pp lst triangles) (setq ptlst (vl-sort ptlst '(lambda (a b) (< (car a) (car b))))) (setq pttlst ptlst) (while (> (length ptlst) 2)   (setq p1 (car ptlst))   (setq p2lst (cdr ptlst))   (setq p2lstt p2lst)   (setq loop2 T)   (while loop2     (setq p2 (car p2lst))     (setq p2lst (cdr p2lst))     (setq p3lst (vl-remove p2 p2lstt))     (setq k 0)     (setq loop3 T)     (while loop3       (setq p3 (car p3lst))       (setq p3lst (cdr p3lst))       (setq circle (circumtriang p1 p2 p3))       (setq pp (nearest (car circle) (vl-remove p1 (vl-remove p2 (vl-remove p3 pttlst)))))       (if (not (ptinsidecir pp circle))         (progn           (setq lst (cons p1 lst) lst (cons p2 lst) lst (cons p3 lst))           (setq triangles (cons lst triangles))           (setq k (1+ k))         )       )       (setq lst nil)       (if (equal p1 (car ptlst) 1e- (setq ptlst (cdr ptlst)))       (if (eq k 2) (setq loop3 nil p2lst (vl-remove p3 p2lst) p2lst (cons p3 p2lst)))       (if (and (eq k 2) (member p3 (flatten (cdr triangles)))) (setq loop2 nil))       (if (eq p3lst nil) (setq loop3 nil))       (if (or (= (length ptlst) 2) (eq p2lst nil)) (setq loop2 nil))     )   ) ) triangles)(defun c:triangulate ( / ss ssw ssn n pt ptlst k xmin xmax ymin ymax dx dy stwpt enwpt stwptq enwptq vecx vecy i ii triangles stwptn enwptn z pto ptolst) (setq ss (ssget '((0 . "POINT")))) (repeat (setq n (sslength ss))   (setq pt (cdr (assoc 10 (entget (ssname ss (setq n (1- n)))))))   (setq ptlst (cons pt ptlst)) ) (setq k (length ptlst)) (setq ptlst (vl-sort ptlst '(lambda (a b) (< (car a) (car b))))) (setq xmin (caar ptlst)) (setq xmax (car (last ptlst))) (setq ptlst (vl-sort ptlst '(lambda (a b) (< (cadr a) (cadr b))))) (setq ymin (cadar ptlst)) (setq ymax (cadr (last ptlst))) (setq n (fix (sqrt (/ k 40.0)))) (setq dx (/ (- xmax xmin) n)) (setq dy (/ (- ymax ymin) n)) (setq stwpt (list xmin ymin)) (setq enwpt (list (+ xmin dx) (+ ymin dy))) (setq vecx (list dx 0.0))  (setq vecy (list 0.0 dy))  (setq triangles '()) (setq stwptq (list (- xmin (/ dx 2.0)) (- ymin (/ dy 2.0)))) (setq enwptq (list (+ xmin (/ dx 2.0)) (+ ymin (/ dy 2.0)))) (setq i -1 ii -1) (repeat n   (setq i (1+ i))   (repeat n     (setq ii (1+ ii))     (setq stwptn (mapcar '+ (mapcar '+ (mapcar '* (list i i) vecy) (mapcar '* (list ii ii) vecx)) stwpt))     (setq enwptn (mapcar '+ (mapcar '+ (mapcar '* (list i i) vecy) (mapcar '* (list ii ii) vecx)) enwpt))     (setq ssw (ssget "_W" stwptn enwptn '((0 . "POINT"))))     (if ssw (setq ssn (acet-ss-intersection ss ssw)) (setq ssn ssw))     (repeat (setq z (if ssn (sslength ssn) 0))       (setq pto (cdr (assoc 10 (entget (ssname ssn (setq z (1- z)))))))       (setq ptolst (cons pto ptolst))     )     (if (eq ii (- n 1)) (setq ii -1))     (setq triangles (append (if (and (> (length ptolst) 3) ptolst) (areatriangulate ptolst) nil) triangles))     (setq ptolst nil)   ) ) (setq i -1 ii -1) (repeat (+ n 1)   (setq i (1+ i))   (repeat (+ n 1)     (setq ii (1+ ii))     (setq stwptn (mapcar '+ (mapcar '+ (mapcar '* (list i i) vecy) (mapcar '* (list ii ii) vecx)) stwptq))     (setq enwptn (mapcar '+ (mapcar '+ (mapcar '* (list i i) vecy) (mapcar '* (list ii ii) vecx)) enwptq))     (setq ssw (ssget "_W" stwptn enwptn '((0 . "POINT"))))     (if ssw (setq ssn (acet-ss-intersection ss ssw)) (setq ssn ssw))     (repeat (setq z (if ssn (sslength ssn) 0))       (setq pto (cdr (assoc 10 (entget (ssname ssn (setq z (1- z)))))))       (setq ptolst (cons pto ptolst))     )     (if (eq ii n) (setq ii -1))     (setq triangles (append (if (and (> (length ptolst) 3) ptolst) (areatriangulate ptolst) nil) triangles))     (setq ptolst nil)   ) )  (foreach triangle (uniquetriangles triangles)   (entmake (list (cons 0 "3DFACE")(cons 10 (car triangle))(cons 11 (cadr triangle))(cons 12 (caddr triangle))(cons 13 (caddr triangle)))) ) (princ))

Regards, M.R.
Hope it'll be of some kind of use...

marko_ribar · 发表于 2022-7-6 00:47:43

For DWG's with over 2000 pts, I suggest that you have duplicate 3DFACEs as working with large lists are unneccessary... You can then convert 3DFACEs into REGIONs and do OVERKILL... Much faster than with calculation of unique 3DFACEs, though I don't quite know how to convert REGIONs back to 3DFACEs... And don't quite know are 3DFACEs necessary for next procedure step described in above posted link...

copy

(defun flatten (lst / lstn) (foreach triangle (reverse lst)   (setq lstn (cons (caddr triangle) lstn) lstn (cons (cadr triangle) lstn) lstn (cons (car triangle) lstn)) ) (reverse lstn))(defun nearest (pt lst / d1 d2 p1 p2) (setq lst (vl-remove pt lst)) (setq d1 (distance pt (car lst)) p1 (car lst)) (foreach p2 (cdr lst)   (if (> d1 (setq d2 (distance pt p2)))     (setq d1 d2 p1 p2)   ) ) p1)(defun mid (p1 p2) (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p2))(defun circumtriang (p1 p2 p3 / pp1 pp2 pp3 mp1p2 mp2p3 npmp1p2 npmp2p3 cen rad) (setq pp1 (list (car p1) (cadr p1))) (setq pp2 (list (car p2) (cadr p2))) (setq pp3 (list (car p3) (cadr p3))) (setq mp1p2 (mid pp1 pp2)) (setq mp2p3 (mid pp2 pp3)) (setq npmp1p2 (polar mp1p2 (+ (angle pp1 pp2) (/ pi 2.0)) 1.0)) (setq npmp2p3 (polar mp2p3 (+ (angle pp2 pp3) (/ pi 2.0)) 1.0)) (setq cen (inters mp1p2 npmp1p2 mp2p3 npmp2p3 nil)) (setq rad (distance cen p1)) (list cen rad))(defun ptinsidecir (pt circle) (setq pt (list (car pt) (cadr pt))) (> (cadr circle) (distance (car circle) pt)))(defun areatriangulate (ptlst / pttlst p1 p2 p3 p2lstt p2lst p3lst loop2 loop3 k circle pp lst triangles) (setq ptlst (vl-sort ptlst '(lambda (a b) (< (car a) (car b))))) (setq pttlst ptlst) (while (> (length ptlst) 2)   (setq p1 (car ptlst))   (setq p2lst (cdr ptlst))   (setq p2lstt p2lst)   (setq loop2 T)   (while loop2     (setq p2 (car p2lst))     (setq p2lst (cdr p2lst))     (setq p3lst (vl-remove p2 p2lstt))     (setq k 0)     (setq loop3 T)     (while loop3       (setq p3 (car p3lst))       (setq p3lst (cdr p3lst))       (setq circle (circumtriang p1 p2 p3))       (setq pp (nearest (car circle) (vl-remove p1 (vl-remove p2 (vl-remove p3 pttlst)))))       (if (not (ptinsidecir pp circle))         (progn           (setq lst (cons p1 lst) lst (cons p2 lst) lst (cons p3 lst))           (setq triangles (cons lst triangles))           (setq k (1+ k))         )       )       (setq lst nil)       (if (equal p1 (car ptlst) 1e- (setq ptlst (cdr ptlst)))       (if (eq k 2) (setq loop3 nil p2lst (vl-remove p3 p2lst) p2lst (cons p3 p2lst)))       (if (and (eq k 2) (member p3 (flatten (cdr triangles)))) (setq loop2 nil))       (if (eq p3lst nil) (setq loop3 nil))       (if (or (= (length ptlst) 2) (eq p2lst nil)) (setq loop2 nil))     )   ) ) triangles)(defun c:triangulate ( / ss ssw ssn n pt ptlst k xmin xmax ymin ymax dx dy stwpt enwpt stwptq enwptq vecx vecy i ii triangles stwptn enwptn z pto ptolst) (setq ss (ssget '((0 . "POINT")))) (repeat (setq n (sslength ss))   (setq pt (cdr (assoc 10 (entget (ssname ss (setq n (1- n)))))))   (setq ptlst (cons pt ptlst)) ) (setq k (length ptlst)) (setq ptlst (vl-sort ptlst '(lambda (a b) (< (car a) (car b))))) (setq xmin (caar ptlst)) (setq xmax (car (last ptlst))) (setq ptlst (vl-sort ptlst '(lambda (a b) (< (cadr a) (cadr b))))) (setq ymin (cadar ptlst)) (setq ymax (cadr (last ptlst))) (setq n (fix (sqrt (/ k 40.0)))) (acet-ui-progress "Progress : " (+ (* n n) (* (+ n 1) (+ n 1)))) (setq dx (/ (- xmax xmin) n)) (setq dy (/ (- ymax ymin) n)) (setq stwpt (list xmin ymin)) (setq enwpt (list (+ xmin dx) (+ ymin dy))) (setq vecx (list dx 0.0))  (setq vecy (list 0.0 dy))  (setq triangles '()) (setq stwptq (list (- xmin (/ dx 2.0)) (- ymin (/ dy 2.0)))) (setq enwptq (list (+ xmin (/ dx 2.0)) (+ ymin (/ dy 2.0)))) (setq i -1 ii -1) (repeat n   (setq i (1+ i))   (repeat n     (setq ii (1+ ii))     (setq stwptn (mapcar '+ (mapcar '+ (mapcar '* (list i i) vecy) (mapcar '* (list ii ii) vecx)) stwpt))     (setq enwptn (mapcar '+ (mapcar '+ (mapcar '* (list i i) vecy) (mapcar '* (list ii ii) vecx)) enwpt))     (setq ssw (ssget "_W" stwptn enwptn '((0 . "POINT"))))     (if ssw (setq ssn (acet-ss-intersection ss ssw)) (setq ssn ssw))     (repeat (setq z (if ssn (sslength ssn) 0))       (setq pto (cdr (assoc 10 (entget (ssname ssn (setq z (1- z)))))))       (setq ptolst (cons pto ptolst))     )     (if (eq ii (- n 1)) (setq ii -1))     (setq triangles (append (if (and (> (length ptolst) 3) ptolst) (areatriangulate ptolst) nil) triangles))     (setq ptolst nil)     (acet-ui-progress -1)   ) ) (setq i -1 ii -1) (repeat (+ n 1)   (setq i (1+ i))   (repeat (+ n 1)     (setq ii (1+ ii))     (setq stwptn (mapcar '+ (mapcar '+ (mapcar '* (list i i) vecy) (mapcar '* (list ii ii) vecx)) stwptq))     (setq enwptn (mapcar '+ (mapcar '+ (mapcar '* (list i i) vecy) (mapcar '* (list ii ii) vecx)) enwptq))     (setq ssw (ssget "_W" stwptn enwptn '((0 . "POINT"))))     (if ssw (setq ssn (acet-ss-intersection ss ssw)) (setq ssn ssw))     (repeat (setq z (if ssn (sslength ssn) 0))       (setq pto (cdr (assoc 10 (entget (ssname ssn (setq z (1- z)))))))       (setq ptolst (cons pto ptolst))     )     (if (eq ii n) (setq ii -1))     (setq triangles (append (if (and (> (length ptolst) 3) ptolst) (areatriangulate ptolst) nil) triangles))     (setq ptolst nil)     (acet-ui-progress -1)  ) )  (foreach triangle triangles   (entmake (list (cons 0 "3DFACE")(cons 10 (car triangle))(cons 11 (cadr triangle))(cons 12 (caddr triangle))(cons 13 (caddr triangle)))) ) (acet-ui-progress-done) (princ))

It did this code on 2000 pts for ab 5min, and above posted didn't even finish for >15 min...

M.R.

marko_ribar · 发表于 2022-7-6 00:49:04

Yes, for the next step AutoCurve it's needed to select 3DFACEs, and I've just figured how to do conversion...

copy

(defun unique (lst) (if lst (cons (car lst) (unique (vl-remove (car lst) (cdr lst))))))(defun c:3ptregs23dfaces ( / ss n reg sslin k lin ps pe ptlst) (setq ss (ssget '((0 . "REGION")))) (repeat (setq n (sslength ss))   (setq reg (ssname ss (setq n (1- n))))   (vl-cmdf "_.explode" reg "")   (setq sslin (ssget "_P"))   (repeat (setq k (sslength sslin))     (setq lin (ssname sslin (setq k (1- k))))     (setq ps (cdr (assoc 10 (entget lin))))     (setq pe (cdr (assoc 11 (entget lin))))     (setq ptlst (cons ps ptlst) ptlst (cons pe ptlst))     (entdel lin)   )   (setq ptlst (unique ptlst))   (entmake (list (cons 0 "3DFACE")(cons 10 (car ptlst))(cons 11 (cadr ptlst))(cons 12 (caddr ptlst))(cons 13 (caddr ptlst))))   (setq ptlst nil) ) (princ))

Sincerely, M.R.

marko_ribar · 发表于 2022-7-6 00:54:00

Last codes for large number of points have been finally revised...
You can test them now...

Sincerely, M.R.

marko_ribar · 发表于 2022-7-6 00:57:29

Main algorithm has been changed to improve performance... Changed only codes for large number of points, as some faces are skipped and some are surplus and therefore needed to be converted to regions, overkill and than back return them to 3dfaces...

Note : change of main algorithm is to improve performance as some faces are skipped so it's not totaly aceptable and therefore main code remained unchanged :

copy

(defun averpttriang (triangle) (mapcar '(lambda (a b c) (/ (+ a b c) 3.0)) (car triangle) (cadr triangle) (caddr triangle)))(defun unique (lst) (if lst (cons (car lst) (unique (vl-remove (car lst) (cdr lst))))))(defun uniquetriangles (triangles / lst assoctriangles uniquetriangs) (foreach triangle triangles   (setq lst (cons (averpttriang triangle) lst)) ) (setq lst (unique lst)) (foreach triangle triangles   (setq assoctriangles (cons (cons (averpttriang triangle) triangle) assoctriangles)) ) (foreach averpt lst   (setq uniquetriangs (cons (cdr (assoc averpt assoctriangles)) uniquetriangs)) ) uniquetriangs)(defun nearest (pt lst / d1 d2 p1 p2) (setq lst (vl-remove pt lst)) (setq d1 (distance pt (car lst)) p1 (car lst)) (foreach p2 (cdr lst)   (if (> d1 (setq d2 (distance pt p2)))     (setq d1 d2 p1 p2)   ) ) p1)(defun mid (p1 p2) (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p2))(defun circumtriang (p1 p2 p3 / pp1 pp2 pp3 mp1p2 mp2p3 npmp1p2 npmp2p3 cen rad) (setq pp1 (list (car p1) (cadr p1))) (setq pp2 (list (car p2) (cadr p2))) (setq pp3 (list (car p3) (cadr p3))) (setq mp1p2 (mid pp1 pp2)) (setq mp2p3 (mid pp2 pp3)) (setq npmp1p2 (polar mp1p2 (+ (angle pp1 pp2) (/ pi 2.0)) 1.0)) (setq npmp2p3 (polar mp2p3 (+ (angle pp2 pp3) (/ pi 2.0)) 1.0)) (setq cen (inters mp1p2 npmp1p2 mp2p3 npmp2p3 nil)) (setq rad (distance cen p1)) (list cen rad))(defun ptinsidecir (pt circle) (setq pt (list (car pt) (cadr pt))) (> (cadr circle) (distance (car circle) pt)))(defun c:triangulate ( / ss n pt ptlst pttlst p1 p2 p3 p2lst p3lst loop2 loop3 k circle pp lst triangles) (setq ss (ssget '((0 . "POINT")))) (repeat (setq n (sslength ss))   (setq pt (cdr (assoc 10 (entget (ssname ss (setq n (1- n)))))))   (setq ptlst (cons pt ptlst)) ) (setq pttlst ptlst) (while (> (length ptlst) 2)   (setq p1 (car ptlst))   (setq p2lst (cdr ptlst))   (setq loop2 T)   (while loop2     (setq p2 (car p2lst))     (setq p2lst (cdr p2lst))     (setq p3lst (vl-remove p2 (cdr ptlst)))     (setq k 0)     (setq loop3 T)     (while loop3       (setq p3 (car p3lst))       (setq p3lst (cdr p3lst))       (setq circle (circumtriang p1 p2 p3))       (setq pp (nearest (car circle) (vl-remove p1 (vl-remove p2 (vl-remove p3 pttlst)))))       (if (not (ptinsidecir pp circle))         (progn           (setq lst (cons p1 lst) lst (cons p2 lst) lst (cons p3 lst))           (setq triangles (cons lst triangles))           (setq k (1+ k))         )       )       (setq lst nil)       (if (equal p1 (car ptlst) 1e- (setq ptlst (cdr ptlst)))       (if (or (eq p3lst nil) (eq k 2)) (setq loop3 nil))       (if (or (= (length ptlst) 2) (eq p2lst nil)) (setq loop2 nil))     )   ) ) (foreach triangle (uniquetriangles triangles)   (entmake (list (cons 0 "3DFACE")(cons 10 (car triangle))(cons 11 (cadr triangle))(cons 12 (caddr triangle))(cons 13 (caddr triangle)))) ) (princ))

And faster code, but may skip some faces around boundary points - (revision 17.04.2012. (shouldn't skip any face)):

copy

(defun averpttriang (triangle) (mapcar '(lambda (a b c) (/ (+ a b c) 3.0)) (car triangle) (cadr triangle) (caddr triangle)))(defun unique (lst) (if lst (cons (car lst) (unique (vl-remove (car lst) (cdr lst))))))(defun uniquetriangles (triangles / lst assoctriangles uniquetriangs) (foreach triangle triangles   (setq lst (cons (averpttriang triangle) lst)) ) (setq lst (unique lst)) (foreach triangle triangles   (setq assoctriangles (cons (cons (averpttriang triangle) triangle) assoctriangles)) ) (foreach averpt lst   (setq uniquetriangs (cons (cdr (assoc averpt assoctriangles)) uniquetriangs)) ) uniquetriangs)(defun flatten (lst / lstn) (foreach triangle (reverse lst)   (setq lstn (cons (caddr triangle) lstn) lstn (cons (cadr triangle) lstn) lstn (cons (car triangle) lstn)) ) (reverse lstn))(defun nearest (pt lst / d1 d2 p1 p2) (setq lst (vl-remove pt lst)) (setq d1 (distance pt (car lst)) p1 (car lst)) (foreach p2 (cdr lst)   (if (> d1 (setq d2 (distance pt p2)))     (setq d1 d2 p1 p2)   ) ) p1)(defun mid (p1 p2) (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p2))(defun circumtriang (p1 p2 p3 / pp1 pp2 pp3 mp1p2 mp2p3 npmp1p2 npmp2p3 cen rad) (setq pp1 (list (car p1) (cadr p1))) (setq pp2 (list (car p2) (cadr p2))) (setq pp3 (list (car p3) (cadr p3))) (setq mp1p2 (mid pp1 pp2)) (setq mp2p3 (mid pp2 pp3)) (setq npmp1p2 (polar mp1p2 (+ (angle pp1 pp2) (/ pi 2.0)) 1.0)) (setq npmp2p3 (polar mp2p3 (+ (angle pp2 pp3) (/ pi 2.0)) 1.0)) (setq cen (inters mp1p2 npmp1p2 mp2p3 npmp2p3 nil)) (setq rad (distance cen p1)) (list cen rad))(defun ptinsidecir (pt circle) (setq pt (list (car pt) (cadr pt))) (> (cadr circle) (distance (car circle) pt)))(defun c:triangulate ( / ss n pt ptlst pttlst p1 p2 p3 p2lstt p2lst p3lst loop2 loop3 k circle pp lst triangles) (setq ss (ssget '((0 . "POINT")))) (repeat (setq n (sslength ss))   (setq pt (cdr (assoc 10 (entget (ssname ss (setq n (1- n)))))))   (setq ptlst (cons pt ptlst)) ) (setq ptlst (vl-sort ptlst '(lambda (a b) (< (car a) (car b))))) (setq pttlst ptlst) (acet-ui-progress "Progress : " n) (while (> (length ptlst) 2)   (setq p1 (car ptlst))   (setq p2lst (cdr ptlst))   (setq p2lstt p2lst)   (setq loop2 T)   (while loop2     (setq p2 (car p2lst))     (setq p2lst (cdr p2lst))     (setq p3lst (vl-remove p2 p2lstt))     (setq k 0)     (setq loop3 T)     (while loop3       (setq p3 (car p3lst))       (setq p3lst (cdr p3lst))       (setq circle (circumtriang p1 p2 p3))       (setq pp (nearest (car circle) (vl-remove p1 (vl-remove p2 (vl-remove p3 pttlst)))))       (if (not (ptinsidecir pp circle))         (progn           (setq lst (cons p1 lst) lst (cons p2 lst) lst (cons p3 lst))           (setq triangles (cons lst triangles))           (setq k (1+ k))         )       )       (setq lst nil)       (if (equal p1 (car ptlst) 1e- (setq ptlst (cdr ptlst)))       (if (eq k 2) (setq loop3 nil p2lst (vl-remove p3 p2lst) p2lst (cons p3 p2lst)))       (if (and (eq k 2) (member p3 (flatten (cdr triangles)))) (setq loop2 nil))       (if (eq p3lst nil) (setq loop3 nil))       (if (or (= (length ptlst) 2) (eq p2lst nil)) (setq loop2 nil))     )   )   (acet-ui-progress -1) ) (foreach triangle (uniquetriangles triangles)   (entmake (list (cons 0 "3DFACE")(cons 10 (car triangle))(cons 11 (cadr triangle))(cons 12 (caddr triangle))(cons 13 (caddr triangle)))) ) (acet-ui-progress-done) (princ))

M.R.

[编程交流] points density - dense.lsp - o

发表回复

精选推荐