四个方向取 Pline 两点间节点

eachy · 发表于 2014-8-2 23:54:34

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

和炫翔版主聊到的一个程序，共享一下

游客，如果您要查看本帖隐藏内容请回复

小龙龙 · 发表于 2014-8-3 06:07:08

学习一下

yoyoho · 发表于 2014-8-3 07:22:34

感谢 eachy 副站长分享程序!

HLCAD · 发表于 2014-8-3 07:34:44

本帖最后由 HLCAD 于 2014-8-22 11:45 编辑

感谢站长！我想如果用于正投影的话，将非常有用！

;;; 点表pnts，沿某一角度ang（弧度）进行投影时，剔除共线的、远离的点
;;; fuzz为精度控制值.
;;; 程序编制：HLCAD，于2014.08.22
;;; 程序吸取了“元老st788796”中的trans用法；
;;; 程序用到“站长eachy”的程序的 ptl、an之后（加一行），
;;; 如：ptl (Pnts-Angle-Project ptl an 1e-06) 解决重复线的问题。
;;; 本想在后跟贴，然太远，特再编辑放到此处。
;| Ex:
(defun c:tt1 nil
(setq tmp (Pnts-Angle-Project
(setq pnts(polyline:verts(car(entsel"\n点取多段线:"))))
(setq ang (getangle "\n投影线角度:"))
(setq fuzz 1e-06)
))
(command"_.pline") (mapcar'(lambda(x)(command"_non"x))tmp) (command"")
)
|;
;;;
(defun Pnts-Angle-Project (pnts ang fuzz / p1 p2 v Lst rtn)
(setq p1 (polar (car pnts) ang 100.)
p2 (polar (car pnts) ang -100.)
)
(setq v (mapcar '- p2 p1)
Lst (mapcar '(lambda (x) (trans (mapcar '- x p1) 0 v)) pnts)
Lst (mapcar '(lambda (x) (list (car x) (caddr x))) Lst) ;去除中间值0.0
Lst (mapcar '(lambda(x y) (list x y)) Lst pnts)
)
(setq Lst (vl-sort Lst
'(lambda (x1 x2)
(if (equal (caar x1) (caar x2) fuzz)
(< (cadar x1) (cadar x2))
(< (caar x1) (caar x2))
))))
(setq rtn '())
(mapcar '(lambda (x)
(if (equal (caar x) (caar(last rtn)) fuzz)
nil
(setq rtn (append rtn (list x)))
)) Lst)
(mapcar 'cadr rtn)
)

;;; 点表pnts，沿某一角度ang（弧度）进行投影时，剔除共线的、远离的点 
;;; fuzz为精度控制值. 
;;; 程序编制：HLCAD，于2014.08.22 
;;; 程序吸取了“元老st788796”中的trans用法； 
;;; 程序用到“站长eachy”的程序的 ptl、an之后（加一行）， 
;;; 如：ptl (Pnts-Angle-Project ptl an 1e-06) 解决重复线的问题。 
;;; 本想在后跟贴，然太远，特再编辑放到此处。 
;| Ex: 
(defun c:tt1 nil 
  (setq tmp (Pnts-Angle-Project 
        (setq pnts(polyline:verts(car(entsel"\n点取多段线:")))) 
        (setq ang (getangle  "\n投影线角度:")) 
        (setq fuzz 1e-06) 
        )) 
  (command"_.pline") (mapcar'(lambda(x)(command"_non"x))tmp) (command"") 
  ) 
|; 
;;; 
(defun Pnts-Angle-Project (pnts ang fuzz / p1 p2 v Lst rtn) 
  (setq p1 (polar (car pnts) ang  100.) 
  p2 (polar (car pnts) ang -100.) 
  ) 
  (setq v (mapcar '- p2 p1) 
  Lst (mapcar '(lambda (x) (trans (mapcar '- x p1) 0 v)) pnts) 
  Lst (mapcar '(lambda (x) (list (car x) (caddr x))) Lst) ;去除中间值0.0 
  Lst (mapcar '(lambda(x y) (list x y)) Lst pnts) 
  ) 
  (setq Lst (vl-sort Lst 
         '(lambda (x1 x2) 
      (if (equal (caar x1) (caar x2) fuzz) 
        (< (cadar x1) (cadar x2)) 
        (< (caar  x1) (caar  x2)) 
        )))) 
  (setq rtn '()) 
  (mapcar '(lambda (x) 
       (if (equal (caar x) (caar(last rtn)) fuzz) 
         nil 
         (setq rtn (append rtn (list x))) 
         )) Lst) 
  (mapcar 'cadr rtn) 
  )

czx663 · 发表于 2014-8-3 08:05:46

回复看看,学习一下

st788796 · 发表于 2014-8-3 08:15:13

正投影，只要看线需要再处理一下顶点

(defun PntsProjectTo (e pnts p1 p2 / v nl nnl)
(setq v (mapcar '- p2 p1)
lst (mapcar '(lambda (x)
(list (last (trans (mapcar '- x p1) 0 v)) x)
)
pnts
)
nl (list (car lst))
lst (cdr lst)
)
(while lst
(if (or (> (caar lst) (caar nl))
(not (equal (caar lst) (caar nl) 1e-6))
)
(setq nl (cons (car lst) nl))
)
(setq nnl (cons (car lst) nnl)
lst (cdr lst)
)
)
(if nnl
(list (reverse (mapcar 'cadr nl))
(reverse (mapcar 'cadr nnl))
)
(list (reverse (mapcar 'cadr nl)))
)
)

auva · 发表于 2014-8-3 08:42:22

不知道是否可以应用到面积分割！谢谢啦！

viphappy · 发表于 2014-8-3 10:22:13

回复看看,学习一下

dwg001 · 发表于 2014-8-3 11:53:46

回帖，看精彩内容去。

ysq101 · 发表于 2014-8-3 12:18:49

这个就是投影啊。。。。。对一些特定专业很实用啊
高手

HLCAD · 发表于 2014-8-3 14:00:52

st788796 发表于 2014-8-3 08:15
正投影，只要看线需要再处理一下顶点

参数E似乎没有作用？

jeen422 · 发表于 2014-8-3 14:33:26

怎么看不了

jeen422 · 发表于 2014-8-3 15:43:20

新人弱弱的问一句，怎么使用啊？命令是什么

xchj81 · 发表于 2014-8-3 16:27:12

感谢 eachy 副站长分享程序!:)

hzj268 · 发表于 2014-8-3 17:23:06

路过不错过

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

[原创] 四个方向取 Pline 两点间节点

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

评分

点评