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.   )
    
12. 
    
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. )

复制代码