Wipeout Ssget

eachy · 发表于 2013-7-13 20:20:19

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

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

×

今天翻出来一个程序，Curve Wipeout 忘了什么时候写的了，xdapi 中已经有更方便的用法
[sell=5]

(defun c:wipess (/ ss ssl i pl
ybl-curve-points *MODELSPACE* DOC EL
OLDLA PL X s ee s1
s2
)
(defun ybl-massoc (code lst / pp)
(if (= (type code) 'LIST)
(while lst
(if (member (caar lst) code)
(setq pp (cons (cdar lst) pp))
)
(setq lst (cdr lst))
)
(while lst
(if (= (caar lst) code)
(setq pp (cons (cdar lst) pp))
)
(setq lst (cdr lst))
)
)
(reverse pp)
)
(defun ybl-curve-points (e / ln->pts arc->pts
circle->pts ell->pts spl->pts
e el p ppl
ps typ x pts-divn
massoc pl->pts solid->pts
)
;;Get Line pts
(defun ln->pts (e)
(list (vlax-curve-getstartpoint e)
(vlax-curve-getendpoint e)
)
)
;; Get arc/circle/ellipse pts
(defun arc->pts (e / spa epa an n an0 pt)
(setq spa (vlax-curve-getstartparam e)
epa (vlax-curve-getendparam e)
an (- epa spa)
n (fix (* 16 (/ an pi)))
)
(if (< n 2)
(setq n 2)
)
(setq an0 (/ an n))
(repeat n
(setq
pt
(cons (vlax-curve-getpointatparam e (setq spa (+ spa an0)))
pt
)
)
)
(cons (vlax-curve-getstartpoint e) (reverse pt))
)
;;Solid and Trace
(defun solid->pts (sl)
(list (cdr (assoc 10 el))
(cdr (assoc 11 el))
(cdr (assoc 12 el))
(cdr (assoc 13 el))
)
)
(defun pl->pts (el / e eel pl a b c v r l a spm n aa an m)
(setq e (cdr (assoc -1 el))
eel (ybl-massoc '(10 42) el)
m 0.
)
(if (vlax-curve-isclosed e)
(setq eel (append eel (list (car eel) 0.)))
)
(while eel
(mapcar 'set '(a b c) eel)
(if (and (zerop b) c)
(setq pl (cons a pl))
(progn
(setq v (vlax-curve-getsecondderiv
e
(vlax-curve-getparamatpoint e a)
)
r (distance '(0. 0. 0.) v)
l (- (vlax-curve-getdistatparam e m)
(vlax-curve-getdistatparam e (1+ m))
)
an (/ l r)
spm (vlax-curve-getparamatpoint e a)
)
(setq n (1+ (abs (fix (/ an 0.0981748))))
aa (/ 1. n)
pl (cons a pl)
)
(repeat (1- n)
(setq pl
(cons (vlax-curve-getpointatparam e (setq spm (+ spm aa)))
pl
)
)
)
)
)
(setq eel (cddr eel)
m (1+ m)
)
)
(reverse pl)
)
;;3DFace Polygen ...
(defun poly->pts (el / getplvertex e typ tf)
(defun getplvertex (e diff / n m pl)
(setq n (fix (vlax-curve-getendparam e))
m 0
)
(repeat (if (= diff 1)
n
(* 2 n)
)
(setq pl (cons (vlax-curve-getpointatparam e m) pl)
m (+ m diff)
)
)
(cons (vlax-curve-getendpoint e) pl)
)
(setq e (cdr (assoc -1 el))
typ (cdr (assoc 70 el))
tf (vlax-curve-isclosed e)
)
(if (= (logand typ 2) 2) ;_ Fit
(setq pl (getplvertex e 0.5))
(setq pl (getplvertex e 1)) ;_Spline
)
pl
)
;;Get Spline points
(defun spl->pts (spl / pp pl)
(vl-catch-all-apply
'(lambda (/ e pts epm p d n m pls ls epm l)
(setq e (cdr (assoc -1 spl))
pts (ybl-massoc 10 spl)
epm (vlax-curve-getendparam e)
)
(if (assoc 11 spl)
(setq p (nth 2 pts))
(setq p (cadr pts))
)
(setq d (distance (vlax-curve-getclosestpointto e p)
p
)
)
(if (< d 1.)
(setq pp pts)
(progn
(setq pl
(vlax-invoke
*modelspace*
'addpolyline
(apply 'append pts)
)
)
(vla-put-type pl acCubicSplinePoly)
(setq n (vlax-curve-getendparam pl)
m -1
l (vlax-curve-getdistatparam pl n)
)
(repeat (fix (1+ n))
(setq
pls
(cons (vlax-curve-getdistatparam pl (setq m (1+ m)))
pls
)
)
)
(setq ls (mapcar '(lambda (x) (/ x l)) (reverse pls)))
(setq
pp (mapcar
'(lambda (x)
(vlax-curve-getpointatparam e (* x epm))
)
ls
)
)
)
)
)
)
(if pl
(vla-delete pl)
)
pp
)
(setq el (entget e)
typ (cdr (assoc 0 el))
)
(cond
((= typ "LINE")
(setq ppl (ln->pts e))
)
((member typ '("ARC" "CIRCLE" "ELLIPSE"))
(setq ppl (arc->pts e))
)
((= typ "SPLINE")
(setq ppl (spl->pts el))
)
((= typ "POLYLINE")
(setq ppl (poly->pts el))
)
((= typ "LWPOLYLINE")
(setq ppl (pl->pts el))
)
((= typ "SOLID")
(setq ppl (solid->pts el))
)
(t)
)
ppl
)
(defun ybl-pts-box (ptl /)
(list (apply 'mapcar (cons 'min ptl))
(apply 'mapcar (cons 'max ptl))
)
)
(defun ybl-mkwipeout (pts / box vv vy vx pc ps)
(setq box (ybl-pts-box pts)
vv (apply 'mapcar (cons '- box))
pc (mapcar '+ (car box) (mapcar '* vv '(-0.5 -0.5 -0.5)))
ps (mapcar
'(lambda (x)
(mapcar '-
(mapcar '/
(mapcar '- x pc)
(list (abs (car vv)) (abs (car vv)) 1.)
)
'(-0.5 -0.5 0.)
)
)
pts
)
)
(entmake (append
'((0 . "WIPEOUT")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(100 . "AcDbWipeout")
(90 . 0)
(71 . 2)
)
(list (cons 10 (car box))
(cons 11 (list (abs (car vv)) 0. 0.))
(cons 12 (list 0. (abs (car vv)) 0.))
'(13 1. 1. 0.)
)
(list (cons 91 (length pts)))
(mapcar '(lambda (x) (cons 14 x)) ps)
)
)
)
(defun ybl-mkpline (pts tf)
(entmakex
(append
'((0 . "lwpolyline")
(100 . "AcDbEntity")
(100 . "AcDbPolyline")
)
(list (cons 90 (length pts)))
(list (cons 70
(if tf
1
0
)
)
)
(mapcar '(lambda (x) (cons 10 (list (car x) (cadr x)))) pts)
)
)
)
(defun ybl-adlayer (layname color / lyr lst oldlst col)
(setq lyr (vla-add (vla-get-layers doc) layname))
(if (= (type color) 'INT)
(vla-put-color lyr color)
)
(setvar "clayer" layname)
)
(princ "\nSelect pline,arc,circle,spline,ellipse....")
(if (setq
ss (ssget
'((0 . "LWpolyline,arc,circle,ellipse,spline,polyline"))
)
)
(progn
(setq ssl (sslength ss)
i -1
doc (vla-get-activedocument (vlax-get-acad-object))
oldla (getvar "clayer")
)
(vla-startundomark doc)
(setq s1 (ssget "x" '((0 . "wipeout"))))
(ybl-adlayer "wipess" 5)
(vl-catch-all-apply
'(lambda (/ e pl ee s2)
(repeat ssl
(setq e (ssname ss (setq i (1+ i))))
(setq pl (ybl-curve-points e))
(setq ee (cons (ybl-mkpline pl t) ee))
)
(if ee
(progn
(foreach x ee
(command ".wipeout" "p" x "y")
)
(if (and (setq s2 (ssget "x" '((0 . "wipeout"))))
(/= (sslength s2) (sslength s1))
)
(if s1
(progn (command ".select" s2 "r" s1 "")
(command ".draworder" "p" "" "U" ss "")
)
(command ".draworder" s2 "" "U" ss "")
)
)
)
)
)
)
(setvar "clayer" oldla)
(vla-endundomark doc)
)
)
(princ)
)
(princ "\nStart Command With Wipess. eachy[eachy@21cn.com]!"
)
(princ)

(defun c:wipess    (/      ss       ssl        i         pl 
         ybl-curve-points  *MODELSPACE*         DOC      EL 
         OLDLA      PL       X        s         ee          s1 
         s2 
        ) 
  (defun ybl-massoc (code lst / pp) 
    (if    (= (type code) 'LIST) 
      (while lst 
    (if (member (caar lst) code) 
      (setq pp (cons (cdar lst) pp)) 
    ) 
    (setq lst (cdr lst)) 
      ) 
      (while lst 
    (if (= (caar lst) code) 
      (setq pp (cons (cdar lst) pp)) 
    ) 
    (setq lst (cdr lst)) 
      ) 
    ) 
    (reverse pp) 
  ) 
  (defun ybl-curve-points (e         /           ln->pts     arc->pts 
               circle->pts           ell->pts     spl->pts 
               e         el           p     ppl 
               ps         typ       x     pts-divn 
               massoc    pl->pts   solid->pts 
              ) 
    ;;Get Line pts 
    (defun ln->pts (e) 
      (list (vlax-curve-getstartpoint e) 
        (vlax-curve-getendpoint e) 
      ) 
    ) 
    ;; Get arc/circle/ellipse pts 
    (defun arc->pts (e / spa epa an n an0 pt) 
      (setq spa    (vlax-curve-getstartparam e) 
        epa    (vlax-curve-getendparam e) 
        an    (- epa spa) 
        n    (fix (* 16 (/ an pi))) 
      ) 
      (if (< n 2) 
    (setq n 2) 
      ) 
      (setq an0 (/ an n)) 
      (repeat n 
    (setq 
      pt 
       (cons (vlax-curve-getpointatparam e (setq spa (+ spa an0))) 
         pt 
       ) 
    ) 
      ) 
      (cons (vlax-curve-getstartpoint e) (reverse pt)) 
    ) 
    ;;Solid and Trace 
    (defun solid->pts (sl) 
      (list (cdr (assoc 10 el)) 
        (cdr (assoc 11 el)) 
        (cdr (assoc 12 el)) 
        (cdr (assoc 13 el)) 
      ) 
    ) 
    (defun pl->pts (el / e eel pl a b c v r l a spm n aa an m) 
      (setq e    (cdr (assoc -1 el)) 
        eel    (ybl-massoc '(10 42) el) 
        m    0. 
      ) 
      (if (vlax-curve-isclosed e) 
    (setq eel (append eel (list (car eel) 0.))) 
      ) 
      (while eel 
    (mapcar 'set '(a b c) eel) 
    (if (and (zerop b) c) 
      (setq pl (cons a pl)) 
      (progn 
        (setq v   (vlax-curve-getsecondderiv 
            e 
            (vlax-curve-getparamatpoint e a) 
              ) 
          r   (distance '(0. 0. 0.) v) 
          l   (- (vlax-curve-getdistatparam e m) 
             (vlax-curve-getdistatparam e (1+ m)) 
              ) 
          an  (/ l r) 
          spm (vlax-curve-getparamatpoint e a) 
        ) 
        (setq n  (1+ (abs (fix (/ an 0.0981748)))) 
          aa (/ 1. n) 
          pl (cons a pl) 
        ) 
        (repeat (1- n) 
          (setq pl 
             (cons (vlax-curve-getpointatparam e (setq spm (+ spm aa))) 
               pl 
             ) 
          ) 
        ) 
      ) 
    ) 
    (setq eel (cddr eel) 
          m      (1+ m) 
    ) 
      ) 
      (reverse pl) 
    ) 
    ;;3DFace Polygen ... 
    (defun poly->pts (el / getplvertex e typ tf) 
      (defun getplvertex (e diff / n m pl) 
    (setq n    (fix (vlax-curve-getendparam e)) 
          m    0 
    ) 
    (repeat    (if (= diff 1) 
          n 
          (* 2 n) 
        ) 
      (setq    pl (cons (vlax-curve-getpointatparam e m) pl) 
        m  (+ m diff) 
      ) 
    ) 
    (cons (vlax-curve-getendpoint e) pl) 
      ) 
      (setq e    (cdr (assoc -1 el)) 
        typ    (cdr (assoc 70 el)) 
        tf    (vlax-curve-isclosed e) 
      ) 
      (if (= (logand typ 2) 2) ;_ Fit 
    (setq pl (getplvertex e 0.5)) 
    (setq pl (getplvertex e 1)) ;_Spline 
      ) 
      pl 
    ) 
 
    ;;Get Spline points 
    (defun spl->pts (spl / pp pl) 
      (vl-catch-all-apply 
    '(lambda (/ e pts epm p d n m pls ls epm l) 
       (setq e   (cdr (assoc -1 spl)) 
         pts (ybl-massoc 10 spl) 
         epm (vlax-curve-getendparam e) 
       ) 
       (if (assoc 11 spl) 
         (setq p (nth 2 pts)) 
         (setq p (cadr pts)) 
       ) 
       (setq d (distance (vlax-curve-getclosestpointto e p) 
                 p 
           ) 
       ) 
       (if (< d 1.) 
         (setq pp pts) 
         (progn 
           (setq pl 
              (vlax-invoke 
            *modelspace* 
            'addpolyline 
            (apply 'append pts) 
              ) 
           ) 
           (vla-put-type pl acCubicSplinePoly) 
           (setq n (vlax-curve-getendparam pl) 
             m -1 
             l (vlax-curve-getdistatparam pl n) 
           ) 
           (repeat (fix (1+ n)) 
         (setq 
           pls 
            (cons (vlax-curve-getdistatparam pl (setq m (1+ m))) 
              pls 
            ) 
         ) 
           ) 
           (setq ls (mapcar '(lambda (x) (/ x l)) (reverse pls))) 
           (setq 
         pp (mapcar 
              '(lambda (x) 
             (vlax-curve-getpointatparam e (* x epm)) 
               ) 
              ls 
            ) 
           ) 
         ) 
       ) 
     ) 
      ) 
      (if pl 
    (vla-delete pl) 
      ) 
      pp 
    ) 
    (setq el  (entget e) 
      typ (cdr (assoc 0 el)) 
    ) 
    (cond 
      ((= typ "LINE") 
       (setq ppl (ln->pts e)) 
      ) 
      ((member typ '("ARC" "CIRCLE" "ELLIPSE")) 
       (setq ppl (arc->pts e)) 
      ) 
      ((= typ "SPLINE") 
       (setq ppl (spl->pts el)) 
      ) 
      ((= typ "POLYLINE") 
       (setq ppl (poly->pts el)) 
      ) 
      ((= typ "LWPOLYLINE") 
       (setq ppl (pl->pts el)) 
      ) 
      ((= typ "SOLID") 
       (setq ppl (solid->pts el)) 
      ) 
      (t) 
    ) 
    ppl 
  ) 
  (defun ybl-pts-box (ptl /) 
    (list (apply 'mapcar (cons 'min ptl)) 
      (apply 'mapcar (cons 'max ptl)) 
    ) 
  ) 
  (defun ybl-mkwipeout (pts / box vv vy vx pc ps) 
    (setq box (ybl-pts-box pts) 
      vv  (apply 'mapcar (cons '- box)) 
      pc  (mapcar '+ (car box) (mapcar '* vv '(-0.5 -0.5 -0.5))) 
      ps  (mapcar 
        '(lambda (x) 
           (mapcar '- 
               (mapcar '/ 
                   (mapcar '- x pc) 
                   (list (abs (car vv)) (abs (car vv)) 1.) 
               ) 
               '(-0.5 -0.5 0.) 
           ) 
         ) 
        pts 
          ) 
    ) 
    (entmake (append 
           '((0 . "WIPEOUT") 
         (100 . "AcDbEntity") 
         (67 . 0) 
         (410 . "Model") 
         (100 . "AcDbWipeout") 
         (90 . 0) 
         (71 . 2) 
        ) 
           (list (cons 10 (car box)) 
             (cons 11 (list (abs (car vv)) 0. 0.)) 
             (cons 12 (list 0. (abs (car vv)) 0.)) 
             '(13 1. 1. 0.) 
           ) 
           (list (cons 91 (length pts))) 
           (mapcar '(lambda (x) (cons 14 x)) ps) 
         ) 
    ) 
  ) 
  (defun ybl-mkpline (pts tf) 
    (entmakex 
      (append 
    '((0 . "lwpolyline") 
      (100 . "AcDbEntity") 
      (100 . "AcDbPolyline") 
     ) 
    (list (cons 90 (length pts))) 
    (list (cons 70 
            (if    tf 
              1 
              0 
            ) 
          ) 
    ) 
    (mapcar '(lambda (x) (cons 10 (list (car x) (cadr x)))) pts) 
      ) 
    ) 
  ) 
  (defun ybl-adlayer (layname color / lyr lst oldlst col) 
    (setq lyr (vla-add (vla-get-layers doc) layname)) 
    (if    (= (type color) 'INT) 
      (vla-put-color lyr color) 
    ) 
    (setvar "clayer" layname) 
  ) 
  (princ "\nSelect pline,arc,circle,spline,ellipse....") 
  (if (setq 
    ss (ssget 
         '((0 . "LWpolyline,arc,circle,ellipse,spline,polyline")) 
       ) 
      ) 
    (progn 
      (setq ssl      (sslength ss) 
        i      -1 
        doc      (vla-get-activedocument (vlax-get-acad-object)) 
        oldla (getvar "clayer") 
      ) 
      (vla-startundomark doc) 
      (setq s1 (ssget "x" '((0 . "wipeout")))) 
      (ybl-adlayer "wipess" 5) 
      (vl-catch-all-apply 
    '(lambda (/ e pl ee s2) 
       (repeat ssl 
         (setq e (ssname ss (setq i (1+ i)))) 
         (setq pl (ybl-curve-points e)) 
         (setq ee (cons (ybl-mkpline pl t) ee)) 
       ) 
       (if ee 
         (progn 
           (foreach    x ee 
         (command ".wipeout" "p" x "y") 
           ) 
           (if (and    (setq s2 (ssget "x" '((0 . "wipeout")))) 
            (/= (sslength s2) (sslength s1)) 
           ) 
         (if s1 
           (progn (command ".select" s2 "r" s1 "") 
              (command ".draworder" "p" "" "U" ss "") 
           ) 
           (command ".draworder" s2 "" "U" ss "") 
         ) 
           ) 
         ) 
       ) 
     ) 
      ) 
      (setvar "clayer" oldla) 
      (vla-endundomark doc) 
    ) 
  ) 
  (princ) 
) 
(princ "\nStart Command With Wipess. eachy[eachy@21cn.com]!" 
) 
(princ)

[/sell]

/db_自贡黄明儒_ · 发表于 2013-7-13 21:49:35

05版以前，这是有相当大的用处的。今天仍然具有。。。

Lisphk · 发表于 2013-7-13 23:13:06

eachy大师，XDRX API里面替代的是什么函数？

GTJ116600 · 发表于 2013-7-14 05:24:32

呵呵，坐坐地板

清风明月10 · 发表于 2013-7-14 09:18:23

有什么作用不清楚，试用后发现它是将封闭线变为光栅图像，但这样的光栅图像又有什么作用呢？我不知道，有知道的能解释一下吗？
它可不是真正的图片啊！

Free-Lancer · 发表于 2013-7-14 09:42:32

是遮盖，wipeout来自: Android客户端

XDSoft · 发表于 2013-7-14 12:02:33

清风明月10 发表于 2013-7-14 09:18
有什么作用不清楚，试用后发现它是将封闭线变为光栅图像，但这样的光栅图像又有什么作用呢？我不知道，有知 ...

这个图像可以盖住其他内容，你在其它想要的放在光栅图上面，相当于把下面的内容裁剪了。不是真正的裁剪，你移动走光栅，又显示出来了。

清风明月10 · 发表于 2013-7-14 13:44:23

谢谢解答！

Free-Lancer · 发表于 2013-7-14 14:28:51

LZ的模拟中精度值得商榷，lisp中对弧线模拟一般都是等距模拟，按显示出现矢高比的至少我没有见到，所以这个遮罩还是有瑕疵来自: Android客户端

flowerson · 发表于 2013-7-15 14:41:20

是怎样用的呢？是说ssget的方法吗？

eachy · 发表于 2013-7-15 14:43:55

flowerson 发表于 2013-7-15 14:41
是怎样用的呢？是说ssget的方法吗？

是对曲线增加一个遮罩，wipeout

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

[每日一码] Wipeout Ssget

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

点评

点评