高仿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)