(XD::DOC:GetPoint)增强型的GETPOINT，支持方向约束

Lispboy · 发表于 2016-5-23 22:01:12

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

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

×

(defun XD::DOC:GetPoint (basePnt info clr ydir bothsides / basePnt3 dis
basepnt2 dis2 dis3 dynpt lastPnts msg myerr
olderr pt pt1 pt2 pt3 v x-dir x-project
y-dir _callback con _drawOrthoVec
)
(defun myerr (msg)
(princ (strcat "\n" msg))
(xdrx_pointmonitor)
(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 _callback (dynpt)
(redraw)
(if ydir
(progn
(if (and (= 1 (XD::SYMBOL:Get '#XD-GLOBALVAR-DRAG-FREEORTHO))
(= (getvar "orthomode") 0)
)
(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 (not bothsides)
(progn
(setq v (xdrx_vector_normalize (mapcar
'-
dynpt
(trans basePnt 1 0)
)
)
)
(setq x-project ydir
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))
)
)
)
)
(xdrx_grdraw clr con (trans basePnt 1 0) pt)
(if (not lastPnts)
(setq lastPnts (cons dynpt lastPnts))
(setq lastPnts (list dynpt (car lastPnts)))
)
(princ)
)
(setq olderr *error*)
(setq *error* myerr)
(xdrx_pointmonitor "_callback")
(setvar "lastpoint" basePnt)
(setq basePnt2 (mapcar
'+
basePnt
(xdrx_vector_normalize ydir)
)
)
(if (not clr)
(setq clr 1)
)
(if (minusp clr)
(setq con 0
clr (abs clr)
)
(setq con 1)
)
(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::DOC:GetPoint (basePnt info clr ydir bothsides / basePnt3 dis 
                                 basepnt2 dis2 dis3 dynpt lastPnts msg myerr 
                                 olderr pt pt1 pt2 pt3 v x-dir x-project 
                                 y-dir _callback con _drawOrthoVec 
                        ) 
  (defun myerr (msg) 
    (princ (strcat "\n" msg)) 
    (xdrx_pointmonitor) 
    (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 _callback (dynpt) 
    (redraw) 
    (if ydir 
      (progn 
        (if (and (= 1 (XD::SYMBOL:Get '#XD-GLOBALVAR-DRAG-FREEORTHO)) 
                 (= (getvar "orthomode") 0) 
            ) 
          (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 (not bothsides) 
            (progn 
              (setq v (xdrx_vector_normalize (mapcar 
                                               '- 
                                               dynpt 
                                               (trans basePnt 1 0) 
                                             ) 
                      ) 
              ) 
              (setq x-project ydir 
                    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)) 
          ) 
        ) 
      ) 
    ) 
    (xdrx_grdraw clr con (trans basePnt 1 0) pt) 
    (if (not lastPnts) 
      (setq lastPnts (cons dynpt lastPnts)) 
      (setq lastPnts (list dynpt (car lastPnts))) 
    ) 
    (princ) 
  ) 
  (setq olderr *error*) 
  (setq *error* myerr) 
  (xdrx_pointmonitor "_callback") 
  (setvar "lastpoint" basePnt) 
  (setq basePnt2 (mapcar 
                   '+ 
                   basePnt 
                   (xdrx_vector_normalize ydir) 
                 ) 
  ) 
  (if (not clr) 
    (setq clr 1) 
  ) 
  (if (minusp clr) 
    (setq con 0 
          clr (abs clr) 
    ) 
    (setq con 1) 
  ) 
  (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 
)

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

[[coior=red]文档类] (XD::DOC:GetPoint)增强型的GETPOINT，支持方向约束

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