|
|
(defun c:pts_along_pipe_trees_by_length ( / *error* pea cad doc -pi/2 3D->2D sortxy remduppoint removeiddup minpath reversepoly makepoly preprocess process bp dd ch c sss i poly n p pl ti trl edges nodes ell xll elqtlst ) ; ell xll elqtlst - lexical globals
(vl-load-com)
(defun *error* ( m )
(if pea
(setvar 'peditaccept pea)
)
(if (and doc (= 8 (logand 8 (getvar 'undoctl))))
(vla-endundomark doc)
)
(if doc
(vla-regen doc acactiveviewport)
)
(if m
(prompt m)
)
(princ)
)
(setq -pi/2 -1.5707963267948966192313216916398)
;; 3D to 2D point - M.R.
;; Returns 2D point list from supplied 3D point list or returns supplied argument if it isn't 3D point list
(defun 3D->2D ( p )
(if (and (listp p) (vl-every (function (lambda ( x ) (eq (type x) 'REAL))) p) (eq (length p) 3))
(list (car p) (cadr p))
p
)
)
;; ;
;; sortxy ;
;; ;
;; Sorts a list of points on Increasing X order and Increasing Y ;
;; ;
(defun sortxy ( lst )
(vl-sort lst
(function (lambda ( a b )
(if (= (car a) (car b))
(< (cadr a) (cadr b))
(< (car a) (car b))
)
))
)
)
;; ;
;; remduppoint by Joe Burke ;
;; ;
;; Remove Duplicate Adjacent Points from Point List with Fuzz Factor ;
;; Point List Needs to be Sorted Prior to Calling this Function ;
;; Modified by ymg to operate on 2d points. (3D->2D p) ;
;; Modified again by M.R. ;
;|
(defun remduppoint ( l fuzz / rtn p )
(repeat (1- (length l))
(setq p (car l))
(if (> (distance (3D->2D p) (cadr l)) fuzz)
(setq rtn (cons p rtn))
)
(setq l (cdr l))
)
(reverse (cons (car l) rtn))
)
|;
(defun remduppoint ( lst fuzz / l1 )
(setq lst (vl-sort lst (function (lambda ( a b ) (< (caddr a) (caddr b))))))
(while (car lst)
(setq l1 (cons (car lst) (vl-remove-if (function (lambda ( x ) (equal (list (car x) (cadr x)) (list (caar lst) (cadar lst)) fuzz))) l1)))
(setq lst (cdr lst))
)
l1
)
(defun removeiddup ( lst )
(if lst
(cons (car lst)
(removeiddup
(vl-remove-if
(function (lambda ( x )
(or
(and
(= (car x) (caar lst))
(= (cadr x) (cadar lst))
)
(and
(= (car x) (cadar lst))
(= (cadr x) (caar lst))
)
)
)) (cdr lst)
)
)
)
)
)
(defun unique ( lst fuzz / a ll )
(while (setq a (car lst))
(if (vl-some (function (lambda ( x ) (equal x a fuzz))) (cdr lst))
(setq ll (cons a ll) lst (vl-remove-if (function (lambda ( x ) (equal x a fuzz))) (cdr lst)))
(setq ll (cons a ll) lst (cdr lst))
)
)
(reverse ll)
)
;; Triangulate - subfunction for drawing Delunay triangulation from specified list of points with provided factor for checking weather calcualted triangulation is convex hull boundary triangulation
;; Returns list of 2 elements - first element is list of triangles defined by 3 points forming triangle and second element is calculated factor for forming supertriangle for next call of triangulate function for gathering correct convex hull boundary of triangulation triangles
(defun triangulate ( pl / tl xmin xmax ymin ymax cs pmin pmax t1 t2 t3 n str rs np al p el tr lst a b c vll cp r )
(setq xmin (caar pl)) ;;; Sorted pl by X ;;;
(setq xmax (caar (vl-sort pl (function (lambda ( a b ) (> (car a) (car b)))))))
(setq ymin (cadar (vl-sort pl (function (lambda ( a b ) (< (cadr a) (cadr b)))))))
(setq ymax (cadar (vl-sort pl (function (lambda ( a b ) (> (cadr a) (cadr b)))))))
(setq cs (list (+ xmin (/ (- xmax xmin) 2.0)) (+ ymin (/ (- ymax ymin) 2.0))))
(setq pmin (list xmin ymin) pmax (list xmax ymax))
(setq t1 (polar cs (/ pi 12.0) (if (setq n (atoi (substr (setq str (rtos (distance pmin cs) 1 0)) (- (strlen str) 2)))) (setq rs (expt 50.0 (+ n 2))))))
(setq t2 (polar cs (+ (/ pi 12.0) (/ (* 2.0 pi) 3.0)) rs))
(setq t3 (polar cs (+ (/ pi 12.0) (/ (* 4.0 pi) 3.0)) rs))
(setq np (length pl))
(setq pl (append pl (list (list (car t1) (cadr t1) 0.0) (list (car t2) (cadr t2) 0.0) (list (car t3) (cadr t3) 0.0))))
(setq al (list (list (car t1) cs rs (list np (+ 1 np) (+ 2 np)))))
(setq n -1)
(repeat np
(setq n (1+ n))
(setq p (nth n pl))
(setq el nil)
(repeat (length al)
(setq tr (car al))
(setq al (cdr al))
(cond
( (< (car tr) (car p)) ;;; Comparison of X values ;;;
(setq tl (cons (cadddr tr) tl))
)
( (< (distance p (cadr tr)) (caddr tr))
(setq a (car (cadddr tr)))
(setq b (cadr (cadddr tr)))
(setq c (caddr (cadddr tr)))
(setq el (vl-list* (list a b) (list b c) (list c a) el))
)
( t (setq lst (cons tr lst)) )
)
)
(setq al lst lst nil)
(while el ;;; el - edge list = ((a b) (b c) (c a) (d e) (e f) (f d) ... )
(if
(or
(vl-position (reverse (car el)) el)
(vl-position (car el) (cdr el))
)
(progn
(setq el (vl-remove (reverse (car el)) el))
(setq el (vl-remove (car el) el))
)
(progn ; This replaces call to getcircumcircle function ;
(setq p (nth n pl))
(setq b (nth (caar el) pl))
(setq c (nth (cadar el) pl))
(setq vll (list n (caar el) (cadar el)))
(if (not (zerop (setq ang (- (angle b c) (angle b p)))))
(progn
(setq cp (polar (3D->2D c) (+ -pi/2 (angle c p) ang) (setq r (/ (distance (3D->2D p) (3D->2D c)) (sin ang) 2.0))))
(setq al (cons (list (+ (car cp) (abs r)) cp (abs r) vll) al))
(setq el (cdr el))
)
(progn
(prompt "\nZero angle difference occurrence... Can't triangulate - quitting...")
(exit)
)
)
)
)
)
)
(foreach tr al
(setq tl (cons (cadddr tr) tl))
)
(setq tl
(vl-remove-if-not
(function (lambda ( x )
(and (< (car x) np) (< (cadr x) np) (< (caddr x) np))
)) tl
)
)
) ;;; end of triangulate
;; minpath - Dijkstra algorithm by ymg...
(defun minpath ( g f nodes edges / brname clnodes closedl goo new nodname old openl totdist ppath )
(setq nodes (vl-remove g nodes))
(setq openl (list (list g 0 nil)))
(setq closedl nil)
(setq goo t)
(foreach n nodes
(setq nodes (subst (list n 0 nil) n nodes))
)
(while (and goo (not (= (caar closedl) f)))
(setq nodname (caar openl))
(setq totdist (cadar openl))
(setq closedl (cons (car openl) closedl))
(setq openl (cdr openl))
(setq clnodes (mapcar (function car) closedl))
(foreach e edges
(setq brname nil)
(cond
( (= (car e) nodname)
(setq brname (cadr e))
)
( (= (cadr e) nodname)
(setq brname (car e))
)
)
(if brname
(progn
(setq new (list brname (+ (caddr e) totdist) nodname))
(cond
( (member brname clnodes) )
( (setq old (vl-some (function (lambda ( x ) (if (= brname (car x)) x))) openl))
(if (< (cadr new) (cadr old))
(setq openl (subst new old openl))
)
)
( t (setq openl (cons new openl)) )
)
)
)
)
(setq openl (vl-sort openl (function (lambda ( a b ) (< (cadr a) (cadr b))))))
(and (null openl) (null (caar closedl)) (setq go nil))
)
(setq ppath (list (car closedl)))
(foreach n closedl
(if (= (car n) (caddr (car ppath)))
(setq ppath (cons n ppath))
)
)
ppath
)
(defun reversepoly ( curve / rlw r3dp rhpl )
(defun rlw ( lw / e x1 x2 x3 x4 x5 x6 )
;; by ElpanovEvgeniy
(if (= (cdr (assoc 0 (setq e (entget lw)))) "LWPOLYLINE")
(progn
(foreach a1 e
(cond
( (= (car a1) 10) (setq x2 (cons a1 x2)) )
( (= (car a1) 40) (setq x4 (cons (cons 41 (cdr a1)) x4)) )
( (= (car a1) 41) (setq x3 (cons (cons 40 (cdr a1)) x3)) )
( (= (car a1) 42) (setq x5 (cons (cons 42 (- (cdr a1))) x5)) )
( (= (car a1) 210) (setq x6 (cons a1 x6)) )
( t (setq x1 (cons a1 x1)) )
)
)
(entmod (append (reverse x1)
(append (apply (function append)
(apply (function mapcar)
(cons (function list)
(list x2
(cdr (reverse (cons (car x3) (reverse x3))))
(cdr (reverse (cons (car x4) (reverse x4))))
(cdr (reverse (cons (car x5) (reverse x5))))
)
)
)
)
x6
)
)
)
(entupd lw)
)
)
)
;; Reverse 3DPOLYLINE - Marko Ribar, d.i.a.
(defun r3dp ( 3dp / r3dppol typ )
(defun r3dppol ( 3dp / v p pl sfa var )
(setq v 3dp)
(while (= (cdr (assoc 0 (entget (setq v (entnext v))))) "VERTEX")
(setq p (cdr (assoc 10 (entget v))) pl (cons p pl))
)
(setq pl (apply (function append) pl) sfa (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length pl)))))
(vlax-safearray-fill sfa pl)
(setq var (vlax-make-variant sfa))
(vla-put-coordinates (vlax-ename->vla-object 3dp) var)
(entupd 3dp)
)
(setq typ (vla-get-type (vlax-ename->vla-object 3dp)))
(vla-put-type (vlax-ename->vla-object 3dp) acsimplepoly)
(r3dppol 3dp)
(if typ (vla-put-type (vlax-ename->vla-object 3dp) typ))
(entupd 3dp)
)
;; Reverse old heavy 2d POLYLINE - Marko Ribar, d.i.a. - sub functions by Roy at Theswamp.org
(defun rhpl ( hpl / KGA_List_Divide_3 KGA_List_IndexSeqMakeLength KGA_Geom_PolylineReverse )
(defun KGA_List_Divide_3 ( lst / ret )
(repeat (/ (length lst) 3)
(setq ret (cons (list (car lst) (cadr lst) (caddr lst)) ret) lst (cdddr lst))
)
(reverse ret)
)
; Make a zero based list of integers.
(defun KGA_List_IndexSeqMakeLength ( len / ret )
(repeat (rem len 4)
(setq ret (cons (setq len (1- len)) ret))
)
(repeat (/ len 4)
(setq ret (vl-list* (- len 4) (- len 3) (- len 2) (- len 1) ret) len (- len 4))
)
ret
)
; Obj must be an "AcDb2dPolyline" of the acsimplepoly type or an "AcDbPolyline".
(defun KGA_Geom_PolylineReverse ( obj / typ bulgeLst idxLst ptLst widLst conWid v vx )
(setq typ (vla-get-type obj))
(vla-put-type obj acsimplepoly)
(setq ptLst (KGA_List_Divide_3 (vlax-get obj 'coordinates)) idxLst (KGA_List_IndexSeqMakeLength (1+ (length ptLst))) v (vlax-vla-object->ename obj))
(while (= (cdr (assoc 0 (setq vx (entget (setq v (entnext v)))))) "VERTEX")
(setq widLst (cons (list (cdr (assoc 40 vx)) (cdr (assoc 41 vx))) widLst) bulgeLst (cons (cdr (assoc 42 vx)) bulgeLst))
)
(if (vl-catch-all-error-p (setq conWid (vl-catch-all-apply (function vla-get-constantwidth) (list obj))))
(mapcar
(function (lambda ( idx pt bulge widSub )
(vla-put-coordinate obj idx (vlax-3d-point pt))
(vla-setbulge obj idx (- bulge))
(vla-setwidth obj idx (cadr widSub) (car widSub))
)) idxLst (reverse ptLst) (append (cdr bulgeLst) (list (car bulgeLst))) (append (cdr widLst) (list (car widLst)))
)
(progn
(mapcar
(function (lambda ( idx pt bulge widSub )
(vla-put-coordinate obj idx (vlax-3d-point pt))
(vla-setbulge obj idx (- bulge))
)) idxLst (reverse ptLst) (append (cdr bulgeLst) (list (car bulgeLst)))
)
(vla-put-constantwidth obj conWid)
)
)
(if typ (vla-put-type obj typ))
)
(KGA_Geom_PolylineReverse (vlax-ename->vla-object hpl))
(entupd hpl)
)
(cond
( (= (cdr (assoc 100 (reverse (entget curve)))) "AcDb2dPolyline") (rhpl curve) )
( (= (cdr (assoc 100 (reverse (entget curve)))) "AcDb3dPolyline") (r3dp curve) )
( (= (cdr (assoc 100 (reverse (entget curve)))) "AcDbPolyline") (rlw curve) )
)
)
(defun makepoly ( pl1 e qt c / polyprocess s ee eel el pl2 pl3 vl i len g f edgesn path n )
(defun polyprocess ( e q c / f ln ep i pbl par b arcll arclx a ex )
(setq ln (vlax-curve-getdistatparam e (setq ep (vlax-curve-getendparam e))))
(repeat (setq i (1+ (fix (+ 0.1 ep))))
(setq pbl
(cons
(list
(vlax-curve-getpointatparam e (float (setq i (1- i))))
(if (not (vl-catch-all-error-p (setq b (vl-catch-all-apply (function vla-getbulge) (list (vlax-ename->vla-object e) i))))) b)
) pbl
)
)
)
(setq par (vlax-curve-getparamatpoint e q))
(if (equal par ep 1e-6)
(progn
(reversepoly e)
(entupd e)
(setq f t)
)
)
(setq pbl nil)
(repeat (setq i (1+ (fix (+ 0.1 ep))))
(setq pbl
(cons
(list
(vlax-curve-getpointatparam e (float (setq i (1- i))))
(if (not (vl-catch-all-error-p (setq b (vl-catch-all-apply (function vla-getbulge) (list (vlax-ename->vla-object e) i))))) b)
) pbl
)
)
)
(setq par (vlax-curve-getparamatpoint e q))
(if (and par pbl)
(progn
(if
(and
(vlax-curve-getpointatparam e (float (fix (1+ par))))
(setq b (cadr (nth (fix par) pbl)))
)
(progn
(setq arcll
(-
(vlax-curve-getdistatparam e (float (fix (1+ par))))
(vlax-curve-getdistatparam e (float (fix par)))
)
)
(setq arclx
(-
(vlax-curve-getdistatparam e par)
(vlax-curve-getdistatparam e (float (fix par)))
)
)
(setq a (* 4.0 (atan b)))
(setq b (/ (sin (/ (* (/ a arcll) arclx) 4.0)) (cos (/ (* (/ a arcll) arclx) 4.0))))
)
)
(setq pbl (reverse (member (nth (fix par) pbl) (reverse pbl))))
(setq pbl (append (subst (list (car (last pbl)) b) (last pbl) pbl) (list (list q nil))))
(setq ex (entget e))
(if f
(progn
(reversepoly e)
(entupd e)
)
)
(if (vl-some (function numberp) (mapcar (function cadr) pbl))
(entmakex
(append
(list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 (length pbl))
(cons 70 (* 128 (getvar 'plinegen)))
(assoc 38 ex)
)
(apply (function append)
(mapcar
(function (lambda ( x )
(list
(cons 10 (trans (car x) 0 (cdr (assoc 210 ex))))
(cons 40 0.0)
(cons 41 0.0)
(cons 42 (if (cadr x) (cadr x) 0.0))
(cons 91 0.0)
)
)) pbl
)
)
(list
(assoc 210 ex)
(cons 62 c)
)
)
)
(progn
(vl-cmdf "_.3DPOLY")
(foreach pb pbl
(vl-cmdf "_non" (trans (car pb) 0 1))
)
(vl-cmdf "")
(entupd
(cdr
(assoc -1
(entmod
(if (assoc 62 (setq ex (entget (entlast))))
(subst (cons 62 c) (assoc 62 ex) ex)
(append ex (list (cons 62 c)))
)
)
)
)
)
)
)
)
)
)
(if (not pl1)
(setq xll (cons (setq pl1 (polyprocess e qt c)) xll))
)
(setq qt (trans (vlax-curve-getpointatparam pl1 0.0) 0 1))
(if (equal qt xxxx 1e-6)
(princ)
)
(if
(and
(not (equal (trans qt 1 0) (trans bp 1 0) 1e-6))
(setq s (ssget "_C" (mapcar (function +) (list -1e-3 -1e-3) qt) (mapcar (function +) (list 1e-3 1e-3) qt) (list (cons 0 "*POLYLINE"))))
(> (sslength s) 0)
)
(progn
(if (ssmemb e s)
(ssdel e s)
)
(if (ssmemb pl1 s)
(ssdel pl1 s)
)
(foreach x xll
(if (and s (ssmemb x s))
(ssdel x s)
)
)
(if (and s (> (sslength s) 0))
(setq eel (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex s))))
)
;(setq len (- dd (vlax-curve-getdistatparam pl1 (vlax-curve-getendparam pl1))))
(setq n nil)
(setq g (vl-some (function (lambda ( x ) (setq n (if (not n) 0 (1+ n))) (if (equal x (trans qt 1 0) 1e-6) n))) pl))
(setq n nil)
(setq f (vl-some (function (lambda ( x ) (setq n (if (not n) 0 (1+ n))) (if (equal x (trans bp 1 0) 1e-6) n))) pl))
(setq edgesn (vl-remove-if (function (lambda ( x ) (or (and (= (car x) g) (= (cadr x) f)) (and (= (cadr x) g) (= (car x) f))))) edges))
(setq path (mapcar (function (lambda ( x ) (nth x pl))) (mapcar (function car) (minpath g f nodes edgesn))))
(setq n nil)
;|
(setq ee
(car
(vl-sort (vl-remove-if-not (function (lambda ( x ) (vl-position x eel))) (append (vl-remove-if (function (lambda ( y ) (vl-position y xll))) ell) eel))
(function (lambda ( a b )
(if (vlax-curve-getparamatpoint a (trans bp 1 0))
a
(<
(vlax-curve-getdistatpoint a (trans pt 1 0))
(vlax-curve-getdistatpoint b (trans pt 1 0))
)
)
))
)
)
)
(progn
(prompt "\nnodes : ") (princ nodes)
(prompt "\nedges : ") (princ edges)
(prompt "\ng : ") (princ g)
(prompt "\nf : ") (princ f)
(prompt "\npath : ") (princ path)
)
(progn
(princ "\n")
(princ (trans pt 1 0))
(princ (car path))
(princ "\n")
(princ (trans bp 1 0))
(princ (last path))
(exit)
)
|;
(setq ee (car (vl-remove-if-not (function (lambda ( x ) (or (vlax-curve-getparamatpoint x (trans bp 1 0))))) eel)))
(if (not ee)
(setq ee (car (vl-remove-if-not (function (lambda ( x ) (or (vlax-curve-getparamatpoint x (cadr path))))) eel)))
)
(if ee
(progn
(setq f nil)
(setq pl3 (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object pl1))))
(if
(>
(vlax-curve-getparamatpoint ee (trans qt 1 0))
(if (vlax-curve-getparamatpoint ee (trans bp 1 0))
(vlax-curve-getparamatpoint ee (trans bp 1 0))
(vlax-curve-getparamatpoint ee (cadr path))
)
)
(setq pl2 (polyprocess ee qt c))
(progn
(reversepoly ee)
(entupd ee)
(setq pl2 (polyprocess ee qt c))
(setq f t)
)
)
(if f
(progn
(reversepoly ee)
(entupd ee)
)
)
(if (and pl2 (not (vlax-erased-p pl2)) pl3 (not (vlax-erased-p pl3)))
(progn
(setq el (entlast))
(vl-cmdf "_.PEDIT" "_M" (ssadd pl2 (ssadd pl3)) "" "_J")
(while (< 0 (getvar 'cmdactive))
(vl-cmdf "")
)
;(vl-cmdf "_.JOIN" (ssadd pl2 (ssadd pl3)) "")
(if (not (eq el (entlast)))
(setq el (entlast))
(setq el (if pl2 pl2 pl3))
)
(preprocess el)
(if (vl-position pl1 xll)
(setq xll (subst el pl1 xll))
(setq xll (cons el xll))
)
)
)
)
)
(if (and ee pl1 (not (vlax-erased-p pl1)))
(entdel pl1)
)
(if (and ee el)
(progn
(if (not (equal (vlax-curve-getpointatparam el 0.0) (trans bp 1 0) 1e-6))
(if (not (vl-some (function (lambda ( x ) (equal x (list el qt) 1e-6))) elqtlst))
(progn
(setq elqtlst (cons (list el qt) elqtlst))
(makepoly el el qt c)
)
)
)
)
)
)
)
)
(defun preprocess ( e / uniquevbl ss ex i b vbl sa coords )
(defun uniquevbl ( lst )
(if lst
(cons (car lst)
(uniquevbl
(vl-remove-if
(function (lambda ( x )
(equal (caar lst) (car x) 1e-6)
)) (cdr lst)
)
)
)
)
)
(if (or e (setq ss (ssget "_A" (list (cons 0 "*POLYLINE")))))
(foreach pl (if e (list e) (vl-remove (function listp) (mapcar (function cadr) (ssnamex ss))))
(setq ex (entget pl))
(if
(and
(not e)
(or
(= (cdr (assoc 90 ex)) 1)
(and
(= (cdr (assoc 90 ex)) 2)
(equal (cdr (assoc 10 ex)) (cdr (assoc 10 (reverse ex))) 1e-6)
)
)
)
(entdel pl)
)
(if (not (vlax-erased-p pl))
(progn
(setq vbl nil)
(setq i (1+ (fix (+ 0.1 (vlax-curve-getendparam pl)))))
(while (<= 0 (setq i (1- i)))
(setq vbl (cons (list (vlax-curve-getpointatparam pl (float i)) (if (not (vl-catch-all-error-p (setq b (vl-catch-all-apply (function vla-getbulge) (list (vlax-ename->vla-object pl) i))))) b)) vbl))
)
(setq vbl (uniquevbl vbl))
(if (= (cdr (assoc 0 ex)) "LWPOLYLINE")
(progn
(setq vbl (mapcar (function (lambda ( x ) (list (trans (car x) 0 (cdr (assoc 210 ex))) (cadr x)))) vbl))
(setq ex (subst (cons 90 (length vbl)) (assoc 90 ex) ex))
(setq ex
(append
(vl-remove-if
(function (lambda ( x )
(vl-position (car x) (list 10 40 41 42 91 210))
)) ex
)
(apply (function append)
(mapcar
(function (lambda ( x )
(list
(cons 10 (car x))
(cons 40 0.0)
(cons 41 0.0)
(cons 42 (cadr x))
(cons 91 0.0)
)
)) vbl
)
)
(list (assoc 210 ex))
)
)
(entupd (cdr (assoc -1 (entmod ex))))
)
(progn
(setq sa (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length (setq coords (apply (function append) (mapcar (function car) vbl))))))))
(vla-put-coordinates (vlax-ename->vla-object pl) (vlax-make-variant (vlax-safearray-fill sa coords)))
)
)
)
)
)
)
)
(defun process ( dd qt pt / proclst processlst ss i el e d len f par lst pp )
(defun proclst ( e dd qt pt / par dx ddd )
(if
(and
(setq par (float (fix (vlax-curve-getparamatpoint e (trans qt 1 0)))))
(setq dx (vlax-curve-getdistatparam e par))
)
(progn
(setq ddd (- dd dx))
(if (> ddd 0)
(setq processlst (cons (list ddd qt pt) processlst))
)
)
)
)
(if
(and
(setq ss (ssget "_C" (mapcar (function +) (list -1e-3 -1e-3) (setq qt (osnap qt "_nea"))) (mapcar (function +) (list 1e-3 1e-3) qt) (list (cons 0 "*POLYLINE"))))
(progn
(foreach x (append xll ell)
(if (ssmemb x ss)
(ssdel x ss)
)
)
(and ss (> (sslength ss) 0))
)
)
(progn
(repeat (setq i (sslength ss))
(if
(and
(not (vl-position (setq e (ssname ss (setq i (1- i)))) ell))
(not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-curve-getstartpoint) (list e))))
(not (vl-position e (append ell xll)))
)
(setq el (cons (list e pt) el))
)
)
(if el
(progn
(setq ell (append (vl-remove-if (function (lambda ( x ) (vl-position x xll))) (mapcar (function car) el)) ell))
(foreach ep el
(setq f nil lst nil)
(setq e (car ep) pt (cadr ep))
(setq d (vlax-curve-getdistatpoint e (trans qt 1 0)))
(setq len (vlax-curve-getdistatparam e (vlax-curve-getendparam e)))
(if (equal d len 1e-6)
(progn
(reversepoly e)
(entupd e)
(setq f t)
)
)
(setq d (vlax-curve-getdistatpoint e (trans qt 1 0)))
(repeat (setq par (fix (+ 0.1 (vlax-curve-getendparam e))))
(setq lst
(cons
(trans (vlax-curve-getpointatparam e (float (1+ (fix (setq par (1- par)))))) 0 1)
lst
)
)
)
(foreach p lst
(if (not (equal p pt 1e-6))
(proclst e dd p pt)
)
)
(cond
( (and
(zerop d)
(= (cdr (assoc 90 (entget e))) 2)
(vlax-curve-getpointatdist e dd)
)
(if (and e (not (vlax-erased-p e)) (setq pp (vlax-curve-getpointatdist e dd)))
(progn
(entmake (list (cons 0 "POINT") (cons 10 pp)))
(if (= ch "Yes") (makepoly nil e pp c))
)
)
)
( (<= 0.0 (+ d dd) len)
(if (and e (not (vlax-erased-p e)) (setq pp (vlax-curve-getpointatdist e (+ d dd))))
(progn
(entmake (list (cons 0 "POINT") (cons 10 pp)))
(if (= ch "Yes") (makepoly nil e pp c))
)
)
)
)
(if f
(progn
(reversepoly e)
(entupd e)
)
)
)
)
)
(foreach lst processlst
(process (car lst) (cadr lst) (caddr lst))
(setq processlst (cdr processlst))
)
)
)
)
(setq pea (getvar 'peditaccept))
(setvar 'peditaccept 1)
(if
(and
(setq doc (vla-get-activedocument (setq cad (vlax-get-acad-object))))
(= 8 (logand 8 (getvar 'undoctl)))
)
(vla-endundomark doc)
)
(if doc
(vla-startundomark doc)
)
(if
(and
(setq bp (getpoint "\nPick or specify main base point : "))
(not (initget 6))
(setq dd (cond ( (not (setq dd (getdist bp "\nPick or specify length from base point for spread around <1.0> : "))) 1.0 ) ( t dd )))
(not (initget "Yes No"))
(setq ch (cond ( (not (setq ch (getkword "\nDo you want to overmake new polylines up to resulting points [Yes / No] <Yes> : "))) "Yes" ) ( t ch )))
(if (= ch "Yes")
(progn
(initget 6)
(setq c (cond ( (not (setq c (getint "\nSpecify color for new polylines <3> : "))) 3 ) ( t c )))
)
t
)
)
(progn
(setq ti (car (_vl-times)))
(if cad
(vla-zoomextents cad)
)
(setq sss (ssget "_A" (list (cons 0 "*POLYLINE"))))
(repeat (setq i (sslength sss))
(setq poly (ssname sss (setq i (1- i))))
(setq n (1+ (fix (+ 0.1 (vlax-curve-getendparam poly)))))
(while (<= 0 (setq n (1- n)))
(setq p (vlax-curve-getpointatparam poly (float n)))
(if (not (equal p (car pl) 1e-6))
(setq pl (cons p pl))
)
)
)
(setq trl (triangulate (setq pl (sortxy (remduppoint pl 1e-6)))))
(setq edges (removeiddup (apply (function append) (mapcar (function (lambda ( x ) (list (list (car x) (cadr x) (distance (nth (car x) pl) (nth (cadr x) pl))) (list (cadr x) (caddr x) (distance (nth (cadr x) pl) (nth (caddr x) pl))) (list (caddr x) (car x) (distance (nth (caddr x) pl) (nth (car x) pl)))))) trl))))
(setq nodes (mapcar (function (lambda ( x ) (vl-position x pl))) pl))
(preprocess nil)
(process dd bp bp)
(prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
)
)
(*error* nil)
) |
|
发表于 2024-6-22 09:46:18
