依据平面四参数变换图形

hothua2020 · 发表于 2020-8-28 17:41

本帖最后由 hothua2020 于 2020-8-28 22:06 编辑

最近写的一个图形变换程序，上传源码供大家参考和提出修改意见。因为我的应用目标主要是地形图方面的坐标变换，其拉扯缩放比例和角度都不大。对于图块插入点与块实际图形范围距离很大的情况，我的转换程序比CASS10.1效果好。借用网络上高手的一些函数，特别是Lee Mac的。

;; TRP
;; Transpose a matrix -Doug Wilson-
(defun trp (m) (apply 'mapcar (cons 'list m)))
;; MXV
;; Apply a transformation matrix to a vector -Vladimir Nesterovsky-
(defun mxv (m v)
(mapcar (function (lambda (r) (apply '+ (mapcar '* r v))))
m
)
)
;; MXM
;; Multiply two matrices -Vladimir Nesterovsky-
(defun mxm (m q)
(mapcar (function (lambda (r) (mxv (trp q) r))) m)
)
;;;
;;--------------------=={ Inverse Matrix }==------------------;;
;; ;;
;; Implements the Gauss-Jordan Elimination algorithm to ;;
;; inverse a non-singular nxn matrix. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ? 2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: m - nxn Matrix ;;
;;------------------------------------------------------------;;
;; Returns: Matrix inverse, or nil if matrix is singular ;;
;;------------------------------------------------------------;;
(defun LM:InverseMatrix ( m / _identity _eliminate p r x )
(defun _identity ( n / i j l m ) (setq i 1)
(repeat n (setq j 0)
(repeat n
(setq l (cons (if (= i (setq j (1+ j))) 1. 0.) l))
)
(setq m (cons l m) l nil i (1+ i)) m
)
)
(defun _eliminate ( m p )
(mapcar
(function
(lambda ( x / d )
(setq d (car x)) (mapcar (function (lambda ( a b ) (- a (* d b)))) (cdr x) p)
)
)
m
)
)
(setq m (mapcar 'append m (_identity (length m))))
(while m
(setq p (apply 'max (mapcar 'abs (mapcar 'car m))))
(while (not (equal p (abs (caar m)) 1e-14))
(setq m (append (cdr m) (list (car m))))
)
(if (equal 0.0 (caar m) 1e-14)
(setq m nil)
(setq p (/ 1. (caar m))
p (mapcar (function (lambda ( x ) (* p x))) (cdar m))
m (_eliminate (cdr m) p)
r (cons p (_eliminate r p))
)
)
)
(reverse r)
)
;; 2D Projection: Unique with Fuzz - Lee Mac
;; Returns a list with all elements considered duplicate to a given tolerance removed.
(defun 2dprojection:uniquefuzz ( lst fuz )
(if lst
(cons (car lst)
(2dprojection:uniquefuzz
(vl-remove-if
(function (lambda ( x ) (equal x (car lst) fuz)))
(cdr lst)
)
fuz
)
)
)
)
;; 2D Projection: Check Collinearity - Lee Mac
;; Returns T if any three points in a supplied list are collinear.
(defun 2dprojection:checkcollinearity ( lst )
(and (caddr lst)
(or ( (lambda ( a b c )
(or (equal (+ a b) c 1e-8)
(equal (+ b c) a 1e-8)
(equal (+ c a) b 1e-8)
)
)
(distance (car lst) (cadr lst))
(distance (cadr lst) (caddr lst))
(distance (car lst) (caddr lst))
)
(2dprojection:checkcollinearity (cdr lst))
)
)
)
;; 2D Projection: Clockwise-p - Lee Mac
;; Returns T if the supplied point list is clockwise oriented.
(defun 2dprojection:clockwise-p ( lst )
(minusp
(apply '+
(mapcar
(function
(lambda ( a b )
(- (* (car b) (cadr a)) (* (car a) (cadr b)))
)
)
lst (cons (last lst) lst)
)
)
)
)
;; 2D Projection: Get Reference Frame - Lee Mac
;; Prompts the user to select a closed planar polyline with 4 vertices in
;; order to obtain 4 counter-clockwise oriented non-collinear points
;; defining a reference frame for the transformation.
(defun 2dprojection:getreferenceframe ( msg / ent enx lst tmp )
(while
(progn (setvar 'errno 0) (setq ent (car (entsel msg)))
(cond
( (= 7 (getvar 'errno))
(princ "\n错误,重试.")
)
( (null ent) nil)
( (or (/= "LWPOLYLINE" (cdr (assoc 0 (setq enx (entget ent)))))
(zerop (logand 1 (cdr (assoc 70 enx))))
(/= 4 (cdr (assoc 90 enx)))
(/= 4 (length (setq lst (2dprojection:uniquefuzz (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) enx)) 1e-8))))
(2dprojection:checkcollinearity (cons (last lst) lst))
)
(setq lst nil)
(princ "\n请选择闭合的4点POLYLINE线.")
)
)
)
)
(if lst
(progn
(if (2dprojection:clockwise-p lst)
(setq lst (reverse lst))
)
(setq tmp (apply 'mapcar (cons 'min lst)))
(repeat (car (vl-sort-i lst '(lambda ( a b ) (< (distance a tmp) (distance b tmp)))))
(setq lst (append (cdr lst) (list (car lst))))
)
lst
)
)
)
;;------------=={ SelectionSet -> VLA Objects }==-------------;;
;; ;;
;; Converts a SelectionSet to a list of VLA Objects ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ? 2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; ss - Valid SelectionSet (Pickset) ;;
;;------------------------------------------------------------;;
;; Returns: List of VLA Objects, else nil ;;
;;------------------------------------------------------------;;
(defun LM:ss->vla ( ss / i l )
(if ss
(repeat (setq i (sslength ss))
(setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
)
)
)
;;;
;;;主执行程序
(defun c:2dTrans(/ FourParam->Matrix ss src des minx miny pt11 pt12 pt13 pt14 pt21 pt22 pt23 pt24 matL matB matBT matX dx dy a b dxys fdx fdy)
;;;
;;;平面四参数->CAD图形转换矩阵
;;;本来应没有minx miny，但是我使用最小二乘法计算转换参数失真，测试降低坐标值结果较好，所以多了先将图形平移到0轴附近在计算参数的多于过程，变换矩阵也就多了minx,miny两个参数
(defun FourParam->Matrix(dx dy ang scl minx miny / )
(list (list (* (cos ang) scl) (* (sin ang) scl -1.) 0. (- (+ dx minx (* (sin ang) scl miny)) (* (cos ang) scl minx)))
(list (* (sin ang) scl) (* (cos ang) scl) 0. (- (+ dy miny) (* (sin ang) scl minx) (* (cos ang) scl miny)))
(list 0. 0. scl 0.0)
'(0. 0. 0. 1.)
)
)
(print "请选择待变换图形")
(setq ss (ssget))
(if ss (progn
(setq src (2dprojection:getreferenceframe "\n请选择源边界: "))
(setq des (2dprojection:getreferenceframe "\n请选择目标边界: "))
;(mapcar '(lambda(x) (print (strcat (rtos (car x) 2 20) "," (rtos (cadr x) 2 20)))) src)
;(mapcar '(lambda(x) (print (strcat (rtos (car x) 2 20) "," (rtos (cadr x) 2 20)))) des)
;;;矩阵运算数值较大结果失真，所以将坐标减去一个最小值
(setq minx (caar src) miny (cadar src))
(mapcar '(lambda(pt) (setq minx (min minx (car pt)) miny (min miny (cadr pt)))) src)
(mapcar '(lambda(pt) (setq minx (min minx (car pt)) miny (min miny (cadr pt)))) des)
(setq src (mapcar '(lambda(pt) (list (- (car pt) minx) (- (cadr pt) miny))) src))
(setq des (mapcar '(lambda(pt) (list (- (car pt) minx) (- (cadr pt) miny))) des))
;;;太多的car或者nth太麻烦,试着用mapcar构造矩阵又没搞定，只好用变量
(mapcar 'set (list 'pt11 'pt12 'pt13 'pt14) src)
(mapcar 'set (list 'pt21 'pt22 'pt23 'pt24) des)
(setq matL (list (list (- (car pt21)(car pt11))) (list (- (cadr pt21)(cadr pt11)))
(list (- (car pt22)(car pt12))) (list (- (cadr pt22)(cadr pt12)))
(list (- (car pt23)(car pt13))) (list (- (cadr pt23)(cadr pt13)))
(list (- (car pt24)(car pt14))) (list (- (cadr pt24)(cadr pt14)))
)
matB (list (list 1. 0. (car pt11) (- 0 (cadr pt11))) (list 0. 1. (cadr pt11) (car pt11))
(list 1. 0. (car pt12) (- 0 (cadr pt12))) (list 0. 1. (cadr pt12) (car pt12))
(list 1. 0. (car pt13) (- 0 (cadr pt13))) (list 0. 1. (cadr pt13) (car pt13))
(list 1. 0. (car pt14) (- 0 (cadr pt14))) (list 0. 1. (cadr pt14) (car pt14))
)
matBT (trp matB)
matX (mxm (LM:InverseMatrix (mxm matBT matB)) (mxm matBT matL))
)
(mapcar 'set (list 'dx 'dy 'a 'b) (mapcar '(lambda(x) (car x)) matX))
(setq ang (atan (/ b (1+ a)))
k (sqrt (+ (* (1+ a) (1+ a)) (* b b)))
matX (vlax-tmatrix (FourParam->Matrix dx dy ang k minx miny))
)
(foreach obj (LM:ss->vla ss)
(vla-transformby obj matX)
)
))
)
(vl-load-com)
(print "键入2dTrans命令运行")
(princ)

;; TRP 
;; Transpose a matrix -Doug Wilson- 
(defun trp (m) (apply 'mapcar (cons 'list m))) 
;; MXV 
;; Apply a transformation matrix to a vector -Vladimir Nesterovsky- 
(defun mxv (m v) 
    (mapcar (function (lambda (r) (apply '+ (mapcar '* r v)))) 
            m 
    ) 
) 
;; MXM 
;; Multiply two matrices -Vladimir Nesterovsky- 
(defun mxm (m q) 
  (mapcar (function (lambda (r) (mxv (trp q) r))) m) 
)   
;;; 
;;--------------------=={ Inverse Matrix }==------------------;; 
;;                                                            ;; 
;;  Implements the Gauss-Jordan Elimination algorithm to      ;; 
;;  inverse a non-singular nxn matrix.                        ;; 
;;------------------------------------------------------------;; 
;;  Author: Lee Mac, Copyright ? 2011 - www.lee-mac.com       ;; 
;;------------------------------------------------------------;; 
;;  Arguments: m - nxn Matrix                                 ;; 
;;------------------------------------------------------------;; 
;;  Returns:  Matrix inverse, or nil if matrix is singular    ;; 
;;------------------------------------------------------------;; 
(defun LM:InverseMatrix ( m / _identity _eliminate p r x ) 
 
  (defun _identity ( n / i j l m ) (setq i 1) 
    (repeat n (setq j 0) 
      (repeat n 
        (setq l (cons (if (= i (setq j (1+ j))) 1. 0.) l)) 
      ) 
      (setq m (cons l m) l nil i (1+ i)) m 
    ) 
  ) 
 
  (defun _eliminate ( m p ) 
    (mapcar 
      (function 
        (lambda ( x / d ) 
          (setq d (car x)) (mapcar (function (lambda ( a b ) (- a (* d b)))) (cdr x) p) 
        ) 
      ) 
      m 
    ) 
  ) 
  (setq m (mapcar 'append m (_identity (length m)))) 
   
  (while m 
    (setq p (apply 'max (mapcar 'abs (mapcar 'car m)))) 
    (while (not (equal p (abs (caar m)) 1e-14)) 
      (setq m (append (cdr m) (list (car m)))) 
    ) 
    (if (equal 0.0 (caar m) 1e-14) 
      (setq m nil) 
      (setq p (/ 1. (caar m)) 
            p (mapcar (function (lambda ( x ) (* p x))) (cdar m)) 
            m (_eliminate (cdr m) p) 
            r (cons p (_eliminate r p)) 
      ) 
    ) 
  ) 
  (reverse r) 
) 
 
;; 2D Projection: Unique with Fuzz  -  Lee Mac 
;; Returns a list with all elements considered duplicate to a given tolerance removed. 
(defun 2dprojection:uniquefuzz ( lst fuz ) 
    (if lst 
        (cons (car lst) 
            (2dprojection:uniquefuzz 
                (vl-remove-if 
                    (function (lambda ( x ) (equal x (car lst) fuz))) 
                    (cdr lst) 
                ) 
                fuz 
            ) 
        ) 
    ) 
) 
 
;; 2D Projection: Check Collinearity  -  Lee Mac 
;; Returns T if any three points in a supplied list are collinear. 
 
(defun 2dprojection:checkcollinearity ( lst ) 
    (and (caddr lst) 
        (or (   (lambda ( a b c ) 
                    (or (equal (+ a b) c 1e-8) 
                        (equal (+ b c) a 1e-8) 
                        (equal (+ c a) b 1e-8) 
                    ) 
                ) 
                (distance (car  lst) (cadr  lst)) 
                (distance (cadr lst) (caddr lst)) 
                (distance (car  lst) (caddr lst)) 
            ) 
            (2dprojection:checkcollinearity (cdr lst)) 
        ) 
    ) 
) 
 
;; 2D Projection: Clockwise-p  -  Lee Mac 
;; Returns T if the supplied point list is clockwise oriented. 
 
(defun 2dprojection:clockwise-p ( lst ) 
    (minusp 
        (apply '+ 
            (mapcar 
                (function 
                    (lambda ( a b ) 
                        (- (* (car b) (cadr a)) (* (car a) (cadr b))) 
                    ) 
                ) 
                lst (cons (last lst) lst) 
            ) 
        ) 
    ) 
) 
;; 2D Projection: Get Reference Frame  -  Lee Mac 
;; Prompts the user to select a closed planar polyline with 4 vertices in 
;; order to obtain 4 counter-clockwise oriented non-collinear points 
;; defining a reference frame for the transformation. 
(defun 2dprojection:getreferenceframe ( msg / ent enx lst tmp ) 
    (while 
        (progn (setvar 'errno 0) (setq ent (car (entsel msg))) 
            (cond 
                (   (= 7 (getvar 'errno)) 
                    (princ "\n错误,重试.") 
                ) 
                (   (null ent) nil) 
                (   (or (/= "LWPOLYLINE" (cdr (assoc 0 (setq enx (entget ent))))) 
                        (zerop (logand 1 (cdr (assoc 70 enx)))) 
                        (/= 4 (cdr (assoc 90 enx))) 
                        (/= 4 (length (setq lst (2dprojection:uniquefuzz (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) enx)) 1e-8)))) 
                        (2dprojection:checkcollinearity (cons (last lst) lst)) 
                    ) 
                    (setq lst nil) 
                    (princ "\n请选择闭合的4点POLYLINE线.") 
                ) 
            ) 
        ) 
    ) 
    (if lst 
        (progn 
            (if (2dprojection:clockwise-p lst) 
                (setq lst (reverse lst)) 
            ) 
            (setq tmp (apply 'mapcar (cons 'min lst))) 
            (repeat (car (vl-sort-i lst '(lambda ( a b ) (< (distance a tmp) (distance b tmp))))) 
                (setq lst (append (cdr lst) (list (car lst)))) 
            ) 
            lst 
        ) 
    ) 
) 
;;------------=={ SelectionSet -> VLA Objects }==-------------;; 
;;                                                            ;; 
;;  Converts a SelectionSet to a list of VLA Objects          ;; 
;;------------------------------------------------------------;; 
;;  Author: Lee Mac, Copyright ? 2011 - www.lee-mac.com       ;; 
;;------------------------------------------------------------;; 
;;  Arguments:                                                ;; 
;;  ss - Valid SelectionSet (Pickset)                         ;; 
;;------------------------------------------------------------;; 
;;  Returns:  List of VLA Objects, else nil                   ;; 
;;------------------------------------------------------------;; 
(defun LM:ss->vla ( ss / i l ) 
    (if ss 
        (repeat (setq i (sslength ss)) 
            (setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l)) 
        ) 
    ) 
) 
;;; 
;;;主执行程序 
(defun c:2dTrans(/ FourParam->Matrix ss src des minx miny pt11 pt12 pt13 pt14 pt21 pt22 pt23 pt24 matL matB matBT matX dx dy a b dxys fdx fdy) 
    ;;; 
  ;;;平面四参数->CAD图形转换矩阵 
  ;;;本来应没有minx miny，但是我使用最小二乘法计算转换参数失真，测试降低坐标值结果较好，所以多了先将图形平移到0轴附近在计算参数的多于过程，变换矩阵也就多了minx,miny两个参数 
  (defun FourParam->Matrix(dx dy ang scl minx miny / ) 
    (list (list (* (cos ang) scl) (* (sin ang) scl -1.) 0. (- (+ dx minx (* (sin ang) scl miny)) (* (cos ang) scl minx)))   
           (list (* (sin ang) scl) (* (cos ang) scl) 0. (- (+ dy miny) (* (sin ang) scl minx) (* (cos ang) scl miny))) 
         (list 0. 0. scl 0.0) 
         '(0. 0. 0. 1.) 
      ) 
  ) 
  (print "请选择待变换图形") 
  (setq ss (ssget)) 
  (if ss (progn 
     (setq src (2dprojection:getreferenceframe "\n请选择源边界: ")) 
         (setq des (2dprojection:getreferenceframe "\n请选择目标边界: ")) 
     ;(mapcar '(lambda(x) (print (strcat (rtos (car x) 2 20) "," (rtos (cadr x) 2 20)))) src) 
     ;(mapcar '(lambda(x) (print (strcat (rtos (car x) 2 20) "," (rtos (cadr x) 2 20)))) des) 
     ;;;矩阵运算数值较大结果失真，所以将坐标减去一个最小值 
    (setq minx (caar src) miny (cadar src)) 
    (mapcar '(lambda(pt) (setq minx (min minx (car pt)) miny (min miny (cadr pt)))) src) 
    (mapcar '(lambda(pt) (setq minx (min minx (car pt)) miny (min miny (cadr pt)))) des) 
    (setq src (mapcar '(lambda(pt) (list (- (car pt) minx) (- (cadr pt) miny))) src)) 
    (setq des (mapcar '(lambda(pt) (list (- (car pt) minx) (- (cadr pt) miny))) des)) 
    ;;;太多的car或者nth太麻烦,试着用mapcar构造矩阵又没搞定，只好用变量 
    (mapcar 'set (list 'pt11 'pt12 'pt13 'pt14) src) 
    (mapcar 'set (list 'pt21 'pt22 'pt23 'pt24) des) 
   
    (setq  matL    (list (list (- (car pt21)(car pt11))) (list (- (cadr pt21)(cadr pt11))) 
                  (list (- (car pt22)(car pt12))) (list (- (cadr pt22)(cadr pt12))) 
                  (list (- (car pt23)(car pt13))) (list (- (cadr pt23)(cadr pt13))) 
                  (list (- (car pt24)(car pt14))) (list (- (cadr pt24)(cadr pt14))) 
            )                            
         matB      (list (list 1. 0. (car pt11) (- 0 (cadr pt11))) (list 0. 1. (cadr pt11) (car pt11)) 
                          (list 1. 0. (car pt12) (- 0 (cadr pt12))) (list 0. 1. (cadr pt12) (car pt12)) 
                  (list 1. 0. (car pt13) (- 0 (cadr pt13))) (list 0. 1. (cadr pt13) (car pt13)) 
                  (list 1. 0. (car pt14) (- 0 (cadr pt14))) (list 0. 1. (cadr pt14) (car pt14)) 
              ) 
        matBT     (trp matB) 
        matX      (mxm (LM:InverseMatrix (mxm matBT matB)) (mxm matBT matL))       
    ) 
    (mapcar 'set (list 'dx 'dy 'a  'b) (mapcar '(lambda(x) (car x))  matX))   
   
    (setq   ang (atan (/ b (1+ a))) 
        k   (sqrt (+ (* (1+ a) (1+ a)) (* b b)))               
        matX (vlax-tmatrix (FourParam->Matrix dx dy ang k minx miny))    
    )    
    (foreach obj (LM:ss->vla ss)       
      (vla-transformby  obj  matX)   
        )      
  )) 
) 
(vl-load-com) 
(print "键入2dTrans命令运行") 
(princ)

999999 · 发表于 2020-8-28 18:47

谢谢大神的分享，请问可不可以加一个演示方式呢

，，小白看不懂代码，对字面意思也不太理解呢

hothua2020 · 发表于 2020-8-28 21:18

我也是一个学习的，最近这个程序也是学了highflybir很多帖子，也看了些LEE MAC的代码，写出来分享的。我学学如何录Gif再发

czb203 · 发表于 2020-9-7 14:41

感谢楼主分享下载试试!

wzg356 · 发表于 2020-11-11 20:56

你这个理解不对
http://bbs.mjtd.com/forum.php?mo ... 6orderby%3Ddateline

账号		自动登录	找回密码
密码			注册

依据平面四参数变换图形

本帖子中包含更多资源