镜像点集

TANER · 发表于 2012-4-15 15:21:22

;;; ==================================================================
(defun th-per (pt obj / pt2 dist)
(if (and
pt
obj
)
(setq dist
(distance pt
(setq pt2 (vlax-curve-getclosestpointto obj pt t))
)
)
)
pt2
)
;;; ==================================================================
(defun txt-mkline (p1 p2 / ent)
(if (setq ent (entmakex (list '(0 . "LINE")
'(100 . "AcDbEntity")
'
(100 . "AcDbLine")
(cons 10 p1)
(cons 11 p2)
'
(210 0. 0. 1.)
)
)
)
ent
)
)
;;; ==================================================================
(defun th-ptlst-mirror (ptlst pt1 pt2 / e lst lst1 lst2 lst3)
(setq e (txt-mkline pt1 pt2))
(setq lst (mapcar
(function (lambda (P)
(th-per p e)
)
)
ptlst
)
)
(entdel e)
(setq lst1 (mapcar
(function (lambda (x0 x1)
(- (* 2 x0) x1)
)
)
(mapcar
(function car)
lst
)
(mapcar
(function car)
ptlst
)
)
)
(setq lst2 (mapcar
(function (lambda (x0 x1)
(- (* 2 x0) x1)
)
)
(mapcar
(function cadr)
lst
)
(mapcar
(function cadr)
ptlst
)
)
)
(setq lst3 (mapcar
(function (lambda (x y)
(list x y)
)
)
lst1
lst2
)
)
)
;;; ==================================================================

;;; ================================================================== 
(defun th-per (pt obj / pt2 dist) 
  (if (and 
        pt 
        obj 
      ) 
    (setq dist 
           (distance pt 
                     (setq pt2 (vlax-curve-getclosestpointto obj pt t)) 
           ) 
    ) 
  ) 
  pt2 
) 
;;; ================================================================== 
(defun txt-mkline (p1 p2 / ent) 
  (if (setq ent        (entmakex (list        '(0 . "LINE") 
                                '(100 . "AcDbEntity") 
                                ' 
                                 (100 . "AcDbLine") 
                                (cons 10 p1) 
                                (cons 11 p2) 
                                ' 
                                 (210 0. 0. 1.) 
                          ) 
                ) 
      ) 
    ent 
  ) 
) 
;;; ================================================================== 
(defun th-ptlst-mirror (ptlst pt1 pt2 / e lst lst1 lst2 lst3) 
  (setq e (txt-mkline pt1 pt2)) 
  (setq        lst (mapcar 
              (function        (lambda        (P) 
                          (th-per p e) 
                        ) 
              ) 
              ptlst 
            ) 
  ) 
  (entdel e) 
  (setq        lst1 (mapcar 
               (function (lambda (x0 x1) 
                           (- (* 2 x0) x1) 
                         ) 
               ) 
               (mapcar 
                 (function car) 
                 lst 
               ) 
               (mapcar 
                 (function car) 
                 ptlst 
               ) 
             ) 
  ) 
  (setq        lst2 (mapcar 
               (function (lambda (x0 x1) 
                           (- (* 2 x0) x1) 
                         ) 
               ) 
               (mapcar 
                 (function cadr) 
                 lst 
               ) 
               (mapcar 
                 (function cadr) 
                 ptlst 
               ) 
             ) 
  ) 
  (setq        lst3 (mapcar 
               (function (lambda (x y) 
                           (list x y) 
                         ) 
               ) 
               lst1 
               lst2 
             ) 
  ) 
 
 
) 
;;; ==================================================================

yoyoho · 发表于 2012-4-15 15:55:53

感谢TANER 分享!

功夫佬 · 发表于 2012-4-28 21:46:27

4分之一可以使用它吧

TANER · 发表于 2012-10-24 09:56:12

本帖最后由 TANER 于 2012-10-24 09:56 编辑

这个更简洁，抄来的哦！

(DEFUN T2-PTLST-MIRROR (PL P1 P2 / MANG)
(SETQ MANG (* 2 (ANGLE P1 P2)))
(MAPCAR
'(LAMBDA (P)
(POLAR P1 (- MANG (ANGLE P1 P)) (DISTANCE P1 P))
)
PL
)
)

复制代码

ynhh · 发表于 2012-10-27 18:08:15

楼主的分享精神

让人值得学习

vlisp2012 · 发表于 2012-10-28 10:40:36

赞一个！！

xyp1964 · 发表于 2012-10-28 10:52:12

;; 伪源码需要e派工具箱(XCAD)的支持
(defun PtnMirror (ptn p1 p2)
(mapcar '(lambda (x) (xyp-Point-MirrorWith2pt x p1 p2)) ptn)
)

c735023723 · 发表于 2012-10-28 21:15:29

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

镜像点集

评分