lisp能否实现四叉树算法

admin

1. ;;参数 pt 位置点坐标
2. ;;     jd 查找半径
3. (defun gxl-sel-SSgetByPoint (pt jd / px py px0 px1 py0 py1 ss pz rtn e)
4.   (setq  px  (car pt)
5.   px0 (- px jd)
6.   px1 (+ px jd)
7.   py  (cadr pt)
8.   py0 (- py jd)
9.   py1 (+ py jd)
10.   pz 1e99
11.   )
13.   (setq  ss
14.    (ssget  "x"
15.     (list '(0 . "point")
16.           '(-4 . "<and")
17.           '(-4 . ">=,>=,<>")
18.           (list 10 px0 py0 pz)
19.           '(-4 . "<=,<=,<>")
20.           (list 10 px1 py1 pz)
21.           '(-4 . "and>")
22.     )
23.    )
24.   )
25.   (if ss
26.     (progn
27.       (repeat (setq n (sslength ss))
28.   (if (<= (distance (list (car pt) (cadr pt)) (cdr (assoc 10 (entget (setq e (ssname ss (setq n (1- n)))))))) jd)
29.     (setq rtn (cons e rtn))
30.     )
31.   )
32.       )
33.   )
34.   ;;颜色变红提示
35.   (foreach e rtn (entmod (append (entget e) '((62 . 1)))))
36.   ;;返回选中点图元名列表
37.   rtn
38. )
39. ;;测试
40. (defun c:tt (/ pt jd)
41.   (setq rtn (gxl-sel-SSgetByPoint (setq pt (getpoint "\n位置点:")) (setq jd (getdist pt "\n半径:"))))
42.   (command "circle" "采用non" pt jd)
43.   (princ (strcat "\n选中" (itoa (length rtn)) "个点."))
44.   (princ)
45.   )

复制代码

admin

1. (defun c:zdlj (/     a           b         dxf   dxf2  ents  ents2 es    jb
2.                jb2   jb-ks jb-pt jdcds l     old   old-cdr     p
3.                p2    ss
4.               )
5.         ;最短路径
6.   (vl-catch-all-apply 'load (list (findfile "zdlj.vlx")))
7.                                         ;声明引用zdlj.vlx这个模块
8.   (vl-catch-all-apply 'vl-doc-import (list "zdlj")) ;声明引用函数
9.   (SETQ JDCDS NIL)
10.   (SETQ ES NIL)
11.   (setq jb-pt nil)
12.   (SETQ SS (SSGET))
13.   (and ss(setq        ents (vl-remove-if
14.                (function listp)
15.                (mapcar (function cadr) (ssnamex SS))
16.              )
17.   ))
18.   (setq jb-ks nil)
19.   (while (setq a (car ents))
20.     (setq dxf nil)
21.     (setq jb nil)
22.     (setq p nil)
23.     (setq ents2 nil)
24.     (setq dxf (entget a))
25.     (setq jb (cdr (assoc 5 dxf)))
26.     (setq p (cdr (assoc 10 dxf)))
27.     (setq ents2 (cdr ents))
28.     (while (setq b (car ents2))
29.       (setq dxf2 nil)
30.       (setq jb2 nil)
31.       (setq p2 nil)
32.       (setq l nil)
33.       (setq old nil)
34.       (setq old-cdr nil)
35.       (setq dxf2 (entget B))
36.       (setq jb2 (cdr (assoc 5 dxf2)))
37.       (setq p2 (cdr (assoc 10 dxf2)))
38.       (SETQ L (DISTANCE P P2))
39.       (SETQ L (VL-PRINC-TO-STRING L))
40.       (setq old (assoc jb jb-ks));建立索引
41.       (setq old-cdr (cdr old))
42.       (setq old-cdr (cons (CONS (cons JB JB2) L) old-cdr))
43.       (setq jb-ks (vl-remove old jb-ks))
44.       (setq jb-ks (cons (cons jb old-cdr) jb-ks)) ;建立数据库索引
45.       (setq ents2 (cdr ents2))
46.     )
47.     (setq jb-pt (cons (cons jb p) jb-pt)) ;建立数据库索引
48.     (setq ents (cdr ents))
49.   )
50.   (setq
51.     jb-ks
52.      (mapcar
53.        (function
54.          (lambda (a)
55.            (cons
56.              (car a)
57.              (vl-sort (cdr a)
58.                       (function (lambda (x y) (< (cdr x) (cdr y))))
59.              )
60.            )
61.          )
62.        )
63.        jb-ks
64.      )
65.   )
66.   (setq jb-ks (reverse jb-ks))
67.   (mapcar (function (lambda (a / e1 e2 p1 p2)
68.                       (setq e1 (car a))
69.                       (setq e2 (cdr (car (car (cdr a)))))
70.                       (setq p1 (cdr (assoc e1 jb-pt))) ;启用索引
71.                       (setq p2 (cdr (assoc e2 jb-pt))) ;启用索引
72.                       (and p1
73.                            p2
74.                            (vla-addLine
75.                              (vla-Get-ModelSpace
76.                                (vla-get-ActiveDocument
77.                                  (vlax-get-acad-object)
78.                                )
79.                              )
80.                              (vlax-3D-Point p1)
81.                              (vlax-3D-Point p2)
82.                            )
83.                       )
84.                     )
85.           )
86.           jb-ks
87.   )
88. )

复制代码