### Author Topic: [Challenge] Point set inscribed the max area triangle  (Read 9578 times)

0 Members and 1 Guest are viewing this topic.

#### chlh_jd

• Guest
##### Re: [Challenge] Point set inscribed the max area triangle
« Reply #45 on: March 18, 2011, 09:28:50 AM »
The way is too long , So let's begin with 2D

#### chlh_jd

• Guest
##### Re: [Challenge] Point set inscribed the max area triangle
« Reply #46 on: March 19, 2011, 02:11:23 AM »
To accurately determine the point is outside the triangle , uses this one
Code: [Select]
`;;;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))`

#### chlh_jd

• Guest
##### Re: [Challenge] Point set inscribed the max area triangle
« Reply #47 on: March 19, 2011, 04:35:50 PM »
hi All , here is a mesh method , not sure it's right .
it can improve eff too much , but slowly yet .
Code: [Select]
`;;;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)`

#### chlh_jd

• Guest
##### Re: [Challenge] Point set inscribed the max area triangle
« Reply #48 on: March 19, 2011, 05:02:52 PM »
Suppose before mesh method is corret ,Now we must solve problem just cal  point set which has a big hole , like the picture .

#### Lee Mac

• Seagull
• Posts: 12313
• London, England
##### Re: [Challenge] Point set inscribed the max area triangle
« Reply #49 on: March 19, 2011, 05:12:50 PM »
Tip:  Use 'png' or 'gif' image format to obtain better quality images when taking screenshots of a vector-based program such as AutoCAD.

#### chlh_jd

• Guest
##### Re: [Challenge] Point set inscribed the max area triangle
« Reply #50 on: March 20, 2011, 06:40:14 AM »
Thanks LEE .

#### chlh_jd

• Guest
##### Re: [Challenge] Point set inscribed the max area triangle
« Reply #51 on: March 20, 2011, 09:03:39 AM »
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 .
Code: [Select]
`(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))`
« Last Edit: March 20, 2011, 09:29:52 AM by chlh_jd »