利用面积法求点表凸包

kkq0305

2. (defun convex-area (ptlst)
   
3.   (setq        cenpt (mapcar '*
   
4.                       '(0.5 0.5)
   
5.                       (mapcar '+
   
6.                               (apply 'mapcar (cons 'min ptlst))
   
7.                               (apply 'mapcar (cons 'max ptlst))
   
8.                       )
   
9.               )
   
10.   )
    
11.   (setq
    
12.     ptlst (vl-sort ptlst
    
13.                    '(lambda (a b) (< (angle cenpt a) (angle cenpt b)))
    
14.           )
    
15.   )
    
16.   (setq
    
17.     f (lambda (lst)
    
18.         (abs
    
19.           (apply
    
20.             '+
    
21.             (mapcar '(lambda (x y)
    
22.                        (* (- (car y) (car x)) (+ (cadr x) (cadr y)))
    
23.                      )
    
24.                     lst
    
25.                     (append (cdr lst) (list (car lst)))
    
26.             )
    
27.           )
    
28.         )
    
29.       )
    
30.   )
    
31.   (setq area (f ptlst))
    
32.   (setq        ptlst (vl-remove-if
    
33.                 '(lambda (x) (> (f (vl-remove x ptlst)) area))
    
34.                 ptlst
    
35.               )
    
36.   )
    
37. )
    
38. (defun c:tt ()
    
39.   (setq        ss    (ssget)
    
40.         n     -1
    
41.         ptlst '()
    
42.   )
    
43.   (while (setq ent (ssname ss (setq n (1+ n))))
    
44.     (setq ptlst (cons (cdr (assoc 10 (entget ent))) ptlst))
    
45.   )
    
46.   (while (not (= (length (setq ptlst (convex-area ptlst)))
    
47.                  (length (setq ptlst (convex-area ptlst)))
    
48.               )
    
49.          )
    
50.   )
    
51.   (entmake (append (list '(0 . "LWPOLYLINE")
    
52.                          '(100 . "AcDbEntity")
    
53.                          '(100 . "AcDbPolyline")
    
54.                          (cons 90 (length ptlst))
    
55.                          '(70 . 1)
    
56.                    )
    
57.                    (mapcar '(lambda (pt) (cons 10 pt)) ptlst)
    
58.            )
    
59.   )
    
60.   (princ)
    
61. )

(defun convex-area (ptlst)<br />   (setq        cenpt (mapcar '*<br />                       '(0.5 0.5)<br />                       (mapcar '+<br />                               (apply 'mapcar (cons 'min ptlst))<br />                               (apply 'mapcar (cons 'max ptlst))<br />                       )<br />               )<br />   )<br />   (setq<br />     ptlst (vl-sort ptlst<br />                    '(lambda (a b) (< (angle cenpt a) (angle cenpt b)))<br />           )<br />   )<br />   (setq<br />     f (lambda (lst)<br />         (abs<br />           (apply<br />             '+<br />             (mapcar '(lambda (x y)<br />                        (* (- (car y) (car x)) (+ (cadr x) (cadr y)))<br />                      )<br />                     lst<br />                     (append (cdr lst) (list (car lst)))<br />             )<br />           )<br />         )<br />       )<br />   )<br />   (setq area (f ptlst))<br />   (setq        ptlst (vl-remove-if<br />                 '(lambda (x) (> (f (vl-remove x ptlst)) area))<br />                 ptlst<br />               )<br />   )<br /> )<br /> (defun c:tt ()<br />   (setq        ss    (ssget)<br />         n     -1<br />         ptlst '()<br />   )<br />   (while (setq ent (ssname ss (setq n (1+ n))))<br />     (setq ptlst (cons (cdr (assoc 10 (entget ent))) ptlst))<br />   )<br />   (while (not (= (length (setq ptlst (convex-area ptlst)))<br />                  (length (setq ptlst (convex-area ptlst)))<br />               )<br />          )<br />   )<br />   (entmake (append (list '(0 . "LWPOLYLINE")<br />                          '(100 . "AcDbEntity")<br />                          '(100 . "AcDbPolyline")<br />                          (cons 90 (length ptlst))<br />                          '(70 . 1)<br />                    )<br />                    (mapcar '(lambda (pt) (cons 10 pt)) ptlst)<br />            )<br />   )<br />   (princ)<br /> )