画衣柜的程序

  
(vl-load-com)
(prompt "命令是YG")
;;;画衣柜的LISP程序-----------------------------------------------------
;;;Copyright Highflybird------------------------------------------------
;;;2011.04.30 ----------------------------------------------------------
(defun c:YG(/ lst doc size pIn str pnt pts scr dlt dist1 dist2 Vec dist 
              lst1 lst2 lst3 cur1 cur2 Cur3 obj1 obj2 Obj3 Objs sLen ang1 ang2 ang par
           )
  (if (< (setq size (getvar "USERR5")) 100.)                            ;初始化衣柜深
    (progn 
      (setvar "USERR5" 600.)                                            
      (setq size 600.)
    )
  )

  ;;获取布置一侧，或设置衣柜深
  (setq str "\n点取布置的一侧[设置(Set)] <走向右侧>:")                  ;获取布置方向
  (initget 8 "Set")
  (setq pIn (getpoint str))
  (while (= pIn "Set")
    (setq size (getvar "USERR5"))
    (initget 14)
    (setq size (getdist (strcat "\n输入衣柜深<" (rtos size) ">:")))     ;如果需要设置衣柜深
    (if (>= size 100)
      (setvar "USERR5" size)
      (setq size (getvar "USERR5"))
    )
    (initget 8 "Set")
    (setq pIn (getpoint str))
  )

  ;;获取靠墙边
  (initget 9)                                                           ;防止空输入，点可在画面外
  (setq pnt (getpoint "\n起点:"))
  (setq pts (cons pnt nil))
  (setq str "\n选取点<回车,空格或右键结束点取>:")
  (while (setq pnt (getpoint (car pts) str))                            ;通过点取方式获得靠墙边
    (setq pnt (list (car pnt) (cadr pnt)))                              ;这步不可少，防止不在同个平面上
    (grdraw pnt (car pts) 3 1)                                          ;虚线显示布置靠墙边
    (setq pts (cons pnt pts))                                   
  )

  ;;输入完成开始画图
  (if (> (length  pts) 1)                                               ;至少要两点
    (progn
      (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
      (vla-StartUndoMark doc)                                           ;设置Undo起始点
      (setq scr (GetRandFunction))
      ;;一些初始化工作--------------------------------------------------
      (setq pts (reverse pts))                                          ;点集反转
      (setq pts (mapcar (function (lambda (x) (trans x 1 0))) pts))     ;把点集转化到世界坐标系
      (if pIn
        (setq pIn (trans pIn 1 0)
              dlt (det (car pts) (cadr pts) pIn)                        ;右手法则
        )
      )                                                 
      (if (> dlt 0)                                                     ;通过右手法则判断偏移方向
        (setq dist1 (* size 0.5)
              dist2 size
        )
        (setq dist1 (* size -0.5)
              dist2 (- size)
        )
      )

      ;;首先构建衣柜的外轮廓和中心线------------------------------------
      (setq lst1 (OffsetPts pts dist1 nil))                             ;衣柜的中心线点
      (setq lst2 (OffsetPts pts dist2 nil))
      (setq lst2 (append pts (reverse lst2)))                           ;衣柜的外轮廓点
      
      (setq Cur1 (make-Poly lst1 nil))                                  ;画衣柜的中心线
      (setq Cur2 (make-Poly lst2 T))                                    ;画衣柜的中心线
      (setq Obj1 (vlax-ename->vla-object Cur1))
      (setq Obj2 (vlax-ename->vla-object Cur2))

      (setq lst3 (OffsetPts lst2 (* (sign dist1) 50) T))
      (setq Cur3 (make-Poly lst3 T))
      (setq obj3 (vlax-ename->vla-object Cur3))

      (setq lst  (list obj1 obj2 obj3))

      (setq Objs (Make-clothes-hanger))                                 ;画衣架
      (setq dist 0.0)
      (setq sLen (vla-get-length Obj1))                                 ;中心线长度
      (setq ang1 (/ pi 0.1 180))                                        ;摆动幅度在10度左右
      (setq ang2 (- ang1))
      (while (< dist sLen)
        (setq pnt (vlax-curve-getPointAtDist Obj1 dist))                ;衣架的定位点
        (setq par (vlax-curve-getParamAtDist Obj1 dist))
        (setq Vec (vlax-curve-getFirstDeriv Obj1 par))                  ;衣架的水平方向
        (setq ang (angle '(0 0 0) Vec))
        (setq ang (+ ang (Rand scr ang1 ang2)))                         ;衣架的旋转角度
        (setq pIn (vlax-curve-getPointAtParam obj1 (fix (+ 0.5 par))))  ;转点
        (if (>= (distance pnt pIn) 300)                                 ;如果与转点距离大于300
          (Copy-and-tranformby Objs pnt ang)                            ;拷贝原点处衣架并变换
        )        
        (setq dist (+ dist (Rand scr 80 300)))                          ;步进到下一点(100,300)这两个数值可自调
      )
      (mapcar 'vla-erase Objs)                                          ;把原点处衣架删除
      (makeGroup Doc Lst)
      (vlax-release-object scr)                                         ;释放脚本实例
      (vla-EndUndoMark doc)                                             ;设置Undo终止点
      (vlax-release-object doc)
    )
  )
  (redraw)                                                              ;重画一下，消除Grdraw的痕迹
  (princ)                                                               ;静默退出
)|;
(defun sign (x)
  (if (< x 0) -1 1)
)
;;;出错处理
(defun *error_msg* (msg)
  (redraw)
  (princ msg)
)

;;;画线段
(defun Make-Line (p q)
  (entmakeX (list (cons 0 "LINE") (cons 10 p) (cons 11 q)))
)

;;;绘制多段线
(defun Make-Poly (pp isClosed / C)
  (if isClosed
    (setq C 1)
    (setq C 0)
  )
  (entmakeX                                                             ;画凸包
    (append
      (list
        (cons 0 "LWPOLYLINE")
        (cons 100 "AcDbEntity")
        (cons 100 "AcDbPolyline")
        (cons 90 (length pp))                                           ;顶点个数
        (cons 70 C)                                                     ;闭合的
      )
      (mapcar (function (lambda (x) (cons 10 x))) pp)                   ;多段线顶点
    )
  )
)

;;;画衣架
(defun Make-clothes-hanger (/)
  (mapcar
    (function (lambda (p q /) (VLAX-ENAME->VLA-OBJECT (make-line p q))))
    '((-17.5 -225.) (+17.5 -225.) (-35.0 -210.) (-35.0 +210.))
    '((-17.5 +225.) (+17.5 +225.) (+35.0 -210.) (+35.0 +210.))
  )
)

;;;拷贝原点处的物体并变换
(defun Copy-and-tranformby (Objs pnt Ang / newObj)
  (foreach obj Objs
    (setq NewObj (vla-copy obj))
    (vla-move NewObj (vlax-3d-point '(0 0 0)) (vlax-3d-point pnt))
    (vla-rotate NewObj (vlax-3d-point pnt) Ang)
    (setq lst (cons NewObj lst))
  )
)

;;;最后做成组
(defun MakeGroup (Doc objLst / Groups sGroup oGroup aBound eArray)
  (setq Groups (vla-get-groups doc))
  (setq sGroup (getvar "cdate"))
  (setq sGroup (rtos (* 1e9 (- sGroup (fix sGroup))) 2 0))
  (setq oGroup (vla-add Groups (strcat "YG" sGroup)))
  (setq aBound (cons 0  (1- (length objLst))))
  (setq eArray (vlax-make-safearray vlax-vbObject aBound))
  (vlax-safearray-fill eArray objLst)
  (vla-AppendItems oGroup eArray)
)

;;;偏移点集(没用vla-offset)
;;;此函数可以扩展，为以后的编程准备
(defun OffsetPts (pts d isClosed / AN1 AN2 CNT HPI LST PN1 PN2 PN3 PN4 PNT PPP PT1 PT2 PT3 P12)
  (setq ppp pts)
  (setq cnt (length ppp))
  (cond
    ( (>= cnt 2)
      (setq hPi (/ Pi 2))
     
      (setq pt1 (car ppp))
      (setq pt2 (cadr ppp))
     
      (setq an1 (angle pt1 pt2))
      (setq pn1 (polar pt1 (+ an1 hPi) d))
      (setq pn2 (polar pt2 (+ an1 hPi) d))
     
      (setq pn4 pn2)

      (setq lst (list pn1))
      (if isClosed
        (setq ppp (append pts (list (car pts)))
              p12 (list pn1 pn2)
        )
      )
      (while (caddr ppp)
        (setq pt1 (car ppp))
        (setq pt2 (cadr ppp))
        (setq pt3 (caddr ppp))
    
        (setq an1 (angle pt1 pt2))
        (setq pn1 (polar pt1 (+ an1 hPi) d))
        (setq pn2 (polar pt2 (+ an1 hPi) d))

        (setq an2 (angle pt2 pt3))
        (setq pn3 (polar pt2 (+ an2 hPi) d))
        (setq pn4 (polar pt3 (+ an2 hPi) d))

        (setq pnt (inters pn1 pn2 pn3 pn4 nil))
        (and  pnt (setq lst (cons pnt lst)))
        (setq ppp (cdr ppp))
      )
      (if isClosed
        (setq lst (cdr (reverse lst))
              pnt (inters pn3 pn4 (car p12) (cadr p12) nil)
              lst (cons pnt lst)
        )
        (setq lst (cons pn4 lst)
              lst (reverse lst)
        )
      )
      (vl-remove nil lst)
    )  
  )
)
;;;===============
;;;行列式,判别法则
;;;===============
(defun det (p1 p2 p3 / x1 y1)
  (setq x1 (car p1)
        y1 (cadr p1)
  )
  (- (* (- (car p2) x1) (- (cadr p3) y1))
     (* (- (car p3) x1) (- (cadr p2) y1))
  )
)

;;;---------------------------------------------------------------------
;;;Definine Rand()  --which one is better? I don't know.                
;;;---------------------------------------------------------------------
(defun GetRandFunction(/ scr str) 
  (setq scr (vlax-create-object "ScriptControl"))                       ;Create a script
  (if scr
    (progn
      (vlax-put scr 'Language "VBS")
      (setq str "Randomize\n
                Function Rand(x,y)\n
                Rand=x+Rnd*(y-x)\n
                End Function"
      )                                                                 ;for randomize some features
      (vlax-invoke Scr 'ExecuteStatement str)                           ;Execute script
      (defun Rand (scr nMin nMax)                                       ;Rand function
        (vlax-invoke scr 'run "Rand" nMin nMax)
      )
    )
    ;;;rand function-some code from Le,--thanks.
    (defun Rand (Option nMin nMax / seed)
      (setq seed (getvar "USERR4"))
      (if (= seed 0.)
        (setq seed (getvar "TDUSRTIMER")
              seed (- seed (fix seed))
              seed (rem (* seed 86400) 1)
        )
      )
      (setq seed (rem (+ (* seed 15625.7) 0.21137152) 1))
      (setvar "USERR4" seed)
      (+ nMin (* seed (- nMax nMin)))
    )
  )
  scr
)

点集的最小包围圆(用LISP求解)

这里是一个经典的几何算法题目，在CAD环境下用LISP编写。

;;;******************************************************
;;; A routine for finding a smallest enclosing circle for
;;; a set of points (SEC problem)                        
;;; command: test                                        
;;; usage:  select some points ,then you will get the SEC
;;;******************************************************
(defun C:test (/ ss pts t0 x cen rad ptmax)
  ;; select the points
  (setq ss (ssget '((0 . "POINT"))))
  (setq pts (ssgetpoint ss))
  ;; get started
  (setq t0 (getvar "TDUSRTIMER"))
  (setq x (mincir pts))
  (princ "\nIt takes")
  (princ (* (- (getvar "TDUSRTIMER") t0) 86400)) 
  (princ "seconds")
  (if (null x)
    (alert "Invalid input!")
    (progn
      (setq cen   (car x)
            rad   (cadr x)
            ptmax (caddr x)
      )
      ;;draw the smallest circle and the radiu.
      (make-circle cen rad)
      (make-line cen ptmax)
    )
  )
  (princ)
)
;;;*****************************************************
;;;Function : find the SEC with a set of points         
;;;Arguments: pts ,the set of points                    
;;;Return: the center and radius of the SEC             
;;;*****************************************************
(defun mincir (pts / CEN CEN_R P1 P2 P3 PTMAX R rad X i)
  (cond
    ;;where it works
    ( (setq p3 (caddr pts))
      (setq p2 (cadr pts))
      (setq p1 (car pts))   
      (setq cen_r (3pc p1 p2 p3))
      (setq ptmax (maxd-cir pts (car cen_r)))
      (setq i 0)
      (while (null (in1 ptmax (car cen_r) (cadr cen_r)))
        (setq cen_r (4pc p1 p2 p3 ptmax))
        (setq p1 (car (caddr cen_r))
              p2 (cadr (caddr cen_r))
              p3 (caddr (caddr cen_r))
        )
        (setq ptmax (maxd-cir pts (car cen_r)))
        (setq i (1+ i))
      )
      (list (car cen_r) (cadr cen_r) ptmax)
    )
    ( (cdr pts) 
      (alert "Two points,radius is the half distance of these points.")
      (setq cen (mid (car pts) (cadr pts))
            rad (/ (distance (car pts) (cadr pts)) 2)
      )
      (list cen rad (car pts))
    )
    ( (car pts) 
      (alert "One point,radius is zero.")
      (list (car pts) 0 (car pts))
    )
  )
)

;;; the midpoint of two points
(defun mid (p1 p2)
  (list
    (* (+ (car p1) (car p2)) 0.5)
    (* (+ (cadr p1) (cadr p2)) 0.5)
  )
)

;;; whether a point is inside a circle or not
(defun in1 (pt cen r)
  (< (- (distance pt cen) r) 1e-8)
)

;;; whether some points is is inside a circle or not
(defun in2 (ptl cen r / pt)
  (while (and (setq pt (car ptl)) (in1 pt cen r))
    (setq ptl (cdr ptl))
  )
  (null pt)
)

;;判断点集是否在圆内----------------------
;;;改为递归写法
(defun in3 (ptl cen r)
  (cond
    ( (null (cadr ptl))
      (in1 (car ptl) cen r)
    )
    ( (in1 (car ptl) cen r)
      (in3 (cdr ptl) cen r)
    )
  )
)

;;; Function: get the SEC with 3 points
;;; Arguments: pa pb pc ,the 3 points
;;; Return: the SEC for 3 points.
(defun 3pc (pa pb pc / D MIDPT)
  (cond
    ( (in1 pc (setq midpt (mid pa pb)) (setq d (/ (distance pa pb) 2)))
      (list midpt d (list pa pb pc))
    )
    ( (in1 pa (setq midpt (mid pb pc)) (setq d (/ (distance pb pc) 2)))
      (list midpt d (list pb pc pa))
    )
    ( (in1 pb (setq midpt (mid pc pa)) (setq d (/ (distance pc pa) 2)))
      (list midpt d (list pc pa pb))
    )
    (t
      (3pcircle pa pb pc)
    )
  )
)

;;; Function: Get the circle of a triangle
;;; Arguments: three points of this triangle
;;; Return: the center and radius
(defun 3PCirCle(P0 P1 P2 / X0 Y0 X1 Y1 X2 Y2 DX1 DY1 DX2 DY2 D 2D C1 C2 CE)
  (setq X0  (car P0)
        Y0  (cadr P0)
        X1  (car P1)
        Y1  (cadr P1)
        X2  (car P2)
        Y2  (cadr P2)
        DX1 (- X1 X0)
        DY1 (- Y1 Y0)
        DX2 (- X2 X0)
        DY2 (- Y2 Y0)
  )
  (setq D (- (* DX1 DY2) (* DX2 DY1)))
  (if (/= D 0.0)
    (progn
      (setq 2D (+ D D)
            C1 (+ (* DX1 (+ X0 X1)) (* DY1 (+ Y0 Y1)))
            C2 (+ (* DX2 (+ X0 X2)) (* DY2 (+ Y0 Y2)))
            CE (List (/ (- (* C1 DY2) (* C2 DY1)) 2D)
                     (/ (- (* C2 DX1) (* C1 DX2)) 2D)
               )
      )
      (list CE (distance CE P0) (list p0 p1 p2))
    )
  )
)

;;; Function: get the SEC with 4 points
;;; Arguments: pa pb pc ptmax,the 4 points
;;; Return: the SEC for 4 points.
(defun 4pc (p1 p2 p3 ptmax / pts mind minr r 4ps)
  (setq pts (list (3pc p1 p2 ptmax)
                  (3pc p1 p3 ptmax)
                  (3pc p2 p3 ptmax)
            )
  )
  (setq 4ps (list p1 p2 p3 ptmax))
  (setq minr 1e308)
  (foreach n pts
    (setq r (cadr n))
    (if (and (< r minr) (in2 4ps (car n) r))
      (setq mind n
            minr r
      )
    )
  )
  mind
)

;;; Function: Get the farthest point from a center.
;;; Arguments: ptl,the points
;;;            cen,the center
;;; Return: the farthest point
(defun maxd-cir (ptl cen / pmax dmax d)
  (setq dmax 0.0)
  (foreach pt ptl
    (if (> (setq d (distance pt cen)) dmax)
      (setq dmax d
            pmax pt
      )
    )
  )
  pmax
)

;;; draw a circle
(defun make-circle (cen rad)
  (entmake
    (list
      '(0 . "circle")
      (cons 10 cen)
      (cons 40 rad)
      (cons 62 1)
    )
  )
)
;;; draw a line
(defun make-line (p q)
  (entmake
    (list
      '(0 . "LINE")
      (cons 10 p)
      (cons 11 q)
    )
  )
)

;;; Gather the coordinates of these points
(defun ssgetpoint (ss / i l a b c)
  (setq i 0)
  (if ss
    (repeat (sslength ss)
      (setq a (ssname ss i))
      (setq b (entget a))
      (setq c (cdr (assoc 10 b)))
      (setq l (cons c l))
      (setq i (1+ i))
    )
  )
  (reverse l)
)

高仿ALIGN命令

下面是一个LISP程序 ，可以仿align命令。 大家可以对此更改，以适合自己。

;;;-----------------------------------------------------------;;
;;; To simulate the command: "align"                          ;;
;;; Command:Align3d                                           ;;
;;; Use in some cases: command can't be applied or you don't  ;;
;;; want to use them; or improve the efficiency,etc.and here  ;;
;;; are some useful functions,e.g. "Mat:Get3PMatrix";Or even  ;;
;;; you can customize "align" command.                        ;;
;;; Author: Highflybird, Date:2012-8-6.                       ;;
;;; All copyrights reserved.                                  ;;
;;;-----------------------------------------------------------;;
(defun C:Align3d (/ sel sP1 sP2 sP3 dP1 dP2 dP3 sclp scl
                    mat0 mat1 mat2 mat i ent obj app doc)
  ;;input
  (setq sel (ssget))
  (initget 9)
  (setq sP1 (getpoint "\nSpecify first source point:"))
  (initget 9)
  (setq dP1 (getpoint "\nSpecify first destination point:"))
  (initget 9)
  (setq sP2 (getpoint "\nSpecify second source point:"))
  (initget 9)
  (setq dP2 (getpoint "\nSpecify second destination point:"))
  (initget 8)
  (setq sP3 (getpoint "\nSpecify third source point or <continue>:"))
  (initget 9)
  (if (null sP3)
    (setq sP3 (Mat:Rotate90 sP2 sP1)
          dP3 (Mat:Rotate90 dP2 dP1)
    )   
    (setq dP3 (getpoint "\nSpecify third destination point:"))
  )
  (foreach x '(sP1 sP2 sP3 dP1 dP2 dP3)
    (set x (trans (eval x) 1 0))
  )
  (initget "Yes No")
  (setq sclp (getkword "\nScale objects based on alignment points? [Yes/No] <N>:"))

  ;;Get the transformation matrix
  (setq mat1 (Mat:Get3PMatrix sP1 sP2 sP3))
  (setq mat2 (Mat:Get3PMatrix dP1 dP2 dP3))
  (if (= "Yes" sclp) 
    (setq scl (/ (distance dP1 dP2) (distance sP2 sP1))
          mat0 (list (list scl 0 0 0)(list 0 scl 0 0) (list 0 0 scl 0) '(0 0 0 1))
          mat (Mat:mxm (cadr mat2) (Mat:mxm mat0 (car mat1)))
    )   
    (setq mat (Mat:mxm (cadr mat2) (car mat1)))
  )

  ;;Apply the transformation.
  (setq app (vlax-get-acad-object))
  (setq doc (vla-get-ActiveDocument app))
  (vla-StartUndoMark doc)
  (setq i 0)
  (if sel 
    (repeat (sslength sel)
      (setq ent (ssname sel i))
      (setq obj (vlax-ename->vla-object ent))
      (vla-transformby obj (vlax-tmatrix mat))
      (setq i (1+ i))
    )
  )
  (vla-EndUndoMark doc)
  (vlax-release-object doc)
  (vlax-release-object app)
  (princ)
)

;;;-----------------------------------------------------------;;
;;; Vector Norm - Lee Mac                                     ;;
;;; Args: v - vector in R^n                                   ;;
;;;-----------------------------------------------------------;;
(defun Mat:norm ( v )
  (sqrt (apply '+ (mapcar '* v v)))
)

;;;-----------------------------------------------------------;;
;;; Vector x Scalar - Lee Mac                                 ;;
;;; Args: v - vector in R^n, s - real scalar                  ;;
;;;-----------------------------------------------------------;;
(defun Mat:vxs ( v s )
  (mapcar (function (lambda ( n ) (* n s))) v)
)

;;;-----------------------------------------------------------;;
;;; Unit Vector - Lee Mac                                     ;;
;;; Args: v - vector in R^n                                   ;;
;;;-----------------------------------------------------------;;
(defun Mat:unit ( v )
  ( (lambda ( n )
      (if (equal 0.0 n 1e-14)
        nil
        (Mat:vxs v (/ 1.0 n))
      )
    )
    (Mat:norm v)
  )
)

;;;-----------------------------------------------------------;;
;;; Mat:v*v Returns the dot product of 2 vectors              ;;
;;;-----------------------------------------------------------;;
(defun Mat:v*v (v1 v2)
  (apply '+ (mapcar '* v1 v2))
)

;;;-----------------------------------------------------------;;
;;; Vector Cross Product - Lee Mac                            ;;
;;; Args: u,v - vectors in R^3                                ;;
;;;-----------------------------------------------------------;;
(defun Mat:v^v ( u v )
  (list
    (- (* (cadr u) (caddr v)) (* (cadr v) (caddr u)))
    (- (* (car  v) (caddr u)) (* (car  u) (caddr v)))
    (- (* (car  u) (cadr  v)) (* (car  v) (cadr  u)))
  )
)

;;;-----------------------------------------------------------;;
;;; Mat:trp Transpose a matrix -Doug Wilson-                  ;;
;;;-----------------------------------------------------------;;
(defun Mat:trp (m)
  (apply 'mapcar (cons 'list m))
)

;;;-----------------------------------------------------------;;
;;; Matrix x Vector - Vladimir Nesterovsky                    ;;
;;; Args: m - nxn matrix, v - vector in R^n                   ;;
;;;-----------------------------------------------------------;;
(defun Mat:mxv (m v)
  (mapcar (function (lambda (r) (apply '+ (mapcar '* r v)))) m)
)

;;;-----------------------------------------------------------;;
;;; Mat:mxm Multiply two matrices -Vladimir Nesterovsky-      ;;
;;;-----------------------------------------------------------;;
(defun Mat:mxm (m q)
  (mapcar (function (lambda (r) (Mat:mxv (Mat:trp q) r))) m)
)

;;;-----------------------------------------------------------;;
;;; Mat:Rotate90 Rotate a point 90 degree by a basepoint      ;;
;;;-----------------------------------------------------------;;
(defun Mat:Rotate90 (Pt BasePt / a)
  (setq a (+ (/ pi 2) (angle BasePt Pt)))
  (polar BasePt a (distance pt basePt))
)

;;;-----------------------------------------------------------;;
;;; Mat:Get3PMatrix  -Highflybird-                            ;;
;;;-----------------------------------------------------------;;
(defun Mat:Get3PMatrix (p1 p2 p3 / v1 v2 v3 mat org)
  (defun AppendMatrix (mat org)
    (append
      (mapcar 'append mat (mapcar 'list org))
      '((0. 0. 0. 1.))
    )
  )
            
  (setq v1 (Mat:unit (mapcar '- p2 p1)))
  (setq v2 (Mat:unit (mapcar '- p3 p1)))
  (setq v3 (Mat:unit (Mat:v^v v1 v2)))
  (setq v2 (Mat:unit (Mat:v^v v3 v1)))
  (setq mat (list v1 v2 v3))
  (setq org (mapcar '- (Mat:mxv mat p1)))
  (list
    (AppendMatrix mat org)              ;this->wcs transformation matrix
    (AppendMatrix (Mat:trp mat) p1)     ;wcs->this transformation matrix
  )
)

(prompt "Command is: Align3d")
(princ)

二叉树

用Lisp构建二叉树： 呵呵，权当玩玩。

;;;=============================================================
;;;用AutoLISP构建一个二叉树(Construct a Binary Search tree)     
;;;从中间分开，直到分得只是剩下两个元素或者一个                 
;;;此结构用于查找一个元素，使得单次查找的时间为O(n) = log(n)    
;;;Author:Highflybird              in Shenzhen,China,2012-06-15 
;;;=============================================================
(defun BTree (lst / L R)
  (cond                                                         
    ( (cddr lst)                                                ;the length of list > 2
      (setq R lst)
      (repeat (/ (length lst) 2)                                ;Split it
        (setq L (cons (car R) L))                               ;Left part of list
        (setq R (cdr R))                                        ;Right part of list
      )
      (cons (car R)                                             ;middle number as the first.
            (cons (BTree (reverse L))                           ;recurse Left part
                  (BTree (cdr R))                               ;recurse Right part
            )
      )
    )
    ( (cdr lst)                                                 ;just two elements
      (cons (cadr lst) (car lst))                               ;the right node is empty.
    )
    ( lst
      (car lst)                                                 ;if just one,the node is an element.
    )
  )
)


;;;=============================================================
;;;用AutoLISP从二叉树中查找一个元素(Search a key in binary tree)
;;;每次查找总是从中间开始，如果不是，大于中间的就查找右边，小于 
;;;中间则查找左边，直到原子或者点对表。                         
;;;因为树的最大深度不超过log(n)，故单次查找的时间为O(n)<=log(n) 
;;;Author:Highflybird              in Shenzhen,China,2012-06-15 
;;;=============================================================
(defun BFind (key Tree n / L R i)
  (if (atom Tree)                                               ;if it's an atom,
    (if (= key Tree) 0)                                         ;set the index as 0
    (if (= (setq L (car Tree)) key)                             ;if left node = key
      (/ n 2)                                                   ;the index is the middle number.
      (if (atom (setq R (cdr Tree)))                            ;if the right node is an atom
        (if (= R key) 0)                                        ;and right node = key, set the index as 0
        (if (> L key)                                           ;if left node > key
          (BFind key (car R) (/ n 2))                           ;recurse Left
          (if (setq i (BFind key (cdr R) (/ (1- n) 2)))         ;otherwise recurse right
            (1+ (+ (/ n 2) i))                                  ;must add the index
          )
        )
      )
    )
  )
)


;;;=============================================================
;;;以下用于测试，用了几种办法对一个有序的数组查找(For test)     
;;;数组为等差数列，从2.5开始，差为1, 例如:(2.5 3.5 4.5 5.5 ....)
;;;查找方法:包括二叉树,折半查找,vl-position,member,assoc,直接查.
;;;如果此程序用优化编译，则是更能提高二叉树的查找和构建速度     
;;;=============================================================
(defun c:test (/ e j k n lst lst1 Tree v x)
  (defun Print-Beginning ()
    (princ "\nStatement                         Times    Elapse(ms)    Average(ms/time)")
    (princ "\n-------------------------------------------------------------------------")
    (princ)
  )
  (defun Print-Result (lst)
    (defun Princ-Column (str value / s)
      (setq s (vl-princ-to-string value))
      (princ s)
      (repeat (- (strlen str) (strlen s))
        (princ " ")
      )
    )
    (princ "\n")
    (princ-Column "Statement                         " (car lst)) 
    (princ-Column "Times    " (cadr lst)) 
    (princ-Column "Elapse(ms)    " (caddr lst))
    (princ-Column "Average(ms/time)" (cadddr lst))
  )
  
  (initget 7)
  (setq v (getvar "LOCALE"))
  (if (= v "CHS")
    (setq j (fix (getreal "\n请输入一个数组大小(如果输入数组过大，可能会导致停止响应): ")))
    (setq j (fix (getreal "\nPlease enter the length of a list (a big number maybe cause nonresponse): ")))
  )

  (setq x (+ 1.5 j)) 
  (setq k (1- j))
  (repeat j
    (setq lst (cons x lst))
    (setq lst1 (cons (cons x k) lst1))
    (setq x (1- x))
    (setq k (1- k))
  )
  (Benchmark '(setq lst (vl-sort lst '<) N (length lst)) "Vl-sort" 1)
  (Benchmark '(setq Tree (BTree lst) N N) "Construct Binary tree" 1)
  (benchmark '(setq Array (makearr lst vlax-vbdouble)) "Construct Safearray" 1)

  (setq k (/ N 10))
  (princ (strcat "\n以下对每个函数重复了" (itoa K) "次测试。"))

  (setq x -7.5)
  (Benchmark '(repeat k (setq e (BFind x Tree N)) (setq x (+ x 10))) "BinaryTree" 1)
  
  (setq x -7.5)
  (benchmark '(repeat k (setq e (HalfSeek x Array)) (setq x (+ x 10))) "HalfSeek" 1)
  
  (setq x -7.5)
  (Benchmark '(repeat k (vl-position x lst) (setq x (+ x 10))) "vl-position" 1)

  (setq x -7.5)
  (Benchmark '(repeat k (cdr (assoc x lst1)) (setq x (+ x 10))) "Assoc" 1)
 
  (setq x -7.5)
  (Benchmark '(repeat k (- N (length (member x lst))) (setq x (+ x 10))) "Member" 1)

  ;(setq x -2.5)
  ;(benchmark '(repeat N (Search x lst) (setq x (1+ x))) "Search Directly" 1)           ;这个方法过慢

  ;;以下显示部分查找结果
  (princ "\n以下显示用二叉树对十个数字的查找结果。")
  (setq x -2.5)
  (repeat 20
    (if (setq e (BFind x Tree j))
      (princ (strcat "\n发现在" (itoa e)))
      (princ (strcat "\n没发现" (rtos x)))
    )
    (setq x (1+ x))
  )
  (gc)
  (princ)
)


;;;============================================================
;;;用AutoLISP折半法查找                                        
;;;首先构造了一个安全数组，这样使得 nth更快。                  
;;;然后从中间找起，如果大于中间，就找右边，小于则找左边，直到找
;;;找完。这个没用递归，在内存上可能会稍微有优势，但是对于速度，
;;;其实跟二叉树相差不大。                                      
;;;Author:Highflybird              in Shenzhen,China,2012-06-15
;;;============================================================
(defun MakeArr (L DataType / n a)
  (setq n (length L))
  (setq a (vlax-make-safearray DataType (cons 0 (1- n))))
  (vlax-safearray-fill a L)
)
(defun HalfSeek (key L / Nmin Nlen Nmax Nmid Nval)
  (setq Nmin 0)
  (setq NLen (1+ (vlax-safearray-get-u-bound L 1)))              
  (setq Nmax (1- NLen))
  (setq Nmid (/ Nlen 2))
  (setq Nval (vlax-safearray-get-element L Nmid))        
  (while (and (/= Nval key) (<= Nmin Nmax))
    (if (> Nval key)
      (setq Nmax (1- Nmid))
      (setq Nmin (1+ Nmid))
    )
    (setq Nmid (/ (+ Nmax Nmin) 2)
          Nval (vlax-safearray-get-element L Nmid)             
    )
  )
  (if (= nval key)
    Nmid
  )
)

;;;============================================================
;;;简单的LISP搜寻，挨个地找，找到为止，对排序和未排序的均可用。
;;;但是单次查找平均时间为O(n)                                  
;;;============================================================
(defun Search (key lst / i x)
  (setq x lst)
  (setq i -1)
  (while (and x (/= (car x) key))
    (setq x (cdr x))
    (setq i (1+ i))
  )
)


;;;============================================================
;;;测试用函数(benchMark function)                              
;;;============================================================
(defun Benchmark (func funName times / t0 t1 Speed res)
  (setq t0 (getvar "TDUSRTIMER"))
  (repeat times
    (setq res (eval func))
  )
  (setq t1 (* (- (getvar "TDUSRTIMER") t0) 86400000))
  (setq speed (/ t1 times))
  ;(princ (strcat "\nIt takes: " (rtos t1 2 6) " Seconds by " funName))
  ;(princ (strcat ".\nTotal times: " (itoa times)))
  ;(princ (strcat ".\nAverage performance: " (rtos speed 2 6) " Seconds/time.\n"))
  (list func times t1 Speed)
)