Schöck
dwg.ru forum rss xml
| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Нужен лиспик, рисующий биссектрисы треугольника.

Нужен лиспик, рисующий биссектрисы треугольника.

Версия для печати
 
Ответ
Опции темы Поиск в этой теме
Непрочитано 16.01.2018, 18:59 #1
Нужен лиспик, рисующий биссектрисы треугольника.
Dant
 
Регистрация: 15.01.2010
Сообщений: 178

Dant вне форума Вставить имя

Собственно вопрос в заголовке.
Может у кого-то есть лисп, который может отрисовывать автоматом биссектрисы треугольника?
Просмотров: 2032
 
Непрочитано 16.01.2018, 19:37
#2
Setvar

Всего понемногу
 
Регистрация: 10.02.2007
Москва
Сообщений: 579


Похожая тема:
https://forum.dwg.ru/showthread.php?t=83128
__________________
Установи FILEDIA в 1 и не парься.
Setvar вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 17.01.2018, 12:46
#3
Do$

AutoCAD/Civil3D LISP/C#
 
Регистрация: 15.08.2008
Санкт-Петербург
Сообщений: 1,641
Отправить сообщение для Do$ с помощью Skype™


Если используется AutoCAD 2018, то никаких лиспов не надо. Там есть инструмент "Осевая линия": http://autode.sk/2DjEEKH
__________________
Толковый выбор приходит с опытом, а к нему приводит выбор бестолковый. (The Mechanic)
Do$ вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 17.01.2018, 17:41
#4
koMon


 
Регистрация: 26.09.2017
Сообщений: 167


Лисп[ик↓↓↓], рисующий биссектрисы для выбранного треугольника многоугольника, в текущем незаблокированном слое. Треугольник Многоугольник должен быть полилинией замкнутой или незамкнутой, с совпадающими началом и концом.

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

;****************************************************************************************************************************************************

;*******************************************************     koMon 17.01.2018     *******************************************************************

;									Команда Draw_Bisectors рисует биссектрисы для выбранного многоугольника
;											в текущем НЕзаблокированном слое в МИРОВЫX координатах.
;									       Проверка пользовательских систем координат ОТСУТСТВУЕТ.
;								       Проверка наличия кривизны в сегментах многоугольника ОТСУТСТВУЕТ.
; 							Выбирается только полилиния замкнутая или незмкнутая с совпадающими началом и концом.
;								Х/з кому это может пригодиться, но как говорится, "что сделано, то сделано".

;****************************************************************************************************************************************************

															  (vl-load-com)

;****************************************************************************************************************************************************

(defun Check_Locale ( / AcaKey AcaVer AppKey TmpKey)
	(setq AcaVer (substr (getvar "ACADVER") 1 4)
		  AppKey (strcat"\\Software\\Autodesk\\AutoCAD\\R" AcaVer)
		  TmpKey (strcat "HKEY_LOCAL_MACHINE" AppKey)
		  AcaKey (if (> (atof AcaVer) 15.0)
		  			(vl-registry-read (strcat "HKEY_CURRENT_USER" AppKey) "CurVer")
		 			(vl-registry-read TmpKey "CurVer")
				  )
	)
	(cond
		(
			(= (vl-registry-read (strcat TmpKey "\\" AcaKey) "Language") "Русский")
				(setq prompts (list '(0 "\nВыберите Многоугольник или нажмите Ecs для отмены команды ") '(1 "\nНеправильный выбор! ") '(2 "\nНичего не выбрано! ") '(3 "\nКоманда отменена!") '(4 " Биссектрисы нарисованы")))
		)
		(
			t
				(setq prompts (list '(0 "\nSelect Polygon or Press ESC to Cancel ") '(1 "\nWrong Selection! ") '(2 "\nNothing is Selected! ") '(3 "\nCommand was Cancelled! ") '(4 " Bisectors Were Drawn")))
		)

	)
)

;***************************************************************************************************************************************

(defun c:Draw_Bisectors ()
  	(setq Draw_Bisectors_vars
								'(
									Acad_Object Cycling_Index Document_Object Edge_1 Edge_2 Entsel_Data Entsel_Return Intersection_Point_Array Is_Selecting_Polygon
									Lambda_Distances_List Lambda_Verices_XY_Coordinates_List Lambda_Vertex_Index Lambda_Vertices_List Modelspace_Object
									Polygon_Object Polygon_Was_Not_Selected Prompts Repeat_Count Vertex_1 Vertex_1_Cycling_List Vertex_2 Vertex_2_Cycling_List
									Vertex_3 Vertex_3_Cycling_List Vertex_Nth Vertex_Nth_Half Vertices_Index Vertices_List Vertices_Xy_Coordinates_List
								)
		  acad_Object (vlax-get-acad-object)
  		  document_Object (vla-get-ActiveDocument acad_Object)
		  modelSpace_object (vla-get-ModelSpace document_Object)
  		  is_selecting_polygon t
		  polygon_was_not_selected nil
  	)
	(Check_Locale)
	(while is_selecting_polygon
		(setq entsel_return (type (setq entsel_data (vl-catch-all-apply 'EntSel (list (cadr (assoc 0 prompts)))))))
		(cond
			(
				(= entsel_return 'LIST)
					(cond
						(
							(and
								(= (vla-get-objectname (setq polygon_object (vlax-ename->vla-object (car entsel_data)))) "AcDbPolyline")
								(or
									(and
										(= (vla-get-closed polygon_object) :vlax-true)
										(> (setq repeat_count (/ (length (setq vertices_XY_Coordinates_list (vlax-get polygon_object 'Coordinates))) 2)) 2)
										(not (equal (car vertices_XY_Coordinates_list) (cadr (reverse vertices_XY_Coordinates_list))))
										(not (equal (cadr vertices_XY_Coordinates_list) (car (reverse vertices_XY_Coordinates_list))))

									)
									(and
										(= (vla-get-closed polygon_object) :vlax-false)
										(> (setq repeat_count (1- (/ (length (setq vertices_XY_Coordinates_list (vlax-get polygon_object 'Coordinates))) 2))) 2)
										(equal (car vertices_XY_Coordinates_list) (cadr (reverse vertices_XY_Coordinates_list)))
										(equal (cadr vertices_XY_Coordinates_list) (car (reverse vertices_XY_Coordinates_list)))
									)
									(and
										(= (vla-get-closed polygon_object) :vlax-true)
										(> (setq repeat_count (1- (/ (length (setq vertices_XY_Coordinates_list (vlax-get polygon_object 'Coordinates))) 2))) 2)
										(equal (car vertices_XY_Coordinates_list) (cadr (reverse vertices_XY_Coordinates_list)))
										(equal (cadr vertices_XY_Coordinates_list) (car (reverse vertices_XY_Coordinates_list)))
									)
									(and
										(= (vla-get-closed polygon_object) :vlax-true)
										(> (setq repeat_count (/ (length (setq vertices_XY_Coordinates_list (vlax-get polygon_object 'Coordinates))) 2)) 2)
									)
								)
							)
									(setq is_selecting_polygon nil)
						)
							(
								t
									(princ (cadr (assoc 1 prompts)))

							)
					)
			)
			(
				(= entsel_return 'VL-CATCH-ALL-APPLY-ERROR)
					(setq is_selecting_polygon nil
						  polygon_was_not_selected t
					)
			)
			(
				t
					(princ (cadr (assoc 2 prompts)))

			)
		)
	)
  	(if (and polygon_object
			 (not polygon_was_not_selected)
		)
				(progn
					(setq vertices_index 0
						  vertices_list '()
					)
					(repeat repeat_count
						(setq vertices_list (cons
												  (list (nth vertices_index vertices_XY_Coordinates_list)
													  	(nth (+ 1 vertices_index) vertices_XY_Coordinates_list)
														0.0
												  )
												  vertices_list
											)
					  		  vertices_index (+ 2 vertices_index)
						)
				   )
				   (setq vertices_list (reverse vertices_list))
				)
	)
	(if polygon_was_not_selected
		(princ (cadr (assoc 3 prompts)))
		(progn
			(setq cycling_index 0
				  vertex_1_cycling_list (list 0)
				  vertex_1_cycling_list (reverse (repeat (1- repeat_count)
													(setq vertex_1_cycling_list (cons (1+ (car vertex_1_cycling_list)) vertex_1_cycling_list))
												 )
										)
				  vertex_2_cycling_list (append (cdr vertex_1_cycling_list) (list (car vertex_1_cycling_list)))
				  vertex_3_cycling_list (cons (last vertex_1_cycling_list) (reverse (cdr (reverse vertex_1_cycling_list))))
			)
			(repeat repeat_count
				(setq vertex_1 (nth (nth cycling_index vertex_1_cycling_list) vertices_list)
				      vertex_2 (nth (nth cycling_index vertex_2_cycling_list) vertices_list)
				      vertex_3 (nth (nth cycling_index vertex_3_cycling_list) vertices_list)
				)
				(if (not (equal (angle vertex_3 vertex_1) (angle vertex_1 vertex_2) 1e-10))
					(if (> (setq edge_1 (distance vertex_1 vertex_2)) (setq edge_2 (distance vertex_1 vertex_3)))
						(setq vertex_nth (polar vertex_1 (angle vertex_1 vertex_2) (min edge_1 edge_2))
						      vertex_nth_half (polar vertex_3 (angle vertex_3 vertex_nth) (/ (distance vertex_3 vertex_nth) 2.0))
						)
						(setq vertex_nth (polar vertex_1 (angle vertex_1 vertex_3) (min edge_1 edge_2))
						      vertex_nth_half (polar vertex_2 (angle vertex_2 vertex_nth) (/ (distance vertex_2 vertex_nth) 2.0))
						)
					)
					(setq vertex_nth_half (polar vertex_1 (- (angle vertex_1 vertex_2) (/ pi 2.0)) (min (distance vertex_1 vertex_2) (distance vertex_1 vertex_3))))
				)
				(set (read (strcat "bisector_" (itoa cycling_index))) (vla-AddLine modelSpace_object (vlax-3d-point vertex_1) (vlax-3d-point vertex_nth_half)))
				(setq intersection_Point_array (vla-IntersectWith (eval (read (strcat "bisector_" (itoa cycling_index)))) polygon_object acExtendThisEntity))
				(vla-put-EndPoint (eval (read (strcat "bisector_" (itoa cycling_index))))
								  (vlax-3d-point
										(apply
											'(lambda (parsed_base_vertex parsed_verices_XY_coordinates_list_array)
													 (setq lambda_vertices_list '()
														   lambda_distances_list '()
														   lambda_vertex_index 0
														   lambda_verices_XY_coordinates_list (vlax-safearray->list (vlax-variant-value parsed_verices_XY_coordinates_list_array))
													 )
													 (repeat (/ (length lambda_verices_XY_coordinates_list) 3)
    												 		(setq lambda_vertices_list (cons (list (car lambda_verices_XY_coordinates_list) (cadr lambda_verices_XY_coordinates_list) (caddr lambda_verices_XY_coordinates_list)) lambda_vertices_list)
																  lambda_distances_list (cons (distance parsed_base_vertex (car lambda_vertices_list)) lambda_distances_list)
																  lambda_verices_XY_coordinates_list (cdddr lambda_verices_XY_coordinates_list)
    														)
													 )
													(nth (cadr (vl-sort-i lambda_distances_list '<)) lambda_vertices_list)
											)
											(list vertex_1 intersection_point_array)
										)
								  )
				)
				(setq cycling_index (1+ cycling_index))
			)
		)
	)
	(princ (strcat "\n" (itoa repeat_count) (cadr (assoc 4 prompts))))
	(setq cycling_index 0)
	(repeat repeat_count
		(vlax-release-object (eval (read (strcat "bisector_" (itoa cycling_index)))))
		(set (read (strcat "bisector_" (itoa cycling_index))) nil)
		(setq cycling_index (1+ cycling_index))
	)
 	(foreach nth_var draw_bisectors_vars (set nth_var nil))
	(setq draw_bisectors_vars nil)
	(princ)
)

;****************************************************************************************************************************************************


Последний раз редактировалось koMon, 25.01.2018 в 09:50.
koMon вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 17.01.2018, 21:18
#5
Alex_Shaton


 
Регистрация: 09.09.2017
Гомель
Сообщений: 13


Есть еще интересное решение от Lee Mac : http://www.lee-mac.com/dynamicanglebisection.html
Alex_Shaton вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 18.01.2018, 09:18
#6
koMon


 
Регистрация: 26.09.2017
Сообщений: 167


Прикольно!) Наверное был отличником по геометрии!)
koMon вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 18.01.2018, 16:22
#7
Setvar

Всего понемногу
 
Регистрация: 10.02.2007
Москва
Сообщений: 579


Лиспик, рисующий биссектрисы треугольника:
Код:
[Выделить все]
(defun C:БИС3 ( / echo osm p1 p2 p3 cen p11 p22 p33)
(setq echo (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq osm (getvar "OSMODE"))
(setvar "OSMODE" 32)
      (setq p1 (getpoint "\nПервый угол: "))
      (setq p2 (getpoint "\nВторой угол: "))
      (setq p3 (getpoint "\nТретий угол: "))
;; Центр вписанной окружности
(setq cen (inters
           p1 (polar p1 (/ (+ (angle p1 p2) (angle p1 p3)) 2) 10)
           p2 (polar p2 (/ (+ (angle p2 p1) (angle p2 p3)) 2) 10)
           nil)
)
(setq p11 (inters p1 cen p2 p3 nil))
(setq p22 (inters p2 cen p1 p3 nil))
(setq p33 (inters p3 cen p1 p2 nil))
(command "_LINE" "_none" p1 "_none" p11 "")
(command "_LINE" "_none" p2 "_none" p22 "")
(command "_LINE" "_none" p3 "_none" p33 "")
(setvar "CMDECHO" echo)
(setvar "OSMODE" osm)
(princ)
)
Треугольник может быть любой, может и совсем отсутствовать.
__________________
Установи FILEDIA в 1 и не парься.

Последний раз редактировалось Setvar, 18.01.2018 в 17:48.
Setvar вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 18.01.2018, 17:06
#8
koMon


 
Регистрация: 26.09.2017
Сообщений: 167


Setvar,
Offtop:
У тебя ведь русский автокад? Не подскажешь ли любезно, что в нём будет на выходе функции ниже?

(defun Check_Locale ( / AcaKey AcaVer AppKey TmpKey)
(setq AcaVer (substr (getvar "ACADVER") 1 4)
AppKey (strcat"\\Software\\Autodesk\\AutoCAD\\R" AcaVer)
TmpKey (strcat "HKEY_LOCAL_MACHINE" AppKey)
AcaKey (if (> (atof AcaVer) 15.0)
(vl-registry-read (strcat "HKEY_CURRENT_USER" AppKey) "CurVer")
(vl-registry-read TmpKey "CurVer")
)
)
(vl-registry-read (strcat TmpKey "\\" AcaKey) "Language")
)
koMon вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 18.01.2018, 17:24
#9
Setvar

Всего понемногу
 
Регистрация: 10.02.2007
Москва
Сообщений: 579


Offtop: На выходе получилось
"Русский"
__________________
Установи FILEDIA в 1 и не парься.
Setvar вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 18.01.2018, 17:48
#10
koMon


 
Регистрация: 26.09.2017
Сообщений: 167


Спасибо!)
Offtop: Вот ведь блин, а я наивно полагал, что будет Russian...
koMon вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 18.01.2018, 17:48
#11
Setvar

Всего понемногу
 
Регистрация: 10.02.2007
Москва
Сообщений: 579


Еще один лиспик на случай треугольника из полилинии:
Код:
[Выделить все]
(defun C:БИС3 ( / echo sp p1 p2 p3 cen p11 p22 p33)
(setq echo (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq sp (read (vl-princ-to-string (vlax-safearray->list
         (vlax-variant-value
	 (vla-get-Coordinates
	 (vlax-ename->vla-object (car (entsel "\nУкажите треугольник-полилинию"))))))))
) ; setq sp
(setq p1 (list (nth 0 sp) (nth 1 sp)))
(setq p2 (list (nth 2 sp) (nth 3 sp)))
(setq p3 (list (nth 4 sp) (nth 5 sp)))
;; Центр вписанной окружности
(setq cen (inters
           p1 (polar p1 (/ (+ (angle p1 p2) (angle p1 p3)) 2) 10)
           p2 (polar p2 (/ (+ (angle p2 p1) (angle p2 p3)) 2) 10)
           nil)
)
(setq p11 (inters p1 cen p2 p3 nil))
(setq p22 (inters p2 cen p1 p3 nil))
(setq p33 (inters p3 cen p1 p2 nil))
(command "_LINE" "_none" p1 "_none" p11 "")
(command "_LINE" "_none" p2 "_none" p22 "")
(command "_LINE" "_none" p3 "_none" p33 "")
(setvar "CMDECHO" echo)
(princ)
)
__________________
Установи FILEDIA в 1 и не парься.

Последний раз редактировалось Setvar, 18.01.2018 в 21:37. Причина: Убраны явно лишние строки кода
Setvar вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 18.01.2018, 19:51
#12
1958


 
Регистрация: 16.04.2016
Сообщений: 25


Цитата:
Сообщение от Setvar Посмотреть сообщение
Еще один лиспик на случай треугольника из полилинии:
Что-то тут странное. См.картинку. По предыдущему лиспу (по точкам) все нормально.
Миниатюры
Нажмите на изображение для увеличения
Название: Буфер обмена01.jpg
Просмотров: 27
Размер:	29.6 Кб
ID:	197903  
1958 вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 18.01.2018, 20:07
#13
Setvar

Всего понемногу
 
Регистрация: 10.02.2007
Москва
Сообщений: 579


Да, странное. Но так и я могу исказить чертеж и приложить здесь всего лишь растровое изображение. Приложи оригинал DWG.

----- добавлено через ~2 ч. -----
Вариант предыдущей программы с некоторыми проверками:
Код:
[Выделить все]
(defun C:БИСП ( / echo pl sp p1 p2 p3 p11 p22 p33)
(setq echo (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq pl (car (entsel "\nУкажите треугольник-полилинию")))
(if (and pl (= (cdr (assoc 0 (entget pl))) "LWPOLYLINE"))
    (progn
    (setq sp (read (vl-princ-to-string (vlax-safearray->list
             (vlax-variant-value
   	     (vla-get-Coordinates
	     (vlax-ename->vla-object pl))))))
    ) ; setq sp
    (setq p1 (list (nth 0 sp) (nth 1 sp)))
    (setq p2 (list (nth 2 sp) (nth 3 sp)))
    (setq p3 (list (nth 4 sp) (nth 5 sp)))
;; Центр вписанной окружности
    (setq cen (inters
               p1 (polar p1 (/ (+ (angle p1 p2) (angle p1 p3)) 2) 10)
               p2 (polar p2 (/ (+ (angle p2 p1) (angle p2 p3)) 2) 10)
               nil)
    )
    (setq p11 (inters p1 cen p2 p3 nil))
    (setq p22 (inters p2 cen p1 p3 nil))
    (setq p33 (inters p3 cen p1 p2 nil))
    (command "_LINE" "_none" p1 "_none" p11 "")
    (command "_LINE" "_none" p2 "_none" p22 "")
    (command "_LINE" "_none" p3 "_none" p33 "")
    ) ; progn
    (alert "\nНе выбран объект или объект не полилиния.")
) ; if
(setvar "CMDECHO" echo)
(princ)
)
__________________
Установи FILEDIA в 1 и не парься.
Setvar вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 19.01.2018, 04:03
#14
1958


 
Регистрация: 16.04.2016
Сообщений: 25


Цитата:
Сообщение от Setvar Посмотреть сообщение
Да, странное. Но так и я могу исказить чертеж и приложить здесь всего лишь растровое изображение. Приложи оригинал DWG.
Если выполнять ваш лисп в чистом чертеже, то все нормально. А я попробовал в уже существующем.
Вложения
Тип файла: dwg
DWG 2007
пример.dwg (408.1 Кб, 5 просмотров)
1958 вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 19.01.2018, 08:09
#15
Setvar

Всего понемногу
 
Регистрация: 10.02.2007
Москва
Сообщений: 579


Судя по всему, ваш чертеж выполнен в метрах. Но не это главное. Главное - он находится страшно далеко от начала координат. Поэтому при вычислении координат точек возникает дикое расхождение. Если же чертеж перенести в начало координат, то отрисовка биссектрис выполняется приемлимо. Однако, в свою программу я никаких изменений вносить не буду.
Кстати, программа koMon из #4 строит биссектрисы нормально.
__________________
Установи FILEDIA в 1 и не парься.

Последний раз редактировалось Setvar, 19.01.2018 в 08:41.
Setvar вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 19.01.2018, 13:54
#16
1958


 
Регистрация: 16.04.2016
Сообщений: 25


Цитата:
Сообщение от Setvar Посмотреть сообщение
Судя по всему, ваш чертеж выполнен в метрах. Но не это главное. Главное - он находится страшно далеко от начала координат. Поэтому при вычислении координат точек возникает дикое расхождение. Если же чертеж перенести в начало координат, то отрисовка биссектрис выполняется приемлимо. Однако, в свою программу я никаких изменений вносить не буду.
Кстати, программа koMon из #4 строит биссектрисы нормально.
Да, мой чертеж выполнен в метрах. А то, что "он находится страшно далеко от начала координат", так это прямоугольные геодезические координаты, которые, извините меня, применяют в геодезии, топографии, картографии, навигации... (нужное подчеркнуть). И я не просил вносить изменений, я просто констатировал факт. Так что буду использовать лисп от koMon.

----- добавлено через ~19 мин. -----
Цитата:
Сообщение от Setvar Посмотреть сообщение
Однако, в свою программу я никаких изменений вносить не буду.
Я на свой страх и риск набрался наглости и внес в ваш лисп свои изменения. Теперь работает нормально, несмотря на то, что треугольник
Цитата:
Сообщение от Setvar Посмотреть сообщение
находится страшно далеко от начала координат
Код:
[Выделить все]
 (defun C:БИС3 (/ echo osm sp p1 p2 p3 cen p11 p22 p33)
 (setq echo (getvar "CMDECHO"))
 (setvar "CMDECHO" 0)
 (setq osm (getvar "OSMODE"))
 (setvar "OSMODE" 32)
;;; (setq sp (read
;;;           (vl-princ-to-string
;;;            (vlax-safearray->list
;;;             (vlax-variant-value
;;;              (vla-get-Coordinates
;;;               (vlax-ename->vla-object (car (entsel "\nУкажите треугольник-полилинию")))
;;;              )
;;;             )
;;;            )
;;;           )
;;;          )
;;; ) ; setq sp
 (setq sp (vlax-safearray->list
           (variant-value
            (vla-get-Coordinates
             (vlax-ename->vla-object (car (entsel "\nУкажите треугольник-полилинию")))
            )
           )
          )
 )
 (setq p1 (list (nth 0 sp) (nth 1 sp)))
 (setq p2 (list (nth 2 sp) (nth 3 sp)))
 (setq p3 (list (nth 4 sp) (nth 5 sp)))
 ;; Центр вписанной окружности
 (setq cen (inters p1
                   (polar p1 (/ (+ (angle p1 p2) (angle p1 p3)) 2) 10)
                   p2
                   (polar p2 (/ (+ (angle p2 p1) (angle p2 p3)) 2) 10)
                   nil
           )
 )
 (setq p11 (inters p1 cen p2 p3 nil))
 (setq p22 (inters p2 cen p1 p3 nil))
 (setq p33 (inters p3 cen p1 p2 nil))
 (command "_LINE" "_none" p1 "_none" p11 "")
 (command "_LINE" "_none" p2 "_none" p22 "")
 (command "_LINE" "_none" p3 "_none" p33 "")
 (setvar "CMDECHO" echo)
 (setvar "OSMODE" osm)
 (princ)
)
1958 вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Автор темы   Непрочитано 19.01.2018, 14:28
#17
Dant


 
Регистрация: 15.01.2010
Сообщений: 178


О, народ проявил активность к теме. Спасибо всем, кто откликнулся, опробую выложенные функции.
Dant вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 19.01.2018, 14:57
| 1 #18
Setvar

Всего понемногу
 
Регистрация: 10.02.2007
Москва
Сообщений: 579


Для 1958.
Никаких претензий по поводу метров и "далеко от начала координат". У каждого свои задачи. Но вот автор темы хотел "лиспик", я и слепил лиспики. Однако, с вашим вариантом фрагмента кода программа претендует на звание "Готовой". Поэтому я приведу здесь окончательный вариант нашей общей программы для случая выполнения треугольника в виде полилинии:
Код:
[Выделить все]
;;; Треугольник-полилиния 
(defun C:БИСП (/ echo sp p1 p2 p3 cen p11 p22 p33)
(setq echo (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq pl (car (entsel "\nУкажите треугольник-полилинию")))
(if (and pl (= (cdr (assoc 0 (entget pl))) "LWPOLYLINE"))
    (progn
    (setq sp (vlax-safearray->list (variant-value
             (vla-get-Coordinates (vlax-ename->vla-object pl)
             )))
    ) ; setq
    (setq p1 (list (nth 0 sp) (nth 1 sp)))
    (setq p2 (list (nth 2 sp) (nth 3 sp)))
    (setq p3 (list (nth 4 sp) (nth 5 sp)))
;; Центр вписанной окружности
    (setq cen (inters 
               p1 (polar p1 (/ (+ (angle p1 p2) (angle p1 p3)) 2) 10)
               p2 (polar p2 (/ (+ (angle p2 p1) (angle p2 p3)) 2) 10)
               nil)
    ) ; setq
    (setq p11 (inters p1 cen p2 p3 nil))
    (setq p22 (inters p2 cen p1 p3 nil))
    (setq p33 (inters p3 cen p1 p2 nil))
    (command "_LINE" "_none" p1 "_none" p11 "")
    (command "_LINE" "_none" p2 "_none" p22 "")
    (command "_LINE" "_none" p3 "_none" p33 "")
    ) ; progn
    (alert "\nНе выбран объект или объект не полилиния.")
) ; if
(setvar "CMDECHO" echo)
(princ)
)
Сдается мне, что эта программа оказалась значительно проще, чем у koMon, но с другой стороны - вдруг у нашей программы всплывут какие-нибудь камни в процессе эксплуатации, тогда его программа к услугам. Только лень русифицировать её. Вот пусть автор темы выскажется. Я думаю, что и программа с указанием 3 точек тоже сгодится.
__________________
Установи FILEDIA в 1 и не парься.
Setvar вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Автор темы   Непрочитано 19.01.2018, 15:11
#19
Dant


 
Регистрация: 15.01.2010
Сообщений: 178


Не знаю, о чем вы спорите между собой (не силен в лиспе), но все выложенные функции работают отлично. Хотелось бы, чтобы биссектрисы после пересечения между собой обрывались, т.е., образовывали точку.
Dant вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 19.01.2018, 15:18
#20
Setvar

Всего понемногу
 
Регистрация: 10.02.2007
Москва
Сообщений: 579


Так продлевать их до противоположной стороны не надо? Блин, я с этого начинал лепить. Где ты был, дядя, до этого?

----- добавлено через ~4 мин. -----
Вот тебе такой вариант:
Код:
[Выделить все]
(defun C:БИСП (/ echo sp p1 p2 p3 cen)
(setq echo (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq pl (car (entsel "\nУкажите треугольник-полилинию")))
(if (and pl (= (cdr (assoc 0 (entget pl))) "LWPOLYLINE"))
    (progn
    (setq sp (vlax-safearray->list (variant-value
             (vla-get-Coordinates (vlax-ename->vla-object pl)
             )))
    ) ; setq
    (setq p1 (list (nth 0 sp) (nth 1 sp)))
    (setq p2 (list (nth 2 sp) (nth 3 sp)))
    (setq p3 (list (nth 4 sp) (nth 5 sp)))
;; Центр вписанной окружности
    (setq cen (inters 
               p1 (polar p1 (/ (+ (angle p1 p2) (angle p1 p3)) 2) 10)
               p2 (polar p2 (/ (+ (angle p2 p1) (angle p2 p3)) 2) 10)
               nil)
    ) ; setq
    (command "_LINE" "_none" p1 "_none" cen "")
    (command "_LINE" "_none" p2 "_none" cen "")
    (command "_LINE" "_none" p3 "_none" cen "")
    ) ; progn
    (alert "\nНе выбран объект или объект не полилиния.")
) ; if
(setvar "CMDECHO" echo)
(princ)
)
__________________
Установи FILEDIA в 1 и не парься.
Setvar вне форума вставить имя Обратить внимание модератора на это сообщение  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Нужен лиспик, рисующий биссектрисы треугольника.

Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск

Быстрый переход

Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Нужен ли ПОС в составе РП на реконструкцию Тимофей Технология и организация строительства 21 13.09.2012 11:18
Нужен ли немецкий язык в строительстве? newAndrey Разное 17 22.07.2011 17:55
Бойлерная в подвале. Нужен ли отдельный выход? F0xik Архитектура 1 08.09.2009 11:49
Помогите, срочно нужен ПОС на прокол трассы. Noki Поиск литературы, чертежей, моделей и прочих материалов 8 17.03.2009 01:10
нужен и интересный сортамент арматуры Dvalin Поиск литературы, чертежей, моделей и прочих материалов 4 10.02.2008 19:06

|| Главная || Каталог САПР || Тендеры || Публикации || Объявления || Биржа труда || Download || Галерея ||
|| Библиотека || Кунсткамера || Каталог предприятий || Контакты || Файлообменник || Блоги ||