[求助]：求点表中所有点是否共线

snsj

求点表中所有点是否共线大家有什么高招～

eachy

取两点然后判断其他点，用几何方法判断是否共线。算法我转贴过一个链接。

xyp1964

以角度判断：
[php]
(defun test (ptlst)
  (if (setq pt1 (car ptlst))
    (setq ptlst (vl-remove pt1 ptlst))
  )
  (if (setq pt2 (car ptlst))
    (setq ptlst        (vl-remove pt2 ptlst)
          ang        (abs (angle pt1 pt2))
    )
  )
  
  (princ "\n共线测试，进度")
  (while (setq pt3 (car ptlst))
    (setq ptlst        (vl-remove pt3 ptlst)
          ang1        (abs (angle pt1 pt3))
          da        (abs (- ang1 ang))
    )   
    (if        (or(< da 0.00000001)(>= da 3.14159))
      (princ ".")
      (progn
        (princ "\n找到不共线点，退出！")
        (setq ptlst nil)
      )
    )
   
  )
  (princ)
)[/php]

(setq ptlst '((88.9966 -90.0683) (170.899 -79.6394) (243.811
-70.3552) (348.686 -57.0012) (455.558 -43.3928) (800.145 0.484633) (777.172
-2.44053) (734.224 -7.90932) (658.975 -17.491) (634.005 -20.6705) (576.075
-28.047) (481.188 -40.1292) (336.362 -58.5704) (405.279 -49.7949) (558.096
-30.3363) (540.118 -32.6255) (501.164 -37.5856) (447.229 -44.4533) (409.274
-49.2862) (361.332 -55.3909) (329.37 -59.4607) (285.423 -65.0567) (212.51
-74.3409) (173.557 -79.301) (133.605 -84.3882) (90.656 -89.857) (44.711
-95.7073) (29.729 -97.615) (-55.1693 -108.425) (-73.1478 -110.715)))
命令: (test ptlst)
共线测试，进度....................

狂刀

da    (abs (- ang1 ang))
    )
    (if    (< da 0.00000001)

如果 ang1=0,ang=PI,那又如何？
比如 pt2 = (-1 0) pt1 =(0 0 ) pt3 =(1 0)
显然共线，但是 da=(abs (- 0 PI))=PI > 0.00000001

eachy

2. 
   
3. (defun ptonln (ptl / p)
   
4.   (setq p (car ptl))
   
5.   (apply 'equal
   
6.          (mapcar '(lambda (x)
   
7.                     (if        (>= (setq an (angle p x)) pi)
   
8.                       (- an pi)
   
9.                       an
   
10.                     )
    
11.                   )
    
12.                  (cdr ptl)
    
13.          )
    
14.   )
    
15. )

<br /> (defun ptonln (ptl / p)<br />   (setq p (car ptl))<br />   (apply 'equal<br />          (mapcar '(lambda (x)<br />                     (if        (>= (setq an (angle p x)) pi)<br />                       (- an pi)<br />                       an<br />                     )<br />                   )<br />                  (cdr ptl)<br />          )<br />   )<br /> )

xyp1964

最初由 eachy 发布
[B][code]
(defun ptonln (ptl / p)
  (setq p (car ptl))
  (apply 'equal
         (mapcar '(lambda (x)
                    (if        (>= (setq an (angle p x)) pi)
                      (- an pi)
                      an
                    )
                  )
                 (cdr ptl)
         ... [/B]

命令: !ptlst
((88.9966 -90.0683) (170.899 -79.6394) (243.811 -70.3552) (348.686 -57.0012)
(455.558 -43.3928) (800.145 0.484633) (777.172 -2.44053) (734.224 -7.90932)
(658.975 -17.491) (634.005 -20.6705) (576.075 -28.047) (481.188 -40.1292)
(336.362 -58.5704) (405.279 -49.7949) (558.096 -30.3363) (540.118 -32.6255)
(501.164 -37.5856) (447.229 -44.4533) (409.274 -49.2862) (361.332 -55.3909)
(329.37 -59.4607) (285.423 -65.0567) (212.51 -74.3409) (173.557 -79.301)
(133.605 -84.3882) (90.656 -89.857) (44.711 -95.7073) (29.729 -97.615)
(-55.1693 -108.425) (-73.1478 -110.715))

命令: (ptonln ptlst)
; 错误: 参数太多

狂刀

[php]
;;测试:
(tt (c:gpt))  ;;返回T为共线,返回nil不共线
;;判断点集是否共线.
;; 方法一(角度判断)
(defun tt (lst / k lst ang a b roop)
  (setq k T roop T)
  (if(and (car lst)
          (cadr lst)
          (setq ang (rem (angle(car lst)(cadr lst)) PI))
     )
    (while (and roop
                (setq lst (cdr lst)
                       a  (car lst)
                       b  (cadr lst))
                )
      (if (and (not(equal a b 1e-4))
               (not(equal ang (rem (angle a b) PI) 1e-4)))
        (setq roop nil k nil)
      )
    )
)
k
)
;;在屏幕取点返回点集.
(defun c:gpt ()
  (setq ptlst nil)
  (while (setq pt (getpoint "\n选点:"))
    (setq ptlst (cons pt ptlst))
  )
  ptlst
)
[/php]

snsj

利于余数，狂刀虽为陌生人，方法的确不错：）

snsj

[php](defun pd-gx (lst / pt1 pt2 x dst1 dst2 pd ang)
(setq ang(+(angle(car lst)(cadr lst))(/ pi 2)))
(setq pt2(polar(setq pt1(car lst))ang 1e+3)pd t)
(mapcar '(lambda(x)
(if(not(equal(distance x pt2)
   (sqrt(+(*(setq dst1(distance x pt1))dst1)
    (*(setq dst2(distance pt1 pt2))dst2)))1e-3))
     (setq pd nil)
      )
       )(vl-remove(car lst)lst)
        )pd
           )
[/php]
我的方法，勾股定理

狂刀

[php]
;;; 方法一(衍生1):
;; (tt2 (setq lst(c:gpt)))
(defun tt2 (lst / a)
  (setq lst (mapcar '(lambda (x) (rem x PI)) (mapcar 'angle (cdr lst) lst))
        a   (car lst))
  (apply 'and (mapcar '(lambda(x)(equal x a 1e-4)) lst))
)
[/php]

[php]
;;  方法二(距离判断):
;; (tt (setq lst(c:gpt)))
(defun tt (lst / k lst ang a b roop)
  (while
    (setq a   (car lst)
          b   (cadr lst)
          c   (caddr lst)
          lst (cdr lst)
          k   (if (and a b c (setq l1(distance a b) l2 (distance b c)l3(distance c a)))
                (equal (+ l1 l2 l3) (* 2 (max l1 l2 l3)) 1e-4)
                nil
              )
    )
  )
  (= 1 (length lst))
)
[/php]

winabcd

我一直用不好mapcar函数，哪位能解释一下下列函数的运行过程，先谢了！
(mapcar 'angle (cdr lst) lst)

LUCAS

2. 
   
3. ;|
   
4. ;;BY LUCAS
   
5. ;;把eachy的程序改了一下
   
6. ;;(PTONLN (POINT LIST) (精確度))
   
7. (setq PTL '((88.9966 -90.0683)
   
8.             (170.899 -79.6394)
   
9.             (243.811 -70.3552)
   
10.             (348.686 -57.0012)
    
11.             (455.558 -43.3928)
    
12.             (800.145 0.484633)
    
13.             (777.172 -2.44053)
    
14.             (734.224 -7.90932)
    
15.             (658.975 -17.491)
    
16.             (634.005 -20.6705)
    
17.             (576.075 -28.047)
    
18.             (481.188 -40.1292)
    
19.             (336.362 -58.5704)
    
20.             (405.279 -49.7949)
    
21.             (558.096 -30.3363)
    
22.             (540.118 -32.6255)
    
23.             (501.164 -37.5856)
    
24.             (447.229 -44.4533)
    
25.             (409.274 -49.2862)
    
26.             (361.332 -55.3909)
    
27.             (329.37 -59.4607)
    
28.             (285.423 -65.0567)
    
29.             (212.51 -74.3409)
    
30.             (173.557 -79.301)
    
31.             (133.605 -84.3882)
    
32.             (90.656 -89.857)
    
33.             (44.711 -95.7073)
    
34.             (29.729 -97.615)
    
35.             (-55.1693 -108.425)
    
36.             (-73.1478 -110.715)
    
37.            )
    
38. )
    
39. (PTONLN PTL 3)
    
40. |;
    
41. (defun PTONLN (PTL NOS / P)
    
42.   (setq P (car PTL))
    
43.   (apply '=
    
44.          (mapcar '(lambda (X)
    
45.                     (if        (>= (setq AN (angle P X)) pi)
    
46.                       (rtos (- AN pi) 2 NOS)
    
47.                       (rtos AN 2 NOS)
    
48.                     )
    
49.                   )
    
50.                  (cdr PTL)
    
51.          )
    
52.   )
    
53. )
    

<br /> ;|<br /> ;;BY LUCAS<br /> ;;把eachy的程序改了一下<br /> ;;(PTONLN (POINT LIST) (精確度)) <br /> (setq PTL '((88.9966 -90.0683)<br />             (170.899 -79.6394)<br />             (243.811 -70.3552)<br />             (348.686 -57.0012)<br />             (455.558 -43.3928)<br />             (800.145 0.484633)<br />             (777.172 -2.44053)<br />             (734.224 -7.90932)<br />             (658.975 -17.491)<br />             (634.005 -20.6705)<br />             (576.075 -28.047)<br />             (481.188 -40.1292)<br />             (336.362 -58.5704)<br />             (405.279 -49.7949)<br />             (558.096 -30.3363)<br />             (540.118 -32.6255)<br />             (501.164 -37.5856)<br />             (447.229 -44.4533)<br />             (409.274 -49.2862)<br />             (361.332 -55.3909)<br />             (329.37 -59.4607)<br />             (285.423 -65.0567)<br />             (212.51 -74.3409)<br />             (173.557 -79.301)<br />             (133.605 -84.3882)<br />             (90.656 -89.857)<br />             (44.711 -95.7073)<br />             (29.729 -97.615)<br />             (-55.1693 -108.425)<br />             (-73.1478 -110.715)<br />            )<br /> )<br /> (PTONLN PTL 3)<br /> |;<br /> (defun PTONLN (PTL NOS / P)<br />   (setq P (car PTL))<br />   (apply '=<br />          (mapcar '(lambda (X)<br />                     (if        (>= (setq AN (angle P X)) pi)<br />                       (rtos (- AN pi) 2 NOS)<br />                       (rtos AN 2 NOS)<br />                     )<br />                   )<br />                  (cdr PTL)<br />          )<br />   )<br /> )<br />

狂刀

再精简
[php]
;;(setq nos 3 ptl (c:gpt) )
;; 限制: 不适合于有多点和第一点重合的情况.
(defun tt3 (PTL NOS / P)
  (setq P (car PTL))
  (apply '=
         (mapcar '(lambda (X)
                      (rtos (rem (angle P X) pi) 2 NOS)
                  )
                 (cdr PTL)
         )
  )
)
[/php]

lijiao

除狂刀的方法2外，其它的都用到了ANGLE函数，ANGLE函数只能计算2D点的角度，如果点列表中加杂着3D点，判断肯定会失误。
我的想法是将点表向两个相互垂直的面进行投影，得到两组2D点表，然后用它们生成两条2D多义线，如果这两条多义线的面积属性为0，这样才能认为所给的点表中所有点共线。
具体代码如下：

2. 
   
3.   [FONT=courier new]
   
4. (defun pt_on_line_P (pt_list jd / OSMODE OUT1 OUT2 PL_OBJ)
   
5.   (setq osmode (getvar "osmode"))
   
6.   (setq cmdecho (getvar "cmdecho"))
   
7.   (setvar "cmdecho" 0)
   
8.   (setvar "osmode" 0)
   
9.   (setq pt_list (gf_pt_list pt_list))
   
10.   (command "pline")
    
11.   (foreach pt (mapcar '(lambda (x)
    
12.                          (list (car x) (cadr x))
    
13.                        )
    
14.                       pt_list
    
15.               )
    
16.     (command pt)
    
17.   )
    
18.   (command "")
    
19.   (setq pl_obj (vlax-ename->vla-object (entlast)))
    
20.   (setq out1 (equal (vla-get-area pl_obj) 0 jd))
    
21.   (vla-delete pl_obj)
    
22.   (command "pline")
    
23.   (foreach pt (mapcar '(lambda (x)
    
24.                          (list (car x) (caddr x))
    
25.                        )
    
26.                       pt_list
    
27.               )
    
28.     (command pt)
    
29.   )
    
30.   (command "")
    
31.   (setq pl_obj (vlax-ename->vla-object (entlast)))
    
32.   (setq out2 (equal (vla-get-area pl_obj) 0 jd))
    
33.   (vla-delete pl_obj)
    
34.   (setvar "osmode" osmode)
    
35.   (setvar "cmdecho" cmdecho)
    
36.   (and out1 out2)
    
37. )
    
38. (defun gf_pt_list (pt_list / I OUT OUT1)
    
39.   (setq out '())
    
40.   (foreach pt pt_list
    
41.     (setq out1 '()
    
42.           i    0
    
43.     )
    
44.     (repeat 3
    
45.       (if (nth i pt)
    
46.         (setq out1 (cons (nth i pt) out1))
    
47.         (setq out1 (cons 0 out1))
    
48.       )
    
49.       (setq i (1+ i))
    
50.     )
    
51.     (setq out (cons (reverse out1) out))
    
52.   )
    
53.   (reverse out)
    
54. )
    
55.   [/FONT]
    

<br />   [FONT=courier new]<br /> (defun pt_on_line_P (pt_list jd / OSMODE OUT1 OUT2 PL_OBJ)<br />   (setq osmode (getvar "osmode"))<br />   (setq cmdecho (getvar "cmdecho"))<br />   (setvar "cmdecho" 0)<br />   (setvar "osmode" 0)<br />   (setq pt_list (gf_pt_list pt_list))<br />   (command "pline")<br />   (foreach pt (mapcar '(lambda (x)<br />                          (list (car x) (cadr x))<br />                        )<br />                       pt_list<br />               )<br />     (command pt)<br />   )<br />   (command "")<br />   (setq pl_obj (vlax-ename->vla-object (entlast)))<br />   (setq out1 (equal (vla-get-area pl_obj) 0 jd))<br />   (vla-delete pl_obj)<br />   (command "pline")<br />   (foreach pt (mapcar '(lambda (x)<br />                          (list (car x) (caddr x))<br />                        )<br />                       pt_list<br />               )<br />     (command pt)<br />   )<br />   (command "")<br />   (setq pl_obj (vlax-ename->vla-object (entlast)))<br />   (setq out2 (equal (vla-get-area pl_obj) 0 jd))<br />   (vla-delete pl_obj)<br />   (setvar "osmode" osmode)<br />   (setvar "cmdecho" cmdecho)<br />   (and out1 out2)<br /> )<br /> (defun gf_pt_list (pt_list / I OUT OUT1)<br />   (setq out '())<br />   (foreach pt pt_list<br />     (setq out1 '()<br />           i    0<br />     )<br />     (repeat 3<br />       (if (nth i pt)<br />         (setq out1 (cons (nth i pt) out1))<br />         (setq out1 (cons 0 out1))<br />       )<br />       (setq i (1+ i))<br />     )<br />     (setq out (cons (reverse out1) out))<br />   )<br />   (reverse out)<br /> )<br />   [/FONT]<br />

狂刀

多义线求面积方法我也想过,但是一来写起来麻烦一些.二来还要进行自相交的判断.(班竹的程序没有自相交判断,理论上是有bug的)
否则如图自相交3d多义线,红线各点求出的任意两个面上多义线面积衡为0.但是他们实际上却不是在一条线上的
另外,我认为除了求距离比较可靠的还有ucs方法.

[php]
;;; 判断点集是否共线. ------by 狂刀.2005.5  适合于3d情况.点重合情况.
;;  方法三(ucs方法):
;;  共点返回nil,但有文字提示.
;;  nos = 精度. 为数值.
;; (tt  (setq lst(c:gpt)) (setq nos 4))
(defun tt (lst nos / lst2 a b k)
  (setq lst2 (mapcar '(lambda(x)(trans x 1 0)) lst))
  (while(and   (setq a (car lst2))
               (setq b (cadr lst2))
               (setq lst2 (cdr lst2))
               (equal a b 1e-4))
  )
  (if (and a b)
    (progn
      (command ".ucs" "n" "3" a b "")
      (setq k (and(apply '= (mapcar '(lambda(x)(rtos x nos))(print(mapcar 'cadr (mapcar '(lambda(x)(trans x 0 1)) lst2)))))
                  (apply '= (mapcar '(lambda(x)(rtos x nos))(print(mapcar 'caddr (mapcar '(lambda(x)(trans x 0 1)) lst2)))))
              )
      )
      (command ".ucs" "p")
    )
    (print "\n 共点!")
  )k
)
[/php]