(XD::Drag:GMove)点监视器实现的通用拖动函数

newer · 发表于 2016-5-25 13:18:45

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

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

×

前几天Lispboy写了个GETPOINT的点监视器实现代码，但只能取点。
受启发，在此基础上修改，增加了回调函数做成通用的点监视器实现的拖动函数。

(defun XD::Drag:GMove (basePnt info clr vec bothsides callback / basePnt2 basePnt3 con dis dis2 dis3 dynpt msg myerr
olderr pt pt1 pt2 pt3 v x-dir x-project y-dir
)
(defun myerr (msg)
(princ (strcat "\n" msg))
(xdrx_pointmonitor)
(redraw)
(setq *error* olderr)
(princ)
)
(defun _drawOrthoVec (x-dir y-dir)
(setq basePnt2 (mapcar
'+
basePnt
(trans x-dir 0 1 2)
)
basePnt3 (mapcar
'+
basePnt
(trans y-dir 0 1 2)
)
pt2 (XD::Pnts:OrthoProject (list dynpt) (trans basePnt 1 0)
(trans basePnt2 1 0)
)
dis2 (distance dynpt (car pt2))
pt3 (XD::Pnts:OrthoProject (list dynpt) (trans basePnt 1 0)
(trans basePnt3 1 0)
)
dis3 (distance dynpt (car pt3))
)
(if (< dis2 dis3)
(setq pt (car pt2)
x-project (trans x-dir 0 1 2)
basePnt2 basePnt2
)
(setq pt (car pt3)
x-project (trans y-dir 0 1 2)
basePnt2 basePnt3
)
)
pt
)
(defun _#XD::Drag:InCallback (dynpt)
(redraw)
(if vec
(progn
(if (and (= 1 (XD::SYMBOL:Get '#XD-GLOBALVAR-DRAG-FREEORTHO))
(= (getvar "orthomode") 0)
)
(progn
(setq pt dynpt
x-project nil
)
)
(if (not bothsides)
(progn
(setq v (xdrx_vector_normalize (mapcar
'-
dynpt
(trans basePnt 1 0)
)
)
)
(setq x-project vec
pt (car (XD::Pnts:OrthoProject (list dynpt)
(trans basePnt 1 0)
(trans basePnt2 1 0)
)
)
)
)
(progn
(setq x-dir vec
y-dir (xdrx_vector_perpvector x-dir)
)
(setq pt (_drawOrthoVec x-dir y-dir))
)
)
)
)
(progn
(if (= 0 (getvar "orthomode"))
(setq pt dynpt
x-project nil
)
(progn
(setq x-dir (getvar "ucsxdir")
y-dir (getvar "ucsydir")
)
(setq pt (_drawOrthoVec x-dir y-dir))
)
)
)
)
(if (/= 0 clr)
(xdrx_grdraw clr con (trans basePnt 1 0) pt)
)
(if (not lastPnts)
(progn
(setq lastPnts (cons dynpt lastPnts))
(setvar "users1" (vl-prin1-to-string dynpt))
)
(progn
(setq lastPnts (list dynpt (car lastPnts)))
(setvar "users2" (vl-prin1-to-string (cadr lastpnts)))
(setvar "users1" (vl-prin1-to-string dynpt))
)
)
(if (= (type (eval (read callback))) 'SUBR)
(eval (list (read callback) (read "pt")))
)
(princ)
)
(if (minusp clr)
(setq con 0
clr (abs clr)
)
(setq con 1)
)
(setq olderr *error*)
(setq *error* myerr)
(if (not callback)
(setq callback "")
)
(xdrx_pointmonitor "_#XD::Drag:InCallback")
(setvar "lastpoint" basePnt)
(setq basePnt2 (mapcar
'+
basePnt
vec
)
)
(if (setq dis (getpoint info))
(progn
(cond
((= (type dis) 'LIST)
(if (not (equal (car lastPnts) (cadr lastPnts) 1e-3))
(progn
(if x-project
(progn
(setq pt1 (XD::Pnts:OrthoProject (list (car lastPnts))
(trans basePnt 1 0)
(trans basePnt2 1 0)
)
x-project (xdrx_vector_normalize (mapcar
'-
(trans
(car pt1)
0 1
)
basePnt
)
)
pt1 (mapcar
'+
basePnt
(xdrx_vector_product x-project
(distance (car lastPnts)
(trans basePnt
1 0
)
)
)
)
)
)
(setq pt1 (trans pt 0 1))
)
)
(setq pt1 (trans pt 0 1))
)
)
((= (type dis) 'STR)
(setq pt1 dis)
)
)
)
(setq pt1 nil)
)
(xdrx_pointmonitor)
(setq *error* olderr)
(redraw)
pt1
)

(defun XD::Drag:GMove (basePnt info clr vec bothsides callback / basePnt2                               basePnt3 con dis dis2 dis3 dynpt msg myerr 
                               olderr pt pt1 pt2 pt3 v x-dir x-project y-dir 
                      ) 
  (defun myerr (msg) 
    (princ (strcat "\n" msg)) 
    (xdrx_pointmonitor) 
    (redraw) 
    (setq *error* olderr) 
    (princ) 
  ) 
  (defun _drawOrthoVec (x-dir y-dir) 
    (setq basePnt2 (mapcar 
                     '+ 
                     basePnt 
                     (trans x-dir 0 1 2) 
                   ) 
          basePnt3 (mapcar 
                     '+ 
                     basePnt 
                     (trans y-dir 0 1 2) 
                   ) 
          pt2 (XD::Pnts:OrthoProject (list dynpt) (trans basePnt 1 0) 
                                     (trans basePnt2 1 0) 
              ) 
          dis2 (distance dynpt (car pt2)) 
          pt3 (XD::Pnts:OrthoProject (list dynpt) (trans basePnt 1 0) 
                                     (trans basePnt3 1 0) 
              ) 
          dis3 (distance dynpt (car pt3)) 
    ) 
    (if (< dis2 dis3) 
      (setq pt (car pt2) 
            x-project (trans x-dir 0 1 2) 
            basePnt2 basePnt2 
      ) 
      (setq pt (car pt3) 
            x-project (trans y-dir 0 1 2) 
            basePnt2 basePnt3 
      ) 
    ) 
    pt 
  ) 
  (defun _#XD::Drag:InCallback (dynpt) 
    (redraw) 
    (if vec 
      (progn 
        (if (and (= 1 (XD::SYMBOL:Get '#XD-GLOBALVAR-DRAG-FREEORTHO)) 
                 (= (getvar "orthomode") 0) 
            ) 
          (progn 
            (setq pt dynpt 
                  x-project nil 
            ) 
          ) 
          (if (not bothsides) 
            (progn 
              (setq v (xdrx_vector_normalize (mapcar 
                                               '- 
                                               dynpt 
                                               (trans basePnt 1 0) 
                                             ) 
                      ) 
              ) 
              (setq x-project vec 
                    pt (car (XD::Pnts:OrthoProject (list dynpt) 
                                                   (trans basePnt 1 0) 
                                                   (trans basePnt2 1 0) 
                            ) 
                       ) 
              ) 
            ) 
            (progn 
              (setq x-dir vec 
                    y-dir (xdrx_vector_perpvector x-dir) 
              ) 
              (setq pt (_drawOrthoVec x-dir y-dir)) 
            ) 
          ) 
        ) 
      ) 
      (progn 
        (if (= 0 (getvar "orthomode")) 
          (setq pt dynpt 
                x-project nil 
          ) 
          (progn 
            (setq x-dir (getvar "ucsxdir") 
                  y-dir (getvar "ucsydir") 
            ) 
            (setq pt (_drawOrthoVec x-dir y-dir)) 
          ) 
        ) 
      ) 
    ) 
    (if (/= 0 clr) 
      (xdrx_grdraw clr con (trans basePnt 1 0) pt) 
    ) 
    (if (not lastPnts) 
      (progn 
        (setq lastPnts (cons dynpt lastPnts)) 
        (setvar "users1" (vl-prin1-to-string dynpt)) 
      ) 
      (progn 
        (setq lastPnts (list dynpt (car lastPnts))) 
        (setvar "users2" (vl-prin1-to-string (cadr lastpnts))) 
        (setvar "users1" (vl-prin1-to-string dynpt)) 
      ) 
    ) 
    (if (= (type (eval (read callback))) 'SUBR) 
      (eval (list (read callback) (read "pt"))) 
    ) 
    (princ) 
  ) 
  (if (minusp clr) 
    (setq con 0 
          clr (abs clr) 
    ) 
    (setq con 1) 
  ) 
  (setq olderr *error*) 
  (setq *error* myerr) 
  (if (not callback) 
    (setq callback "") 
  ) 
  (xdrx_pointmonitor "_#XD::Drag:InCallback") 
  (setvar "lastpoint" basePnt) 
  (setq basePnt2 (mapcar 
                   '+ 
                   basePnt 
                   vec 
                 ) 
  ) 
  (if (setq dis (getpoint info)) 
    (progn 
      (cond 
        ((= (type dis) 'LIST) 
          (if (not (equal (car lastPnts) (cadr lastPnts) 1e-3)) 
            (progn 
              (if x-project 
                (progn 
                  (setq pt1 (XD::Pnts:OrthoProject (list (car lastPnts)) 
                                                   (trans basePnt 1 0) 
                                                   (trans basePnt2 1 0) 
                            ) 
                        x-project (xdrx_vector_normalize (mapcar 
                                                           '- 
                                                           (trans 
                                                                  (car pt1) 
                                                                  0 1 
                                                           ) 
                                                           basePnt 
                                                         ) 
                                  ) 
                        pt1 (mapcar 
                              '+ 
                              basePnt 
                              (xdrx_vector_product x-project 
                                                   (distance (car lastPnts) 
                                                             (trans basePnt 
                                                                    1 0 
                                                             ) 
                                                   ) 
                              ) 
                            ) 
                  ) 
                ) 
                (setq pt1 (trans pt 0 1)) 
              ) 
            ) 
            (setq pt1 (trans pt 0 1)) 
          ) 
        ) 
        ((= (type dis) 'STR) 
          (setq pt1 dis) 
        ) 
      ) 
    ) 
    (setq pt1 nil) 
  ) 
  (xdrx_pointmonitor) 
  (setq *error* olderr) 
  (redraw) 
  pt1 
)

newer · 发表于 2016-5-25 13:28:56

具体的应用例子见： http://bbs.xdcad.net/thread-704336-1-1.html

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

[拖动] (XD::Drag:GMove)点监视器实现的通用拖动函数

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