大家都来玩玩：选图形生成pat填充文件

elitefish · 发表于 2013-12-6 00:42:46

信·CAD工具箱用户使用 7I 命令导入 7xz文件
没装工具箱的加载EF_Lib 和EF_Pat

创建填充图样命令 EF_PatMake 文本查看 EF_PatEdit

elitefish · 发表于 2013-12-6 00:47:40

本帖最后由 elitefish 于 2013-12-6 01:04 编辑

伪源程序
思路
1.将外框分割为 nxn 行列网格
2.将所有框内直线点坐标对齐到网格中
3.根据PAT规则逐条写入各元素
难点：
1.分割网格要保证精度的同时不至于过多分割
2.直线的空白长度不是外框对角线长度－直线长度
  而是看直线占据了多少格比如 i * k格，那空白长度为 i * k外框的对角线长度 L-直线长度
3.相邻直线的位置不是左边一个外框
这里用了穷举法找出 i*k个外框内离直线平行距离最近的一个外框
以该外框内直线作为第二线段起始位置
  希望高手用数学的方法解决最近平行直线定位

注意：由于图案线段角度精度的问题，故填充时请选择将原点设置在填充框内，
      否则距离世界坐标原点很远的地方填充变形，差之毫厘谬以千里啊。

;填充子样块按 X Y 边分割为 n m 份〕
;n 为整数分格数
;保证 n/m ≈ x/Y 且 lstX lstY坐标对齐到分割网格后误差小于(* fuzz (min a b)) (a b)为子样块边长
;lstX lstY 子样图形 X Y坐标集合
;Box 子样块范围盒坐标
;fuzz 容差比例 (按最小
(defun EF_Pat:FenGeShu (ptList Box fuzz
/
lstX lstY
X Y x0 y0
n
rtn
dx dy d
)
(setq X (- (caadr Box) (caar Box))
Y (- (cadadr Box) (cadar Box))
x0 (caar Box)
y0 (cadar Box)
lstX (mapcar 'car ptList)
lstY (mapcar 'cadr ptList)
lstX (mapcar '(lambda (e) (- e x0)) lstX)
lstY (mapcar '(lambda (e) (- e y0)) lstY)
n 1
dx (/ X n)
dy (/ Y n)
d (* fuzz (min X Y))
)
(while (or (apply 'or (mapcar '(lambda (e)
(> (abs (- (* dx (EF_Math:FixEx (/ e dx) 0)) e)) d) ;对齐网格后的存在某个X坐标误差超出范围
)
lstX
))
(apply 'or (mapcar '(lambda (e)
(> (abs (- (* dy (EF_Math:FixEx (/ e dy) 0)) e)) d) ;对齐网格后的存在某个X坐标误差超出范围
)
lstY
))
)
;进一步细分网格
(setq n (1+ n)
dx (/ X n)
dy (/ Y n)
)
)
(list (mapcar '(lambda (pt / x1 y1)
(setq x1 (- (car pt) x0)
y1 (- (cadr pt) y0)
)
(list (* dx (EF_Math:FixEx (/ x1 dx) 0))
(* dy (EF_Math:FixEx (/ y1 dy) 0))
)
)
ptList
);网格对齐后，相对Box左下角坐标
(list dx dy) ;网格尺寸
n ;网格行列数
(mapcar '(lambda (pt / x1 y1)
(setq x1 (- (car pt) x0)
y1 (- (cadr pt) y0)
)
(list (EF_Math:FixEx (/ x1 dx) 0)
(EF_Math:FixEx (/ y1 dy) 0)
)
)
ptList
);网格对齐后，坐标对应网格位置
)
)
;pt 点坐标（相对）
;X Y 子样块x,y向总长
(defun EF_Pat:PointPat (pt X Y
/
Ox Oy
)
(list 0.0 (car pt) (cadr pt) 0 Y 0.0 (- 0 X))
)
;pt1 pt2 直线坐标（相对）
;X Y 子样块x,y向总长
;dx dy 网格距离
(defun EF_Pat:LinePat (pt1 pt2 X Y dx dy
/
m n |m| |n|
ox oy
len dLen
ang a
divY
i k
lstDiv div
)
(setq m (EF_Math:FixEx (/ (- (car pt2) (car pt1)) dx) 0) ;直线X向占格数
n (EF_Math:FixEx (/ (- (cadr pt2) (cadr pt1)) dy) 0) ;直线Y向占格数
)
;以下保证 m n 互质
(setq i (min (abs n) (abs m)))
(while (> i 1)
(if (and (= (rem m i) 0) (= (rem n i) 0))
(progn
(setq m (/ m i)
n (/ n i)
)
(setq i (min (abs n) (abs m)))
)
(setq i (1- i))
)
)
;以上保证 m n 互质
(if (= m 0) (setq n 1))
(if (= n 0) (setq m 1))
(setq ox (car pt1) ;起点坐标x
oy (cadr pt1) ;起点坐标y
len (distance pt1 pt2) ;直线长度
dLen (- (distance '(0 0) (list (* m X) (* n Y))) len) ;直线空白间隔
)
(if (and (= m 0) (= n 0))
(setq ang 0)
(setq ang (angle pt1 pt2)) ;直线角度
)
;第m n个子样块直线到本子样块直线的平行间距
(defun divY (m n / l a)
(setq a (angle '(0 0) (list (* m X) (* n Y)))
l (distance '(0 0) (list (* m X) (* n Y)))
a (- a ang)
)
(* l (sin a))
);end divY
(cond ((= m 0) (setq i 1 k 0))
((= n 0) (setq i 0 k 1))
(T
(if (> m 0) (setq i -1) (setq i 1))
(repeat (1+ (fix (abs m)))
(if (> n 0) (setq k -1) (setq k 1))
;(setq k -1)
(if (> m 0) (setq i (1+ i)) (setq i (1- i)))
(repeat (1+ (fix (abs n)))
(if (> n 0) (setq k (1+ k)) (setq k (1- k)))
(if (or (/= i 0) (/= k 0))
(setq lstDiv (cons (list (divY i k) i k) lstDiv))
)
)
)
(setq lstDiv (vl-sort lstDiv '(lambda (e1 e2) (< (abs (car e1)) (abs (car e2))))))
(setq lstDiv (vl-remove-if '(lambda (e) (equal (car e) 0 1e-6)) lstDiv))
(setq i (cadar lstDiv) k (caddar lstDiv))
)
)
;最近的平线直线在 i k 块
(setq a (angle '(0 0) (list (* i X) (* k Y)))
l (distance '(0 0) (list (* i X) (* k Y)))
a (- a ang)
)
(setq delta-x (* l (cos a))
delta-y (* l (sin a))
)
(list ang ox oy delta-x delta-y len (- 0 dLen))
)
;========================================================================
;========================== 主函数 ===========================
;========================================================================
(defun C:EF_PatMake ( /
ss pt b s
name desc
i n ename edata
pat pats
FenGe
dx dy ptList X Y
pt10 pt11
fuzz
)
(prompt "\n[创建填充图样] 选择图样外框(矩形)")
;设置精度比例
(if (EF:Config-getDwgKey "填充图样" "精度")
(setq fuzz (atof (EF:Config-getDwgKey "填充图样" "精度")))
(setq fuzz 0.01)
)
(if (and (setq e (car (entsel)))
(setq box (EF:PickSet-getBox e))
(setq ss (ssget "C"
(car box)
(cadr box)
'((0 . "POINT,LINE"))
))
(setq name (getstring "\n图样命名:"))
(setq desc (getstring "\n图样说明:"))
(setq s (getreal "\n图样比例:"))
)
(progn
(setq X (- (caadr box) (caar box))
Y (- (cadadr box) (cadar box))
)
(setq i -1 n (sslength ss))
(while (< (setq i (1+ i)) n)
(setq ename (ssname ss i)
edata (entget ename)
)
(if (assoc 10 edata) (setq ptList (cons (cdr (assoc 10 edata)) ptList)))
(if (assoc 11 edata) (setq ptList (cons (cdr (assoc 11 edata)) ptList)))
)
(setq FenGe (EF_Pat:FenGeShu ptList box fuzz))
(setq dx (caadr FenGe)
dy (cadadr FenGe)
ptList (mapcar '(lambda (e1 e2) (list e1 e2)) ptList (car FenGe)) ;实际坐标对应相对坐标
)
(setq i -1
n (sslength ss)
pats (list (strcat "*" name ", " desc))
)
(while (< (setq i (1+ i)) n)
(setq ename (ssname ss i))
(setq edata (entget ename))
(cond ((= (cdr (assoc 0 edata)) "POINT")
(setq pt10 (cdr (assoc 10 edata))
pt10 (cadr (assoc pt10 ptList))
)
(setq pat (EF_Pat:PointPat
(mapcar '(lambda (e) (/ e s)) pt10)
(/ X s)
(/ Y s)
)
)
)
((= (cdr (assoc 0 edata)) "LINE")
(setq pt10 (cdr (assoc 10 edata))
pt10 (cadr (assoc pt10 ptList))
pt11 (cdr (assoc 11 edata))
pt11 (cadr (assoc pt11 ptList))
)
(setq pat (EF_Pat:LinePat
(mapcar '(lambda (e) (/ e s)) pt10)
(mapcar '(lambda (e) (/ e s)) pt11)
(/ X s)
(/ Y s)
(/ dx s)
(/ dy s)
)
)
)
)
(setq pat (strcat (EF:String-SimpleNum (angtos (car pat) 0 6))
","
(EF:List->String (mapcar '(lambda (e)
(EF:String-SimpleNum (rtos e 2 6))
)
(cdr pat)) ",")
)
)
(setq pats (append pats (list pat)))
)
(setq file (open (if (= (getvar 'measurement) 1)
(findfile "acadiso.Pat")
(findfile "acad.Pat")
)
"a"
)
)
(write-line "" file)
(mapcar '(lambda (e) (write-line e file)) pats)
(close file)
(princ "\n成功添加填充图样")
(princ)
)
)
)
;打开Pat文件
(defun C:EF_PatEdit ()
(if (= (getvar 'measurement) 1)
(startapp "explorer" (findfile "acadiso.Pat"))
(startapp "explorer" (findfile "acad.Pat"))
)
)

;填充子样块 按 X Y 边分割为 n m 份〕 
;n 为整数 分格数 
;保证 n/m ≈ x/Y 且 lstX lstY坐标对齐到分割网格后误差小于(* fuzz (min a b))   (a b)为子样块边长 
;lstX lstY 子样图形 X Y坐标集合 
;Box 子样块范围盒坐标 
;fuzz 容差比例 (按最小 
(defun EF_Pat:FenGeShu (ptList Box fuzz 
      / 
      lstX lstY 
      X Y x0 y0 
      n 
      rtn 
      dx dy d 
      ) 
  (setq X (- (caadr Box) (caar Box)) 
  Y (- (cadadr Box) (cadar Box)) 
  x0 (caar Box) 
  y0 (cadar Box) 
  lstX (mapcar 'car ptList) 
  lstY (mapcar 'cadr ptList) 
  lstX (mapcar '(lambda (e) (- e x0)) lstX) 
  lstY (mapcar '(lambda (e) (- e y0)) lstY) 
  n 1 
  dx (/ X n) 
  dy (/ Y n) 
  d (* fuzz (min X Y)) 
  ) 
   
  (while (or (apply 'or (mapcar '(lambda (e) 
           (> (abs (- (* dx (EF_Math:FixEx (/ e dx) 0)) e)) d)  ;对齐网格后的存在某个X坐标误差超出范围 
           ) 
        lstX 
        )) 
       (apply 'or (mapcar '(lambda (e) 
           (> (abs (- (* dy (EF_Math:FixEx (/ e dy) 0)) e)) d)  ;对齐网格后的存在某个X坐标误差超出范围 
           ) 
        lstY 
        )) 
         ) 
    ;进一步细分网格 
    (setq n (1+ n) 
    dx (/ X n) 
    dy (/ Y n) 
    ) 
    ) 
   
  (list (mapcar '(lambda (pt / x1 y1) 
       (setq x1 (- (car pt) x0) 
       y1 (- (cadr pt) y0) 
       ) 
       (list (* dx (EF_Math:FixEx (/ x1 dx) 0)) 
       (* dy (EF_Math:FixEx (/ y1 dy) 0)) 
       ) 
       ) 
    ptList 
    );网格对齐后，相对Box左下角坐标 
  (list dx dy)  ;网格尺寸 
  n    ;网格行列数 
  (mapcar '(lambda (pt / x1 y1) 
       (setq x1 (- (car pt) x0) 
       y1 (- (cadr pt) y0) 
       ) 
       (list (EF_Math:FixEx (/ x1 dx) 0) 
       (EF_Math:FixEx (/ y1 dy) 0) 
       ) 
       ) 
    ptList 
    );网格对齐后，坐标对应网格位置 
  ) 
  ) 
 
 
;pt 点坐标（相对） 
;X Y     子样块x,y向总长 
(defun EF_Pat:PointPat (pt X Y 
      / 
      Ox Oy 
      ) 
  (list 0.0 (car pt) (cadr pt) 0 Y 0.0 (- 0 X)) 
  ) 
 
 
;pt1 pt2 直线坐标（相对） 
;X Y     子样块x,y向总长 
;dx dy   网格距离 
(defun EF_Pat:LinePat (pt1 pt2 X Y dx dy 
           / 
           m n |m| |n| 
           ox oy 
           len dLen 
           ang a 
           divY 
           i k 
           lstDiv div 
           ) 
  (setq m (EF_Math:FixEx (/ (- (car pt2) (car pt1)) dx) 0)    ;直线X向占格数 
  n (EF_Math:FixEx (/ (- (cadr pt2) (cadr pt1)) dy) 0)  ;直线Y向占格数 
  ) 
   
  ;以下保证 m n 互质 
  (setq i (min (abs n) (abs m))) 
  (while (> i 1) 
    (if (and (= (rem m i) 0) (= (rem n i) 0)) 
      (progn 
  (setq m (/ m i) 
        n (/ n i) 
        ) 
  (setq i (min (abs n) (abs m))) 
  ) 
      (setq i (1- i)) 
      ) 
    ) 
  ;以上保证 m n 互质 
   
  (if (= m 0) (setq n 1)) 
  (if (= n 0) (setq m 1)) 
   
  (setq ox (car pt1)  ;起点坐标x 
  oy (cadr pt1)  ;起点坐标y 
  len (distance pt1 pt2)  ;直线长度 
  dLen (- (distance '(0 0) (list (* m X) (* n Y))) len)  ;直线空白间隔 
  ) 
   
  (if (and (= m 0) (= n 0)) 
    (setq ang 0) 
    (setq ang (angle pt1 pt2))  ;直线角度 
    ) 
   
  ;第m n个子样块直线到本子样块直线的平行间距 
  (defun divY (m n / l a) 
    (setq a (angle '(0 0) (list (* m X) (* n Y))) 
    l (distance '(0 0) (list (* m X) (* n Y))) 
    a (- a ang) 
    ) 
    (* l (sin a)) 
    );end divY 
 
  (cond ((= m 0) (setq i 1 k 0)) 
  ((= n 0) (setq i 0 k 1)) 
  (T 
   (if (> m 0) (setq i -1) (setq i 1)) 
   (repeat (1+ (fix (abs m))) 
     (if (> n 0) (setq k -1) (setq k 1)) 
     ;(setq k -1) 
     (if (> m 0) (setq i (1+ i))  (setq i (1- i))) 
     (repeat (1+ (fix (abs n))) 
       (if (> n 0) (setq k (1+ k)) (setq k (1- k))) 
       (if (or (/= i 0) (/= k 0)) 
         (setq lstDiv (cons (list (divY i k) i k) lstDiv)) 
         ) 
       ) 
     ) 
   (setq lstDiv (vl-sort lstDiv '(lambda (e1 e2) (< (abs (car e1)) (abs (car e2)))))) 
   (setq lstDiv (vl-remove-if '(lambda (e) (equal (car e) 0 1e-6)) lstDiv)) 
   (setq i (cadar lstDiv) k (caddar lstDiv)) 
   ) 
  ) 
 
  ;最近的平线直线在 i k 块 
  (setq a (angle '(0 0) (list (* i X) (* k Y))) 
  l (distance '(0 0) (list (* i X) (* k Y))) 
  a (- a ang) 
  ) 
   
  (setq delta-x (* l (cos a)) 
  delta-y (* l (sin a)) 
  ) 
   
  (list ang ox oy delta-x delta-y len (- 0 dLen)) 
  ) 
 
 
;======================================================================== 
;==========================      主函数       =========================== 
;======================================================================== 
(defun C:EF_PatMake ( / 
         ss pt b s 
         name desc 
         i n ename edata 
         pat pats 
         FenGe 
         dx dy ptList X Y 
         pt10 pt11 
         fuzz 
         ) 
  (prompt "\n[创建填充图样] 选择图样外框(矩形)") 
   
  ;设置精度比例 
  (if (EF:Config-getDwgKey "填充图样" "精度") 
    (setq fuzz (atof (EF:Config-getDwgKey "填充图样" "精度"))) 
    (setq fuzz 0.01) 
    ) 
   
  (if (and (setq e (car (entsel))) 
     (setq box (EF:PickSet-getBox e)) 
     (setq ss (ssget "C" 
         (car box) 
         (cadr box) 
         '((0 . "POINT,LINE")) 
         )) 
     (setq name (getstring "\n图样命名:")) 
     (setq desc (getstring "\n图样说明:")) 
     (setq s (getreal "\n图样比例:")) 
     ) 
    (progn 
      (setq X (- (caadr box) (caar box)) 
      Y (- (cadadr box) (cadar box)) 
      ) 
      (setq i -1 n (sslength ss)) 
      (while (< (setq i (1+ i)) n) 
  (setq ename (ssname ss i) 
        edata (entget ename) 
        ) 
  (if (assoc 10 edata) (setq ptList (cons (cdr (assoc 10 edata)) ptList))) 
  (if (assoc 11 edata) (setq ptList (cons (cdr (assoc 11 edata)) ptList))) 
  ) 
 
      (setq FenGe (EF_Pat:FenGeShu ptList box fuzz)) 
      (setq dx (caadr FenGe) 
      dy (cadadr FenGe) 
      ptList (mapcar '(lambda (e1 e2) (list e1 e2)) ptList (car FenGe))  ;实际坐标对应相对坐标 
      ) 
       
      (setq i -1 
      n (sslength ss) 
      pats (list (strcat "*" name ", " desc)) 
      ) 
       
      (while (< (setq i (1+ i)) n) 
  (setq ename (ssname ss i)) 
  (setq edata (entget ename)) 
  (cond ((= (cdr (assoc 0 edata)) "POINT") 
         (setq pt10 (cdr (assoc 10 edata)) 
         pt10 (cadr (assoc pt10 ptList)) 
         ) 
         (setq pat (EF_Pat:PointPat 
         (mapcar '(lambda (e) (/ e s)) pt10) 
         (/ X s) 
         (/ Y s) 
         ) 
         ) 
         ) 
        ((= (cdr (assoc 0 edata)) "LINE") 
         (setq pt10 (cdr (assoc 10 edata)) 
         pt10 (cadr (assoc pt10 ptList)) 
         pt11 (cdr (assoc 11 edata)) 
         pt11 (cadr (assoc pt11 ptList)) 
         ) 
         (setq pat (EF_Pat:LinePat 
         (mapcar '(lambda (e) (/ e s)) pt10) 
         (mapcar '(lambda (e) (/ e s)) pt11) 
         (/ X s) 
         (/ Y s) 
         (/ dx s) 
         (/ dy s) 
         ) 
         ) 
         ) 
        ) 
   
  (setq pat (strcat (EF:String-SimpleNum (angtos (car pat) 0 6)) 
        "," 
        (EF:List->String (mapcar '(lambda (e) 
                  (EF:String-SimpleNum (rtos e 2 6)) 
                  ) 
               (cdr pat)) ",") 
        ) 
        ) 
  (setq pats (append pats (list pat))) 
  ) 
      (setq file (open (if (= (getvar 'measurement) 1) 
       (findfile "acadiso.Pat") 
       (findfile "acad.Pat") 
       ) 
           "a" 
           ) 
      ) 
      (write-line "" file) 
      (mapcar '(lambda (e) (write-line e file)) pats) 
      (close file) 
      (princ "\n成功添加填充图样") 
      (princ) 
      ) 
    ) 
  ) 
 
;打开Pat文件 
(defun C:EF_PatEdit () 
  (if (= (getvar 'measurement) 1) 
    (startapp "explorer" (findfile "acadiso.Pat")) 
    (startapp "explorer" (findfile "acad.Pat")) 
    ) 
  )

浮世小半生 · 发表于 2014-10-21 12:05:22

成果呢? 飞诗大师打完酱油就消失了?

sxm121233 · 发表于 2015-2-2 23:10:49

好，高手顶一下

Exlw · 发表于 2015-7-19 14:18:09

想不出通用的原理

xyp1964 · 发表于 2015-7-19 14:31:14

MENGZE · 发表于 2016-2-15 16:44:47

http://bbs.mjtd.com/thread-171504-1-1.html 相关源码，能用但不是很优秀

ZHENGRONGXUN · 发表于 2016-5-26 17:58:59

老魏_shuo · 发表于 2016-7-22 10:59:29

hao3ren 发表于 2013-11-28 10:28
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=91425&extra=page%3D1%26filter%3Dtypeid%26typeid%3D1 ...

非常感谢！！

老魏_shuo · 发表于 2016-7-22 11:05:27

hao3ren 发表于 2013-11-28 10:28
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=91425&extra=page%3D1%26filter%3Dtypeid%26typeid%3D1 ...

非常感谢！！

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

[讨论] 大家都来玩玩：选图形生成pat填充文件

本帖子中包含更多资源

评分

评分

本帖子中包含更多资源