Lisp - проблема с получением точки?

Lisp - проблема с получением точки? · 08.09.2006, 13:08

Мой вариант получения точки, к сожалению, работает только на виде "сверху" или "снизу".
Есть несколько вопросов:
1. Как сделать работу в любой системе координат, с корректным построением временного отрезка?
2. Как отследить клавиатурный ввод?
Собственно код:

Код:

[Выделить все]

;|
*    Получение точки от базовой под переданным углом (радиан). Получение
* идет с построением временного отрезка. проверено только в WCS
*    Параметры вызова:
*	start-point	начальная точка. nil -> вводится пользователем
*	ang		угол, под которым выполнять "вычисление" точки
*			Возможно указание "диапазона" углов списком (в радианах)
*		вида:
	      '(("ucs" . t)	; учитывать или нет возможные повороты ucs
		("base" . 0.)	; "базовый" угол, вдоль которого вычислять точку
				; При установленной ucs за 0 принимается угол поворота текущей ucs
				; nil -> определяется пользователем
		("step" . pi)	; "шаг" смещений.
*    Примеры вызова:
(_kpblc-get-point-with-start-and-angle nil nil)
(_kpblc-get-point-with-start-and-angle nil '(("ucs" . t)))
(_kpblc-get-point-with-start-and-angle nil '(("ucs" . t) ("base" . 0.)))
(_kpblc-get-point-with-start-and-angle nil (list '("ucs" . t) (cons "base" (/ pi 2.)) (cons "step" (/ pi 4.))))
(_kpblc-get-point-with-start-and-angle '(0. 0. 0.) (list '("ucs" . t) (cons "base" (/ pi 2.)) (cons "step" (/ pi 4.))))
|;

(defun _kpblc-get-point-with-start-and-angle (start-point  ang
					      /		   loc:deltemp
					      *error*	   ent_temp
					      ucs_angle	   res
					      rot_angle	   rot_steps
					      )
  (defun loc:deltemp ()
    (if	(and ent_temp (not (vlax-erased-p (_kpblc-conv-ent-to-vla ent_temp))))
      (entdel ent_temp)
      ) ;_ end of if
    ) ;_ end of defun
  (defun *error* (msg)
    (loc:deltemp)
    (princ msg)
    (princ)
    ) ;_ end of defun

  (if (not start-point)
    (setq start-point (getpoint "Укажите начальную точку <Выход> : "))
    ) ;_ end of if
  (if start-point
    (progn
      (entmake (list (cons 0 "LINE")
		     (cons 10 (trans start-point 1 0))
		     (cons 11
			   (list (1+ (car (trans start-point 1 0)))
				 (cadr (trans start-point 1 0))
				 (caddr (trans start-point 1 0))
				 ) ;_ end of list
			   ) ;_ end of cons
		     ) ;_ end of list
	       ) ;_ end of entmake
      (setq ent_temp (entlast))
      (while (and (setq res (grread 3 0)) (= (car res) 5))
	(setq res	(cadr res)
	      ucs_angle	(if (cdr (assoc "ucs" ang))
			  (angle (getvar "ucsorg")
				 (mapcar '+ (getvar "ucsorg") (getvar "ucsxdir"))
				 ) ;_ end of angle
			  0.
			  ) ;_ end of if
	      rot_angle	(angle (trans start-point 1 0) (trans res 1 0))
	      ) ;_ end of setq
	(if (cdr (assoc "base" ang))
	  (progn
	    (setq ucs_angle (+ ucs_angle (cdr (assoc "base" ang))))
	    (if	(cdr (assoc "step" ang))
	      (repeat (atoi (rtos (/ (* 2 pi) (cdr (assoc "step" ang)))))
		(setq rot_steps
		       (append
			 rot_steps
			 (list
			   (if rot_steps
			     (+ (last rot_steps) (cdr (assoc "step" ang)))
			     (cdr (assoc "step" ang))
			     ) ;_ end of if
			   ) ;_ end of list
			 ) ;_ end of append
		      ) ;_ end of setq
		) ;_ end of REPEAT
	      ) ;_ end of if
	    ) ;_ end of progn
	  ) ;_ end of if
	(if rot_steps
	  (setq	ucs_angle (car (vl-sort	rot_steps
					'(lambda (a b)
					   (< (abs (- rot_angle a))
					      (abs (- rot_angle b))
					      ) ;_ end of <
					   ) ;_ end of lambda
					) ;_ end of vl-sort
			       ) ;_ end of car
		) ;_ end of setq
	  ) ;_ end of if
	(_kpblc-ent-modify-autoregen
	  ent_temp
	  11
	  (if (cdr (assoc "base" ang))
	    (polar
	      (trans start-point 1 0)
	      ucs_angle
	      (* (cos
		   (- rot_angle ucs_angle)
		   ) ;_ end of cos
		 (distance (trans start-point 1 0) (trans res 1 0))
		 ) ;_ end of *
	      ) ;_ end of polar
	    (trans res 1 0)
	    ) ;_ end of if
	  t
	  ) ;_ end of _kpblc-ent-modify-autoregen
	) ;_ end of while
      ) ;_ end of progn
    ) ;_ end of if
  (loc:deltemp)
  (cond
    ((= (car res) 2)
     (_kpblc-get-point-with-start-and-angle start-point ang)
     )
    ((= (car res) 3)
     (trans (cadr res) 1 0)
     )
    (t nil)
    ) ;_ end of cond
  ) ;_ end of defun

Использует функцию модификации примитива

Код:

[Выделить все]

;|=============================================================================
*    Функция модификации указанного бита примитива
*    Параметры вызова:
*	entity	- примитив, полученный через (entsel), (entlast) etc
*	bit	- dxf-код, значение которого надо установить
*	value	- новое значение
*	regen	- выполнять или нет регенерацию примитива сразу. t/ nil
*    Примеры вызова:
(_kpblc-ent-modify (entlast) 8 "0" t)	; перенести последний примитив на слой 0
(_kpblc-ent-modify (entsel) 62 10 nil)	; установить выбранному примитиву цвет 10
*    Возвращаемое значение:
*	примитив с модифицированным dxf-списком. Примитив перерисовывается в
* зависимости от значения ключа ext_regen
=============================================================================|;
(defun _kpblc-ent-modify-autoregen (ent	       bit	  value	     ext_regen
				    /	       ent_list	  old_dxf    new_dxf
				    layer_dxf70
				    )
  (setq ent (_kpblc-conv-ent-to-ename ent))
  (if (not
	(and
	  (or
	    (= (strcase (cdr (assoc 0 (entget ent))) nil) "STYLE")
	    (= (strcase (cdr (assoc 0 (entget ent))) nil) "DIMSTYLE")
	    (= (strcase (cdr (assoc 0 (entget ent))) nil) "LAYER")
	    ) ;_ end of or 
	  (= bit 100)
	  ) ;_ end of and 
	) ;_ end of not 
    (progn
      (setq ent_list (entget ent)
	    new_dxf  (cons bit
			   (if (and (= bit 62) (= (type value) 'str))
			     (if (= (strcase value) "BYLAYER")
			       256
			       0
			       ) ;_ end of if 
			     value
			     ) ;_ end of if 
			   ) ;_ end of cons 
	    ) ;_ end of setq 
      (if (not (equal new_dxf (setq old_dxf (assoc bit ent_list))))
	(progn
	  (entmod (if old_dxf
		    (subst new_dxf old_dxf ent_list)
		    (append ent_list (list new_dxf))
		    ) ;_ end of if 
		  ) ;_ end of entmod
	  (if ent_regen
	    (entupd ent)
	    (redraw ent)
	    ) ;_ end of if
	  ) ;_ end of progn 
	) ;_ end of if 
      ) ;_ end of progn 
    ) ;_ end of if 
  ent
  ) ;_ end of defun

ShaggyDoc · 08.09.2006, 14:35

http://www.autocad.ru/cgi-bin/f1/boa...20060908143354

Кулик Алексей aka kpblc · 08.09.2006, 14:37

Спасибо.

Елпанов Евгений · 08.09.2006, 15:14

Код:

[Выделить все]

(defun c:clo (/ A1 GR I S)
  ;;  ElpanovEvgeniy, Russia, Moscow, 2006
  ;;  Clock that show time in the screen
  (setq a1 (/ pi 30))
  (while (= (car (setq gr (grread 5))) 5)
    (setq s  (/ (getvar "viewsize") 12.)
          gr (trans (cadr gr) 1 3)
          i  0
    ) ;_  setq
    (redraw)
    (grvecs ;SS
      '(2 (-0.01 0.) (1. 0.))
      ((lambda (a)
         ((lambda (c s x y sc)
            (list (list c (- s) 0. x) (list s c 0. y) (list 0. 0. sc 0.) '(0. 0. 0. 1.))
          ) ;_  lambda
           (* (cos a) s)
           (* (sin a) s)
           (car gr)
           (+ (* s 1.5) (cadr gr))
           s
         )
       ) ;_  lambda
        (- (/ pi 2.) (* (/ pi 30.) (atof (menucmd "M=$(edtime,$(getvar,date),SS.MSEC)"))))
      )
    ) ;_  grvecs
    (grvecs ;MM
      '(3(-0.01 0.)(0.8 0.)3(-0.01 -0.01)(0.6 -0.01)3(-0.01 0.01)(0.6 0.01)3(-0.01 -0.02)(0.4 -0.02)3(-0.01 0.02)(0.4 0.02))
      ((lambda (a)
         ((lambda (c s x y sc)
            (list (list c (- s) 0. x) (list s c 0. y) (list 0. 0. sc 0.) '(0. 0. 0. 1.))
          ) ;_  lambda
           (* (cos a) s)
           (* (sin a) s)
           (car gr)
           (+ (* s 1.5) (cadr gr))
           s
         )
       ) ;_  lambda
        (- (/ pi 2.) (* (/ pi 30.) (atoi (menucmd "M=$(edtime,$(getvar,date),MM)"))))
      )
    ) ;_  grvecs
    (grvecs ;H
      '(3(-0.01 0.)(0.5 0.)3(-0.01 -0.01)(0.4 -0.01)3(-0.01 0.01)(0.4 0.01)3(-0.01 -0.02)(0.3 -0.02)
        3(-0.01 0.02)(0.3 0.02)3(-0.01 -0.03)(0.2 -0.03)3(-0.01 0.03)(0.2 0.03)
       )
      ((lambda (a)
         ((lambda (c s x y sc)
            (list (list c (- s) 0. x) (list s c 0. y) (list 0. 0. sc 0.) '(0. 0. 0. 1.))
          ) ;_  lambda
           (* (cos a) s)
           (* (sin a) s)
           (car gr)
           (+ (* s 1.5) (cadr gr))
           s
         )
       ) ;_  lambda
        (- (/ pi 2.)
           (* (/ pi 6.)
              (+ (atoi (menucmd "M=$(edtime,$(getvar,date),H)"))
                 (/ (atoi (menucmd "M=$(edtime,$(getvar,date),MM)")) 60.)
              ) ;_  +
           ) ;_  *
        ) ;_  -
      )
    ) ;_  grvecs
    (repeat 4
      (grvecs
        '(5(0.8 0.)(0.82 0.02)5(0.82 0.02)(1. 0.02)5(1. 0.02)(1. -0.02)5(1. -0.02)(0.82 -0.02)5(0.82 -0.02)(0.8 0.))
        ((lambda (c s x y sc)
           (list (list c (- s) 0. x) (list s c 0. y) (list 0. 0. sc 0.) '(0. 0. 0. 1.))
         ) ;_  lambda
          (* (cos (* a1 i)) s)
          (* (sin (* a1 i)) s)
          (car gr)
          (+ (* s 1.5) (cadr gr))
          s
        )
      ) ;_  grvecs
      (repeat 3
        (grvecs
          '(5(1. 0.01)(0.92 0.01)5(1. -0.01)(0.92 -0.01))
          ((lambda (c s x y sc)
             (list (list c (- s) 0. x) (list s c 0. y) (list 0. 0. sc 0.) '(0. 0. 0. 1.))
           ) ;_  lambda
            (* (cos (* a1 i)) s)
            (* (sin (* a1 i)) s)
            (car gr)
            (+ (* s 1.5) (cadr gr))
            s
          )
        ) ;_  grvecs
        (repeat 5
          (grvecs
            '(5 (0.9 0) (1 0))
            ((lambda (c s x y sc)
               (list (list c (- s) 0. x) (list s c 0. y) (list 0. 0. sc 0.) '(0. 0. 0. 1.))
             ) ;_  lambda
              (* (cos (* a1 i)) s)
              (* (sin (* a1 i)) s)
              (car gr)
              (+ (* s 1.5) (cadr gr))
              s
            )
          ) ;_  grvecs
          (setq i (1+ i))
        ) ;_  repeat
      ) ;_  repeat
    ) ;_  repeat
  ) ;_  while
  (redraw)
)