There is more food for thoughts, but this one is the worst... But, perhaps someone find it usable in making good mods...
(defun 2droof (pol / insidep unique _vl-remove ridge onlin-p assocon prelst suflst
ll pl pln i rl tl v v1 v2 vl vp vp1 vp2 vpp1 vpp2 vpl vrl vtl vx fl
)
(defun insidep (pt entn / big flag obj1 obj2 obj3 p1 p2 small)
(if (and pt entn)
(progn
(setq obj1 (vlax-ename->vla-object entn))
(setq obj2 (car (vlax-invoke obj1 'Offset 0.001))
obj3 (car (vlax-invoke obj1 'Offset -0.001))
)
(if (> (vla-get-area obj2) (vla-get-area obj3))
(progn
(set 'big obj2)
(set 'small obj3)
)
(progn
(set 'big obj3)
(set 'small obj2)
)
)
(setq p1 (vlax-curve-getClosestPointTo big pt)
p2 (vlax-curve-getClosestPointTo small pt)
)
(if (> (distance pt p1) (distance pt p2))
(setq flag T)
(setq flag nil)
)
(mapcar (function (lambda (x)
(progn
(vla-delete x)
(vlax-release-object x)
)
)
)
(list big small)
)
)
)
flag
)
(defun unique (lst)
(if lst
(cons (car lst)
(unique (_vl-remove (car lst) (cdr lst) 1e-6))
)
)
)
(defun _vl-remove (el lst fuzz)
(vl-remove-if
'(lambda (x)
(and (equal (car x) (car el) fuzz)
(equal (cadr x) (cadr el) fuzz)
)
)
lst
)
)
(defun ridge (v1 v2)
(if (not
(minusp (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1))))
)
(mapcar '*
(list -1.0 -1.0 -1.0)
(mapcar '- v1 v2)
)
(if (or (equal (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1)))
0.0
1e-8
)
(equal (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1)))
-0.0
-1e-8
)
)
(if (equal v1 v2 1e-8)
(polar '(0.0 0.0 0.0)
(+ (angle '(0.0 0.0 0.0) v1) (/ pi 2.0))
1.0
)
v2
)
(mapcar '- v1 v2)
)
)
)
(defun onlin-p (p1 p2 p)
(and
(equal (distance p1 p2)
(+ (distance p1 p) (distance p2 p))
1e-8
)
(not (equal p1 p 1e-8))
(not (equal p2 p 1e-8))
)
)
(defun assocon (SearchTerm Lst func fuzz)
(car
(vl-member-if
(function
(lambda (pair)
(equal SearchTerm (apply func (list pair)) fuzz)
)
)
lst
)
)
)
(defun prelst (lst el / f)
(vl-remove-if
'(lambda (a) (or f (setq f (equal a el 1e-8))))
lst
)
)
(defun suflst (lst el)
(cdr (vl-member-if '(lambda (a) (equal a el 1e-8)) lst))
)
(defun unit (v)
(mapcar '(lambda (x) (/ x (distance '(0.0 0.0 0.0) v))) v)
)
(setq
vl (mapcar
'cdr
(vl-remove-if-not
'(lambda (x) (= (car x) 10))
(entget pol)
)
)
)
(setq vl (cons (last vl) vl))
(setq tl (mapcar '(lambda (a b) (mapcar '- b a)) vl (cdr vl)))
(setq tl (mapcar '(lambda (x) (unit x)) tl))
(setq vtl (mapcar '(lambda (a b) (list a b)) vl tl))
(setq rl (mapcar '(lambda (a b) (ridge a b))
tl
(cdr (reverse (cons (car tl) (reverse tl))))
)
)
(setq rl (mapcar '(lambda (x) (unit x)) rl))
(setq vrl (mapcar '(lambda (a b) (list a b))
(cdr (reverse (cons (car vl) (reverse vl))))
rl
)
)
(setq vrl (cons (last vrl) (reverse (cdr (reverse vrl)))))
(setq pln T)
(defun kr (lst / pl vpx1 vpxp1 vpx2 vpxp2 pp vxx z)
(mapcar
'(lambda (a b)
(setq p
(inters (car a)
(mapcar '+ (car a) (cadr a))
(car b)
(mapcar '+ (car b) (cadr b))
nil
)
)
(setq pl (cons p pl))
)
(reverse (cons (car lst) (reverse lst)))
(cdr (reverse (cons (car lst) (reverse lst))))
)
(setq vpl (mapcar '(lambda (a b c) (list (list a b) (list c b)))
vl
(reverse pl)
(cdr (reverse (cons (car vl) (reverse vl))))
)
)
(setq vpl (apply 'append vpl))
; (while (assocon nil vpl 'cadr 1e-6)
; (setq vpl (vl-remove (assocon nil vpl 'cadr 1e-6) vpl))
; )
(setq pln nil)
(foreach p pl
(if (vl-some
'(lambda (x)
(vl-catch-all-apply 'onlin-p (list (car x) (cadr x) p))
)
vpl
)
(setq pln (cons p pln))
)
)
(setq pln (mapcar '(lambda (x) (if (insidep x pol) x)) pln))
(setq pln (vl-remove nil pln))
(setq vx nil)
(foreach p pln
(mapcar '(lambda (x)
(if (equal (cadr x) p 1e-6)
(setq vx (cons x vx))
)
)
vpl
)
)
(if (and (null fl) (null plnn)) (setq plnn pln fl t))
(setq vxx vx)
(if plnz (setq plnzz (cons (car plnz) plnzz)))
(if (and (not (= (length pln) 1)) vx)
(progn
(setq vx (vl-sort vx
'(lambda (a b)
(< (distance (car a) (cadr a))
(distance (car b) (cadr b))
)
)
)
)
(if (car plnn)
(if (vl-some
'(lambda (x)
(onlin-p (car x) (cadr x) (car plnn))
)
vx
)
(if (assocon (car plnn) vx 'cadr 1e-6)
(setq
vx (subst (assocon (car plnn) vx 'cadr 1e-6) (car vx) vx)
)
)
)
)
(if (and (null plnn) plnz)
(progn
(setq vx (vl-sort vx
'(lambda (a b)
(< (distance (cadr a) (car plnz))
(distance (cadr b) (car plnz))
)
)
)
)
(setq vx (vl-remove-if-not '(lambda (x) (equal (car x) (car plnz) 1e-6)) vx))
(if (and (eq (length vx) 2)
(> (distance (caar vx) (cadar vx))
(distance (caadr vx) (cadadr vx))
)
)
(setq vx (cons (cadr vx) (cons (car vx) (cddr vx))))
)
(foreach v vpl
(if (setq catch (vl-catch-all-apply
'onlin-p
(list (car v) (cadr v) (car plnz))
)
)
(if (vl-catch-all-error-p catch)
(setq tst (cons nil tst))
(setq tst (cons T tst))
)
(setq tst (cons nil tst))
)
)
(setq vxxx (vl-sort vxx
'(lambda (a b)
(< (distance (car a) (cadr a))
(distance (car b) (cadr b))
)
)
)
)
(if plnzz
(foreach p plnzz
(if (assocon p vxxx 'car 1e-6)
(setq
vxxx (vl-remove (assocon p vxxx 'car 1e-6) vxxx)
)
)
(if (assocon p vxxx 'car 1e-6)
(setq
vxxx (vl-remove (assocon p vxxx 'car 1e-6) vxxx)
)
)
)
)
(if (or (/= (length vx) 2)
(eval (cons 'or tst))
(if (and vxxx vx (onlin-p (caar vx) (cadar vxxx) (cadar vx)))
(> (distance (caar vx) (cadar vx))
(distance (caar vx) (cadar vxxx))
)
(if (not (null vxxx))
(> (distance (caar vx) (cadar vx))
(distance (caar vxxx) (cadar vxxx))
)
nil
)
)
)
(progn
(if vxxx
(setq vx (vl-sort vxxx
'(lambda (a b)
(< (distance (cadr a) (car plnz))
(distance (cadr b) (car plnz))
)
)
)
)
(setq vx (vl-sort vxx
'(lambda (a b)
(< (distance (car a) (cadr a))
(distance (car b) (cadr b))
)
)
)
)
)
)
)
)
)
(setq plnn (cdr plnn))
(setq pln (list (cadar vx)))
)
)
(setq tst nil)
(if (null vx)
(setq pln nil)
)
(if (vl-every '(lambda (x) (equal (cadar vpl) (cadr x) 1e-6))
vpl
)
(if (and (vl-every '(lambda (x) (eq (cadr x) nil)) vpl)
(eq (length (unique vpl)) 2)
)
(progn
(setq z (entmakex (list '(0 . "LINE")
(cons 10 (caar (unique vpl)))
(cons 11 (caadr (unique vpl)))
)
)
zz (cons z zz)
)
(setq pln nil)
)
(progn
(foreach l (unique vpl)
(setq z (entmakex (list '(0 . "LINE")
(cons 10 (car l))
(cons 11 (cadr l))
)
)
zz (cons z zz)
)
)
(setq pln nil)
)
)
)
(if (equal pln (list nil))
(setq pln nil)
)
(setq plnz pln)
(foreach p pln
(setq vp1 (cons (assocon p vpl 'cadr 1e-6) vp1))
(setq vp2 (cons (assocon p (cdr (member (car vp1) vpl)) 'cadr 1e-6) vp2))
(if (car vp1)
(setq z (entmakex (list '(0 . "LINE")
(cons 10 (caar vp1))
(cons 11 (cadar vp1))
)
)
zz (cons z zz)
)
)
(if (car vp2)
(setq z (entmakex (list '(0 . "LINE")
(cons 10 (caar vp2))
(cons 11 (cadar vp2))
)
)
zz (cons z zz)
)
)
(setq vpp2 (caar vp2))
(setq v2 nil)
(while (setq vpp2 (car (assocon vpp2 vp2 'cadr 1e-6)))
(if (not (null vpp2))
(setq v2 vpp2)
)
)
(if (null v2)
(setq v2 (caar vp2))
)
(setq vpp1 (caar vp1))
(setq v1 nil)
(while (setq vpp1 (car (assocon vpp1 vp1 'cadr 1e-6)))
(if (not (null vpp1))
(setq v1 vpp1)
)
)
(if (null v1)
(setq v1 (caar vp1))
)
(setq pp
(list
p
(unit
(ridge
(if
(cadr
(last (prelst vtl (assocon v1 vtl 'car 1e-6)))
)
(cadr
(last (prelst vtl (assocon v1 vtl 'car 1e-6)))
)
(cadr (last vtl))
)
(cadr (assocon v2 vtl 'car 1e-6))
)
)
)
)
(setq vrl (if vrl
(subst pp (assocon (caar vp1) vrl 'car 1e-6) vrl)
(subst pp (assocon (caar vp1) lst 'car 1e-6) lst)
)
vrl (if (assocon (caar vp2) vrl 'car 1e-6)
(subst pp (assocon (caar vp2) vrl 'car 1e-6) vrl)
)
)
(setq vl (subst p (caar vp1) vl)
vl (subst p (caar vp2) vl)
)
)
)
(while pln (kr vrl))
)
(defun c:2droof-MR (/ *error* adoc plnn plnz plnzz)
(vl-load-com)
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
(defun *error* (msg)
(if plnn
(setq plnn nil)
)
(if plnz
(setq plnz nil)
)
(if plnzz
(setq plnzz nil)
)
(if zz
(setq zz nil)
)
(if poly
(setq poly nil)
)
(vla-endundomark adoc)
(if msg
(prompt msg)
)
(princ)
)
(vla-startundomark adoc)
(setq poly
(car
(entsel
"\nPick closed LWPOLYLINE in WCS oriented CCW and with only straight segments-edges"
)
)
)
(2droof poly)
(*error* nil)
(princ)
)
