TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: chlh_jd on March 12, 2011, 12:07:59 PM
-
There's no require unless the title .
And here's your pretty codes ...
-
here's picture to express
-
Problem needs a clear definition. The example picture doesn't help convey that.
-
agreed Paul.
Looks to me like a MINIMUM triangle inside a collection of entities ??
... or perhaps not :|
-
Hello swamp people:
The problem is so?:
Find the 3 points of a given set that form the largest triangle not containing any point?
Is the good question ?
This may be related to the algorithms of Delaunay?
Regards... :-)
-
Hello :
(http://img853.imageshack.us/img853/7158/triangulomayor.gif) (http://img853.imageshack.us/i/triangulomayor.gif/)
Could this be the solution to this problem?
I have a very ugly code (brute force) , but if you want I'll post it.
Regards. :-)
-
Yes, that would be my guess too.
Find the 3 points of a given set that form the largest triangle not containing any point?
Pseudo Code
Iterate all points, comparing by 3 to get triangle
Test for size & if it is free of points inside
-
Like this?
(http://www.theswamp.org/screens/alanjt/largesttriangle.gif)
Clunky and probably really slow...
(defun c:Test (/ AT:TriangleArea _toList _lwpline _uTrans pointlist trianglelist triangle)
(defun AT:TriangleArea (a b c)
;; Returns area of three provided points
;; If returned value is negative, last point (c) exists on right side of a-b vector
;; Alan J. Thompson, 06.09.10
(/ (- (* (- (car b) (car a)) (- (cadr c) (cadr a)))
(* (- (cadr b) (cadr a)) (- (car c) (car a)))
)
2.
)
)
(defun _toList (ss / i l)
(if (and (eq (type ss) 'PICKSET) (> (sslength ss) 2))
(repeat (setq i (sslength ss))
(setq l (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) l))
)
)
)
(defun _lwpline (lst)
(if (> (length lst) 1)
(entmakex (append
(list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length lst))
'(70 . 1)
)
(mapcar (function (lambda (p) (list 10 (car p) (cadr p)))) lst)
)
)
)
)
(defun _uTrans (p) (trans p 0 1))
(foreach a (setq pointlist (_toList (ssget '((0 . "POINT")))))
(mapcar (function
(lambda (b c)
(if (not (ssget "_WP" (mapcar (function _uTrans) (list a b c))))
(setq trianglelist (cons (list (abs (AT:TriangleArea a b c)) a b c) trianglelist))
)
)
)
(cdr pointlist)
(cddr pointlist)
)
)
(_lwpline (cdr (car (vl-sort trianglelist (function (lambda (a b) (> (car a) (car b))))))))
(princ)
)
-
Sorry to ALL , my English would be too less yet , I think I must go abored to the English countary to inprove my simple Einglish .
Thanks SOFITO_SOFT a lot !
and thank Alan , I'll try your codes .
-
Hi Alan , I mean that the points can be on the triangle , but not be in it .
Perhaps the 'ssget fun error , it take a not correct result ;
-
My solution for the new exemple:
3 Points in corners but none inside or in border:
(http://img861.imageshack.us/img861/8687/triangulomayor2.gif) (http://img861.imageshack.us/i/triangulomayor2.gif/)
Regards. :-)
-
my version:
(defun c:test (/ A1 A2 L LST S)
(defun ins (l p)
;; check is a point inside the triangle.
;; by ElpanovEvgeniy
(not (if (< (sin (- (angle (last l) p) (angle (last l) (car l)))) -1e-14)
(vl-every (function (lambda (a b) (< (sin (- (angle a p) (angle a b))) -1e-14)))
l
(cdr l)
)
(vl-every (function (lambda (a b) (> (sin (- (angle a p) (angle a b))) 1e-14)))
l
(cdr l)
)
)
)
)
(defun area_geron (p1 p2 p3 / l p)
;; area triangle
;; Uses the formula of Heron
(setq l (cons 0 (mapcar (function distance) (list p1 p2 p3) (list p2 p3 p1)))
p (/ (apply (function +) l) 2.)
)
(sqrt (abs (apply (function *) (mapcar (function -) l (list p p p p)))))
)
(if (setq a1 0
s (ssget "_x" '((0 . "point")))
)
(foreach a (setq lst (mapcar (function (lambda (a) (cdr (assoc 10 (entget (cadr a))))))
(ssnamex s)
)
)
(foreach b lst
(foreach c lst
(if (and (> (setq a2 (area_geron a b c)) a1)
(vl-every (function (lambda (p) (ins (list a b c) p))) lst)
)
(setq a1 a2
l (list a b c)
)
)
)
)
)
)
(entmakex
(append
'((0 . "LWPOLYLINE") (100 . "AcDbEntity") (100 . "AcDbPolyline") (90 . 3) (70 . 1))
(mapcar (function (lambda (a) (cons 10 a))) l)
)
)
(princ)
)
-
hi , SOFITO_SOFT , I didn't see your picture ...
hi, Evgeniy , yours run fast , but not often a corret result ,see the picture : red is corret , yellow is yours result
tested in the new dwg
-
hi, Evgeniy , yours run fast , but not often a corret result ,see the picture : red is corret , yellow is yours result
tested in the new dwg
This is easily solved in the code in my checks, are not allowed a point lying on the sides of the triangle.
-
new version:
(defun c:t1 (/ A1 A2 L LST S)
(defun ins (l p)
;; check is a point inside the triangle.
;; by ElpanovEvgeniy
(not (if (< (sin (- (angle (last l) p) (angle (last l) (car l)))) -1e-6)
(vl-every (function (lambda (a b) (< (sin (- (angle a p) (angle a b))) -1e-6)))
l
(cdr l)
)
(vl-every (function (lambda (a b) (> (sin (- (angle a p) (angle a b))) 1e-6)))
l
(cdr l)
)
)
)
)
(defun area_geron (p1 p2 p3 / l p)
;; area triangle
;; Uses the formula of Heron
(setq l (cons 0 (mapcar (function distance) (list p1 p2 p3) (list p2 p3 p1)))
p (/ (apply (function +) l) 2.)
)
(sqrt (abs (apply (function *) (mapcar (function -) l (list p p p p)))))
)
(if (setq a1 0
s (ssget "_x" '((0 . "point")))
)
(foreach a (setq lst (mapcar (function (lambda (a) (cdr (assoc 10 (entget (cadr a))))))
(ssnamex s)
)
)
(foreach b lst
(foreach c lst
(if (and (> (setq a2 (area_geron a b c)) a1)
(vl-every (function (lambda (p) (ins (list a b c) p))) lst)
)
(setq a1 a2
l (list a b c)
)
)
)
)
)
)
(entmakex
(append
'((0 . "LWPOLYLINE") (100 . "AcDbEntity") (100 . "AcDbPolyline") (90 . 3) (70 . 1))
(mapcar (function (lambda (a) (cons 10 a))) l)
)
)
(princ)
)
-
hi , all
hi , Evgeniy
about pt in or at the triangle , I tested result is
函数:EE:PITP运行10000次测试结果00:00:00:108函数:SS-PITP运行10000次测试结果00:00:00:061函数:SS-PITP0运行10000次测试结果00:00:00:921函数:SS-PITP1运行10000次测试结果00:00:00:360
use cal number of intersections method is the fastest , is it a wrong test ?
(defun EE:pitp (p l)
;; check is a point inside the triangle.
;; by ElpanovEvgeniy
(if (< (sin (- (angle (last l) p) (angle (last l) (car l))))
-1e-6
)
(vl-every
(function
(lambda (a b) (< (sin (- (angle a p) (angle a b))) -1e-6))
)
l
(cdr l)
)
(vl-every
(function
(lambda (a b) (> (sin (- (angle a p) (angle a b))) 1e-6))
)
l
(cdr l)
)
)
)
;;;number of intersection
;;;fastest
(defun ss-pitp (p l)
;;check point inside triangle .
;;by GSLS(SS)
((lambda (a b c)
(eq (+ (length (inters p a b c nil))
(length (inters p b a c nil))
(length (inters p c a b nil))
)
9
)
)
(car l)
(cadr l)
(caddr l)
)
)
;;;with the same direction method
(defun ss-pitp0 (p l / foo)
;;check point inside triangle .
;;by GSLS(SS)
(defun foo (a b c p / ac ab ap)
(setq ac (mapcar '- c a)
ab (mapcar '- b a)
ap (mapcar '- p a)
)
(>= (vxv (v^v ab ac) (v^v ab ap)) 0.0)
)
((lambda (a b c)
(and (foo a b c p) (foo b c a p) (foo c a b p))
)
(car l)
(cadr l)
(caddr l)
)
)
;;;with the same direction method
;;;by trans
(defun ss-pitp1 (p l)
;;check point inside triangle .
;;by GSLS(SS)
((lambda (a b c)
(and (<= (* (car (trans (mapcar '- p a) 0 (mapcar '- b a)))
(car (trans (mapcar '- p a) 0 (mapcar '- c a)))
)
0
)
(<= (* (car (trans (mapcar '- p b) 0 (mapcar '- a b)))
(car (trans (mapcar '- p b) 0 (mapcar '- c b)))
)
0
)
)
)
(car l)
(cadr l)
(caddr l)
)
)
-
forget func .
;;; gile
;;; vxv returns the dot product of 2 vectors
;;; dot product
(defun vxv (v1 v2)
(apply
'+
(mapcar
'*
v1
v2
)
)
)
;;; gile
;;; cross product
(defun v^v (v1 v2)
(list (- (* (cadr v1) (caddr v2)) (* (caddr v1) (cadr v2)))
(- (* (caddr v1) (car v2)) (* (car v1) (caddr v2)))
(- (* (car v1) (cadr v2)) (* (cadr v1) (car v2)))
)
)
-
to cal area of triangle ,
Uses conventional formula, but slower than Heron Formula.
is it no compile reason or the codes written to bad ?
(defun ss-aat (p1 p2 p3)
;;area triangle
;;Uses conventional formula, but slower than Heron Formula.
(* 0.5
(sqrt
(apply (function +)
(mapcar (function (lambda (a b c)
(expt (- (+
(* (car a) (cadr b))
(* (car b) (cadr c))
(* (car c) (cadr a))
)
(+
(* (car a) (cadr c))
(* (car b) (cadr a))
(* (car c) (cadr b))
)
)
2.
)
)
)
(list p1 (cdr p1) (list (caddr p1) (car p1)))
(list p2 (cdr p2) (list (caddr p2) (car p2)))
(list p3 (cdr p3) (list (caddr p3) (car p3)))
)
)
)
)
)
-
Area of triangle
(defun ph:area (p1 p2 p3)
(* 0.5
(abs (+
(* (cadr p1) (- (car p2) (car p3)))
(* (cadr p2) (- (car p3) (car p1)))
(* (cadr p3) (- (car p1) (car p2)))
)
)
)
)
-
Area of triangle
(defun ph:area (p1 p2 p3)
(* 0.5
(abs (+
(* (cadr p1) (- (car p2) (car p3)))
(* (cadr p2) (- (car p3) (car p1)))
(* (cadr p3) (- (car p1) (car p2)))
)
)
)
)
http://www.theswamp.org/index.php?topic=37455.msg424735#msg424735
-
Another...
(defun LM:TriangleArea ( p1 p2 p3 )
(* 0.5 (distance p1 p2) (distance p2 p3) (abs (sin (- (angle p2 p1) (angle p2 p3)))))
)
-
hi All, to cal area of 3d points triangle, please test with it
(ss-aat '(1 2 0) '(4 4 3) '(5 6 0))
(ss-aat '(1 2 0) '(2 4 3) '(3 6 0))
-
hi All, to cal area of 3d points triangle, please test with it
(ss-aat '(1 2 0) '(4 4 3) '(5 6 0))
Oh yes - I would note that mine was for 2D purposes....
For 3D:
(defun LM:TriangleArea ( p1 p2 p3 )
( (lambda ( n ) (* 0.5 (sqrt (apply '+ (mapcar '* n n)))))
(v^v (mapcar '- p2 p1) (mapcar '- p3 p1))
)
)
(defun v^v ( u v )
(list
(- (* (cadr u) (caddr v)) (* (cadr v) (caddr u)))
(- (* (car v) (caddr u)) (* (car u) (caddr v)))
(- (* (car u) (cadr v)) (* (car v) (cadr u)))
)
)
-
hi All, to cal area of 3d points triangle, please test with it
(ss-aat '(1 2 0) '(4 4 3) '(5 6 0))
Oh yes - I would note that mine was for 2D purposes....
Ditto.
-
Point to judge whether in atriangle and the area of the triangle has a reasonable calculation function ,
And, ElpanovEvgeniy often the corret routine , however the overall complexity of the algorithm is O(n^3),
is it possible to let down ?
-
hi , Lee ,
that's my test result
_$
函数:AREA_GERON运行10000次测试结果00:00:00:171函数:LM:TRIANGLEAREA运行10000次测试结果00:00:00:281函数:SS-AAT运行10000次测试结果00:00:00:297
"00:00:00:297"
_$
-
A quick test:
_$ (setq p1 '(1. 2. 0.) p2 '(4. 4. 3.) p3 '(5. 6. 0.))
(5.0 6.0 0.0)
_$ (ss-aat p1 p2 p3)
8.7178
_$ (LM:TriangleArea p1 p2 p3)
8.7178
_$ (area_geron p1 p2 p3)
8.7178
_$ (Benchmark '((ss-aat p1 p2 p3) (LM:TriangleArea p1 p2 p3) (area_geron p1 p2 p3)))
Benchmarking ..................Elapsed milliseconds / relative speed for 32768 iteration(s):
(AREA_GERON P1 P2 P3)..........1701 / 1.25 <fastest>
(LM:TRIANGLEAREA P1 P2 P3).....1857 / 1.14
(SS-AAT P1 P2 P3)..............2122 / 1.00 <slowest>
-
here's a new test dwg for total routine
-
new version
(defun c:t1 (/ A1 A2 L LST S)
(defun ins (p a b c) (or (inters p a b c) (inters p b a c) (inters p c a b)))
(defun area_geron (a b c / l p)
(setq l (cons 0 (mapcar (function distance) (list a b c) (list b c a)))
p (/ (apply (function +) l) 2.)
) ;_ setq
(sqrt (abs (apply (function *) (mapcar (function -) l (list p p p p)))))
) ;_ defun
(if (setq a1 0
s (ssget "_x" '((0 . "point")))
) ;_ setq
(foreach a (setq lst (mapcar (function (lambda (a) (cdr (assoc 10 (entget (cadr a))))))
(ssnamex s)
) ;_ mapcar
) ;_ setq
(foreach b lst
(foreach c lst
(if (and (> (setq a2 (area_geron a b c)) a1)
(vl-every (function (lambda (p) (ins p a b c))) lst)
) ;_ and
(setq a1 a2
l (list a b c)
) ;_ setq
) ;_ if
) ;_ foreach
) ;_ foreach
) ;_ foreach
) ;_ if
(entmakex
(append
'((0 . "LWPOLYLINE") (100 . "AcDbEntity") (100 . "AcDbPolyline") (90 . 3) (70 . 1))
(mapcar (function (lambda (a) (cons 10 a))) l)
) ;_ append
) ;_ entmakex
(princ)
)
-
hi , all
hi , Evgeniy
about pt in or at the triangle , I tested result is
函数:EE:PITP运行10000次测试结果00:00:00:108函数:SS-PITP运行10000次测试结果00:00:00:061函数:SS-PITP0运行10000次测试结果00:00:00:921函数:SS-PITP1运行10000次测试结果00:00:00:360
use cal number of intersections method is the fastest , is it a wrong test ?
;;;number of intersection
;;;fastest
(defun ss-pitp (p l)
;;check point inside triangle .
;;by GSLS(SS)
((lambda (a b c)
(eq (+ (length (inters p a b c nil))
(length (inters p b a c nil))
(length (inters p c a b nil))
)
9
)
)
(car l)
(cadr l)
(caddr l)
)
)
In your program ss-pitp error
-
Hi,
While using a function which returns the triangle algebraic area (signed area) as Alanjt's AT:TriangleArea (http://www.theswamp.org/index.php?topic=37455.msg424735#msg424735) or algeb-area (http://www.theswamp.org/index.php?topic=18725.msg229319#msg229319) for the triangle area, the same routine can be used to evaluate if a point is inside the triangle:
(defun algeb-area (p1 p2 p3)
(/ (- (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
(* (- (car p3) (car p1)) (- (cadr p2) (cadr p1)))
)
2.0
)
)
(defun isInside (pt p1 p2 p3)
((lambda (a1 a2 a3)
(or
(and (<= 0.0 a1) (<= 0.0 a2) (<= 0.0 a3))
(and (<= a1 0.0) (<= a2 0.0) (<= a3 0.0))
)
)
(algeb-area pt p1 p2)
(algeb-area pt p2 p3)
(algeb-area pt p3 p1)
)
)
This will return T if the point is strictly inside or lies on the triangle.
Replacing '<=' with '<' will evaluate only strictly inside point.
-
Or perhaps another method:
(defun isInside ( pt p1 p2 p3 )
(
(lambda ( a1 a2 a3 )
(or
(and (<= 0.0 a1) (<= 0.0 a2) (<= 0.0 a3))
(and (<= a1 0.0) (<= a2 0.0) (<= a3 0.0))
)
)
(sin (- (angle p1 pt) (angle p1 p2)))
(sin (- (angle p2 pt) (angle p2 p3)))
(sin (- (angle p3 pt) (angle p3 p1)))
)
)
[ Used some of your code Gile ]
-
hi Gile , Lee ,
to judge a point in or at triangle ofcause can use area method , but it take a lot cal , I think the intersetion method is fastest .
hi Evgeniy , in the routine it can be
(defun ss-pitp (p l)
;;check point inside triangle .
;;by GSLS(SS)
(< ((lambda (a b c)
(+ (length (inters p a b c nil))
(length (inters p b a c nil))
(length (inters p c a b nil))
)
)
(car l)
(cadr l)
(caddr l)
)
9
)
)
however yours 'ins' is Excellent ! but the wholl routine is too slow if the points nums is more , e.g. 528 points in my often dwg .
-
by the way , in this routine , the area cal is for Comparison , so it can be simplified like this
(defun ss-aat (p1 p2 p3)
;;area triangle
;;Uses conventional formula.
(apply (function +)
(mapcar (function (lambda (a b c)
(expt (- (+
(* (car a) (cadr b))
(* (car b) (cadr c))
(* (car c) (cadr a))
)
(+
(* (car a) (cadr c))
(* (car b) (cadr a))
(* (car c) (cadr b))
)
)
2.
)
)
)
(list p1 (cdr p1) (list (caddr p1) (car p1)))
(list p2 (cdr p2) (list (caddr p2) (car p2)))
(list p3 (cdr p3) (list (caddr p3) (car p3)))
)
)
)
-
is it possible to use Mesh method ?
-
Perhaps , We can solve it from 2D first
-
hi Gile , Lee ,
to judge a point in or at triangle ofcause can use area method , but it take a lot cal , I think the intersetion method is fastest .
hi Evgeniy , in the routine it can be
(defun ss-pitp (p l)
;;check point inside triangle .
;;by GSLS(SS)
(< ((lambda (a b c)
(+ (length (inters p a b c nil))
(length (inters p b a c nil))
(length (inters p c a b nil))
)
)
(car l)
(cadr l)
(caddr l)
)
9
)
)
however yours 'ins' is Excellent ! but the wholl routine is too slow if the points nums is more , e.g. 528 points in my often dwg .
It seems to me that the ss-pitp routine do not return right results, for example:
(ss-pitp '(2. 1. 0.) '((0. 0. 0.) (5. 0. 0.) (3. 2. 0.))) returns nil even (2. 1. 0.) is inside the triangle.
-
hi Gile
that's right result , because it change into the cond that whether point out of triangle , if to judge in or at it , use this
(defun ss-pitp (p l)
;;check point inside triangle .
;;by GSLS(SS)
(= ;|if judge out of , ucs /= or < |; ((lambda (a b c)
(+ (length (inters p a b c nil))
(length (inters p b a c nil))
(length (inters p c a b nil))
)
)
(car l)
(cadr l)
(caddr l)
)
9
)
)
-
to sort point set by mesh , can use follow func , but not sure it's right
;;;
(defun sort-mesh
(pts n / minpt maxpt dvx fsx dvy fsy i dm a b mid ptm end)
;;sort point set by mesh
;;by GSLS(SS)
(setq minpt (apply
'mapcar
(cons 'min pts)
)
maxpt
(apply
'mapcar
(cons 'max pts)
)
dvx (/ (- (car maxpt) (car minpt)) n)
fsx (car minpt)
dvy (/ (- (cadr maxpt) (cadr minpt)) n)
fsy (cadr minpt)
)
(setq pts
(vl-sort pts
(function
(lambda (e1 e2)
(< (car e1) (car e2))
)
)
)
)
(setq i 1)
(while pts
(setq dm (+ fsx (* i dvx)))
(setq a (car pts))
(cond ((<= (- dm dvx) (car a) dm)
(setq mid (cons a mid)
pts (cdr pts)
)
)
((<= dm (car a) (+ dm dvx))
(setq ptn (cons mid ptn)
mid nil
mid (cons a mid)
pts (cdr pts)
i (1+ i)
)
)
(t
(setq ptn (cons nil (cons mid ptn))
mid nil
i (1+ i)
)
)
)
)
(setq end nil)
(foreach b ptn
(if b
(progn
(setq b
(vl-sort b
(function
(lambda (e1 e2)
(< (cadr e1) (cadr e2))
)
)
)
i 1
mid nil
ptm nil
)
(while b
(setq dm (+ fsy (* i dvy)))
(setq a (car b))
(cond ((<= (- dm dvy) (cadr a) dm)
(setq mid (cons a mid)
b (cdr b)
)
)
((<= dm (cadr a) (+ dm dvy))
(setq ptm (cons mid ptm)
mid nil
mid (cons a mid)
b (cdr b)
i (1+ i)
)
)
(t
(setq ptm (cons nil (cons mid ptm))
mid nil
i (1+ i)
)
)
)
)
(setq end (cons (reverse ptm) end))
)
(setq end (cons (repeat n (setq b (cons nil b))) end))
)
)
end
)
;;test
(foreach a
(sort-mesh
(mapcar
(function
(lambda (x) (cdr (assoc 10 (entget (cadr x)))))
)
(cdr (reverse (ssnamex (ssget '((0 . "point"))))))
)
20
)
(princ a)
)
-
hi Gile
that's right result , because it change into the cond that whether point out of triangle , if to judge in or at it , use this
(defun ss-pitp (p l)
;;check point inside triangle .
;;by GSLS(SS)
(= ;|if judge out of , ucs /= or < |; ((lambda (a b c)
(+ (length (inters p a b c nil))
(length (inters p b a c nil))
(length (inters p c a b nil))
)
)
(car l)
(cadr l)
(caddr l)
)
9
)
)
Sorry, I can't understand what you mean.
Your new routine still return false result IMO.
The point (3. -2. 0.) is outside the triangle ((0. 0. 0.) (5. 0. 0.) (3. 2. 0.)) but
(ss-pitp '(3. -2. 0.) '((0. 0. 0.) (5. 0. 0.) (3. 2. 0.))) returns T
-
hi Gile
that's right result , because it change into the cond that whether point out of triangle , if to judge in or at it , use this
(defun ss-pitp (p l)
;;check point inside triangle .
;;by GSLS(SS)
(= ;|if judge out of , ucs /= or < |; ((lambda (a b c)
(+ (length (inters p a b c nil))
(length (inters p b a c nil))
(length (inters p c a b nil))
)
)
(car l)
(cadr l)
(caddr l)
)
9
)
)
Sorry, I can't understand what you mean.
Your new routine still return false result IMO.
The point (3. -2. 0.) is outside the triangle ((0. 0. 0.) (5. 0. 0.) (3. 2. 0.)) but
(ss-pitp '(3. -2. 0.) '((0. 0. 0.) (5. 0. 0.) (3. 2. 0.))) returns T
hi gile , my test reulet return NIL
-
hi gile , my test reulet return NIL
I do not know how you're making your tests, but :
(inters p a b c nil) returns (15.0 -10.0 0.0) => length = 3
(inters p b a c nil) returns (15.0 10.0 0.0) => lenght = 3
(inters p c a b nil) returns (3.0 0.0 0.0) => length = 3
Total lengthes = 9 => T
Try this little test command
(defun c:test (/ l p)
(setq l '((0. 0. 0.) (5. 0. 0.) (3. 2. 0.)))
(command "_.pline")
(mapcar '(lambda (p) (command "_non" p)) l)
(command "_close")
(while (setq p (getpoint))
(alert
(if (ss-pitp p l)
"Inside"
"Outside"
)
)
)
(princ)
)
-
Nice gile !
thank you for often a nice test routine .
it really take a wrong result .
-
by the cods , it'll return error result inside ,like the picture
(defun ss-pitp (p l)
;;check point inside triangle .
((lambda (a b c)
(not (or (inters p a b c) (inters p b a c) (inters p c a b)))
)
(car l)
(cadr l)
(caddr l)
)
)
-
by the way , angle & inters are use in 2D plan , in 3Dplan it can't return corret reslut .
if in 3D , do it can use this func , I can't sure it because less of 'trans .
;;;with the same direction method
;;;by trans
(defun ss-pitp1 (p l)
;;check point inside triangle .
;;by GSLS(SS)
((lambda (a b c)
(and (<= (* (car (trans (mapcar '- p a) 0 (mapcar '- b a)))
(car (trans (mapcar '- p a) 0 (mapcar '- c a)))
)
0
)
(<= (* (car (trans (mapcar '- p b) 0 (mapcar '- a b)))
(car (trans (mapcar '- p b) 0 (mapcar '- c b)))
)
0
)
)
)
(car l)
(cadr l)
(caddr l)
)
)
-
The way is too long , So let's begin with 2D :-P
-
To accurately determine the point is outside the triangle , uses this one
;;;is outside of triangle
(defun ss-ostp (p l)
(if (vl-some (function (lambda (x) (equal p x 1e-6)))
l
);_ pt at Triangle point
nil
;;Gile & Lee Mac
((lambda (a b c)
(not
(or
(and (<= -1e-6 a) (<= -1e-6 b) (<= -1e-6 c))
(and (<= a 1e-6) (<= b 1e-6) (<= c 1e-6))
);_if at triangle edge, so add tolerance
)
)
(sin (- (angle (car l) p) (angle (car l) (cadr l))))
(sin (- (angle (cadr l) p) (angle (cadr l) (caddr l))))
(sin (- (angle (caddr l) p) (angle (caddr l) (car l))))
)
)
)
;;;Gile
(defun c:test (/ l p)
(setq l '((3. 2. 0.) (0. 0. 0.) (5. 0. 0.)))
(command "_.pline")
(mapcar '(lambda (p) (command "_non" p)) l)
(command "_close")
(while (setq p (getpoint))
(alert
(if (ss-ostp p l)
"Outside"
"Inside"
)
)
)
(princ)
)
-
hi All , here is a mesh method , not sure it's right .
it can improve eff too much , but slowly yet .
;;;to draw the Embedded triangle of point set which has max area , in the no other point of the pts inside it
;;;by GSLS(SS)
(defun c:test (/ ostp area_geron sort-mesh
pt-ishp get-ijlst cal-nil-counter pts
minpt maxpt fsx fsy hull
n lst i j nil_lst_i
new_lst_i end tri_area new new_lst
a1 a b c d
r1_lst r2_lst len end_lst_i
)
;;;is outside of triangle
(defun ostp (p p1 p2 p3);_(check-pt (list p p1 p2 p3))
;;Gile & Lee Mac
((lambda (a b c)
(not
(or
(and (< 0.0 a) (< 0.0 b) (< 0.0 c))
(and (< a 0.0) (< b 0.0) (< c 0.0))
) ;_if at triangle edge, so add tolerance
)
)
(sin (- (angle p1 p) (angle p1 p2)))
(sin (- (angle p2 p) (angle p2 p3)))
(sin (- (angle p3 p) (angle p3 p1)))
)
)
;;cal area of triangle for Comparison
(defun area_geron (a b c / l p)
(setq l (cons 0
(mapcar (function distance) (list a b c) (list b c a))
)
p (/ (apply (function +) l) 2.)
) ;_ setq
(abs
(apply (function *) (mapcar (function -) l (list p p p p)))
) ;_Omit the square root
) ;_ defun
(defun sort-mesh
(pts n / i dm a b mid ptm ptn end)
(setq dvx (/ (- (car maxpt) (car minpt)) n)
dvy (/ (- (cadr maxpt) (cadr minpt)) n)
)
(setq pts
(vl-sort pts
(function
(lambda (e1 e2)
(< (cadr e1) (cadr e2))
)
)
)
) ;_sort point set by Y coor
(setq i 1
mid nil)
(while pts
(setq dm (+ fsy (* i dvy)))
(setq a (car pts)
)
(cond ((<= (- dm dvy) (cadr a) dm)
(setq mid (cons a mid)
pts (cdr pts)
)
)
((<= dm (cadr a) (+ dm dvy))
(setq ptn (cons mid ptn)
mid nil
mid (cons a mid)
pts (cdr pts)
i (1+ i)
)
)
(t
(setq ptn (cons nil (cons mid ptn))
mid nil
i (1+ i)
)
)
)
)
(if mid (setq ptn (cons mid ptn)))
(setq end nil)
(foreach b ptn ;_(setq b (car ptn))
(if b
(progn
(setq b
(vl-sort b
(function
(lambda (e1 e2)
(< (car e1) (car e2))
)
)
) ;_sort points by X coor
i 1
mid nil
ptm nil
)
(while b
(setq dm (+ fsx (* i dvx)))
(setq a (car b))
(cond ((<= (- dm dvx) (car a) dm)
(setq mid (cons a mid)
b (cdr b)
)
)
((<= dm (car a) (+ dm dvx))
(setq ptm (cons mid ptm)
mid nil
mid (cons a mid)
b (cdr b)
i (1+ i)
)
)
(t
(setq ptm (cons mid ptm)
mid nil
i (1+ i)
)
)
)
)
(if mid (setq ptm (cons mid ptm)))
(repeat (- n (length ptm))
(setq ptm (cons nil ptm))
)
(setq end (cons (reverse ptm) end))
)
(setq end (cons (repeat n (setq b (cons nil b))) end))
)
)
end
)
(defun pt-ishp (pt hull / hull_cen is_inh)
(setq hull_cen (mapcar (function (lambda (x) (/ x (length hull))))
(apply 'mapcar (cons '+ hull))
)
hull (cons (last hull) hull)
is_inh T
)
(while (and is_inh (cadr hull))
(if (inters hull_cen pt (car hull) (cadr hull) T)
(setq is_inh nil)
(setq hull (cdr hull))
)
)
is_inh
)
;;;
(defun get-ijlst (ij n len / i j it ib jl jr new i%)
;;;get ij N round items i & j
(setq i (car ij)
j (cadr ij)
it (+ i n)
ib (- i n)
jl (- j n)
jr (+ j n)
)
(setq new (list
(list i jl)
(list i jr)
(list ib jl)
(list ib j)
(list ib jr)
(list it j)
(list it jl)
(list it jr)
)
)
(setq i% 0)
(repeat (1- n)
(setq new (append (list (list it (- j (setq i% (1+ i%))))
(list it (+ j i%))
(list ib (+ j i%))
(list ib (- j i%))
(list (+ i i%) jl)
(list (- i i%) jl)
(list (+ i i%) jr)
(list (- i i%) jr)
)
new
)
)
)
(vl-remove-if-not
(function (lambda (x)
(and (<= 0 (car x) (1- len))
(<= 0 (cadr x) (1- len))
)
)
)
new
)
)
;;;
(defun cal-nil-counter
(ij nil_lst_i len / is_go ij_lst i new)
(setq is_go T
i 1
)
(while is_go
(setq new nil
ij_lst (get-ijlst ij i len)
i% -1
)
(if
(apply
'and
(mapcar (function (lambda (x) (vl-position x nil_lst_i)))
ij_lst
)
)
(setq i (1+ i))
(setq is_go nil)
)
)
i
)
;;....................................................................................
(setq pts (mapcar
(function
(lambda (x) (cdr (assoc 10 (entget (cadr x)))))
)
(cdr (reverse (ssnamex (ssget '((0 . "point"))))))
)
)
(setq minpt (apply
'mapcar
(cons 'min pts)
) ;_lb point
maxpt
(apply
'mapcar
(cons 'max pts)
) ;_rt point
fsx (car minpt)
fsy (cadr minpt)
hull (Graham-scan pts) ;_Convex hull
n 19
)
(while (or (null nil_lst_i) (< (length nil_lst_i) 200))
(setq lst (sort-mesh pts (setq n (1+ n)))) ;_sort points and return a mesh points list
;_(check-pt (cadr (vl-remove nil (car lst))))
(setq nil_lst_i nil
i 0
)
(foreach a lst
(setq j 0)
(foreach b a
(if (= b nil)
(setq nil_lst_i (cons (list i j) nil_lst_i))
)
(setq j (1+ j))
)
(setq i (1+ i))
)
)
(setq nil_lst_i (reverse nil_lst_i)
nil_lst_i (vl-remove-if-not
(function
(lambda (x)
(pt-ishp (list (+ fsx (* (+ (car x) 0.5) dvx))
(+ fsy (* (+ (cadr x) 0.5) dvy))
)
hull
)
)
)
nil_lst_i
)
new_lst_i (mapcar
(function
(lambda (x)
(append x
(list (cal-nil-counter x nil_lst_i n))
)
)
)
nil_lst_i
)
new_lst_i (vl-sort new_lst_i
(function (lambda (e1 e2)
(> (caddr e1) (caddr e2))
)
)
)
len (caddar new_lst_i)
new_lst_i (vl-remove-if-not
(function (lambda (x)
(= (caddr x) len)
)
)
new_lst_i
)
end_lst_i nil
end nil
tri_area 0
)
(while new_lst_i
(setq a (car new_lst_i)
new_lst_i (cdr new_lst_i)
)
(if (null end_lst_i)
(setq end_lst_i (list (list (reverse (cdr (reverse a))))))
(if (setq b
(car
(vl-remove-if-not
(function
(lambda (x)
(or (vl-position (list (car a) (1- (cadr a))) x)
(vl-position (list (car a) (1+ (cadr a))) x)
(vl-position (list (1- (car a)) (cadr a)) x)
(vl-position (list (1- (car a)) (1- (cadr a))) x)
(vl-position (list (1- (car a)) (1+ (cadr a))) x)
)
)
)
end_lst_i
)
)
)
(setq end_lst_i (cons (cons (reverse (cdr (reverse a))) b)
(vl-remove b end_lst_i)
)
)
(setq end_lst_i
(cons (list (reverse (cdr (reverse a)))) end_lst_i)
)
)
)
)
(setq end_lst_i (vl-sort end_lst_i
(function (lambda (e1 e2)
(> (length e1) (length e2))
)
)
)
)
;;just test 4 areas
(foreach a (list (car end_lst_i) ;_(setq a (car end_lst_i))
(cadr end_lst_i)
)
(if a
(progn
(setq new nil
new_lst nil
)
(foreach b a
(foreach c (get-ijlst b len (1- n))
;_here must be (append (get-ijlst b len (1- n)) (get-ijlst b (1+ len) (1- n))) , but too slow although the points number only 100 .
(setq new (cons c new))
(if (and (not (vl-position b new))
(setq d (nth (cadr c) (nth (car c) lst)))
)
(setq new_lst (append new_lst d)
)
)
)
)
;_(check-pt new_lst)
;; Evgeniy method
;; this part too slowly , how can improve it ?
(princ (length new_lst));_for test
(foreach b new_lst
(foreach c new_lst
(foreach d new_lst
(if (and (not (equal b c 1e-6))
(not (equal c d 1e-6))
(not (equal b d 1e-6))
(> (setq a1 (area_geron b c d)) tri_area)
(vl-every (function (lambda (p) (ostp p b c d)))
new_lst
)
) ;_ and
(setq tri_area a1
end (list b c d)
) ;_ setq
) ;_ if
) ;_ foreach
) ;_ foreach
)
)
)
)
(entmakex
(append
'((0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(100 . "AcDbPolyline")
(90 . 3)
(70 . 1)
)
(mapcar (function (lambda (a) (cons 10 a))) end)
) ;_ append
) ;_ entmakex
(princ)
)
(defun Graham-scan (ptl / det hPs rPs PsY Pt0 sPs P Q)
;;by highflybird
;;定义三点的行列式,即三点之倍面积
;;Definition of the determinant of three points, that is 2 times area of triangle
(defun det (p1 p2 p3)
(- (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
(* (- (car p3) (car p1)) (- (cadr p2) (cadr p1)))
)
)
(if (< (length ptl) 4) ;3点以下
ptl ;是本集合
(progn
(setq rPs (mapcar (function (lambda (x)
(if (= (length x) 3)
(cdr x)
x
)
)
)
(mapcar 'reverse ptl)
) ;点_表的X和Y交换
PsY (mapcar 'cadr ptl) ;_点表的Y值的表
Pt0 (reverse (assoc (apply 'min PsY) rPs)) ;_最下面的点
sPs (sort-ad ptl Pt0) ;_按角度距离排序点集
hPs (list (caddr sPs) (cadr sPs) Pt0) ;_开始的三点
)
(foreach n (cdddr sPs) ;从第4点开始
(setq hPs (cons n hPs) ;把Pi加入到凸集
P (cadr hPs) ;Pi-1
Q (caddr hPs) ;Pi-2
)
(while (and q (> (det n P Q) -1e-6)) ;如果左转
(setq hPs (cons n (cddr hPs)) ;删除Pi-1点
P (cadr hPs) ;得到新的Pi-1点
Q (caddr hPs) ;得到新的Pi-2点
)
)
)
hPs ;返回凸集
)
)
)
(defun sort-ad (ptlist pt / Ang1 Ang2)
-
Suppose before mesh method is corret ,Now we must solve problem just cal point set which has a big hole , like the picture .
-
Tip: Use 'png' or 'gif' image format to obtain better quality images when taking screenshots of a vector-based program such as AutoCAD.
-
Thanks LEE .
-
Hi All , this one can get the right result for the e.g. dwg , but not solve problem , Mass Calculation of the end point set
I'v upload the new test drawing .
(defun c:test (/ ostp area_geron sort-mesh
pt-ishp get-ijlst get-subspace-rings pts
minpt maxpt fsx fsy hull
n lst i j nil_lst_i
new_lst_i end tri_area new new_lst
a1 a b c d
r1_lst r2_lst len end_lst_i
)
;;;is outside of triangle
(defun ostp (p p1 p2 p3);_(check-pt (list p p1 p2 p3))
;;Gile & Lee Mac
((lambda (a b c)
(not
(or
(and (< 1e-6 a) (< 1e-6 b) (< 1e-6 c))
(and (< a -1e-6) (< b -1e-6) (< c -1e-6))
) ;_if at triangle edge, so add tolerance
)
)
(sin (- (angle p1 p) (angle p1 p2)))
(sin (- (angle p2 p) (angle p2 p3)))
(sin (- (angle p3 p) (angle p3 p1)))
)
)
;;cal area of triangle for Comparison
(defun area_geron (a b c / l p)
(setq l (cons 0
(mapcar (function distance) (list a b c) (list b c a))
)
p (/ (apply (function +) l) 2.)
) ;_ setq
(abs
(apply (function *) (mapcar (function -) l (list p p p p)))
) ;_Omit the square root
) ;_ defun
(defun sort-mesh
(pts n / i dm a b mid ptm ptn end)
(setq dvx (/ (- (car maxpt) (car minpt)) n)
dvy (/ (- (cadr maxpt) (cadr minpt)) n)
)
(setq pts
(vl-sort pts
(function
(lambda (e1 e2)
(< (cadr e1) (cadr e2))
)
)
)
) ;_sort point set by Y coor
;;
(setq i 1
mid nil)
(while pts
(setq dm (+ fsy (* i dvy)))
(setq a (car pts)
)
(cond ((<= (- dm dvy) (cadr a) dm)
(setq mid (cons a mid)
pts (cdr pts)
)
)
((<= dm (cadr a) (+ dm dvy))
(setq ptn (cons mid ptn)
mid nil
mid (cons a mid)
pts (cdr pts)
i (1+ i)
)
)
(t
(setq ptn (cons nil (cons mid ptn))
mid nil
i (1+ i)
)
)
)
)
(if mid (setq ptn (cons mid ptn)))
;(setq end nil) ;_bypass
(foreach b ptn ;_(setq b (car ptn))
(if b
(progn
(setq b
(vl-sort b
(function
(lambda (e1 e2)
(< (car e1) (car e2))
)
)
) ;_sort points by X coor
i 1
mid nil
ptm nil
)
(while b
(setq dm (+ fsx (* i dvx)))
(setq a (car b))
(cond ((<= (- dm dvx) (car a) dm)
(setq mid (cons a mid)
b (cdr b)
)
)
((<= dm (car a) (+ dm dvx))
(setq ptm (cons mid ptm)
mid nil
mid (cons a mid)
b (cdr b)
i (1+ i)
)
)
(t
(setq ptm (cons mid ptm)
mid nil
i (1+ i)
)
)
)
)
(if mid (setq ptm (cons mid ptm)))
(repeat (- n (length ptm))
(setq ptm (cons nil ptm))
)
(setq end (cons (reverse ptm) end))
)
(setq end (cons (repeat n (setq b (cons nil b))) end))
)
)
end
)
(defun pt-ishp (pt hull / hull_cen is_inh)
(setq hull_cen (mapcar (function (lambda (x) (/ x (length hull))))
(apply 'mapcar (cons '+ hull))
)
hull (cons (last hull) hull)
is_inh T
)
(while (and is_inh (cadr hull))
(if (inters hull_cen pt (car hull) (cadr hull) T)
(setq is_inh nil)
(setq hull (cdr hull))
)
)
is_inh
)
;;; Calculating sublattice number of the ij-position expanding n outer ring
(defun get-ijlst (ij n len / i j it ib jl jr new i%)
(setq i (car ij)
j (cadr ij)
it (+ i n)
ib (- i n)
jl (- j n)
jr (+ j n)
)
(setq new (list
(list i jl)
(list i jr)
(list ib jl)
(list ib j)
(list ib jr)
(list it j)
(list it jl)
(list it jr)
)
)
(setq i% 0)
(repeat (1- n)
(setq new (append (list (list it (- j (setq i% (1+ i%))))
(list it (+ j i%))
(list ib (+ j i%))
(list ib (- j i%))
(list (+ i i%) jl)
(list (- i i%) jl)
(list (+ i i%) jr)
(list (- i i%) jr)
)
new
)
)
)
(vl-remove-if-not
(function (lambda (x)
(and (<= 0 (car x) (1- len))
(<= 0 (cadr x) (1- len))
)
)
)
new
)
)
;;; cal sub-space
(defun get-subspace-rings
(ij nil_lst_i len / is_go ij_lst i new)
(setq is_go T
i 1
)
(while is_go
(setq new nil
ij_lst (get-ijlst ij i len)
i% -1
)
(if
(apply
'and
(mapcar (function (lambda (x) (vl-position x nil_lst_i)))
ij_lst
)
)
(setq i (1+ i))
(setq is_go nil)
)
)
i
)
;;....................................................................................
(setq pts (mapcar
(function
(lambda (x) (cdr (assoc 10 (entget (cadr x)))))
)
(cdr (reverse (ssnamex (ssget '((0 . "point"))))))
)
)
(setq minpt (apply
'mapcar
(cons 'min pts)
) ;_lb point
maxpt
(apply
'mapcar
(cons 'max pts)
) ;_rt point
fsx (car minpt)
fsy (cadr minpt)
hull (Graham-scan pts) ;_Convex hull
n (fix(sqrt(* 2.9 (length pts)))) ;_changed , to get enough number of mesh ,
;_The best is a prime number - 1 .
)
(while (or (null nil_lst_i) (< (length nil_lst_i) 200)) ;_the number of sub-spaces '200', is it suit ?
(setq lst (sort-mesh pts (setq n (1+ n)))) ;_sort points and return a mesh points list
(setq nil_lst_i nil
i 0
)
(foreach a lst
(setq j 0)
(foreach b a
(if (= b nil)
(setq nil_lst_i (cons (list i j) nil_lst_i))
)
(setq j (1+ j))
)
(setq i (1+ i))
)
)
;;;-----------------------------------------
;;; Calculating contain most sub-space Area
;;; This part is too cumbersome ... can be simplified .
(setq nil_lst_i (reverse nil_lst_i)
nil_lst_i (vl-remove-if-not
(function
(lambda (x)
(pt-ishp (list (+ fsx (* (+ (car x) 0.5) dvx))
(+ fsy (* (+ (cadr x) 0.5) dvy))
)
hull
)
)
)
nil_lst_i
)
new_lst_i (mapcar
(function
(lambda (x)
(append x
(list (get-subspace-rings x nil_lst_i n))
)
)
)
nil_lst_i
)
new_lst_i (vl-sort new_lst_i
(function (lambda (e1 e2)
(> (caddr e1) (caddr e2))
)
)
)
len (caddar new_lst_i)
new_lst_i (vl-remove-if-not
(function (lambda (x)
(= (caddr x) len)
)
)
new_lst_i
)
end_lst_i nil
)
(while new_lst_i
(setq a (car new_lst_i)
new_lst_i (cdr new_lst_i)
)
(if (null end_lst_i)
(setq end_lst_i (list (list (reverse (cdr (reverse a))))))
(if (setq b
(car
(vl-remove-if-not
(function
(lambda (x)
(or (vl-position (list (car a) (1- (cadr a))) x)
(vl-position (list (car a) (1+ (cadr a))) x)
(vl-position (list (1- (car a)) (cadr a)) x)
(vl-position (list (1- (car a)) (1- (cadr a))) x)
(vl-position (list (1- (car a)) (1+ (cadr a))) x)
)
)
)
end_lst_i
)
)
)
(setq end_lst_i (cons (cons (reverse (cdr (reverse a))) b)
(vl-remove b end_lst_i)
)
)
(setq end_lst_i
(cons (list (reverse (cdr (reverse a)))) end_lst_i)
)
)
)
)
(setq end_lst_i (vl-sort end_lst_i
(function (lambda (e1 e2)
(> (length e1) (length e2))
)
)
)
end nil
tri_area 0
)
;;;--------------------------------------
;;;end of calculating number of sub-space
;;just test 4 areas
(foreach a (list (car end_lst_i) ;_(setq a (car end_lst_i))
(cadr end_lst_i)
(caddr end_lst_i)
(cadddr end_lst_i)
)
(if a
(progn
(setq new nil
new_lst nil
)
(foreach b a
(foreach c (append (get-ijlst b len (1- n)) (get-ijlst b (1+ len) (1- n)) (get-ijlst b (+ 2 len) (1- n)))
;_here has problem , jow much the number of expand outer ring Need to search point set ?
;_based on the grid subdivision and the discrete of point set ?
(if (and (not (vl-position c new))
(setq d (nth (cadr c) (nth (car c) lst)))
)
(setq new (cons c new)
new_lst (append new_lst d)
)
)
)
)
;_(check-pt new_lst)
;_(princ (length new_lst));_for test
;_(setq new_lst (remove-same-pts new_lst 1e-6))
(princ (length new_lst));_for test
;_the last points for search .
;_can it search by centre scanning or other scanning method ?
;; Evgeniy method
;; this part too slowly , how can improve it ?
(foreach b new_lst
(foreach c new_lst
(foreach d new_lst
(if (and (not (equal b c 1e-6))
(not (equal c d 1e-6))
(not (equal b d 1e-6))
(> (setq a1 (area_geron b c d)) tri_area)
(vl-every (function (lambda (p) (ostp p b c d)))
new_lst
)
) ;_ and
(setq tri_area a1
end (list b c d)
) ;_ setq
) ;_ if
) ;_ foreach
) ;_ foreach
);
)
)
)
(entmakex
(append
'((0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(100 . "AcDbPolyline")
(90 . 3)
(70 . 1)
)
(mapcar (function (lambda (a) (cons 10 a))) end)
) ;_ append
) ;_ entmakex
(princ)
)