I have a LISP solution which I believe yields the correct straight skeleton result for 90% of cases, but have not released it as freeware:You are great! I wish it won't undercut your business! :lmao:
..
Where were you 6 years ago! 8-)Yes, that one has alluded me for a long time. :-(
http://www.theswamp.org/index.php?topic=9659.msg123862;topicseen#msg123862
;-)
Current project. Roof ridge is not correct but close.:-o Holly Batman and I thought I had it bad! We do a lot of wood framed apartment buildings so little more consistency before a change in a roof plane. I forgot about McMansions.
It is a remodel so I don't need it to be correct.
This example will surely undercut Lee's business with the code selling... Maybe Lee would change his mind and post the code for learning purposes of us that don't know how to create *.lsp routine for this...
LeeMac has invested considerable time and effort in learning to code well. I think he has every rightMe too . :-)
to recoup something for his investment. He has shared his talent freely in many threads so I feel
he has given plenty to our community.
I have a LISP solution which I believe yields the correct straight skeleton result for 90% of cases, but have not released it as freeware:
(http://www.theswamp.org/lilly_pond/leemac/Straight-Skeleton.gif)
Some more examples:
(http://www.theswamp.org/lilly_pond/leemac/Straight-Skeleton2.gif)
Awesome Lee... so where does one purchase such a cool bit of code?
THE CODE REMOVED DUE IT'S UNNECESSARY - HAVEN'T GIVE CORRECT RESULTS UNDER A2008... CHECK MY POST BELOW WITH CODE CORRECT FOR A2008->A2012...
Command: roof
Pick 2d polyline
Pick point inside 2d polyline
Enter choice (2D / 3D) : 2D
Unknown command "ROOF". Press F1 for help.
Requires numeric distance, two points, or option keyword.
Unable to extrude the selected object.
Unknown command "ROOF". Press F1 for help.
1 face found.
Modeling Operation Error:
No solution for a vertex.
Unknown command "ROOF". Press F1 for help.
But Lee, isn't this the same as yours (used cheat from video I posted)... Only thing is one more input of inside polyline point...Nice code!Thanks!
...
M.R.
Command: extrude
Current wire frame density: ISOLINES=4
Select objects: 1 found
Select objects:
Specify height of extrusion or [Path]: Specify second point:
Specify angle of taper for extrusion <0>: 45
Which One is right ?
(-1 . <Entity name: 78e362b8>)
(0 . "LWPOLYLINE")
(330 . <Entity name: 7ee6fc10>)
(5 . "9D887")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(100 . "AcDbPolyline")
(90 . 7)
(70 . 1)
(43 . 0.0)
(38 . 0.0)
(39 . 0.0)
(10 2257.34 2328.59)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 2447.94 2328.59)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 2447.94 2181.56)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 2335.75 2181.56)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 2335.75 2222.18)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 2257.34 2222.18)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 2257.34 2328.59)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(210 0.0 0.0 1.0)
(-1 . <Entity name: 78e36248>)
(0 . "LWPOLYLINE")
(330 . <Entity name: 7ee6fc10>)
(5 . "9D879")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(100 . "AcDbPolyline")
(90 . 8)
(70 . 1)
(43 . 0.0)
(38 . 0.0)
(39 . 0.0)
(10 2054.14 2133.5)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 2054.14 2184.36)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 1984.3 2184.36)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 1984.3 2328.33)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 2201.47 2328.33)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 2201.47 2163.63)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 2108.51 2163.63)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 2108.51 2133.5)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(210 0.0 0.0 1.0)
(-1 . <Entity name: 78e59cf8>)
(0 . "LWPOLYLINE")
(330 . <Entity name: 78e6dc10>)
(5 . "31BF")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(100 . "AcDbPolyline")
(90 . 18)
(70 . 1)
(43 . 0.0)
(38 . 0.0)
(39 . 0.0)
(10 788.057 1041.58)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 926.057 1041.58)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 926.057 883.583)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 1090.06 883.583)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 1090.06 898.583)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 1198.06 898.583)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 1198.06 877.583)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 1410.06 877.583)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 1410.06 1355.58)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 1363.56 1355.58)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 1363.56 1369.58)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 1245.56 1369.58)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 1245.56 1355.58)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 1216.06 1355.58)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 1216.06 1417.58)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 969.266 1417.58)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 969.266 1563.58)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 788.057 1563.58)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(210 0.0 0.0 1.0)
(-1 . <Entity name: 78de2858>)
(0 . "LWPOLYLINE")
(330 . <Entity name: 78df7c10>)
(5 . "19F53")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "TEXT")
(100 . "AcDbPolyline")
(90 . 10)
(70 . 1)
(43 . 0.0)
(38 . 0.0)
(39 . 0.0)
(10 2666.24 -241.035)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 2433.3 -241.035)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 2433.3 111.629)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 2666.24 111.629)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 2666.24 40.2463)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 2990.99 40.2461)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 2990.99 -238.486)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 2868.57 -238.486)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 2868.57 -178.151)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 2666.24 -178.15)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(210 0.0 0.0 1.0)
Cab Wrote
LeeMac has invested considerable time and effort in learning to code well. I think he has every right
to recoup something for his investment. He has shared his talent freely in many threads so I feel
he has given plenty to our community.
Krampaul82 wrote;
Agreed!
(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
)
(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
)
)
(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 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 vxxx)
(setq vx (vl-sort vxx
'(lambda (a b)
(< (distance (car a) (cadr a))
(distance (car b) (cadr b))
)
)
)
)
)
)
)
)
)
(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 plnz plnzz)
(vl-load-com)
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
(defun *error* (msg)
(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)
)
Thank you Gian... Your code works fantastic...
(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)
)
There is more food for thoughts, but this one is the worst... But, perhaps someone find it usable in making good mods...Code: [Select]...
(entmakex '((0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(410 . "Model")
(100 . "AcDbPolyline")
(90 . 10)
(70 . 1)
(43 . 0.0)
(38 . 0.0)
(39 . 0.0)
(10 763.88 532.697)
(10 963.376 567.524)
(10 886.098 759.253)
(10 566.259 721.203)
(10 269.828 475.846)
(10 63.224 475.846)
(10 141.075 248.441)
(10 446.489 368.128)
(10 446.489 113.793)
(10 763.88 113.793)
(210 0.0 0.0 1.0)
)
)
There is more food for thoughts, but this one is the worst... But, perhaps someone find it usable in making good mods...Code: [Select]...Code: [Select](entmakex '((0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(410 . "Model")
(100 . "AcDbPolyline")
(90 . 10)
(70 . 1)
(43 . 0.0)
(38 . 0.0)
(39 . 0.0)
(10 763.88 532.697)
(10 963.376 567.524)
(10 886.098 759.253)
(10 566.259 721.203)
(10 269.828 475.846)
(10 63.224 475.846)
(10 141.075 248.441)
(10 446.489 368.128)
(10 446.489 113.793)
(10 763.88 113.793)
(210 0.0 0.0 1.0)
)
)
(defun 2droof (pol / insidep _reml 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 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 _reml (l1 l2 / a n ls)
(while
(setq n nil
a (car l2)
)
(while (and l1 (null n))
(if (equal a (car l1) 1e-8)
(setq l1 (cdr l1)
n t
)
(setq ls (append ls (list (car l1)))
l1 (cdr l1)
)
)
)
(setq l2 (cdr l2))
)
(append ls l1)
)
(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-6
)
(not (equal (distance p1 p) 0.0 1e-6))
(not (equal (distance p2 p) 0.0 1e-6))
)
)
(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 plnn plnnn pll plll 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))
(if
(and
(vl-catch-all-apply
'onlin-p
(list (car a) p (mapcar '+ (car a) (cadr a)))
)
(vl-catch-all-apply
'onlin-p
(list (car b) p (mapcar '+ (car b) (cadr b)))
)
)
(setq pll (cons p pll))
)
(if
(and
(vl-catch-all-apply
'onlin-p
(list (mapcar '+ (car a) (cadr a)) p (car a))
)
(vl-catch-all-apply
'onlin-p
(list (mapcar '+ (car b) (cadr b)) p (car b))
)
)
(setq plll (cons p plll))
)
)
(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))
)
)
(foreach p (reverse pln)
(if (vl-some
'(lambda (x)
(vl-catch-all-apply 'onlin-p (list (car x) p (cadr x)))
)
vpl
)
(setq pln (vl-remove-if '(lambda (x) (equal x p 1e-6)) pln))
)
)
(foreach p pl
(setq vpx1 (assocon p vpl 'cadr 1e-6))
(setq vpxp1 (if (last (prelst vpl vpx1))
(last (prelst vpl vpx1))
(last vpl)
)
)
(if (equal (car vpx1) (car vpxp1) 1e-6)
(setq vpxp1 (if (last (prelst vpl vpxp1))
(last (prelst vpl vpxp1))
(last vpl)
)
)
)
(setq vpx2 (assocon p (vl-remove vpx1 vpl) 'cadr 1e-6))
(setq vpxp2 (if (car (suflst vpl vpx2))
(car (suflst vpl vpx2))
(car vpl)
)
)
(if (equal (car vpx2) (car vpxp2) 1e-6)
(setq vpxp2 (if (car (suflst vpl vpxp2))
(car (suflst vpl vpxp2))
(car vpl)
)
)
)
(if (or (and (equal (unit (mapcar '- (cadr vpx1) (car vpx1)))
(unit (mapcar '- (car vpxp1) (cadr vpxp1)))
1e-6
)
(equal (unit (mapcar '- (cadr vpx2) (car vpx2)))
(unit (mapcar '- (car vpxp2) (cadr vpxp2)))
1e-6
)
)
(and (equal (unit (mapcar '- (cadr vpx1) (car vpx1)))
(unit (mapcar '- (cadr vpxp1) (car vpxp1)))
1e-6
)
(equal (unit (mapcar '- (cadr vpx2) (car vpx2)))
(unit (mapcar '- (cadr vpxp2) (car vpxp2)))
1e-6
)
)
(and (equal (unit (mapcar '- (cadr vpx1) (car vpx1)))
(unit (mapcar '- (car vpxp1) (cadr vpxp1)))
1e-6
)
(equal (unit (mapcar '- (cadr vpx2) (car vpx2)))
(unit (mapcar '- (cadr vpxp2) (car vpxp2)))
1e-6
)
)
(and (equal (unit (mapcar '- (cadr vpx1) (car vpx1)))
(unit (mapcar '- (cadr vpxp1) (car vpxp1)))
1e-6
)
(equal (unit (mapcar '- (cadr vpx2) (car vpx2)))
(unit (mapcar '- (car vpxp2) (cadr vpxp2)))
1e-6
)
)
)
(setq plnn (cons p plnn))
)
)
(foreach p plnn
(if (vl-member-if '(lambda (x) (equal x p 1e-6)) pll)
(setq plnnn (cons p plnnn))
)
)
(setq pln (append pln plnnn))
(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
)
)
(foreach p plll
(mapcar '(lambda (x)
(if (equal (cadr x) p 1e-6)
(setq vx (vl-remove x vx))
)
)
vx
)
)
(if (not (= (length pln) 1))
(setq
pln (list (cadar
(setq vx (vl-sort vx
'(lambda (a b)
(< (distance (car a) (cadr a))
(distance (car b) (cadr b))
)
)
)
)
)
)
)
)
(setq i 0)
(if (and vx ppl (not (= (length pln) 1)))
(while
(and (if (< (setq i (1+ i)) (length vx))
T
(progn (setq pln (list (cadr (nth 0 vx)))) nil)
)
(not
(vl-some
'(lambda (x)
(equal (list (car x) (cadr x)) (car pln) 1e-6)
)
(mapcar 'cadr
(vl-remove (list (list nil nil) (list nil nil))
(_reml ppl vx)
)
)
)
)
)
(setq pln (list (cadr (nth i vx))))
)
)
(if (null vx)
(setq pln nil)
)
(if (vl-every '(lambda (x) (equal (cadar vpl) (cadr x) 1e-6))
vpl
)
(progn
(foreach l (unique vpl)
(if
(not (vl-some
'(lambda (x) (equal (list (car l) (cadr l)) x 1e-6))
ppl
)
)
(setq z (entmakex (list '(0 . "LINE")
(cons 10 (car l))
(cons 11 (cadr l))
)
)
zz (cons z zz)
)
)
)
(setq pln nil)
)
)
(if (and (equal pln (list nil)) (= (length (unique vrl)) 2))
(if (not
(vl-some
'(lambda (x)
(equal (list (caar (unique vrl)) (caadr (unique vrl)))
x
1e-6
)
)
ppl
)
)
(setq z (entmakex (list '(0 . "LINE")
(cons 10 (caar (unique vrl)))
(cons 11 (caadr (unique vrl)))
)
)
zz (cons z zz)
)
)
)
(if (equal pln (list nil))
(setq pln nil)
)
(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)
(if
(not
(vl-some
'(lambda (x) (equal (list (caar vp1) (cadar vp1)) x 1e-6))
ppl
)
)
(setq z (entmakex (list '(0 . "LINE")
(cons 10 (caar vp1))
(cons 11 (cadar vp1))
)
)
zz (cons z zz)
)
)
)
(if (car vp2)
(if
(not
(vl-some
'(lambda (x) (equal (list (caar vp2) (cadar vp2)) x 1e-6))
ppl
)
)
(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)
(vl-load-com)
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
(defun *error* (msg)
(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)
)
Thank you Gian... I was wondering when I'll get some support... Your code works fantastic...
x2
Fantastic! :-D
Gian Paolo, what ab this one... If it works for you, then please help me...
(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)
)
Thanks Tim ! Sorry for reviting it too later .Which One is right ?
The one on the left
The one on the right has a "Dead Vally" (a flat valley). This is to be avoided but sometime can not.Alan,thank you too ! Sorry for reviting it too later .
When you can't get away from the situation you add a "Cricket" 8-)
Which One is right ?
The one on the left
Which is correct?
CAB,
Is correct, not sure if its the resolution but there appears to be a little jog in the ridge...
Now there are no dead valleys... Both solutions are correct... If you don't believe, use my 2droof3d.lsp and check it in 3D... One on the left was made by my last 2droof-MR.lsp and one on the right by GP's HR.lsp... So now we stand for solution - which one do you like it more?I think the right is right . In MidLine ABC, |AB|<|AC|；it can be deduced by Offset-method , Outline offset to Point C will be continued, but offset to Point B will be break .
Regards, M.R.
Another update of 2droof3d.lsp... You can find it here :I test your "2droof3d new old lisp" , it can't run well in my ACAD2011 , See the test Gif .
http://www.theswamp.org/index.php?topic=41837.msg513241#msg513241
Sorry for inconvenience... There was mistake in my subfunction ListClockwise-p which I fixed - the code was actually the same as old one - only this fix and now this is new version...
M.R.
chlh_jd... But to use 2droof3d.lsp, you have to have 2d soultion firstly created... You just selected LWPOLYLINE without 2D solution ridge lines... And I suggest that you use simple 2droof3d.lsp - not the old version... As for the above example, I agree that this HP.lsp solution can be derived from built-in EXTRUDE - TAPER command, but then you'll miss possible other soultions like I showed on left example... Both are correct and more over - to my opinion, left solution is much nicer as in practical possible realization reasons there are no close ridge edges that collapse into top apex... There is much nicer top ridge that is then continued to transform into porche roof mass that is attached to main roof solution...I'll test 2droof3d.lsp later, I don't think the Left result in your above example is right , just I reply following it . One boundary-line only One Roof-line , I think .
Hi, chlh_jd... I must say I am very impressed... It almost work in every situation... I don't know why, by my "Another example" didn't finish like you showed on your animated GIF... I am on A2014 and didn't modify file I posted, just checked on the same polyline and it failed around start/end vertex... I've turned off debug mode, removed layer creation of ridge lines - uses current layer and done overkilling duplicate ridges through ALISP... And you showed on very complex example with revcloud some lack... Hope you'll solve this when you did it so good so far... I'll attach your lisp with those mods I mentioned (I don't want duplicate ridges)... Very grateful for this, thanks again GSLS(SS)...You are welcome .
M.R.
chlh_jd, I've tried to improve, but I don't know if my attempt is good... Now my case is solved, but I don't know ab your (revcloud)... My attempt was pretty simple in comparison to your coding (made main sub-function - "start", and if it runs on error it restarts main function with little modified order of vertices - had to nil rgl variable)... So error should be printed, but solution should be made if my estimations were correct... Also made better formatting of code - never mind it's now bigger...Ribar , Thank you for test , please post your error polygon for me , thanks .
So long from me for now, M.R.
Ribar , Thank you for test , please post your error polygon for me , thanks .
(princ "\n ***Error*** : ...")
(setq rgl nil)
(setq err (1+ err))
(setq pl (cons (last pl) (reverse (cdr (reverse pl)))))
(if (eq err 1) (start pl))
To this, so it can exchange all points and attempt to solve for each combination : (princ "\n ***Error*** : ...")
(setq rgl nil)
(setq err (1+ err))
(setq pl (cons (last pl) (reverse (cdr (reverse pl)))))
(if (< err n) (start pl))
;; if the point in the triangle {pa pb [i0~3]} which construct by the inzone side {pa pb}
;; and it's bisector rays inters with line {p p1} or line {p p2}
;; SCH. of Invalid ray-inters of side {p1 p2}
;; p2___________p1
;; \i1 /
;; ／＼ /
;; ／ \＼ /
;; bi_a ／ \ ＼/
;; | ／ \ /＼bi_b
;; |／ P ＼
;; pa-------------------pb
Congratulations, GSLS... What is the problem then with revcloud? I also have issues with arced polylines... But solving my posted DWG, I hope situation is much better... chlh_jd, do I have to use my attached version to solve posted DWG "Another example" or do you also have some better approach? I'll attach my version of implemented your new solution - this is what I use finally for now... Thanks again... M.R.
[EDIT] : Attached one more case...
[EDIT] : LSP file reattached so that now if solution was found no need for overkill of ridges...
(4 downloads of old version)
Preliminary add command mode .
Solid make failure , Need more improved work .
Enjoy .
Ribar , thank you for test every time , you're very welcome :-)
chlh_jd, I use for modelling 2droof3d.lsp posted here on my previous posts... It works everything on my comp... Only thing you should say is that polyline should be scaled approx. 1000 times to avoid errors... I'll attach your code with my add of making ridges as single lines... This is prepared for 2droof3d.lsp... Thank you very much GSLS... I lost time checking what was the issue with errors and then I simply scaled and it worked... Congratulations on this code - it's very powerful...
Marko
chlh_jdThanks Alan :-)
Awesome work :)
chlh_jd,Ribar , thank you for test .
Still more problems, see attached DWG (if you have time for coding - I am pleased with solution like it is, but...)...
M.R.
hi chlh_jd,Thanks hanhphuc .
i just notice small bug, assume we open a new drawing,
so layer "Proof" does not exist
(setvar "CLAYER" "Proof") ;rejected?
my suggest (if (tblsearch "LAYER" "proof") then etc..
Just curiuos, my VLIDE inspects the REAL _pi2: 1.5707963267948966192313216916395, it returns 1.5708. if (* _pi2 100000.); returns 157080.0 does it mean the precision reduced?
Thanx your amazing code :-)
Here, I've modified my version of your code... So now there are 2 versions - while version (2droof.lsp) and if version (2droof-t.lsp)... Sometime like in my posted DWG, maybe it's better to use while version... 2droof-t.lsp is newest one... Note that both are the same just one uses while, and other if...For get the second case in your post dwgs , need determine neighbor first closed before add the vertex into RGL .
Thanks...
...
(progn ;_force out routine ...
(princ "\n ***Error*** : ...")
(setq rgl nil)
(setq errr (1+ errr))
(setq pl (cons (last pl) (reverse (cdr (reverse pl)))))
(if (and (< errr n) (not err))
(start pl)
)
...
...
(while li
(if
(not
(vl-some (function (lambda (x)
(or (and (equal (car x) (caar li) 1e-8)
(equal (cadr x) (cadar li) 1e-8)
)
(and (equal (cadr x) (caar li) 1e-8)
(equal (car x) (cadar li) 1e-8)
)
)
)
)
(cdr li)
)
)
(setq ll (cons (car li) ll))
)
(setq li (cdr li))
)
(foreach l ll
(entmake (list
'(0 . "LINE")
(cons 10 (car l))
(cons 11 (cadr l))
'(62 . 1)
)
)
)
(setq err t)
)
...
...
;;------------------------------------main routine ------------------------------;;
(setq e (car (entsel "\nSelect a closed polygon :")))
; (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
; (vla-startundomark adoc)
(setq #gsls_systemvar# (list "CMDECHO" "CLAYER"))
(_svos) ;_undo begin , system variables store .
(setq area (vlax-curve-getarea e))
(if (< area 1000000000.0)
(progn
(setq scf (sqrt (/ 1000000000.5 area)))
(alert "You must scale polyline - quitting")
(prompt
(strcat
"\nYou must scale polyline with this factor to make routine compute ridges correctly : "
(rtos scf 2 15)
)
)
(prompt
(strcat
"\nInverse scale factor to return scaled solution back is : "
(rtos (/ 1.0 scf) 2 15)
)
)
(textscr)
(exit)
)
)
;|
(setq pl
(mapcar (function cdr)
(vl-remove-if-not (function (lambda (a) (= (car a) 10))) (entget e))))
|;
(setq pl (lm:entity->pointlist e) ;_for pl with arc
pl (remove-same-pts pl 1e-6)
) ;_has doubles points in pl with arc
(setq errr 0)
(start pl)
(_clos) ;_undo end , system variables reset .
)
...
chlh_jd, only if you have spare time... Look attached DWG... Hope I am not exaggerating...Ribar , thank you for test :-)
(My posted LSP files updated and reattached in my previous post)
M.R.
[EDIT] : Attached one more...
Thanks...
Just to mention, SOLUTION WASNT FINISHED.DWG is solvable through multiple attempts with error prompts from one of 2 versions - I think (while) 2droof.lsp...Just like I've said ,if want to let it no catch any error , other word , to suit for any case (In fact, because there is precision in the calculation can not be done , I agree you that some case must be scaled , it also can be determine in the routine , after get the roof lines scaling back ) , It must give up some efficiency .
Just uncomment these lines :
And this - note (setq err t) :
And this - note (setq errr 0) :
M.R.
I've scaled it even more and fixed scale factor to be nicer rounded number... Seems that now sometime it solves simple lwpolyline width outline and sometime it fails... But this is the best I could do... Your code remained unchanged... Here are the routines I use for now... Sorry I was been unsatisfied it passed me... Some very complex polylines can't be solved, but almost all that are decently drawn are solvable...Ribar , you're welcome .
Thanks, chlh_jd, and sorry for my rough and wrong expectations...
Regards, all the best, M.R.
(defun c:test(/ f1 f2 p0 p1 p2 p3 an1 an2 i p pa pb pc i%)
(setq p0 (getpoint)
p1 (getpoint p0)
p2 (getpoint)
p3 (getpoint p2))
(setq an1 (angle p0 p1)
an2 (angle p2 p3)
i 0)
(defun f1 (p)
(mapcar (function (lambda (x)
(* x 0.1 (expt 10 i))))
p))
(defun f2 (p)
(mapcar (function (lambda (x)
(/ x (* 0.1 (expt 10 i)))))
p))
(repeat 9
(setq i (1+ i))
(setq p0 (f1 p0)
p1 (f1 p1)
p2 (f1 p2)
p3 (f1 p3))
(setq p (inters p0 p1 p2 p3 nil)
pa (inters p0 (polar p0 an1 1.) p2 (polar p2 an2 1.) nil)
pb (inters p0 (polar p0 an1 1e3) p2 (polar p2 an2 1e3) nil)
pc (inters p0 (polar p0 an1 1e9) p2 (polar p2 an2 1e9) nil))
(setq p (f2 p)
pa (f2 pa)
pb (f2 pb)
pc (f2 pc))
(setq i% 0)
(mapcar (function (lambda (p)
(if p
(entmake (list (cons 0 "POINT")
(cons 10 p)
(cons 62 (+ i (* 10 i%))))))
(setq i% (1+ i%))
))
(list p pa pb pc))
)
(princ)
)
chlh_jd, thanks for your LISP... Found little mistake - change (getangle) to (getreal) when specifying Degrees...Ribar , you're welcome . Many thanks for your test .
... Everything else is fine... I haven't analyzed it but it seems that it handles polyline width outlinesThe width pl to ontlines routine I'v writen so long ago and no time to opt it , do you have a better version ?
Thanks, M.R.
... So with less coding it's better than mine, but there is one example where my version can handle complex polyline - after error messages and your is looping forever...Can you post the error dwg ? Thanks .
If you plan to keep (getangle), you should remove line with conversion of variable a to radians - getangle takes values in degrees and automatically assigns radians to variable... The simplest way for modifications is to change (getangle) to (getreal) and to keep everything else as it is...chlh_jd, thanks for your LISP... Found little mistake - change (getangle) to (getreal) when specifying Degrees...Ribar , you're welcome . Many thanks for your test .
GetAngle allow user type in specifying angle , I don't think it's a mistake unless you give some e.g. .
No, chlh_jd I use your version, but I believe Lee Mac has also this routine - both normal and advanced versions with elliptical arcs if polyline with arced segments...... Everything else is fine... I haven't analyzed it but it seems that it handles polyline width outlinesThe width pl to ontlines routine I'v writen so long ago and no time to opt it , do you have a better version ?
Thanks, M.R.
I'll post examples, but note that I can't occupy theswamp with so many of them, still there are complex polylines that aren't solvable for now, just draw one with many vertices and go zig-zag in making segments - avoid convex shapes - concave are problematical...... So with less coding it's better than mine, but there is one example where my version can handle complex polyline - after error messages and your is looping forever...Can you post the error dwg ? Thanks .
Yes, you're right chlh_jd... But by offset tests, if you check it in 3D it will be correct...One 2D closed curve reflect one best 3D roof , but it can be other 3D roofs which also can drainage .
Never mind that, I think your last Proof_11.lsp is seriously the best... If I may conclude from my side, all my tests passed, so I'll leave to others if some revision is to be made... If I may say, I thank you very much for all your efforts to bring this topic to finish in appropriate way...Thank you , Ribar :-)
...You are certainly one among them chlh_jd,
and as I see now old topic have become actual and I also want to thank to Mr. Lee Mac for his unselfish ...I'v not seen dear and clever Lee Mac , a long time . I think he has a broad mind and forgive some one .
I must say that when I first started Lisping back in 2003 I did not understand
the ownership of code. When collecting routines & subroutines I did not collect
the link to the source. This became a problem when I wanted to use the routine
in a posting of my own because often the author did not include a proper header
only a prefix on the defun name. The mistake I made was to include the
subroutine in my routine which I placed a header implying ownership. Fortunately
someone pointed out the error in my thinking (thank you MP) & I made an effort
to add headers to those sub-functions and links back to the source. This is like
foot notes in an article or book. So to omit these references is unthinking and
doing it regularly is rude behavior. I still have code floating around out in
cyberspace that I would like to correct but it is too late for most.
Once it leaves here you can not track it all down.
But now I make sure that any code I barrow has a reference to who or at least
where I obtained it so as not to IMPLY that I was the creator of the code. There
is a lot of effort and many late night study sessions that went into the ability
to create these routines that are so good that we want to reuse them rather than
create one of our own.
So honor that effort by including the proper header and or link back to the source.
Here are my latest codes referencing this topic...Nice work Ribar :-)
Video can be found at Youtube...
http://youtu.be/FapqxIqQRv8
In attachment are all relevant routines used in this video...
Regards, M.R.
P.S. In some situations, 2droof-final.lsp may fail to produce correct and desired results, so be careful... Suggested is not to use sr.lsp until 2d solution made by 2droof-final.lsp is adequate (sr.lsp is using the same algorithm)
Nice work Ribar :-)
Thank you for keep the head .
Is there problem in my last post version ?
Code removed due to the fact that I solved this issue and it's relatively faster then it was and I am satisfied with that now...
Code removed due to the lack of interest... You can PM on ribarm@gmail.com if you are interested...WOW
Hi ribarm. I am confused with all this changes. Can you post the final code ? Is it possible to add a roof tiles hatch ?
Thanks
Nice Job!
You have 9 lisp routins. What lisp is the best to use ?
...
(setq ipp nil dd nil ipo nil)
(if (progn (process) (not f))
(if ipll
(progn
(setq ipo ip)
(foreach y (reverse pal)
(setq ipp (cons (vl-remove-if-not '(lambda ( x ) (vl-some '(lambda ( a ) (or (equal (rem (+ a pi) (* 2 pi)) (angle (car y) x) 1e-6) (equal a (angle (car y) x) 1e-6))) (cadr y))) (mapcar 'car (vl-sort ipldtl '(lambda ( a b ) (> (car (cadr a)) (car (cadr b))))))) ipp))
)
(setq dd 1e+99)
(mapcar '(lambda ( x y ) (if x (mapcar '(lambda ( xx ) (if (and (< (distance xx y) dd) (not (vl-some '(lambda ( a ) (vl-some '(lambda ( b ) (equal (distance xx a) (+ (distance xx b) (distance b a)) 1e-6)) (vl-remove xx (vl-remove a (append (mapcar 'car pal) (mapcar 'car ipldtl)))))) (vl-remove xx (append (mapcar 'car pal) (mapcar 'car ipldtl)))))) (setq dd (distance xx y) ip xx))) x))) ipp (mapcar 'car pal))
)
)
)
;;;;; This portion that follows is crucial, but I can't discover how to get correct ip from list ipp - it may be that some of points from ipp are good and some are bad... ;;;;;;
(if (equal ip ipo 1e-6)
(progn
(setq dd 1e+99)
(mapcar '(lambda ( x y ) (if x (mapcar '(lambda ( xx ) (if (< (distance xx y) dd) (setq dd (distance xx y) ip xx))) x))) ipp (mapcar 'car pal))
)
)
...
...
(if (equal ip ipo 1e-6)
(progn
(setq ipp (apply 'append ipp))
(setq ipp (mapcar '(lambda ( p ) (list p (findipinterschilds p pla))) ipp))
(setq ip (car (car (vl-sort ipp '(lambda ( a b ) (< (+ (distance (car a) (car (mapcar 'car (cadr a)))) (distance (car a) (cadr (mapcar 'car (cadr a))))) (+ (distance (car b) (car (mapcar 'car (cadr b)))) (distance (car b) (cadr (mapcar 'car (cadr b)))))))))))
)
)
...
Wow pretty fantastic shape to work out a roof, its like the AUS opera house they said it could not be built.
@d2010, I've revised my last code, so perhaps you'll have to revise your too...
Sorry for inconvenience...
M.R.
In my BrisCad2020 x86 , your-program failed to work.Your post is very strange. :?
:reallysad:@d2010, I've revised my last code, so perhaps you'll have to revise your too...
Sorry for inconvenience...
M.R.
;; EXAMPLE LISP SHORT VERSION OF PROGRESS-BAR
(defun progressbar (a b c d)
(cond ((= 0 a)
(acet-ui-progress-init d 100)
(setq c 0)
)
((= 1 a)
(setq c (+ (/ 100.0 b) c))
(acet-ui-progress-safe c)
)
((= 2 a)
(acet-ui-progress-done)
)
)
c
)
(setq repeatvariable 45) ; 45 just a sample number
(setq progress (Progressbar 0 repeatvariable progress "Processing:")) ;Create the progress bar, total length is repeatvariable or 10000
(repeat repeatvariable
(setq progress (Progressbar 1 repeatvariable progress ""))
(alert "press") ; code goes here
)
(Progressbar 2 0 0 "") ;arg(a) is set to 2 to close the progress bar, arg (b), (c) & (d) can be blanks
(defun LM:Inside-p (pt ent / unit v^v _GroupByNum fd1 fd2 par lst nrm obj tmp)
(vl-load-com)
(defun unit (v / d)
(if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-8))
(mapcar (function (lambda (x) (/ x d))) v)
)
)
(defun v^v (u v)
(list
(- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
(- (* (caddr u) (car v)) (* (car u) (caddr v)))
(- (* (car u) (cadr v)) (* (cadr u) (car v)))
)
)
(defun _GroupByNum (l n / r)
(if l
(cons (reverse (repeat n (setq r (cons (car l) r) l (cdr l)) r)) (_GroupByNum l n))
)
)
(if (= (type ent) 'VLA-OBJECT)
(setq obj ent ent (vlax-vla-object->ename ent))
(setq obj (vlax-ename->vla-object ent))
)
(if (vlax-curve-isplanar ent)
(progn
;(setq fd1 (vlax-curve-getfirstderiv ent (setq par (vlax-curve-getstartparam ent))))
;(while (or (equal fd1 (setq fd2 (vlax-curve-getfirstderiv ent (setq par (+ par 0.001)))) 1e-3) (null (setq nrm (unit (v^v fd1 fd2))))))
(setq nrm '(0.0 0.0 1.0)) ;;; mod by M.R. - gaining speed
(setq lst
(_GroupByNum
(vlax-invoke
(setq tmp
(vlax-ename->vla-object
(entmakex
(list
(cons 0 "RAY")
(cons 100 "AcDbEntity")
(cons 100 "AcDbRay")
(cons 10 pt)
(cons 11 (trans '(1.0 0.0 0.0) nrm 0))
)
)
)
)
'IntersectWith obj acextendnone
) 3
)
)
(vla-delete tmp)
;; gile:
(and
lst
(not (vlax-curve-getparamatpoint ent pt))
(= 1 (rem (length (vl-remove-if (function (lambda (p / pa p- p+ p0)
(setq pa (vlax-curve-getparamatpoint ent p))
(and (setq p- (cond ((setq p- (vlax-curve-getPointatParam ent (- pa 1e-8)))
(trans p- 0 nrm)
)
((trans (vlax-curve-getPointatParam ent (- (vlax-curve-getEndParam ent) 1e-8)) 0 nrm)
)
)
)
(setq p+ (cond ((setq p+ (vlax-curve-getPointatParam ent (+ pa 1e-8)))
(trans p+ 0 nrm)
)
((trans (vlax-curve-getPointatParam ent (+ (vlax-curve-getStartParam ent) 1e-8)) 0 nrm)
)
)
)
(setq p0 (trans pt 0 nrm))
(<= 0 (* (sin (angle p0 p-)) (sin (angle p0 p+)))) ;; LM Mod
)
)
) lst
)
) 2
)
)
)
)
)
)
You code-lisp is fantastic, but is huge./ or too complex , for manage and search bugs.Nice Job!Thank you pacman.z80 , paperboy.z80, or postaman.z80
You are posting gibberish code examples...
.... I must say that you are spamming this topic that is IMHO very profound and well composed...
Agree also where is the Administrators ?
AProgramul tau Lisp este de bun, dar daca tu cresti complexitatea ribarm2droof.lsp, atunci, in viitor, programul tau nu va avea viitor, deoarece devineI agree your posts are hard to follow ... here's a translation to English for those following.
imposibil de corectat/debug-insideo-on-Real-Time. :wideeyed:
Tu gandeste-te daca (sizeof "* ribarm2droof.lsp") dimensiunea lui creste cu m*1ko, atunci tu sa corectezi real-debug-in dificultatea lui/creste exponential la +65535...
:-P
Your Lisp program is good, but if you increase the complexity of ribarm2droof.lsp, then in the future your program will have no future because it becomes
impossible to correct / debug-insideo-on-Real-Time.
You think if (sizeof "* ribarm2droof.lsp") its size increases by m * 1ko, then you correct real-debug-in its difficulty / increase exponentially to +65535 ...
@Lee, @Daniel, @Gilles, @Evgeniy, @Owen, @Highflybird, ... and others, tell me how to continue, but not to loose speed too much...
@Lee, @Daniel, @Gilles, @Evgeniy, @Owen, @Highflybird, ... and others, tell me how to continue, but not to loose speed too much...
Where are the code comments?
Want speed - get out of lisp.
Want speed - keep nested loops to a minimum.
Want speed - don't do heavy calculations deep in the loops.
Want speed - don't do if checks deep in the loops.
Want speed - learn algorithms and data structures.
And here is it classical example of how topic get overcrowded with other new ones...
Have someone thought ab this examples, especially the ones posted at cadtutor.net - download section...
I would like to see something new that may be better than my attempts...
M.R.
Is my routine hardware dependent... (roof2d-new-new-offset.lsp)... If so, which is mostly the case, then the job is done... I don't know how to tweak for ultimate roofs (100 and more vertices)... If it doesn't depend on the hardware, then let someone more expert than me take a look... It doesn't matter if it's *.lsp, *.arx, *.brx, * .dll... it's only important that it works optimally, which I doubt... I don't know, if you care, ask around, maybe by chance a solution for slowness will be found... I took all the parameters into circulation and matched them with each other ... Perhaps I should have left something out, but then not all the tests would have passed... See what you can do, if you have the time and interest...
THE CODE IS SOMEWHAT WORSE THAN PREVIOUSLY POSTED, SO I REMOVED IT FROM SITE...
Who is interested in this over custom _offset sub function version, I've made few improvements, but still it doesn't solve but there is attempt which is pretty good for a start for experienced member that wants to continue... Also I've implemented *.lsp in archive at www.cadtutor.net download section...
If nothing, I've played with this challenge one more time...
Thanks for following, but I see there are no too much interest for roofs - hipped ones...
Cool stuff, never had the need to draw sloped roofs. back when I was drafting, I was in New Mexico, most of the houses were Adobe, with flat roofs.
That, and I mostly did submittals for commercial casework
I have no feedback...I just tried it and it does nothing ?
Could someone have a look into my attachment in previous post and give opinion, or better implement something I forgot...
It seems that this all looks like joke, but I've spent a lot of time to collect and compose and this version... So please, help by download and look, or give opinion ab things implemented or more yet to be implemented next...
C'mon show some courage...
I have no feedback...I just tried it and it does nothing ?
Could someone have a look into my attachment in previous post and give opinion, or better implement something I forgot...
It seems that this all looks like joke, but I've spent a lot of time to collect and compose and this version... So please, help by download and look, or give opinion ab things implemented or more yet to be implemented next...
C'mon show some courage...
non-ortho hipped roofs...
@ribarm,
What is your definition ofQuotenon-ortho hipped roofs...
Best new year wishes.
I am realy stacked here with "roof-2chk-n.lsp"... Can someone check it from line 653 - roof-chk-n.lsp / 642 - roof-chk-nn.lsp to the end of file... In my opinion it should work, but it isn't - it just starts and then stops after 6 lines drawn... If someone has spare time, please download it from this post : https://www.theswamp.org/index.php?topic=41837.msg618211#msg618211
Your help is always welcomed...
M.R.
;;; printf debugging added by Paul Kohut, 1/14/2024
;;; Purpose: track down why code is not outputting the correct
;;; roof ridge lines. The debug output sent to the acad console,
;;; tags will help tie to the source code/variables/entities.
;;;
;;; The cpatured data was weakly tested against some key subrointes,
;;; all of them preformed as expected.
;;; Original code provided by Marko Ribar in HIPPED ROOF ROUTINES.ZIP
(setq lst (mapcar (function (lambda ( a b c d ) (list a (angle a b) c d))) pl pli (cons (last tl) (reverse (cdr (reverse tl)))) tl))
(princ (strcat "\natt=" (itoa att) " lst length=" (itoa (length lst))))
(print lst)
;;; pk - I think at this point the first 7 entity are rerun a
;;; few times creating duplicate ridge geometry in lst.
;;; These long complex lines should get reformed so debugging
;;; in VLISP or VS Code is easier.
@pkohut
I saw attachment, but reposting the same file I attach doesn't solve things... I posted files in hope that they could be used purpously in task for completion of whole ridge solution on any non-ortho closed polygonal LWPOLYLINE... Nevertheless I attached few more at *.ZIP at cadtutor... So now I wait cos' I don't know why it stops after drawing 6 lines... At the end I'll give up with those roof-*.lsp... So still I am hoping that "roof2d-new-new-new.lsp" could be converted to *.arx, *.brx, or *.dll...
Have a nice day...
M.R.
posted in ZIP I uploaded at cadtutor download section
That's all from me for now...
Like BIGAL - every millisecond counts...
M.R.
@ribarmQuoteposted in ZIP I uploaded at cadtutor download section
I'm old and cranky, so . .
why do you assume that everyone is a member there, and would travel to pick it up ??
I'm noticing this attitude more and more.
This is a peer to peer forum where responsibility to roles is expected to be honoured, and an example set for newer members.
Regards,