I worked just a little more ab this 2D solutions and yesterday I've made this code... It is with approximately good results, also not 100% reliable, but I must warn you - it is the slowest code I ever made... So if you have example that's not to complex, and soultion is unique - no additional roof porches and you have a time to experiment you can try it... But it's not 100% correct also... My recomendations is to use last code I posted to Evgeniy, if you're not satisfied then try first code posted in [ code ] tags - not [ code=cadlisp-7 ] tags, and if you again aren't satisfied and if you have time and strong computer only then try this code... My motives for posting this one is that fact that it introduces few new sub-functions that may be useful and are related to this task... So I warned you - this isn't the worst code, but certainly the slowest one... Be careful with your time - maybe someone can do it manually faster...
(defun 2droof (pol / ListDupes valid-inscribed-circle-p inscribed-circle 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)
(defun ListDupes (l / x r)
(while l
(if (vl-member-if '(lambda (a) (equal a (setq x (car l)) 1e-10)) (cdr l))
(setq r (cons x r))
)
(setq l (vl-remove x (cdr l)))
)
(reverse (acet-list-remove-duplicates r 1e-6))
)
(defun valid-inscribed-circle-p (p pol / plst xl xll ip ipp dstl)
(setq
plst (mapcar '(lambda (x) (list (car x) (cadr x) 0.0))
(mapcar 'cdr (acet-list-m-assoc 10 (entget pol)))
)
)
(mapcar '(lambda (a b)
(progn (setq xl
(entmakex (list '(0 . "XLINE") '(100 . "AcDbEntity") '(100 . "AcDbXline") (cons 10 a) (cons 11 (unit (mapcar '- b a)))))
)
(setq xll (cons xl xll))
)
)
plst
(cdr (reverse (cons (car plst) (reverse plst))))
)
(foreach x xll
(setq ip (vlax-curve-getclosestpointto x p))
(setq ipp (cons ip ipp))
)
(setq dstl (mapcar '(lambda (x) (distance x p)) ipp))
(foreach x xll
(entdel x)
)
;(foreach r (ListDupes dstl)
; (entmake (list '(0 . "CIRCLE") (cons 10 (list (car p) (cadr p) 0.0)) (cons 40 r)))
;)
(if (ListDupes dstl) t nil)
)
(defun inscribed-circle (p pol / plst xl xll ip ipp dstl)
(setq
plst (mapcar '(lambda (x) (list (car x) (cadr x) 0.0))
(mapcar 'cdr (acet-list-m-assoc 10 (entget pol)))
)
)
(mapcar '(lambda (a b)
(progn (setq xl
(entmakex (list '(0 . "XLINE") '(100 . "AcDbEntity") '(100 . "AcDbXline") (cons 10 a) (cons 11 (unit (mapcar '- b a)))))
)
(setq xll (cons xl xll))
)
)
plst
(cdr (reverse (cons (car plst) (reverse plst))))
)
(foreach x xll
(setq ip (vlax-curve-getclosestpointto x p))
(setq ipp (cons ip ipp))
)
(setq dstl (mapcar '(lambda (x) (distance x p)) ipp))
(foreach x xll
(entdel x)
)
(eval (cons 'min (ListDupes dstl)))
)
(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 pln
(mapcar
'(lambda (x)
(if (valid-inscribed-circle-p 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 (not (= (length pln) 1)) vx)
(progn
(setq vx (vl-sort vx
'(lambda (a b)
(< (inscribed-circle (cadr a) pol)
(inscribed-circle (cadr b) pol)
)
)
)
)
(if (and plnz (equal (cadr plnz) (inscribed-circle (cadar vx) pol) 1e-6))
(if (equal (cadar vx) (cadadr vx) 1e-8)
(if (> (distance (car plnz) (cadar vx)) (distance (car plnz) (cadr (caddr vx))))
(setq vx (cons (caddr vx) vx))
)
(if (> (distance (car plnz) (cadar vx)) (distance (car plnz) (cadadr vx)))
(setq vx (cons (cadr vx) vx))
)
)
)
(setq pln (list (cadar vx)))
)
)
(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)
)
(if pln (setq plnz (list (car pln) (inscribed-circle (car pln) pol))))
(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 plnz)
(vl-load-com)
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
(defun *error* (msg)
(if plnz
(setq plnz 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)
)
