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)