[Kirill_Ja]

Итак, в символьной таблице "UCS" хранится информация о ПСК
код 10 - начало ПСК в МСК
код 11 - единичный вектор оси X
код 12 - единичный вектор оси Y

А как мне расчитать единичный вектор оси Z???
В идеале нужно создать программку, которая пересчитывает координаты из ПСК в МСК и обратно.
В качестве исходных данных только имена СК и координаты точки.

Вот что у меня получилось:

Код:

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

 (defun tg_get_DXF_pairs (pairs inp_list / )

;;;Праграмма оставляет точечные пары только с кодами
;;;которые входят в список pairs
;;;
(vl-remove-if-not (function
		    (lambda (x) (member (car x) pairs))
	  )
	inp_list);end mapcar  
);end defun

(defun TG_set_UCS (ucs / old_ucs)
;;;
;;;Программа устанавливает текущую СК на СК с именем UCS
;;;В случае ошибочного аргумента устанавливает мировую СК
;;;Возвращает имя текущей СК, если она именована
(if (not (vl-catch-all-error-p (setq old_ucs (vl-catch-all-apply 'vla-get-activeUCS (list curent_doc)))))
	  (setq old_ucs (cdr
			(assoc 2(entget(vlax-vla-object->ename
					 old_ucs
					)
				 )
			 )))
		(setq old_ucs nil);else
	  );end if
  
 (if (setq ucs (tblobjname "UCS" ucs))
	(progn
	  	(vla-put-ActiveUCS curent_doc (vlax-ename->vla-object ucs))
	  );end progn

   (command "_UCS" "");else

   );end if 
 old_ucs 
);end defun

(defun TG_trans_to_UCS (point ucs / )
;;Программа преобразует координаты из Мировой СК
;;
;;
(if (setq ucs (tblobjname "UCS" ucs))
    (progn
	(setq ucs (tg_get_DXF_pairs '(10 11 12) (entget ucs)))
        (setq point (mapcar (function (lambda (x y) (- x y) ) ) point (cdr (assoc 10 ucs))))
        (setq point
	       (mapcar (function
			 (lambda (p m11 m12) (list (* p m11)(* p m12)))
			 );end function
		       point (cdr (assoc 11 ucs)) (cdr (assoc 12 ucs))
		       );end mapcar
	      )
         (mapcar (function (lambda (x y z ) (+ x y z ))) (nth 0 point)(nth 1 point)(nth 2 point))
     );end progn
);end if
);end defun


(defun TG_trans_to_WGS (point ucs / curent_ucs)

;;;Программа преобразует координаты в Мировую СК
;;;
;;;
  
(if (tblobjname "UCS" ucs)
    (progn
	(setq curent_ucs (TG_set_UCS ucs))
        (setq point (trans point 1 0))
      	(if curent_ucs (TG_set_UCS curent_ucs))
     );end progn
);end if
 point
);end defun

Вот еще забыл

Код:

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

 (defun tg_ActiveX_start (/)

(vl-load-com)
(setq curent_doc (vla-get-ActiveDocument (vlax-get-acad-object)))
  
);end defun

Первая выдает только плановые координаты (x и y), а вторая просто кривая и так вообще не пишутся нормальные функции после 5-о класса школы.
Помогите, пожалуйста, сделать лучше.

[Кулик Алексей aka kpblc]

Сообщение от Kirill_Ja В идеале нужно создать программку, которая пересчитывает координаты из ПСК в МСК и обратно.

А чем не нравится trans?

[Kirill_Ja]

Сообщение от Кулик Алексей aka kpblc А чем не нравится trans?

Чтобы ее использовать нужно, чтобы стояла СК из которой или в которую переводишь.
Мне надо переводить, находясь при этом в МСК. Иначе будут тысячи ненужных операций.

А оптимальный вариант вообще сделать функцию, которая переводит координаты из системы в систему по имени. Даже из ПСК в ПСК. Это будет сильно круто и поможет тем, кто сталкивается так или иначе с системами координат, то есть чуть больше, чем всем

[Кулик Алексей aka kpblc]

Сообщение от Kirill_Ja Чтобы ее использовать нужно, чтобы стояла СК из которой или в которую переводишь.

Из старых запасов:

Код:

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

 (defun _kpblc-eval-vector-multiple (vec1 vec2)
                                   ;|
*    Вычисляет произведение двух векторов
*    Вектора - обязательно 3-мерные списки, контроля не производится
|;
  (list (- (* (cadr vec1) (caddr vec2))
           (* (caddr vec2) (cadr vec1))
           ) ;_ end of -
        (- (* (caddr vec1) (car vec2))
           (* (car vec1) (caddr vec2))
           ) ;_ end of -
        (- (* (car vec1) (cadr vec2))
           (* (cadr vec1) (car vec2))
           ) ;_ end of -
        ) ;_ end of list
  ) ;_ end of defun

[Kirill_Ja]

Спасибо)) С этого момента уже попроще.

[Kirill_Ja]

Сообщение от Kirill_Ja Спасибо)) С этого момента уже попроще.

Короче, получилось. Для перевода из ПСК в ПСК запускаем сначала trans_from_ucs потом trans_to_ucs
Буду благодарен за конструктивную критику.

Код:

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

 

(defun tg_vector_multiple (vec1 vec2)

;*    Вычисляет произведение двух векторов
;*    Вектора - обязательно 3-мерные списки, контроля не производится

  (list (- (* (cadr vec1) (caddr vec2))
           (* (caddr vec1) (cadr vec2))
           ) ;_ end of -
        (- (* (caddr vec1) (car vec2))
           (* (car vec1) (caddr vec2))
          ) ;_ end of -
        (- (* (car vec1) (cadr vec2))
           (* (cadr vec1) (car vec2))
           ) ;_ end of -
        ) ;_ end of list
  ) ;_ end of defun



(defun tg_ucs_compliment_pair14 (ucs / kod14)
;;;
;;;Дополняет данные о системе координат (пары 10 11 12)
;;;парой 14, содержащей единичный вектор оси Z
;;;
  (if (setq ucs (tblobjname "UCS" ucs))
    (progn
	(setq ucs (append (tg_get_DXF_pairs '(10 11 12) (entget ucs))
			  (list (cons 14
				(tg_vector_multiple (cdr (assoc 11 (entget ucs)))(cdr (assoc 12 (entget ucs))))))))
	);end prodn
  );end if
);end defun


(defun tg_matrix_multipline (matrix values / i str g gmax val)
;;; Умножает квадратную матрицу на матрицу из одного стобца 
;;;     m1 m2 m3  -   v1
;;;     m4 m5 m6  -   v2
;;;     m7 m8 m9  -   v3
;;; Перемножает матрицы (см выше)
(if (= (length matrix) (expt (length values) 2))
(progn
(setq i -1)  
(while (< (setq i (1+ i)) (length values))
 (setq g (1- (* i (length values))) gmax (* (1+ i) (length values)))
 (while (< (setq g (1+ g)) gmax) (setq str (append str (list (* (nth g matrix) (nth i values))))))
 (setq val (append val (list str)) str nil)
);end while
(mapcar (function (lambda (x y z) (+ x y z))) (nth 0 val)(nth 1 val)(nth 2 val) )
);end progn
);end if
);end defun


(defun tg_trans_to_ucs (point ucs / ucs_bp tmp)
;;;Переводит координаты точки сз мировой системы координат в пользовательскую
(if (setq ucs (tg_ucs_compliment_pair14 ucs))
(progn
 (setq ucs_bp (cdr (assoc 10 ucs)))
 (setq point (mapcar (function (lambda (x y) (- x y))) point ucs_bp))
 (setq ucs (mapcar (function (lambda (x y z) (list x y z))) (cdr (assoc 11 ucs)) (cdr (assoc 12 ucs)) (cdr (assoc 14 ucs))))
 (setq point (tg_matrix_multipline (append (nth 0 ucs)(nth 1 ucs)(nth 2 ucs)) point))
);end progn
);end if  
);end defun


(defun tg_trans_from_ucs (point ucs / ucs_bp tmp)
;;;Переводит координаты точки сз мировой системы координат в пользовательскую
(if (setq ucs (tg_ucs_compliment_pair14 ucs))
(progn
 (setq ucs_bp (cdr (assoc 10 ucs)))
 (setq ucs (mapcar (function (lambda (x y z) (list x y z))) (cdr (assoc 11 ucs)) (cdr (assoc 12 ucs)) (cdr (assoc 14 ucs))))
 (setq ucs (mapcar (function (lambda (x y z) (list x y z))) (nth 0 ucs)(nth 1 ucs)(nth 2 ucs) ))
; (setq ucs (append (cdr (assoc 11 ucs)) (cdr (assoc 12 ucs)) (cdr (assoc 14 ucs))))
 (setq point (tg_matrix_multipline (append (nth 0 ucs)(nth 1 ucs)(nth 2 ucs)) point))
 (setq point (mapcar (function (lambda (x y) (+ x y))) point ucs_bp))
);end progn
);end if  

);end defun


(defun tg_get_DXF_pairs (pairs inp_list / )

;;;Праграмма оставляет точечные пары только с кодами
;;;которые входят в список pairs
;;;
(vl-remove-if-not (function
		    (lambda (x) (member (car x) pairs))
	  )
	inp_list);end mapcar  
);end defun

Алексей, извини, что переименовал твою функцию перемножения векторов, но уж больно у нее название длинючее.

[Salt]

Глянь еще вот это, вдруг пригодится.

[Kirill_Ja]

Offtop: Вот же!!! А я тут велосипеды изобретаю. В любом случае, разобраться во всем самому было не лишним. Может пригодится в будущем))))

[VVA]

;;;Дополняет данные о системе координат (пары 10 11 12) 23 ;;;парой 14, содержащей единичный вектор оси Z

Уж не этим ли вектором дополняешь?

Команда: (entget(entlast)) ((-1 . <Имя объекта: 7ffffb065b0>) (0 . "LINE") (330 . <Имя объекта: 7ffffb03a10>) (5 . "352B") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0") (100 . "AcDbLine") (10 1692.47 594.265 0.0) (11 1912.88 704.448 0.0) (210 0.0 0.0 1.0))

Вот еще темы
UCS transformation matrix
how to find diameter from 3D SOLID (cylinder) пост #7

[Нефтепроводчик]

Перекликается с функцией, которую я писал для постоения ПСК из МСК по двум точкам с известными координатами в ПСК. Может кому пригодится.

Код:

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

 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Функция создает новую ПСК "ПСК объекта"
;;; по двум известным точкам. Вызов команды (NEW_UCS_2P)
(defun NEW_UCS_2P (/ p0 p1 p1* p2 p2* M V Vt p*->p)
  (vla-regen adoc acallviewports)
  (initget 1)
  (setq	p1					  ; Получаем координаты точки 1 в МСК
	 (getpoint
	   "\nУкажите первую точку: "
	 )
  )
  (setq p1* "")
  (while (or (null (wcmatch p1* "#*[/]#*"))
	     (wcmatch p1* "*[~0-9./]*")
	 )
    (initget 1)
    (setq p1*					  ; Получаем координаты точки 1 в ПСК
	   (getstring
	     "\nУкажите координаты первой точки в виде Y/X: "
	   )
    )
  )
  (initget 1)
  (setq	p2					  ; Получаем координаты точки 2 в МСК
	 (getpoint
	   "\nУкажите вторую точку: "
	 )
  )
  (setq p2* "")
  (while (or (null (wcmatch p2* "#*[/]#*"))
	     (wcmatch p2* "*[~0-9./]*")
	 )
    (initget 1)
    (setq p2*					  ; Получаем координаты точки 1 в ПСК
	   (getstring
	     "\nУкажите координаты второй точки в виде Y/X: "
	   )
    )
  )
  (setq	p1* (read (strcat "(" (vl-string-subst " " "/" p1*) ")"))
	p2* (read (strcat "(" (vl-string-subst " " "/" p2*) ")"))
  )

;;; Операции над матрицами. _gile
;;; http://forums.autodesk.com/t5/Visual-LISP-AutoLISP-and-General/Transformation-Matrix-Inverse/td-p/2351798
;;; REMOVE-I
  (defun remove-i (ind lst)
    (if	(or (zerop ind) (null lst))
      (cdr lst)
      (cons (car lst) (remove-i (1- ind) (cdr lst)))
    )
  )
;;; VXS
  (defun vxs (v s) (mapcar (function (lambda (x) (* x s))) v))
;;; VXV
  (defun vxv (v1 v2) (apply '+ (mapcar '* v1 v2)))
;;; MXS
  (defun mxs (m s) (mapcar (function (lambda (v) (vxs v s))) m))
;;; MXV
  (defun mxv (m v) (mapcar '(lambda (r) (vxv r v)) m))
;;; TRP
  (defun trp (m) (apply 'mapcar (cons 'list m)))
;;; COFACT
  (defun cofact	(i j m)
    (* (determ
	 (remove-i
	   (1- i)
	   (mapcar (function (lambda (x) (remove-i (1- j) x))) m)
	 )
       )
       (expt -1 (+ i j))
    )
  )
;;; DETERM
  (defun determ	(m)
    (if	(= 2 (length m))
      (- (* (caar m) (cadadr m)) (* (caadr m) (cadar m)))
      ((lambda (r n)
	 (apply	'+
		(mapcar
		  (function (lambda (x) (* x (cofact 1 (setq n (1+ n)) m))))
		  r
		)
	 )
       )
	(car m)
	0
      )
    )
  )
;;; ADJ-MAT
  (defun adj-mat (m / i)
    (setq i 0)
    (trp
      (mapcar
	(function
	  (lambda (v / j)
	    (setq i (1+ i)
		  j 0
	    )
	    (mapcar
	      (function (lambda (x) (cofact i (setq j (1+ j)) m)))
	      v
	    )
	  )
	)
	m
      )
    )
  )
;;; INV-MAT
  (defun inv-mat (m / d)
    (if	(/= 0 (setq d (determ m)))
      (mxs (adj-mat m) (/ 1.0 d))
    )
  )
;;; Конец операций над матрицами

  (setq	M (list	(list (car p1*) (cadr p1*) 1 0)	  ; Матрица СЛАУ двух точек в ПСК
		(list (- (cadr p1*)) (car p1*) 0 1)
		(list (car p2*) (cadr p2*) 1 0)
		(list (- (cadr p2*)) (car p2*) 0 1)
	  )
  )
  (setq V (list (car p1) (cadr p1) (car p2) (cadr p2))) ; Вектор двух точек в МСК
  (setq Vt (mxv (inv-mat M) V))			  ; Вектор преобразования ПСК->МСК
  (defun p*->p (p* /)				  ; Уравнения преобразования координат точки ПСК->МСК
    (list (+ (* (nth 0 Vt) (car p*)) (+ (* (nth 1 Vt) (cadr p*))) (nth 2 Vt))
	  (+ (* (nth 1 Vt) (car p*)) (- (* (nth 0 Vt) (cadr p*))) (nth 3 Vt))
    )
  )
  (setq	p0 (p*->p '(0 0))
	p1 (p*->p '(0 1000000))
	p2 (p*->p '(1000000 0))
  )
  (if (zerop (getvar "worlducs"))
    (setq p0 (trans p0 1 0)
	  p1 (trans p1 1 0)
	  p2 (trans p2 1 0)
    )
  )
  (setq	ucs (vla-add
	      (vla-get-UserCoordinateSystems adoc)
	      (vlax-3d-point p0)
	      (vlax-3d-point p1)
	      (vlax-3d-point p2)
	      "ПСК объекта"
	    )
  )
)

[Kirill_Ja]

Тут вспомнил про тему и мне пришел в голову еще один интересный вариант реализации:

Функция (trans) аргументы <СК-в> и <СК-из> могут принимать следующие значения: .... -трехмерный вектор выдавливания (вектор нормали к плоскости СК) ... Цитата из "AutoLisp и VisualLisp в среде AutoCad".

То есть, можно было вообще не изобретать велосипед, а просто посчитать вышеупомянутые вектора и воспользоваться простой функцией.
Хотя как получилось было весьма познавательно