动态收缩Pline边

eachy · 发表于 2013-10-21 07:07:27

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

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

×

以下程序尚未完成，贴上来供大家研讨
问题：1 去点部分还有问题；2 未考虑弧段部分；3 只能收缩恢复部分没有写

(defun XD::Polylie:NearIndex (e pnt / pam num)
(setq pam (xdrx_curve_getparamatpoint e pnt)
num (xdrx_polyline_numverts e)
pam (fix (+ pam 0.5))
)
(if (= pam num)
0
pam
)
)
(defun *error*_New (msg)
(setq *error* *error*_Old)
(if (wcmatch (strcase msg t) "*break,*cancel*,*exit*,*取消*")
(if (= (getvar "LOCALE") "CHS")
(princ "\n用户按了<Esc>强制退出")
(princ "\nYou cancelled The operation!")
)
(princ (strcat "\n" msg))
)
(if pt
(xdrx_entity_delete pt)
)
(if color
(xdrx_entity_setproperty e "color" color)
)
(xdrx_PointMonitor)
(xdrx_end)
(princ)
)
(defun c:tt (/ callback e index p0 e pt
color ne v p1 p2 pn orindex
index1 index2
)
(defun callback (dynpt / ResetPntAt pts ptsindex)
(defun ResetPntAt (e lst index pt / il)
(if (< (car lst) index (cadr lst))
(progn
(xdrx_polyline_setpointat ne index pt)
(setq il lst)
)
(progn
;;以下有问题!
(xdrx_polyline_removevertexat ne index)
(xdrx_polyline_compress ne)
;;(xdrx_polyline_reset ne)
(setq il (XD::PolyLine:-Index+
ne
(XD::Polylie:NearIndex ne pt)
)
)
)
)
il
)
;;main dyn
(if
(and (setq pts (xdrx_curve_getinters
(list dynpt (mapcar '+ dynpt v))
ne
1
)
)
(= (length pts) 2)
(setq
ptsIndex (mapcar '(lambda (x) (XD::Polylie:NearIndex ne x))
pts
)
)
(not (apply 'equal ptsindex))
)
(progn
(setq index1 (ResetPntAt ne index1 (car ptsIndex) (car pts)))
(setq index2 (ResetPntAt ne index2 (cadr ptsIndex) (cadr pts)))
)
)
)
;;main program
(setq *error*_Old *error*) ;save the *error* handle
(setq *error* *error*_New) ;set a new *error* handle
(xdrx_begin)
(if (setq e (xdrx_entsel "\nPick pline: " '((0 . "lwpolyline"))))
(progn
(xdrx_polyline_compress e)
(setq index (fix (apply 'xdrx_curve_getparamatpoint e))
p0 (cadr e)
e (car e)
pt (xdrx_point_make (xdrx_curve_getpointatparam e p0))
color (xdrx_getpropertyvalue e "color")
ne (ssname
(xdrx_entity_transformedcopy e (xdrx_matrix_identity 3))
0
)
)
(xdrx_setpropertyvalue e "color" '(0 0 0))
(mapcar 'set '(p1 p2) (xdrx_polyline_getlinesegat e index))
(setq v (mapcar '- p2 p1)
index1 (XD::PolyLine:-Index+
e
(fix (xdrx_curve_getparamatpoint e p1))
)
index2 (XD::PolyLine:-Index+
e
(fix (xdrx_curve_getparamatpoint e p2))
)
)
(setq ret (xdrx_pointmonitor "Callback" pt))
(setq pn (getpoint p0 "\nNext point: "))
(xdrx_pointmonitor)
(xdrx_entity_delete pt)
(xdrx_entity_setproperty e "color" color)
)
)
(xdrx_end)
(princ)
)

(defun XD::Polylie:NearIndex (e pnt / pam num) 
  (setq    pam (xdrx_curve_getparamatpoint e pnt) 
    num (xdrx_polyline_numverts e) 
    pam (fix (+ pam 0.5)) 
  ) 
  (if (= pam num) 
    0 
    pam 
  ) 
) 
(defun *error*_New (msg) 
  (setq *error* *error*_Old) 
  (if (wcmatch (strcase msg t) "*break,*cancel*,*exit*,*取消*") 
    (if    (= (getvar "LOCALE") "CHS") 
      (princ "\n用户按了<Esc>强制退出") 
      (princ "\nYou cancelled The operation!") 
    ) 
    (princ (strcat "\n" msg)) 
  ) 
  (if pt 
    (xdrx_entity_delete pt) 
  ) 
  (if color 
    (xdrx_entity_setproperty e "color" color) 
  ) 
  (xdrx_PointMonitor) 
  (xdrx_end) 
  (princ) 
) 
(defun c:tt (/        callback      e     index    p0     e      pt 
         color  ne       v      p1     p2    pn     orindex 
         index1 index2 
        ) 
 
  (defun callback (dynpt / ResetPntAt pts ptsindex) 
    (defun ResetPntAt (e lst index pt / il) 
      (if (< (car lst) index (cadr lst)) 
    (progn 
      (xdrx_polyline_setpointat ne index pt) 
      (setq il lst) 
    ) 
    (progn 
      ;;以下有问题! 
      (xdrx_polyline_removevertexat ne index) 
      (xdrx_polyline_compress ne) 
      ;;(xdrx_polyline_reset ne) 
      (setq    il (XD::PolyLine:-Index+ 
             ne 
             (XD::Polylie:NearIndex ne pt) 
           ) 
      ) 
    ) 
      ) 
      il 
    ) 
    ;;main dyn 
    (if 
      (and (setq pts (xdrx_curve_getinters 
               (list dynpt (mapcar '+ dynpt v)) 
               ne 
               1 
             ) 
       ) 
       (= (length pts) 2) 
       (setq 
         ptsIndex (mapcar '(lambda (x) (XD::Polylie:NearIndex ne x)) 
                  pts 
              ) 
       ) 
       (not (apply 'equal ptsindex)) 
      ) 
       (progn 
     (setq index1 (ResetPntAt ne index1 (car ptsIndex) (car pts))) 
     (setq index2 (ResetPntAt ne index2 (cadr ptsIndex) (cadr pts))) 
       ) 
    ) 
  ) 
  ;;main program 
  (setq *error*_Old *error*)        ;save the *error* handle 
  (setq *error* *error*_New)        ;set a new *error* handle 
  (xdrx_begin) 
  (if (setq e (xdrx_entsel "\nPick pline: " '((0 . "lwpolyline")))) 
    (progn 
      (xdrx_polyline_compress e) 
      (setq index (fix (apply 'xdrx_curve_getparamatpoint e)) 
        p0      (cadr e) 
        e      (car e) 
        pt      (xdrx_point_make (xdrx_curve_getpointatparam e p0)) 
        color (xdrx_getpropertyvalue e "color") 
        ne      (ssname 
            (xdrx_entity_transformedcopy e (xdrx_matrix_identity 3)) 
            0 
          ) 
      ) 
      (xdrx_setpropertyvalue e "color" '(0 0 0)) 
      (mapcar 'set '(p1 p2) (xdrx_polyline_getlinesegat e index)) 
      (setq v       (mapcar '- p2 p1) 
        index1 (XD::PolyLine:-Index+ 
             e 
             (fix (xdrx_curve_getparamatpoint e p1)) 
           ) 
        index2 (XD::PolyLine:-Index+ 
             e 
             (fix (xdrx_curve_getparamatpoint e p2)) 
           ) 
      ) 
      (setq ret (xdrx_pointmonitor "Callback" pt)) 
      (setq pn (getpoint p0 "\nNext point: ")) 
      (xdrx_pointmonitor) 
      (xdrx_entity_delete pt) 
      (xdrx_entity_setproperty e "color" color) 
    ) 
  ) 
  (xdrx_end) 
  (princ) 
)

Free-Lancer · 发表于 2013-10-21 09:28:56

遇到节点时要Remove一个

liuyj · 发表于 2013-10-21 14:18:08

捕捉功能好像没有多大意义，因为始终在自己身上。关了捕捉就和grread效果一样了

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

[研讨] 动态收缩Pline边

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

相关帖子