(XD::Doc:GetRectang)动态拖动画矩形向量

newer · 发表于 2016-5-28 11:13:52

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

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

×

本帖最后由 newer 于 2016-5-28 14:01 编辑

(defun XD::Doc:GetRectang (info pts clr / con dis dynpt flag ins lastPnts
msg myerr olderr p1 p2 p3 p4 pts1 ret vec
xdir ydir RecCallback1 RecCallback2
)
(defun RecCallback1 (dynpt /)
(redraw)
(setq ins (car (xd::pnts:orthoproject (list dynpt) p1 p2)))
(setq vec (mapcar
'-
dynpt
ins
)
)
(if (not lastPnts)
(setq lastPnts (cons dynpt lastPnts))
(setq lastPnts (list dynpt (car lastPnts)))
)
(setq p3 (mapcar
'+
p2
vec
)
p4 (mapcar
'+
p1
vec
)
pts1 (list p1 p2 p3 p4)
)
(apply
'xdrx_grdraw
(append
(list clr con)
(xd::pnts:close pts1)
)
)
p3
)
(defun RecCallback2 (dynpt /)
(redraw)
(setq p3 dynpt
p2 (mapcar
'+
p1
xdir
)
p2 (car (xd::pnts:orthoproject (list p3) p1 p2))
p4 (car (xd::pnts:orthoproject (list p3) p1 (mapcar
'+
p1
ydir
)
)
)
)
(if (not lastPnts)
(setq lastPnts (cons dynpt lastPnts))
(setq lastPnts (list dynpt (car lastPnts)))
)
(xdrx_grdraw clr con p1 p2 p3 p4 p1)
dynpt
)
(defun myerr (msg)
(princ (strcat "\n" msg))
(setq *error* myerr)
(redraw)
(xdrx_end)
(XD::Doc:Command (list ".undo" 1))
)
(setq olderr *error*)
(setq *error* myerr)
(xdrx_begin)
(setq p1 (car pts)
p2 (cadr pts)
flag 0
)
(setq p1 (trans p1 1 0))
(if p2
(setq p2 (trans p2 1 0))
)
(setq xdir (getvar "ucsxdir")
ydir (getvar "ucsydir")
)
(setvar "lastPoint" (trans p1 0 1))
(if p2
(progn
(setq flag 1)
)
)
(if (not clr)
(setq clr 1)
)
(if (minusp clr)
(setq con 0
clr (abs clr)
)
(setq con 1)
)
(xdrx_pointmonitor (if (= flag 1)
"RecCallback1"
"RecCallback2"
)
)
(setq ret (getpoint info))
(xdrx_pointmonitor)
(cond
((= (type ret) 'STR))
((= (type ret) 'LIST)
(if (not (equal (last lastpnts) (trans ret 1 0) 1e-3))
(progn
(if (cadr pts)
(progn
(setq dis (distance ret (trans p1 0 1))
ins (car (xd::pnts:orthoproject (list (trans ret 1 0))
p1 p2
)
)
)
(setq vec (mapcar
'-
(trans ret 1 0)
ins
)
)
(setq vec (xdrx_vector_product (xdrx_vector_normalize vec) dis)
p3 (mapcar
'+
p2
vec
)
p4 (mapcar
'+
p1
vec
)
)
)
)
)
)
(setq ret (xd::pnts:wcs2ucs (list p1 p2 p3 p4)))
)
)
(redraw)
(setq *error* olderr)
(xdrx_end)
ret
)

(defun XD::Doc:GetRectang (info pts clr / con dis dynpt flag ins lastPnts 
                                msg myerr olderr p1 p2 p3 p4 pts1 ret vec 
                                xdir ydir RecCallback1 RecCallback2 
                          ) 
  (defun RecCallback1 (dynpt /) 
    (redraw) 
    (setq ins (car (xd::pnts:orthoproject (list dynpt) p1 p2))) 
    (setq vec (mapcar 
                '- 
                dynpt 
                ins 
              ) 
    ) 
    (if (not lastPnts) 
      (setq lastPnts (cons dynpt lastPnts)) 
      (setq lastPnts (list dynpt (car lastPnts))) 
    ) 
    (setq p3 (mapcar 
               '+ 
               p2 
               vec 
             ) 
          p4 (mapcar 
               '+ 
               p1 
               vec 
             ) 
          pts1 (list p1 p2 p3 p4) 
    ) 
    (apply 
      'xdrx_grdraw 
      (append 
        (list clr con) 
        (xd::pnts:close pts1) 
      ) 
    ) 
    p3 
  ) 
  (defun RecCallback2 (dynpt /) 
    (redraw) 
    (setq p3 dynpt 
          p2 (mapcar 
               '+ 
               p1 
               xdir 
             ) 
          p2 (car (xd::pnts:orthoproject (list p3) p1 p2)) 
          p4 (car (xd::pnts:orthoproject (list p3) p1 (mapcar 
                                                        '+ 
                                                        p1 
                                                        ydir 
                                                      ) 
                  ) 
             ) 
    ) 
    (if (not lastPnts) 
      (setq lastPnts (cons dynpt lastPnts)) 
      (setq lastPnts (list dynpt (car lastPnts))) 
    ) 
    (xdrx_grdraw clr con p1 p2 p3 p4 p1) 
    dynpt 
  ) 
  (defun myerr (msg) 
    (princ (strcat "\n" msg)) 
    (setq *error* myerr) 
    (redraw) 
    (xdrx_end) 
    (XD::Doc:Command (list ".undo" 1)) 
  ) 
  (setq olderr *error*) 
  (setq *error* myerr) 
  (xdrx_begin) 
  (setq p1 (car pts) 
        p2 (cadr pts) 
        flag 0 
  )                                      
  (setq p1 (trans p1 1 0)) 
  (if p2 
    (setq p2 (trans p2 1 0)) 
  ) 
  (setq xdir (getvar "ucsxdir") 
        ydir (getvar "ucsydir") 
  ) 
  (setvar "lastPoint" (trans p1 0 1)) 
  (if p2 
    (progn 
      (setq flag 1) 
    ) 
  ) 
  (if (not clr) 
    (setq clr 1) 
  ) 
  (if (minusp clr) 
    (setq con 0 
          clr (abs clr) 
    ) 
    (setq con 1) 
  ) 
  (xdrx_pointmonitor (if (= flag 1) 
                       "RecCallback1" 
                       "RecCallback2" 
                     ) 
  ) 
  (setq ret (getpoint info)) 
  (xdrx_pointmonitor) 
  (cond 
    ((= (type ret) 'STR)) 
    ((= (type ret) 'LIST) 
      (if (not (equal (last lastpnts) (trans ret 1 0) 1e-3)) 
        (progn 
          (if (cadr pts) 
            (progn 
              (setq dis (distance ret (trans p1 0 1)) 
                    ins (car (xd::pnts:orthoproject (list (trans ret 1 0)) 
                                                    p1 p2 
                             ) 
                        ) 
              ) 
              (setq vec (mapcar 
                          '- 
                          (trans ret 1 0) 
                          ins 
                        ) 
              ) 
              (setq vec (xdrx_vector_product (xdrx_vector_normalize vec) dis) 
                    p3 (mapcar 
                         '+ 
                         p2 
                         vec 
                       ) 
                    p4 (mapcar 
                         '+ 
                         p1 
                         vec 
                       ) 
              ) 
            ) 
          ) 
        ) 
      ) 
      (setq ret (xd::pnts:wcs2ucs (list p1 p2 p3 p4))) 
    ) 
  ) 
  (redraw) 
  (setq *error* olderr) 
  (xdrx_end) 
  ret 
)

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

[[coior=red]文档类] (XD::Doc:GetRectang)动态拖动画矩形向量

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