Реклама i
Стань нашим партнером - зарабатывай с нами!
| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму | Файлообменник |

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

Научите лиспу на примере (или как kpblc, VVA и компания пытаются обучить чайника лиспу)

Ответ
Поиск в этой теме
Непрочитано 20.07.2008, 20:12
Научите лиспу на примере (или как kpblc, VVA и компания пытаются обучить чайника лиспу)
Red Nova
 
ՃԱՐՏԱՐԱԳԵՏ, Տ.Գ.Թ.
 
Торонто
Регистрация: 23.10.2007
Сообщений: 1,980

Со школы не ладится у меня с программированием. Все предметы щелкал, а на экзамене по информатике (Visual foxpro) программку типа суммирования столбцов списал у соседа (это уже в университете).
Не смотря на эте намерен научится писать программы для Автокада на лиспе, скачал книгу Хювенена, несколько примеров создания программ, но после получасового “смотрения” таких книг мое мышление явно притормаживает.
Решил пойти другим путем.
Нашел самый короткий лисп из моей коллекции, и прошу программистов с этого форума пошагово объяснить какой символ что означает. Надеюсь на вашу помощь.


Код:
[Выделить все]
(defun c:make-blocks-explodeable (/ adoc)
  (vl-load-com)
  (vla-startundomark
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
    ) ;_ end of vla-startundomark
  (vlax-for blk_def (vla-get-blocks adoc)
    (if (and (equal (vla-get-isxref blk_def) :vlax-false)
             (equal (vla-get-islayout blk_def) :vlax-false)
             ) ;_ end of and
      (vl-catch-all-apply '(lambda () (vla-put-explodable blk_def :vlax-true)))
      ) ;_ end of if
    ) ;_ end of vlax-for
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun
_____________________________________________________________________________________________________________

Прошло много лет и топик теперь представляет из себя площадку для обучения азов программирования для многих начинающих.
Так что начинающие лиспогрызы приветствуются .
__________________
Блог

Последний раз редактировалось Red Nova, 12.07.2017 в 05:43.
Просмотров: 1965818
 
Автор темы   Непрочитано 27.02.2018, 19:14
#3481
Red Nova

ՃԱՐՏԱՐԱԳԵՏ, Տ.Գ.Թ.
 
Регистрация: 23.10.2007
Торонто
Сообщений: 1,980
Отправить сообщение для Red Nova с помощью Skype™


Ну у меня то как раз вариант где требовалось остановить выполнение кода после (*error* nil). Выходит мне нужно вместо (*error* nil) использовать (exit), которая уже в свою очередь вызовет *error*...
__________________
Блог
Red Nova вне форума  
 
Непрочитано 27.02.2018, 21:07
#3482
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,787


А разве настолько необходимо локальное переопределение *error*?
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Автор темы   Непрочитано 27.02.2018, 22:32
#3483
Red Nova

ՃԱՐՏԱՐԱԳԵՏ, Տ.Գ.Թ.
 
Регистрация: 23.10.2007
Торонто
Сообщений: 1,980
Отправить сообщение для Red Nova с помощью Skype™


Ну в общем нет. Но так уж у меня пока все написано
__________________
Блог
Red Nova вне форума  
 
Непрочитано 28.02.2018, 05:11
#3484
skkkk


 
Регистрация: 20.03.2008
Сообщений: 2,653


Offtop: Привет, Red Nova
Даже и не знаю, с чем тебя поздравлять: с золотом или с бронзой? Однако очень мне жаль, что наши наши не схлестнулись с вашими нашими

Насчёт твоего вопроса - то чувство, когда знаешь откуда ноги растут...

Цитата:
Сообщение от Red Nova Посмотреть сообщение
После того как отработала переопределенная функция (*error* nil), разве не должен происходить выход из вычислений? Я наивно пологал что вызов error остановит вычисления на моменте где собственно и вызвать error .
С чего, интересно, ты так полагал? Припоминаю, что когда-то я мог тебя направить на этот путь, вот только, где точно, найти быстро не смог.

Мысль была такова, что после выполнения всех действий программы нам надо восстановить состояние среды: вернуть все системные переменные, удалить временные и вспомогательные примитивы, перерисовать (redraw) и т.д. То же самое (как правило) надо сделать в случае вылета программы с ошибкой, когда автоматически вызывается локально переопределенная функция *error*. И в ней по задуманному алголитму содержится (как правило) тот же сценарий, что и после завершения программы. Поэтому, дабы не дублировать куски кода, можно вместо этого в конце функции вызвать (*error* nil). Таким образом, вызвав посреди кода (*error* nil), ты просто вернешь состояние среды в первоначальное, не дождавшись завершения работы программы.

Изначально я эту мысль извлек среди прочих из урока gomer. Она мне очень понравилась и прижилась. Помню, что делился ею с тобой в какой-то теме, вроде бы даже в этой, но пролистал поиск на несколько десятков страниц - и не нашел. А ты, видимо, чуть подзабыв, интерпретировал ее так, как тебе было удобно в какой-то момент

Цитата:
Сообщение от Red Nova Посмотреть сообщение
Но у меня в данном примере после (+ 1 1) отрабатывает error а после этого отрабатывает и (+ 2 2). Все так и должно быть?
Если все так и должно быть, то как грамотно обеспечить выход при error?
Иными словами, так и должно быть. Но что ты имел в виду под "выход при error"?

Обеспечить выход (если не говорить о вылете с ошибкой), разумеется, можно через (exit), который спровоцирует вызов *error*. Но давно когда-то читал тут на форуме, что такого выхода лучше избегать. Причин не помню, вроде как они и озвучены не были. Предполагаю, что по мнению автора этой идеи было неправильным искусственно провоцировать ошибку с записью в командной строке "Ошибка завершить/выйти/прервать" (или что-то типа того). И вышло так, что я приучил себя выходить из программы при помощи соответствующего построения алгоритма. Например, использовать cond, и в случае, если не выполняется ни одно из условий, то собственно, ничего и не делать и завершать программу по-тихому. И параллельно приучил себя после урока gomer'a просто вызвать (*error* nil) после завершения cond.
То есть приучился не вызывать искусственно завершение программы, так как это приводит к ошибке, но при этом искусственно вызывать программу, которая должна сработать при ошибке

Вот такие вот пироги. Да.
skkkk вне форума  
 
Автор темы   Непрочитано 01.03.2018, 19:25
#3485
Red Nova

ՃԱՐՏԱՐԱԳԵՏ, Տ.Գ.Թ.
 
Регистрация: 23.10.2007
Торонто
Сообщений: 1,980
Отправить сообщение для Red Nova с помощью Skype™


skkkk,
Спасибо за развернутый ответ. Познавательно.
Цитата:
Сообщение от skkkk Посмотреть сообщение
С чего, интересно, ты так полагал? Припоминаю, что когда-то я мог тебя направить на этот путь, вот только, где точно, найти быстро не смог.
После того как error у меня стал делать то чего делать не должен я не в чем не уверен )).
Offtop:
Цитата:
Сообщение от skkkk Посмотреть сообщение
Offtop: Привет, Red Nova
Даже и не знаю, с чем тебя поздравлять: с золотом или с бронзой? Однако очень мне жаль, что наши наши не схлестнулись с вашими нашими
За Россию болелось охотнее )) (особенно ввиду того что Армения могет тока в шахматы, а зимних шахмат пока не придумали).
__________________
Блог
Red Nova вне форума  
 
Непрочитано 18.03.2018, 02:48
#3486
Ivv


 
Регистрация: 17.03.2018
Санкт-Петербург
Сообщений: 5


Всем привет!

Пишу программу на AUTOLISP с диалоговым окном DCL.

Обнаружил некие ограничения элемента диалога list_box с установленным атрибутом multiple_select=true.

Возвращаемое значение функции get_tile ограничено длиной строки приблизительно 2017 символов.
Если количество выбранных элементов списка листбокса формирует строку длиннее 2017 символов (а это максимум 532 первых элементов списка листбокса) get_tile возвращает nil.

Значение переменной действия $value ограничено 256 элементами списка листбокса. При указании большего числа элементов в диалоге значение переменной всё равно 256 элементов.

Сталкивался ли кто-либо с подобным ограничением?
Существуют ли другие способы получить корректное значение из list_box окна DCL при указании более 532 элементов?

Версия AutoCAD 2012.
Ivv вне форума  
 
Непрочитано 18.03.2018, 15:02
#3487
Сергей812


 
Регистрация: 10.08.2013
Сообщений: 11,004


может, попробовать написать сам диалог не на DCL - например, в виде сборки dll с атрибутом LispFunction
Сергей812 вне форума  
 
Непрочитано 18.03.2018, 16:17
#3488
Ivv


 
Регистрация: 17.03.2018
Санкт-Петербург
Сообщений: 5


К сожалению ООП, Active X и (.NET) для меня пока слишком высокие материи...

Кроме того, если я верно пониманаю, применение dll подразумевает установку программы и наличие прав администратора?

Их у меня нет, - политика компании и всё такое.


Программа уже написана. Ошибка вылезла на стадии тестирования.

Пока сделал заплатку с выводом сообщения в errtile о слишком большом выборе.

Ожидаемое количество элементов списка вышеуказанного листбокса - до 1000 элементов. За две операции выбора задачу по обработке списка можно решить.


Однако, удивляет что подобная особенность поведения функции get_tile и переменной $value не описана у Полещука. Также не обнаружил упоминания об этих особенностях на ресурсах Autodesk и у Ли Мака. Вот и закралось подозрение - может проблеммы и нет вовсе... Может чего не то с настройками автокада или проблема как то решается.
Ivv вне форума  
 
Непрочитано 18.03.2018, 21:01
1 | #3489
Сергей812


 
Регистрация: 10.08.2013
Сообщений: 11,004


Цитата:
Сообщение от Ivv Посмотреть сообщение
применение dll подразумевает установку программы и наличие прав администратора?
не требует - просто надо будет положить dll в "доверенную" папку (чтобы не выскакивали предупреждения) и загружать перед вызовом программы (или сделать автозагрузку). Их не надо регистрировать в операционной системе. Но может подскажут, как обойти этот ограничение в DCL, конечно.
Сергей812 вне форума  
 
Непрочитано 18.03.2018, 21:51
#3490
Ivv


 
Регистрация: 17.03.2018
Санкт-Петербург
Сообщений: 5


Цитата:
Сообщение от Сергей812 Посмотреть сообщение
не требует - просто надо будет положить dll в "доверенную" папку.
Благодарю за разъяснение!..

P.S.: Только сегодня зарегистрировался, наблюдаю какие-то то проблемы с форумом: сообщения не публикуются часами, со стационарного компьютера вообще на страницу форума попасть не могу... Пишу с мобильного телефона...
Ivv вне форума  
 
Непрочитано 20.03.2018, 00:29
#3491
Wanted


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


Всем доброй ночи, помогите поправить LISP, при его использовании пропадают привязки. Помогите вернуть привязки по окончанию LISP-a.
Благодарю Вас!
Код:
[Выделить все]
;бесконечный вызов
(defun c:p5 (/)
  (while T (c:p2))
)

;*******************************************************
 ; Проставление размеров по точкам
 ;*******************************************************
(defun C:P2 (/ DELTA J KT L1 L2 L3 LP  OB6 OLD P1 P2 POB SP SPOINT  T1 T2 TS1 TS11 U1 U2 UGG UGR V0 VK VN W
	       dim_list ss maxp minp x y old_ucsicon flag flag1 obstruct1 obstruct2 obstruct0 detail_int_list stop_list only_one_inters achivement textbox1
	       dim_list_1 ss0 KILL_LIST CUR_POS CUR_WIDTH_F X_KILL_FLAG
	       last_obj_before_bound inner_dim_list inner_complex_list inner_walls_list
	    )
 ; (vl-cmdf "_.style" "GOST_B" "GOST type B" "250" "1" "0" "_n" "_n");если нет такого стиля - создать
  ;(vl-cmdf "_.style" "GOST_B" "Arial" "250" "1" "0" "_n" "_n");если нет такого стиля - создать
  ;(setvar "TEXTSTYLE" "GOST_B")
  (IF (= (member "_Area"         (LayerNameList)) nil)  (command "_LAYER" "_N" "_Area" ""))
  (IF (= (member "_Perimeter"    (LayerNameList)) nil)  (command "_LAYER" "_N" "_Perimeter" ""))
  (IF (= (member "_DIM"          (LayerNameList)) nil)  (command "_LAYER" "_N" "_DIM" ""))
  ;(IF (= (member "del"          (LayerNameList)) nil)  (command "_LAYER" "_N" "del" ""))
  ;(command "_-LAYER" "_off" "del" "")
  (IF (= (member "_Hidden"       (LayerNameList)) nil)  (command "_LAYER" "_N" "_Hidden" ""))  
  (setq  HT (cdr (assoc 40 (tblsearch "STYLE" (getvar 'textstyle))))) ; - высота букв (0, если высота не фиксирована)
  (if (= HT 0.0) (progn (alert "В текстовом стиле задай высоту текста!") (command "'_style") (Quit)))
    (setvar "CmdEcho" 0)
    (setvar "PDMODE" 0)
    (setvar "PDSIZE" 1)
    (setq OLD (getvar "OSMODE")) (setq old_ucsicon (getvar "ucsicon")) (setq only_one_inters nil)
    (setvar "OSmode" 0)
    (SetVar "PICKSTYLE" 1)
    (setvar "FILEDIA" 1)
    (setvar "ucsicon" 0)
    (setq last_obj_before_bound (entlast))
  
  
  

  
  ;   (Repeat 1000000
    (setq Ts1 (getpoint "\nТочка внутри контура :"))
    (setq Ts11 Ts1)
       
       ;(setvar "CeColor" "2")
       (command "_-Boundary" Ts1 "")
       (setq Ob6 (entlast)); исходная полилиния
 (setq inner_complex_list (inner_walls Ob6 last_obj_before_bound HT))
 (setq inner_dim_list (car inner_complex_list))
 (setq inner_walls_list (cadr inner_complex_list))

  
;Оптимизация контура       
       (setq LP (poly Ob6)); к-во и список точек полилинии

(setq KT (- (car LP) 1)); кол-во точек
(setq L1 (cdr LP)); список точек без кол-ва
(setq L2 (cdr (reverse L1)));обратный список точек без последней
(setq L3 (reverse L2)); нормальный список точек без последней
       (setq w 0) (setq SPoint nil)
       (Repeat KT
	  (If (= w 0)  (setq VN (last L3))  (setq VN (nth (- w 1) L3)))
	  (If (= w (- KT 1)) (setq VK (nth 0 L3)) (setq VK (nth (+ w 1) L3)))
	  (setq V0 (nth w L3))
      		(setq U1 (atof (rtos (r2g (angle V0 VK)) 2 2)))
      		(setq U2 (atof (rtos (r2g (angle VN V0)) 2 2)))
                (If (= U1 360.0) (setq U1 0.0))
                (If (= U2 360.0) (setq U2 0.0))
	 (if (/= U1 U2) (setq SPoint (cons V0 SPoint)))
	 (setq w (+ 1 w))
	 )
(entdel Ob6)

  ;(setvar "CLAYER" "_Perimeter");эта строка зачем-то была закомментирована
  ;(setvar "CeColor" "10")
       
(Setq KT (- (length Spoint)1 ))
       (command "_PLINE" (car SPoint) "_W" 35.0 35.0)
       (setq w 1)
       (Repeat KT
	 (setq V0 (nth w Spoint))
	 (command V0)
	 (setq w (+ 1 w))
	 )
(command "_C");замыкание полилинии

(Setq Pob (entlast)); объект контура!!!!!!!!!!!!
(setq LP (poly POb))
    (setq j 1)
;(setvar "CLAYER" "_DIM");;эта строка зачем-то была закомментирована
  ;(setvar "CeColor" "224")       
    (Repeat (- (car LP) 1)
            (setq T1 (nth j LP))
	    (setq T2 (nth (+ j 1) LP))
            (setq Delta (distance T1 T2))
	           (if (> (car T1)  (car T2)) (setq P1 T2 P2 T1) (setq P1 T1 P2 T2))
    	    (setq UgR      (angle P1 P2))
	    (setq UgG (r2g (angle P1 P2)))
                   (if (= (fix UgG) 270.0) (setq UgG 90.0))
       ;(setq T0  (polar (seredina P1 P2) (G2R (+ UgG 90.0))(/  HT 3.0)))
       ;(setq T00 (polar (seredina P1 P2) (G2R (+ UgG 90.0))(+ (* 0.5 HT)  HT 3.0)))
  ;#########################################################################################
  ;#########################################################################################
       (setq SP (PSW1 Pob (polar (seredina P1 P2) (G2R (+ UgG 90.0)) 0.01))); 0.01 - размер "щупа" для определения направления сегмента полилинии. был 100. много!
  ;#########################################################################################
  ;#########################################################################################
    (if (= SP 1) (setq T00 (polar (seredina T1 T2) (G2R (+ UgG 90.0)) (+ (* 0.5 HT) 100.0))))
    (if (= SP 0) (setq T00 (polar (seredina T1 T2) (G2R (- UgG 90.0)) (+ (* 0.5 HT) 100.0))))
      
         (command "_TEXT" "_j" "_MC" T00 (+ UgG 0.0) (rtos (/ Delta 1000.0) 2 2)) (setq Ob (entLAST))

;;;;;;;;;;;;;;;;;;;;;;добавка 1 - СПИСОК РАЗМЕРНЫХ ТЕКСТОВ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
         (setq dim_list (append dim_list (list (list
					   Ob
					   (distof (vla-get-TextString (vlax-ename->vla-object Ob)))
					   (angle (seredina T1 T2) T00)
					   (vla-get-ScaleFactor (vlax-ename->vla-object Ob))
					   T00
;;;					   (cons "dir_ang" (angle (seredina T1 T2) T00))
;;;					   (cons "sc_f" (vla-get-ScaleFactor (vlax-ename->vla-object (entLAST))))
					 ))
			)
	 );конец добавки 1
	;???????????????????????????????????????????????????????????
    (setq j (+ 1 j))
  )

  ;#########################################################################################
 
 ; );REPEAT 10000000000000000000000
 ;**********************************************
 (if inner_dim_list (setq dim_list (append dim_list inner_dim_list)))

  
;общая "прополка"
(cleanup dim_list pob T inner_walls_list)
  
(setq dim_list (vl-remove-if-not '(lambda (y) (entget (car y))) dim_list))
  (foreach w dim_list
    (setq flag (inters_detect w dim_list pob nil nil))
        (if (cdr (assoc "general_flag" (car flag))) ;безнадежных фтопку. как вариант - можно на выключенный слой
          (vla-delete (vlax-ename->vla-object (car w)))
	)
  )  

(if inner_walls_list
	(foreach k inner_walls_list
	  (entdel k);внутренние контуры фтопку 
	)
)
  
;главный контур фтопку  
(entdel pob)

  
(SetVAR "OsMode" Old)
(setvar "ucsicon" old_ucsicon)
 (princ)
(setvar "osmode" osm)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;добавка 3
(defun inters_detect (ent dimlist pob inner inner_walls / minp maxp ss ss0  flag_full flag flag0 int_dimlist found_list new_found_list cp_list FLAG1 POB_FLAG)
     (setq flag nil new_found_list nil minp nil maxp nil)
     (setq FLAG1 nil POB_FLAG nil flag_full nil)
 (setq int_dimlist  dimlist)
     ; проверка на принадлежность контуру
 (if inner
   (progn  
     (setq ss0 (ssget "_CP" (plv1 (vlax-ename->vla-object pob))))
     (if ss0
	(if (ssmemb (car ent) ss0)
	  (setq flag0 t);размер внутри контура, можно проверять дальше
	  (setq flag t); размер не внутри контура, все плохо
	)
     )
     (setq ss0 nil); (setq flag flag0)
   )
   (setq flag0 t);размер и не должен быть внутри контура
 );eo if inner
  
;если размер внутри контура или не должен там быть, можно проверять дальше
     (if flag0
       (progn
	     (if inner (setq int_dimlist (append dimlist (list (list pob)))))
             (foreach f inner_walls
	       (setq int_dimlist (append int_dimlist (list (list f))))
	     )
	     (setq int_dimlist (vl-remove ent int_dimlist))
	     (setq int_dimlist (mapcar 'car int_dimlist))
	  
	     (vl-cmdf "_ucs" "_OB" (car ent))
	     (gc:UcsBoundingBox (car ent) 'minp 'maxp)
	     (setq cp_list (list
				     (trans (list (car minp) (cadr minp) (caddr minp)) 1 0)
				     (trans (list (car minp) (cadr maxp) (caddr minp)) 1 0)
				     (trans (list (car maxp) (cadr maxp) (caddr minp)) 1 0)
				     (trans (list (car maxp) (cadr minp) (caddr minp)) 1 0)
		           )
	     )
	     (vl-cmdf "_ucs" "_p")
	     (setq ss (ssget "_CP" cp_list))
  
	     (if ss
	       (progn
	        (setq found_list (ssnamex ss))
		(setq ss nil)
		(setq found_list (mapcar 'cadr found_list))
		(setq found_list (vl-remove-if-not '(lambda (x) (eq (type x) 'ENAME)) found_list))
		(setq found_list (vl-remove (car ent) found_list))
		(foreach z found_list
		  (if (member z int_dimlist)
		   (setq new_found_list (append new_found_list (list z)))
		  )
		)
		(if new_found_list (setq flag T))
	       );eo progn
     	     )
	 )
      )
 (if new_found_list 
	 (if (or (member pob new_found_list)
		 (vl-some '(lambda (jj) (member jj inner_walls)) new_found_list)
	     )
	   (setq pob_flag T); размер пересекает внешний или внутр. контур, все плохо
	   (if (= 1 (length new_found_list)) (setq flag1 T));объект не пересекает контур, но пересекает один из размеров. причем только один
	 )
 )
 ;(setq flag_full (list (cons "general_flag" flag) (cons "pob_flag" pob_flag) (cons "flag1" flag1)))
 (setq flag_full (list
		   (cons "general_flag" flag)
		   (cons "pob1_flag" (and (not pob_flag)  flag1))
		   (cons "pob_flag" (not pob_flag));!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		 )
 )
 
 (list flag_full new_found_list)
)
;;;;;;;;конец добавки 3
;;;;;;;;добавка 4
(defun inters_detect1 (ent detail_int_list pob / text_int_list textbox1 point)
  	(setq text_int_list detail_int_list)
  	(if (member pob text_int_list)
	  (setq text_int_list (vl-remove pob text_int_list))
	)	    
  	(if (= 1 (length text_int_list))
	  (progn
	    ;(vla-put-color (vlax-ename->vla-object (car text_int_list)) acred)
	    (setq textbox1 (textbox (entget (car text_int_list))))
	    (vla-put-TextAlignmentPoint
	      (vlax-ename->vla-object (car ent))
	      (vlax-3d-point
		      (polar
			(vlax-safearray->list (vlax-variant-value (vla-get-TextAlignmentPoint (vlax-ename->vla-object (car ent)))))
			(nth 2 ent)
			;(* 1.1 (min_dist_inters (car ent)  (car text_int_list)))
			;(* 1.2 (vla-get-Height (vlax-ename->vla-object (car text_int_list))))
			;(* 0.5 textbox1)
			(* 0.35(- (caadr textbox1) (caar textbox1)))
		      ); eo polar
	      );eo vlax-3d-point
	    ); eo vla-put-TextAlignmentPoint  
	    (car text_int_list)
	  );eo progn  
	  nil;else
	);eo if  

)

;;;;;;;;конец добавки 4

;;;;;;;;;;;;;  
;############################################################################
;############################################################################
(defun POISK1 (_P1 _P2 /  _DELTA _DIS _DL _S _T0 _TC _UGG _UGR _W1 _W2 _W3 _W4 )
    ;(setq  HT 150.0)
  (setq A (List 1000000.0 (List 0.0 0.0 0.0)))
   (setq _DELTA (distance _P1 _P2 ))
    		            (setq _UgR      (angle _P1 _P2))
			    (setq _UgG (r2g (angle _P1 _P2)))
    (if (= (fix _UgG) 270.0) (setq _UgG 90.0))
       (command "_TEXT" "_j" "_C" T0 (+ _UgG 0.0) (rtos _UgG 2 2))
       (setq _DL (TXTLen (entlast))) (setq Ob (entlast)) (entdel OB)
       (setq _DIS (+ _DL (* 0.5 _DELTA)))
       (setq _T0 (seredina _P1 _P2))
       (setq _TC (Polar _T0 (G2R (+ _UgG 90.0))(/  HT 3.0)))

; Верх назад ----------------------------------------------------       
       (setq _W1 (Polar _TC (G2R (- _UgG 180.0)) (* 0.5 _DL)))
       (setq _W2 (Polar _W1 (G2R (+ _UgG   0.0)) (* 1.0 _DL)))
       (setq _W3 (Polar _W2 (G2R (+ _UgG  90.0))  HT))
       (setq _W4 (Polar _W1 (G2R (+ _UgG  90.0))  HT))  
       (setq _S (ssget "_CP" (list _W1 _W2 _W3 _W4 _W1)))
       (IF (= _S nil) (progn
	 ;(command "_TEXT" "_j" "_C" (seredina _W1 _W2) (+ _UgG 0.0) (rtos _UgG 2 2))
	 ;(command "_PLINE" _W1 _W2 _W3 _W4 "_c")
	 (setq A (List (distance (seredina _W1 _W3) (seredina _P1 _P2)) (seredina _W1 _W3) (seredina _W1 _W3)))
	 (setq _DIS 0.0)
	 )) 
       ;(command "_PLINE" _W1 _W2 _W3 _W4 "_c") 
       (while (> _DIS (Distance _TC _W1))
	       (setq _W1 (Polar _W1 (G2R (- _UgG 180.0)) (/  HT 3.0)))
	       (setq _W2 (Polar _W2 (G2R (- _UgG 180.0)) (/  HT 3.0)))
	       (setq _W3 (Polar _W3 (G2R (+ _UgG 180.0)) (/  HT 3.0)))
	       (setq _W4 (Polar _W4 (G2R (+ _UgG 180.0)) (/  HT 3.0)))
	       ;(command "_PLINE" _W1 _W2 _W3 _W4 "_c")
	       (setq _S (ssget "_CP" (list _W1 _W2 _W3 _W4 _W1)))
	       (IF (= _S nil) (progn
		 ;(command "_TEXT" "_j" "_C" (seredina _W1 _W2) (+ _UgG 0.0) (rtos _UgG 2 2))
		 (setq A (List (distance (seredina _W1 _W3) (seredina _P1 _P2)) (seredina _W1 _W3) (seredina _W1 _W3)))
		 (setq _DIS 0.0)
		 )) 
	 
	 )
  (princ) (setq A A)
  )
 ; Верх ВПЕРЕД  ----------------------------------------------------
(defun POISK2 (_P1 _P2 /  _DELTA _DIS _DL _S _T0 _TC _UGG _UGR _W1 _W2 _W3 _W4 )
    ;(setq  HT 150.0)
  (setq A (List 1000000.0 (List 0.0 0.0 0.0)))
   (setq _DELTA (distance _P1 _P2 ))
    		            (setq _UgR      (angle _P1 _P2))
			    (setq _UgG (r2g (angle _P1 _P2)))
    (if (= (fix _UgG) 270.0) (setq _UgG 90.0))
       (command "_TEXT" "_j" "_C" T0 (+ _UgG 0.0) (rtos _UgG 2 2))
       (setq _DL (TXTLen (entlast))) (setq Ob (entlast)) (entdel OB)
       (setq _DIS (+ _DL (* 0.5 _DELTA)))
  
       (setq _T0 (seredina _P1 _P2))
       (setq _TC (Polar _T0 (G2R (+ _UgG 90.0))(/  HT 3.0)))
  
       (setq _W1 (Polar _TC (G2R (- _UgG 180.0)) (* 0.5 _DL)))
       (setq _W2 (Polar _W1 (G2R (+ _UgG   0.0)) (* 1.0 _DL)))
       (setq _W3 (Polar _W2 (G2R (+ _UgG  90.0))  HT))
       (setq _W4 (Polar _W1 (G2R (+ _UgG  90.0))  HT))
  
       (setq _S (ssget "_CP" (list _W1 _W2 _W3 _W4 _W1)))
       (IF (= _S nil) (progn
	 ;(command "_TEXT" "_j" "_C" (seredina _W1 _W2) (+ _UgG 0.0) (rtos _UgG 2 2))
	 ;(command "_PLINE" _W1 _W2 _W3 _W4 "_c")
	  (setq A (List (distance (seredina _W1 _W3) (seredina _P1 _P2)) (seredina _W1 _W3) (seredina _W1 _W3)))
	 (setq _DIS 0.0)
	 )) 

       ;(command "_PLINE" _W1 _W2 _W3 _W4 "_c")
       (while (> _DIS (Distance _TC _W1))
	       (setq _W1 (Polar _W1 (G2R (- _UgG 0.0)) (/  HT 3.0)))
	       (setq _W2 (Polar _W2 (G2R (- _UgG 0.0)) (/  HT 3.0)))
	       (setq _W3 (Polar _W3 (G2R (+ _UgG 0.0)) (/  HT 3.0)))
	       (setq _W4 (Polar _W4 (G2R (+ _UgG 0.0)) (/  HT 3.0)))
	       ;(command "_PLINE" _W1 _W2 _W3 _W4 "_c")
	       (setq _S (ssget "_CP" (list _W1 _W2 _W3 _W4 _W1)))
	       (IF (= _S nil) (progn
		 ;(command "_TEXT" "_j" "_C" (seredina _W1 _W2) (+ _UgG 0.0) (rtos _UgG 2 2))
		 (setq A (List (distance (seredina _W1 _W3) (seredina _P1 _P2)) (seredina _W1 _W3) (seredina _W1 _W3)))
		 (setq _DIS 0.0)
		)) 
	 )
(princ) (setq A A)
)
;############################################################################
; НИЗ назад ----------------------------------------------------
(defun POISK3 (_P1 _P2 /  _DELTA _DIS _DL _S _T0 _TC _UGG _UGR _W1 _W2 _W3 _W4 )
    ;(setq  HT 150.0)
  (setq A (List 1000000.0 (List 0.0 0.0 0.0)))
   (setq _DELTA (distance _P1 _P2 ))
    		            (setq _UgR      (angle _P1 _P2))
			    (setq _UgG (r2g (angle _P1 _P2)))
    (if (= (fix _UgG) 270.0) (setq _UgG 90.0))
       (command "_TEXT" "_j" "_C" T0 (+ _UgG 0.0) (rtos _UgG 2 2))
       (setq _DL (TXTLen (entlast))) (setq Ob (entlast)) (entdel OB)
       (setq _DIS (+ _DL (* 0.5 _DELTA)))
;----------------------------------------------------------------------  
       (setq _T0 (seredina _P1 _P2))
       (setq _TC (Polar _T0 (G2R (- _UgG 90.0))(/  HT 3.0)))
  
       (setq _W1 (Polar _TC (G2R (- _UgG 180.0)) (* 0.5 _DL)))
       (setq _W2 (Polar _W1 (G2R (+ _UgG   0.0)) (* 1.0 _DL)))
       (setq _W3 (Polar _W2 (G2R (- _UgG  90.0))  HT))
       (setq _W4 (Polar _W1 (G2R (- _UgG  90.0))  HT))  

       (setq _S (ssget "_CP" (list _W1 _W2 _W3 _W4 _W1)))
       (IF (= _S nil) (progn
	 ;(command "_TEXT" "_j" "_C" (seredina _W4 _W3) (+ _UgG 0.0) (rtos _UgG 2 2))
	 ;(command "_PLINE" _W1 _W2 _W3 _W4 "_c")
	  (setq A (List (distance (seredina _W1 _W3) (seredina _P1 _P2)) (seredina _W3 _W1) (seredina _W1 _W3)))
	 (setq _DIS 0.0)
	 )) 


  
       ;(command "_PLINE" _W1 _W2 _W3 _W4 "_c")
       (while (> _DIS (Distance _TC _W1))
	       (setq _W1 (Polar _W1 (G2R (- _UgG 180.0)) (/  HT 3.0)))
	       (setq _W2 (Polar _W2 (G2R (- _UgG 180.0)) (/  HT 3.0)))
	       (setq _W3 (Polar _W3 (G2R (+ _UgG 180.0)) (/  HT 3.0)))
	       (setq _W4 (Polar _W4 (G2R (+ _UgG 180.0)) (/  HT 3.0)))
	       ;(command "_PLINE" _W1 _W2 _W3 _W4 "_c")
	       (setq _S (ssget "_CP" (list _W1 _W2 _W3 _W4 _W1)))
	       (IF (= _S nil) (progn
		 ;(command "_TEXT" "_j" "_C" (seredina _W3 _W4) (+ _UgG 0.0) (rtos _UgG 2 2))
		 (setq A (List (distance (seredina _W1 _W3) (seredina _P1 _P2))(seredina _W3 _W1)  (seredina _W1 _W3)))
		 (setq _DIS 0.0)
		)) 
	 )
(princ) (setq A A)
)
;############################################################################
; НИЗ ВПЕРЕД  ----------------------------------------------------
  (defun POISK4 (_P1 _P2 /  _DELTA _DIS _DL _S _T0 _TC _UGG _UGR _W1 _W2 _W3 _W4 )
  ;(setq  HT 150.0)
   (setq A (List 1000000.0 (List 0.0 0.0 0.0))) 
   (setq _DELTA (distance _P1 _P2 ))
    		            (setq _UgR      (angle _P1 _P2))
			    (setq _UgG (r2g (angle _P1 _P2)))
    (if (= (fix _UgG) 270.0) (setq _UgG 90.0))
       (command "_TEXT" "_j" "_C" T0 (+ _UgG 0.0) (rtos _UgG 2 2))
       (setq _DL (TXTLen (entlast))) (setq Ob (entlast)) (entdel OB)
       (setq _DIS (+ _DL (* 0.5 _DELTA)))
;----------------------------------------------------------------------    
       (setq _T0 (seredina _P1 _P2))
       (setq _TC (Polar _T0 (G2R (- _UgG 90.0))(/  HT 3.0)))
  
       (setq _W1 (Polar _TC (G2R (- _UgG 180.0)) (* 0.5 _DL)))
       (setq _W2 (Polar _W1 (G2R (+ _UgG   0.0)) (* 1.0 _DL)))
       (setq _W3 (Polar _W2 (G2R (- _UgG  90.0))  HT))
       (setq _W4 (Polar _W1 (G2R (- _UgG  90.0))  HT))  

       (setq _S (ssget "_CP" (list _W1 _W2 _W3 _W4 _W1)))
       (IF (= _S nil) (progn
	 ;(command "_TEXT" "_j" "_C" (seredina _W3 _W4) (+ _UgG 0.0) (rtos _UgG 2 2))
	 ;(command "_PLINE" _W1 _W2 _W3 _W4 "_c")
	  (setq A (List (distance (seredina _W1 _W2) (seredina _P1 _P2)) (seredina _W3 _W1) (seredina _W1 _W3)))
	 (setq _DIS 0.0)
	 )) 

    
       ;(command "_PLINE" _W1 _W2 _W3 _W4 "_c")
       (while (> _DIS (Distance _TC _W1))
	       (setq _W1 (Polar _W1 (G2R (- _UgG 0.0)) (/  HT 3.0)))
	       (setq _W2 (Polar _W2 (G2R (- _UgG 0.0)) (/  HT 3.0)))
	       (setq _W3 (Polar _W3 (G2R (+ _UgG 0.0)) (/  HT 3.0)))
	       (setq _W4 (Polar _W4 (G2R (+ _UgG 0.0)) (/  HT 3.0)))
	       ;(command "_PLINE" _W1 _W2 _W3 _W4 "_c")
	       (setq _S (ssget "_CP" (list _W1 _W2 _W3 _W4 _W1)))
	       (IF (= _S nil) (progn
		 ;(command "_TEXT" "_j" "_C" (seredina _W3 _W4) (+ _UgG 0.0) (rtos _UgG 2 2))
		 (setq A (List (distance (seredina _W1 _W2) (seredina _P1 _P2)) (seredina _W3 _W1) (seredina _W1 _W3)))
		 (setq _DIS 0.0)
		)) 
	 )
(princ) (setq A A)
)
;############################################################################
;############################################################################
;############################################################################
;############################################################################
;############################################################################
;############################################################################
;############################################################################
;############################################################################
;############################################################################
;############################################################################
(defun SEREDINA (TE1 TE2 / AA DX DY DZ)
    (setq DX (/ (+ (car TE1) (car TE2)) 2.0))
    (setq DY (/ (+ (cadr TE1) (cadr TE2)) 2.0))
    (setq DZ 0.0)
    (if (and (/= (caddr TE1) NIL) (/= (caddr TE2) NIL))
        (progn
            (setq DZ (/ (+ (caddr TE1) (caddr TE2)) 2.0))
        )
    )
    (setq AA (list DX DY DZ))
) ;END DEFUN


;###############################################################################
;###############################################################################  
;;--------------------------------------------------------
;; Функция получает строковое представление ObjectID
;; вне зависимости от того AutoCAD x86 или x64
;; Источник: https://discussion.autodesk.com/forums/message.jspa?messageID=6172961
;;--------------------------------------------------------
(defun get-objectid-x86-x64 (obj / util)
  (setq util (vla-get-utility (vla-get-activedocument (vlax-get-acad-object))))
  (if (= (type obj) 'ename)
    (setq obj (vlax-ename->vla-object obj))
    ) ;_ end of if
  (if (= (type obj) 'vla-object)
    (if (> (vl-string-search "x64" (getvar "platform")) 0)
      (vlax-invoke-method util "GetObjectIdString" obj :vlax-false)
      (rtos (vla-get-objectid obj) 2 0)
      ) ;_ end of if
    ) ;_ end of if
  ) ;_ end of defun  
  ;###############################################################################
  
  
  
;###############################################################################
;Программа создания поля, отображающего, длину указанного отрезка
;###############################################################################
(defun InsFld (_obj _T1 / adoc ent pt)
 
(vl-load-com)
  (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
  (if (and (= (type
                (setq
                  ent (vl-catch-all-apply
                        (function
                          (lambda ()
                            (vlax-ename->vla-object
                              _Obj ;(car (entsel "\nУкажите отрезок, полилинию или сплайн <Отмена> : ")) ;_ end of car
                              ) ;_ end of vlax-ename->vla-object
                            ) ;_ end of lambda
                          ) ;_ end of function
                        ) ;_ end of vl-catch-all-apply
                  ) ;_ end of setq
                ) ;_ end of type
              'vla-object
              ) ;_ end of =
           (vlax-property-available-p ent 'length)
           (= (type (setq pt (vl-catch-all-apply
                               (function
                                 (lambda ()
		                        _T1 ; (getpoint "\nУкажите точку для простановки поля <Отмена> : ")
                                   ) ;_ end of lambda
                                 ) ;_ end of function
                               ) ;_ end of vl-catch-all-apply
                          ) ;_ end of setq
                    ) ;_ end of type
              'list
              ) ;_ end of =
           pt
           ) ;_ end of and
    (vla-addtext
      (vla-objectidtoobject
        adoc
        (vla-get-ownerid ent)
        ) ;_ end of vla-ObjectIDToObject
      (strcat "%<\\AcObjProp Object(%<\\_ObjId "
              (vl-princ-to-string (get-objectid-x86-x64 ent))
              ">%).Length \\f \"%lu6\">%"
              ) ;_ end of strcat
      (vlax-3d-point pt)
      250
      ) ;_ end of vla-addtext
    ) ;_ end of if
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun



(defun PSW1 ( _e1 _Pt1 /)
  (vl-load-COM)
  (and
    ;(setq _e1 (car(entsel "\nВыбери полилинию-контур: ")))
    ;(setq _pt1 (getpoint "\nУкажи точку (не на контуре): "))
    (setq _pt2 (vlax-curve-getclosestpointto _e1 _pt1)) ;_ см п.2 пост #20
    (setq _pt3 (vlax-curve-getFirstDeriv _e1 (vlax-curve-getParamAtPoint _e1 _pt2)));_ см п.3 пост #20
    (setq _pt1 (mapcar '- _pt1 _pt2))
    (setq _ang (3d_Wnorm _pt1 _pt3)) ;_ см п.4 пост #20
    (if (lib:pline_clockwise _e1) ;;; если контур по часовой стрелке
      (progn
        ;;;Если бы точка была снаружи, то угол был бы отрицательным
        (if (minusp (last _ang))
          (setq _Kon 0);(alert "Точка снаружи")
          (setq _Kon 1);(alert "Точка внутри")
          )
        )
      (progn  ;;; если контур против часовой стрелки
        (if (minusp (last _ang))
          (setq _Kon 1) ;(alert "Точка внутри")
          (setq _Kon 0);(alert "Точка снаружи")
          )
        )
      )
    )
  (setq _kon _Kon)
  )

;********************************
; Векторное произведение векторов
;********************************
; W1, W2 - вектора
; Возвращает: вектор нормали к плоскости заданной векторами  в правой системе координат.
;W1 и W2 не должны лежать на одной прямой).
(defun 3d_Wnorm (W1 W2)
  (if (< (length W1) 3)(setq W1 (list (car W1)(cadr W1) 0)))
  (if (< (length W2) 3)(setq W2 (list (car W2)(cadr W2) 0)))
  (list (- (* (cadr W1)(caddr W2))(* (caddr W1)(cadr W2)))
        (- (* (caddr W1)(car W2)) (* (car W1)(caddr W2)))(- (* (car W1)(cadr W2)) (* (cadr W1)(car W2))))
  )


(defun lib:pline_clockwise ( lw  / LST MAXP MINP)
  
(if (= (type lw) 'ENAME)
    (setq lw (vlax-ename->vla-object lw)))  
		(vla-GetBoundingBox lw 'MinP 'MaxP)
		(setq
			minp(vlax-safearray->list minp)
			MaxP(vlax-safearray->list MaxP)
			lst(mapcar(function(lambda(x)
			(vlax-curve-getParamAtPoint lw
			(vlax-curve-getClosestPointTo lw x))))
			(list minp(list(car minp)(cadr MaxP))MaxP(list(car MaxP)(cadr minp))))
		)
		(if(or
			(<=(car lst)(cadr lst)(caddr lst)(cadddr lst))
			(<=(cadr lst)(caddr lst)(cadddr lst)(car lst))
			(<=(caddr lst)(cadddr lst)(car lst)(cadr lst))
			(<=(cadddr lst)(car lst)(cadr lst)(caddr lst)))
		  t nil)
  )
 ;************************************************************************
 ;************************************************************************
 ;************************************************************************
  ; ПРОВЕРКА НАЛИЧИЯ СЛОЯ
; Пример вызова (member "LyrName" (LayerNameList))
(defun LayerNameList ( / res)
  (setq res '())
  (vlax-for lyr (vla-get-Layers (vla-get-ActiveDocument (vlax-get-acad-object)))
    (setq res (cons (vla-get-Name lyr) res))
  )
  (cond (res (acad_strlsort res)))
)
 ;************************************************************************
 ;************************************************************************
;************************************************************************
 ; Функция переводит градусы в радианы
 ; Параметр  - угол в градусах
 ;************************************************************************
(defun G2R (GG / AA _n)
      (setq _n (fix (/ GG 360.0)))
    (setq GG (- GG (* _n 360.0))) 
    (setq AA (/ (* pi GG) 180.0))
) ;END DEFUN
 ;************************************************************************
 ;************************************************************************
 ; Функция переводит радианы в  градусы 
 ; Параметр  - угол в радианах
 ;************************************************************************
(defun R2G (GG / AA _n)
    (setq AA (/ (* 180.0 GG) pi))
    (setq _n (fix (/ AA 360.0)))
    (setq AA (- AA (* _n 360.0)))
) ;END DEFUN
 ;************************************************************************
 ;************************************************************************
 ;************************************************************************
 ;***************************************************
 ; Функция определения длины текста
 ; параметр - имя примитива (car (entsel))
 ;***************************************************
(defun TXTLEN (_EN / _E1 _ED _LENGTH1 _PT1 _PT2)
    (setq _ED (entget _EN))
    (if
        (= "TEXT" (cdr (assoc 0 _ED)))
           (progn
               (setq _E1 _ED)
               (setq _ED (subst (cons 72 2) (assoc 72 _ED) _ED))
               (entmod _ED)
               (setq _ED (entget _EN))
               (setq _PT1 (cdr (assoc 10 _ED)))
               (setq _PT2 (cdr (assoc 11 _ED)))
               (setq _LENGTH1 (distance _PT1 _PT2))
               (setq _ED _E1)
               (entmod _ED)
           ) ; progn
    ) ; if
    (if (/= "TEXT" (cdr (assoc 0 _ED)))
        (setq _LENGTH1 NIL)
    )
    (setq _LENGTH1 _LENGTH1)
) ; end defun txtlen
 ;***************************************************
;****************************************************************
; Функция возвращает список всех точек полилинии
; первый элемент кол-во точек полилинии
; ( 5 (0.0 0.0) (1.0 0.0)  (0.0 2.0) (5.0 5.0) (10.0 -20.0) 
;****************************************************************
(defun POLY (A1 / _P1 _A1 _A2 _TIP _A200 _N_MAX _N1 _N2 _I)
    (setq _A2 (entget A1))
    (setq _TIP (cdr (assoc 0 _A2)))
    (setq _A200 NIL)
 ;**************************************************************
    (if (= _TIP "LWPOLYLINE")
        (progn
            (setq _N_MAX (length _A2))
            (setq _I 0)
            (setq _ii 0)
            (repeat _N_MAX
                (setq _SP (nth _I _A2))
                (if (= (car _SP) 10)
                    (progn
                    (setq _A200 (cons (cdr _SP) _A200))
                    (if (= _ii 0) (setq _T0 (cdr _SP)))
                    (setq _ii 1)
                ))
                		
                (setq _I (+ 1 _I))
            ) ;Repeat
            					(setq _CLOSE (cdr (assoc 70 _A2)))
            					(IF (= _CLOSE 1) (setq _A200 (cons _T0 _A200)))
            (setq _N_MAX (length _A200))
            (setq _A200 (reverse _A200))
            (setq _A200 (cons _N_MAX _A200))            
        ) ;progn
    ) ;if
 ;**************************************************************
 ;**************************************************************
    (if (= _TIP "LINE")
        (progn
            (setq N1 (cdr (assoc 10 _A2)))
            (setq N2 (cdr (assoc 11 _A2)))
            (setq _A200 (list 2 N1 N2))
        ) ;progn
    ) ;if
;***************************************************************    
    (if (= _TIP "SOLID")
        (progn
            (setq N1 (cdr (assoc 10 _A2)))
            (setq N2 (cdr (assoc 11 _A2)))
            (setq N3 (cdr (assoc 12 _A2)))
            (setq N4 (cdr (assoc 13 _A2)))
            (setq _A200 (list 4 N1 N2 N3 N4))
        ) ;progn
    ) ;if
;***************************************************************    
(setq _A200 _A200)
);END DEFUN
 ;******************************************************************


;; gc:UcsBoundingBox - Lee Mac
;; Returns the UCS coordinates of the object bounding box about current UCS
;;
;; Arguments
;; obj: an entity (ENAME or VLA-OBJCET)
;; _OutputMinPtSym: a quoted symbol (output)
;; _OutputMaxPtSym: a quoted symbol (output)
(defun gc:UcsBoundingBox ( obj _OutputMinPtSym _OutputMaxPtSym )
(and (= (type obj) 'ename)
(setq obj (vlax-ename->vla-object obj))
)
(vla-transformby obj (vlax-tmatrix (gc:TMatrixFromTo 1 0)))
(vla-getboundingbox obj _OutputMinPtSym _OutputMaxPtSym)
(vla-transformby obj (vlax-tmatrix (gc:TMatrixFromTo 0 1)))
(set _OutputMinPtSym (vlax-safearray->list (eval _OutputMinPtSym)))
(set _OutputMaxPtSym (vlax-safearray->list (eval _OutputMaxPtSym)))
)
;; gc:TMatrixFromTo
;; Returns the 4X4 transformation matrix from a coordinate system to an other one
;;
;; Arguments
;; from to: same arguments as for the 'trans' function
(defun gc:TMatrixFromTo ( from to )
(append
(mapcar
(function
(lambda ( v o )
(append (trans v from to t) (list o))
)
)
'(
(1.0 0.0 0.0)
(0.0 1.0 0.0)
(0.0 0.0 1.0)
)
(trans '(0.0 0.0 0.0) to from)
)
'((0.0 0.0 0.0 1.0))
)
)


(defun plv1 (plyn / K listvert ) ;список вершин полилинии без излишеств
 
 
       (setq k 0) 
       (while 
    (not 
      (vl-catch-all-error-p 
        (vl-catch-all-apply 
          (function 
       (lambda (x) 
         (setq vert     (vla-get-coordinate x k) 
          listvert (cons vert listvert) 
         ) ;_ end of setq 
       ) ;_ end of lambda 
          ) ;_ end of function 
          (list  plyn)
        ) ;_ end of vl-catch-all-apply 
      ) ;_ end of VL-CATCH-ALL-ERROR-P 
    ) ;_ end of not 
     (setq k (1+ k)) 
       ) ;_ end of while 
       (setq listvert (mapcar 'vlax-safearray->list 
               (mapcar 'vlax-variant-value listvert) 
            ) ;_ end of mapcar 
       ) ;_ end of setq
    

) ;_ end of defun 


;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun min_dist_inters (ent1 ent2 / l1_pl l2_pl dist_list minp maxp
		       )
  (setq dist_list nil)

	(vl-cmdf "_ucs" "_OB" ent1)
	(gc:UcsBoundingBox ent1 'minp 'maxp)
	(setq l1_pl (list
			     (trans (list (car minp) (cadr minp) (caddr minp)) 1 0)
			     (trans (list (car minp) (cadr maxp) (caddr minp)) 1 0)
			     (trans (list (car maxp) (cadr maxp) (caddr minp)) 1 0)
			     (trans (list (car maxp) (cadr minp) (caddr minp)) 1 0)
	           )
	)
	(vl-cmdf "_ucs" "_p")

	(vl-cmdf "_ucs" "_OB" ent2)
	(gc:UcsBoundingBox ent2 'minp 'maxp)
	(setq l2_pl (list
			     (trans (list (car minp) (cadr minp) (caddr minp)) 1 0)
			     (trans (list (car minp) (cadr maxp) (caddr minp)) 1 0)
			     (trans (list (car maxp) (cadr maxp) (caddr minp)) 1 0)
			     (trans (list (car maxp) (cadr minp) (caddr minp)) 1 0)
	           )
	)
	(vl-cmdf "_ucs" "_p")  
 
  (foreach x l1_pl
    (foreach y l2_pl
	     (setq dist_list (append dist_list (list (distance x y))))
    )
  )
  (setq dist_list (vl-sort dist_list (function (lambda (e1 e2)
					          (< e1 e2)
					       )
			             )
	          )
  )
  (car dist_list)
)



;;;;;;;;;функция зачистки;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;функция зачистки;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;функция зачистки;;;;;;;;;;;;;;;;;;;;
(defun cleanup (dim_list pob inner inner_walls
	       /
	       ACHIVEMENT CUR_POS CUR_WIDTH_F DIM_LIST_1 FLAG KILL_LIST OBSTRUCT0 OBSTRUCT1 OBSTRUCT2 ONLY_ONE_INTERS SS0 TEXTBOX1 X_KILL_FLAG Y
	       )
 (setq dim_list (vl-sort dim_list (function (lambda (e1 e2)
					      (< (cadr e1) (cadr e2))
					    )
			          )
	        )
 ); сортировка
 (setq dim_list_1 dim_list);используется в конце для сверки и зачистки

 (foreach x dim_list
   (setq y nil flag nil only_one_inters nil achivement nil obstruct1 nil obstruct2 nil obstruct0 nil x_kill_flag nil);предполагаем плохой вариант - пересечения есть  и не одно.

    (setq flag (inters_detect x dim_list pob inner inner_walls)); первая проверка пересечений
    (if (cdr (assoc "pob1_flag" (car flag))); если при даннном варианте единич. пересечение
		  (setq only_one_inters (list
					  (cons "align_1" (vla-get-Alignment (vlax-ename->vla-object (car x))))
					  (cons "width_1"(vla-get-ScaleFactor (vlax-ename->vla-object (car x))))
				        )
		  )
    )
    (if (cdr (assoc "pob_flag" (car flag))) (setq achivement (append achivement ;сколько на хвосте при каких обстоятельствах
									     (list (list
									       (cons "trail" (length (cadr flag)))
									       (cons "align_1" (vla-get-Alignment (vlax-ename->vla-object (car x))))
									       (cons "width_1"(vla-get-ScaleFactor (vlax-ename->vla-object (car x))))								       
									     ))  
							     )
					    )
    )  
   
    (if (cdr (assoc "general_flag" (car flag)));если проверка выше не пройдена - двигаемся дальше
      (progn
      	(vla-put-Alignment (vlax-ename->vla-object (car x)) acAlignmentMiddleRight);изначально размеры выровнены по центру. пробуем подвигать сначала вправо
	(vla-update (vlax-ename->vla-object (car x)));@@@@@@@@@@@@@@@@@@@@@@@@
	(setq flag (inters_detect x dim_list pob inner inner_walls)); проверка того, что получилось
	(if (cdr (assoc "pob1_flag" (car flag))); если при даннном варианте единич. пересечение
		  (setq only_one_inters (list
					  (cons "align_1" (vla-get-Alignment (vlax-ename->vla-object (car x))))
					  (cons "width_1"(vla-get-ScaleFactor (vlax-ename->vla-object (car x))))
				        )
		  )
	)
        (if (cdr (assoc "pob_flag" (car flag))) (setq achivement (append achivement ;сколько на хвосте при каких обстоятельствах
									     (list (list
									       (cons "trail" (length (cadr flag)))
									       (cons "align_1" (vla-get-Alignment (vlax-ename->vla-object (car x))))
									       (cons "width_1"(vla-get-ScaleFactor (vlax-ename->vla-object (car x))))								       
									     ))  
							     )
					    )
        ) 	
      ); eo progn
    );eo if

    
    
    (if (cdr (assoc "general_flag" (car flag)));если проверка выше не пройдена - двигаемся дальше
	      (progn
	      	(vla-put-Alignment (vlax-ename->vla-object (car x)) acAlignmentMiddleLeft);потом влево
		(vla-update (vlax-ename->vla-object (car x)));@@@@@@@@@@@@@@@@@@@@@@@@
		(setq flag (inters_detect x dim_list pob inner inner_walls)); проверка того, что получилось
		(if (cdr (assoc "pob1_flag" (car flag))); если при даннном варианте единич. пересечение
			  (setq only_one_inters (list
						  (cons "align_1" (vla-get-Alignment (vlax-ename->vla-object (car x))))
						  (cons "width_1"(vla-get-ScaleFactor (vlax-ename->vla-object (car x))))
					        )
			  )
		)
	        (if (cdr (assoc "pob_flag" (car flag))) (setq achivement (append achivement ;сколько на хвосте при каких обстоятельствах
									     (list (list
									       (cons "trail" (length (cadr flag)))
									       (cons "align_1" (vla-get-Alignment (vlax-ename->vla-object (car x))))
									       (cons "width_1"(vla-get-ScaleFactor (vlax-ename->vla-object (car x))))								       
									     ))   
								     )
						    )
	        ) 		
	      ); eo progn

    )
    
    (if (and (cdr (assoc "general_flag" (car flag))) achivement);если проверка выше не пройдена - двигаемся дальше. пробуем просто отодвинуть. без других условий
	      (progn
		 (setq achivement (vl-sort achivement (function (lambda (e1 e2)
							            (< (cdar e1) (cdar e2))
						                )
					              )
			          )
		 ); сортировка
		(vla-put-Alignment (vlax-ename->vla-object (car x)) (cdr (assoc "align_1" (car achivement))));ставим вариант, когда перечечений меньше всего
		(vla-put-ScaleFactor (vlax-ename->vla-object (car x)) (cdr (assoc "width_1" (car achivement))));ставим вариант, когда перечечений меньше всего
		(setq textbox1 (textbox (entget (car x))))
		(vla-put-TextAlignmentPoint
		      (vlax-ename->vla-object (car x))
		      (vlax-3d-point
			      (polar
				(vlax-safearray->list (vlax-variant-value (vla-get-TextAlignmentPoint (vlax-ename->vla-object (car x)))))
				(nth 2 x)
				(* 0.6 (- (caadr textbox1) (caar textbox1)))
				;(* 1.2 (vla-get-Height (vlax-ename->vla-object (car x))))
			      ); eo polar
		      );eo vlax-3d-point
		); eo vla-put-TextAlignmentPoint  		
		(vla-update (vlax-ename->vla-object (car x)));@@@@@@@@@@@@@@@@@@@@@@@@
		(setq flag (inters_detect x dim_list pob inner inner_walls)); проверка того, что получилось
		
	      ); eo progn

    )   
   
     
  ;не помогло? а может угловые? тогда один подвинуть
    (if (and (cdr (assoc "general_flag" (car flag)))
	     (or (cdr (assoc "pob1_flag" (car flag))) only_one_inters)
	);eo and - если пересечения остались, но только одно или был отмечен вариант, когда пересечение только одно
      (progn;пошла передвижка
	(if (and (not (cdr (assoc "pob1_flag" (car flag)))) only_one_inters); если вариант, когда было одно пересечение, сбит - возвращаем его
	  (progn
		(vla-put-Alignment (vlax-ename->vla-object (car x)) (cdr (assoc "align_1" only_one_inters)));ставим вариант, когда перечечение только одно
		(vla-put-ScaleFactor (vlax-ename->vla-object (car x)) (cdr (assoc "width_1" only_one_inters)));ставим вариант, когда перечечение только одно
	        (vla-put-TextAlignmentPoint (vlax-ename->vla-object (car x)) (vlax-3d-point(nth 4 x)));ставим на место, если вдруг неудачно сместился в пред. пункте
	        (vla-update (vlax-ename->vla-object (car x)));@@@@@@@@@@@@@@@@@@@@@@@@
	        (setq flag (inters_detect x dim_list pob inner inner_walls))
	  );eo progn
	);eo if
	
	(setq obstruct1 (inters_detect1 x (cadr flag) pob));двигаем текущий размер и получаем ename того размера, что мешает или мешал
	(setq obstruct2 (car (vl-member-if '(lambda (y) (eq obstruct1 (car y))) dim_list)));расширенная версия того что мешает по структуре dim_list
	
	(vla-update (vlax-ename->vla-object (car x)));@@@@@@@@@@@@@@@@@@@@@@@@
	(setq flag (inters_detect x dim_list pob inner inner_walls));проверяем предпоследний раз
	(if (and
	      (cdr (assoc "general_flag" (car flag)))
	      obstruct2
	    )  ; если пересечение до сих пор есть
          (progn
	  	(inters_detect1 obstruct2 (list (car x)) pob);двигаем второго из пары
	        (vla-update (vlax-ename->vla-object (car obstruct2)));@@@@@@@@@@@@@@@@@@@@@@@@
	    	(setq flag (inters_detect x dim_list pob inner inner_walls));проверяем последний раз
	  ); eo progn
	 );eo if
	;по второму разу
	(if (and
	      (cdr (assoc "general_flag" (car flag)))
	      obstruct2
	    )  ; если пересечение до сих пор есть
          (progn
	  	(inters_detect1 obstruct2 (list (car x)) pob);двигаем второго из пары
	        (vla-update (vlax-ename->vla-object (car obstruct2)));@@@@@@@@@@@@@@@@@@@@@@@@
	    	(setq flag (inters_detect x dim_list pob inner inner_walls));проверяем последний раз
	  ); eo progn
	 );eo if 	
;^^^^^^^^^^^^^^^^^^^^^^^^^^^^^если все совсем плохо^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
	 (if  (cdr (assoc "general_flag" (car flag)))
          	(progn
		        (vla-put-TextAlignmentPoint (vlax-ename->vla-object (car x)) (vlax-3d-point(nth 4 x)));ставим на место, если вдруг неудачно сместился в пред. пункте
		        (vla-update (vlax-ename->vla-object (car x)));@@@@@@@@@@@@@@@@@@@@@@@@
		  	(setq flag (inters_detect x dim_list pob inner inner_walls))
		  	(setq obstruct0 (car (vl-member-if '(lambda (y) (eq (caadr flag) (car y))) dim_list)));что еще мешает - расширенная версия по структуре dim_list
		        (if obstruct0
			  (progn
			        (setq textbox1 (textbox (entget (car obstruct0))))
				(vla-put-TextAlignmentPoint
				      (vlax-ename->vla-object (car obstruct0))
				      (vlax-3d-point
					      (polar
						(vlax-safearray->list (vlax-variant-value (vla-get-TextAlignmentPoint (vlax-ename->vla-object (car obstruct0)))))
						(nth 2 obstruct0)
						(* 0.4 (- (caadr textbox1) (caar textbox1)))
						;(* 1.1 (min_dist_inters (car ent)  (car text_int_list)))
						;(* 1.2 (vla-get-Height (vlax-ename->vla-object (car obstruct0))))
					      ); eo polar
				      );eo vlax-3d-point
				); eo vla-put-TextAlignmentPoint  		
			        (vla-update (vlax-ename->vla-object (car obstruct0)));@@@@@@@@@@@@@@@@@@@@@@@@
			    	(setq flag (inters_detect x dim_list pob inner inner_walls));проверяем самый последний раз
			        (if  (cdr (assoc "general_flag" (car flag)))
				  (progn
					(vla-put-TextAlignmentPoint
					      (vlax-ename->vla-object (car obstruct0))
					      (vlax-3d-point
						      (polar
							(vlax-safearray->list (vlax-variant-value (vla-get-TextAlignmentPoint (vlax-ename->vla-object (car obstruct0)))))
							(nth 2 obstruct0)
							(* 0.5 (- (caadr textbox1) (caar textbox1)))
							;(* 1.1 (min_dist_inters (car ent)  (car text_int_list)))
							;(* 1.2 (vla-get-Height (vlax-ename->vla-object (car obstruct0))))
						      ); eo polar
					      );eo vlax-3d-point
					); eo vla-put-TextAlignmentPoint
				    (vla-update (vlax-ename->vla-object (car obstruct0)));@@@@@@@@@@@@@@@@@@@@@@@@
				    (setq flag (inters_detect x dim_list pob inner inner_walls));проверяем самый распоследний раз
				  )
			       )	  
			  )
			)  
		)
	   )  ; eo if

	
       	  
        );eo progn


    );eo if - проверка угловых

   ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    ;если просто так не получилось - возвращаем выравнивание и позицию назад и пробуем сузить, потом подвигать
    (if (cdr (assoc "general_flag" (car flag)));если проверка выше не пройдена - двигаемся дальше
      (progn
		(vla-put-Alignment (vlax-ename->vla-object (car x)) acAlignmentMiddleCenter)
	        (vla-put-TextAlignmentPoint (vlax-ename->vla-object (car x)) (vlax-3d-point(nth 4 x)))
		(if obstruct0 (vla-put-TextAlignmentPoint (vlax-ename->vla-object (car obstruct0)) (vlax-3d-point(nth 4 obstruct0))))
		(if obstruct2 (vla-put-TextAlignmentPoint (vlax-ename->vla-object (car obstruct2)) (vlax-3d-point(nth 4 obstruct2))))
		(vla-put-ScaleFactor (vlax-ename->vla-object (car x))
			(* 0.75 (vla-get-ScaleFactor (vlax-ename->vla-object (car x))))
	      	)
		(vla-update (vlax-ename->vla-object (car x)));@@@@@@@@@@@@@@@@@@@@@@@@
		(setq flag (inters_detect x dim_list pob inner inner_walls)); проверка того, что получилось
		(if (cdr (assoc "pob1_flag" (car flag))); если при даннном варианте единич. пересечение
			  (setq only_one_inters (list
						  (cons "align_1" (vla-get-Alignment (vlax-ename->vla-object (car x))))
						  (cons "width_1"(vla-get-ScaleFactor (vlax-ename->vla-object (car x))))
					        )
			  )
		)
	        (if (cdr (assoc "pob_flag" (car flag))) (setq achivement (append achivement ;сколько на хвосте при каких обстоятельствах
									     (list (list
									       (cons "trail" (length (cadr flag)))
									       (cons "align_1" (vla-get-Alignment (vlax-ename->vla-object (car x))))
									       (cons "width_1"(vla-get-ScaleFactor (vlax-ename->vla-object (car x))))								       
									     ))  
								     )
						    )
	        ) 	
	);eo progn
	
    )
	
      
   
    (if (cdr (assoc "general_flag" (car flag)));если проверка выше не пройдена - двигаемся дальше
	      (progn
	      	(vla-put-Alignment (vlax-ename->vla-object (car x)) acAlignmentMiddleRight);снова вправо
		(vla-update (vlax-ename->vla-object (car x)));@@@@@@@@@@@@@@@@@@@@@@@@
		(setq flag (inters_detect x dim_list pob inner inner_walls)); проверка того, что получилось
		(if (cdr (assoc "pob1_flag" (car flag))); если при даннном варианте единич. пересечение
			  (setq only_one_inters (list
						  (cons "align_1" (vla-get-Alignment (vlax-ename->vla-object (car x))))
						  (cons "width_1"(vla-get-ScaleFactor (vlax-ename->vla-object (car x))))
					        )
			  )
		)
	        (if (cdr (assoc "pob_flag" (car flag))) (setq achivement (append achivement ;сколько на хвосте при каких обстоятельствах
									     (list (list
									       (cons "trail" (length (cadr flag)))
									       (cons "align_1" (vla-get-Alignment (vlax-ename->vla-object (car x))))
									       (cons "width_1"(vla-get-ScaleFactor (vlax-ename->vla-object (car x))))								       
									     ))  
								     )
						    )
	        ) 		
	      ); eo progn

    )

    (if (cdr (assoc "general_flag" (car flag)));если проверка выше не пройдена - двигаемся дальше
	      (progn
	      	(vla-put-Alignment (vlax-ename->vla-object (car x)) acAlignmentMiddleLeft);потом влево
		(vla-update (vlax-ename->vla-object (car x)));@@@@@@@@@@@@@@@@@@@@@@@@
		(setq flag (inters_detect x dim_list pob inner inner_walls)); проверка того, что получилось
		(if (cdr (assoc "pob1_flag" (car flag))); если при даннном варианте единич. пересечение
			  (setq only_one_inters (list
						  (cons "align_1" (vla-get-Alignment (vlax-ename->vla-object (car x))))
						  (cons "width_1"(vla-get-ScaleFactor (vlax-ename->vla-object (car x))))
					        )
			  )
		)
	        (if (cdr (assoc "pob_flag" (car flag))) (setq achivement (append achivement ;сколько на хвосте при каких обстоятельствах
									     (list (list
									       (cons "trail" (length (cadr flag)))
									       (cons "align_1" (vla-get-Alignment (vlax-ename->vla-object (car x))))
									       (cons "width_1"(vla-get-ScaleFactor (vlax-ename->vla-object (car x))))								       
									     ))  
								     )
						    )
	        ) 		
	      ); eo progn

    )
   


   
    (if (cdr (assoc "general_flag" (car flag))) ;безнадежных фтопку. как вариант - можно на выключенный слой
      (progn
	;(vla-put-Layer (vlax-ename->vla-object (car x)) "del")
	(if obstruct2 (vla-put-TextAlignmentPoint (vlax-ename->vla-object (car obstruct2)) (vlax-3d-point(nth 4 obstruct2))));зря двигали второго из пары угловых. вернем на место
	(if obstruct0 (vla-put-TextAlignmentPoint (vlax-ename->vla-object (car obstruct0)) (vlax-3d-point(nth 4 obstruct0))))
	;(if (cdr (assoc "pob_flag" (car flag))) (Setq x_kill_flag T));зацепил контур - сразу фтопку
	(foreach q (cadr flag)
	  (if (vlax-property-available-p (vlax-ename->vla-object q) 'TextString)
		  (if (> (distof (vla-get-TextString (vlax-ename->vla-object (car x))))
			 (distof (vla-get-TextString (vlax-ename->vla-object q)))
		      )
		      (setq kill_list (append kill_list (list q)));если рассматриваемый элемент затрагивает мелочь пузатую, ее фтопку
		    ;else
		      (setq x_kill_flag T); если затрагивает кого-то крупнее себя - его самого фтопку
		  )
	  )
	)
	
	(if (and kill_list (not x_kill_flag))
	  (foreach z kill_list
	    (if (entget z)
	    	(vla-delete (vlax-ename->vla-object z))
	    )  
	    ;(setq dim_list (vl-remove (car (vl-member-if '(lambda (i) (eq z (car i))) dim_list)) dim_list))
	  )
	)
	(if x_kill_flag (vla-delete (vlax-ename->vla-object (car x))))
	;(setq flag (inters_detect x dim_list pob inner inner_walls))
	;(if (cdr (assoc "general_flag" (car flag))) (vla-delete (vlax-ename->vla-object (car x))))
	;(vla-put-color (vlax-ename->vla-object (car x)) acByLayer)
	
      );eo progn	
    ); eo if - если не помогло - удаляем

 );eo foreach x
  
 ;зачистка выпавших

	 (setq dim_list_1 (vl-remove-if-not '(lambda (y) (entget (car y))) dim_list_1))
	  
	 (foreach y dim_list_1
	     (if (not (vlax-erased-p (vlax-ename->vla-object (car y))))
	       (progn
		  (setq ss0 (ssget "_WP" (plv1 (vlax-ename->vla-object pob))))
		  (if ss0
			(if (not (ssmemb (car y) ss0))
			  (vla-delete (vlax-ename->vla-object (car y))); размер не внутри контура, все плохо. фтопку
			)
		        
	     	  )
	     	  (setq ss0 nil)
		);eo progn
	      )
	 )
  (if inner_walls
    (progn
	 (setq dim_list_1 (vl-remove-if-not '(lambda (y) (entget (car y))) dim_list_1))
	  
	 (foreach y dim_list_1
	     (if (not (vlax-erased-p (vlax-ename->vla-object (car y))))
	       (progn
		 (foreach z inner_walls
		  (setq ss0 (ssget "_CP" (plv1 (vlax-ename->vla-object z))))
		  (if ss0
			(if (ssmemb (car y) ss0)
			  (vla-delete (vlax-ename->vla-object (car y))); размер пересекает внутр. контур, все плохо. фтопку
			)
		        
	     	  )
	     	  (setq ss0 nil)
		 )  
		);eo progn
	      )
	 )
    )
  )  
  
 
	 ;зачистка неоправданно узких и сдвинутых
	 (setq dim_list_1 (vl-remove-if-not '(lambda (y) (entget (car y))) dim_list_1))
	 (foreach y dim_list_1
		  (setq cur_width_f (vla-get-ScaleFactor (vlax-ename->vla-object (car y))))
		  (vla-put-ScaleFactor (vlax-ename->vla-object (car y)) (nth 3 y))
	          (vla-update (vlax-ename->vla-object (car y)));@@@@@@@@@@@@@@@@@@@@@@@@   
		  (setq flag (inters_detect y dim_list_1 pob inner inner_walls))
		  (if (cdr (assoc "general_flag" (car flag)))
		    (vla-put-ScaleFactor (vlax-ename->vla-object (car y)) cur_width_f)
	          )
	   
	   	  (setq cur_pos (vla-get-TextAlignmentPoint (vlax-ename->vla-object (car y))))
	          (vla-put-TextAlignmentPoint (vlax-ename->vla-object (car y)) (vlax-3d-point(nth 4 y)))
	          (vla-update (vlax-ename->vla-object (car y)));@@@@@@@@@@@@@@@@@@@@@@@@   
		  (setq flag (inters_detect y dim_list_1 pob inner inner_walls))
		  (if (cdr (assoc "general_flag" (car flag)))
		    (vla-put-TextAlignmentPoint (vlax-ename->vla-object (car y)) cur_pos)
	          )   	  
	 )

)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;внутр. стены;;;;;;;;;;;;;;;;;;;;;;;;;
(defun inner_walls (boundary_object last_obj_before_bound HT
		    /
		    INNER_OBJECT INNER_OBJECTS_LIST io_points
		    DELTA  I P1 P2 SP T00 T1 T2 UGG UGR
		    dim_list_cur dim_list_inner_full Ob
		    )
  (if (not (eq (entnext last_obj_before_bound) boundary_object)) (setq inner_object (entnext last_obj_before_bound)))
  (setq	inner_objects_list nil)
  (if inner_object
    (progn
    	  (while (not (eq inner_object boundary_object))
		(setq inner_objects_list (append inner_objects_list (list inner_object)))
	        (vla-put-color (vlax-ename->vla-object inner_object) acblue)
		(setq inner_object (entnext inner_object))
	  )
	  (foreach io inner_objects_list
	    (setq io_points (plv1 (vlax-ename->vla-object io)))
	    (setq i 0 dim_list_cur nil)
	    (while (<= i (- (length io_points) 1))
	      (setq t1 (nth i io_points))
	      (if	(< i (- (length io_points) 1))
	        (setq t2 (nth (1+ i) io_points))
	        (setq t2 (nth 0 io_points))
	      )
	      (setq Delta (distance T1 T2))
	      (if (> (car T1) (car T2))
	        (setq P1 T2 P2 T1)
	        (setq P1 T1 P2 T2)
	      )
	      (setq UgR (angle P1 P2))
	      (setq UgG (r2g (angle P1 P2)))
	      (if (= (fix UgG) 270.0) (setq UgG 90.0))
	      (setq SP (PSW1 io (polar (seredina P1 P2) (G2R (- UgG 90.0)) 0.01))); 0.01 - размер "щупа" для определения направления сегмента полилинии. был 100. много!
	      (if (= SP 1) (setq T00 (polar (seredina T1 T2) (G2R (+ UgG 90.0)) (+ (* 0.5 HT) 100.0)) ))
	      (if (= SP 0) (setq T00 (polar (seredina T1 T2) (G2R (- UgG 90.0)) (+ (* 0.5 HT) 100.0)) ))
	      (command "_TEXT" "_j" "_MC" T00 (+ UgG 0.0) (rtos (/ Delta 1000.0) 2 2))
	      (setq Ob (entLAST))
	      (setq dim_list_cur (append dim_list_cur (list (list
							   Ob
							   (distof (vla-get-TextString (vlax-ename->vla-object Ob)))
							   (angle (seredina T1 T2) T00)
							   (vla-get-ScaleFactor (vlax-ename->vla-object Ob))
							   T00
		;;;					   (cons "dir_ang" (angle (seredina T1 T2) T00))
		;;;					   (cons "sc_f" (vla-get-ScaleFactor (vlax-ename->vla-object (entLAST))))
							 ))
			        )
	      )
	      (setq i (1+ i))
	    ); eo while i
	    ;(cleanup dim_list_cur io nil)
	    (setq dim_list_cur (vl-remove-if-not '(lambda (y) (entget (car y))) dim_list_cur))
	    (setq dim_list_inner_full (append dim_list_inner_full  dim_list_cur))
	  );eo foreach io	    
    )
  )
  (list dim_list_inner_full inner_objects_list)
)
Wanted вне форума  
 
Непрочитано 20.03.2018, 07:53
#3492
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,787


М-да, код вызывает оторопь
В функции c:p2, похоже, идет генерация ошибки до того, как вызываются функции восстановления значения переменных. Проходи пошагово, выясняй, в каком именно месте геренируется ошибка.
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 22.03.2018, 04:43
#3493
Wanted


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


То мне на заказ писали, а я подумал что можно добавить строку для возврата привязок.
Wanted вне форума  
 
Непрочитано 22.03.2018, 07:50
#3494
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,787


Ну тогда советую обратиться к автору кода.
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 22.03.2018, 09:24
#3495
koMon


 
Блог
 
Регистрация: 26.09.2017
Сообщений: 1,665


закомментируйте сторку 153 в коде.
Цитата:
Сообщение от Wanted Посмотреть сообщение
(setvar "osmode" osm)
----- добавлено через ~3 мин. -----


Цитата:
Сообщение от Кулик Алексей aka kpblc Посмотреть сообщение
М-да, код вызывает оторопь
я бы хотел сказать по-другому…
koMon вне форума  
 
Непрочитано 23.03.2018, 03:41
#3496
Wanted


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


Дело в том что я не помню автора, я работал с 4-5ю авторами по разным вопросам) Осталось высчитать в блокноте 153-ю страницу.


Я туда строку вставил?
https://c2n.me/3SRXgsC
Wanted вне форума  
 
Непрочитано 23.03.2018, 09:04
#3497
koMon


 
Блог
 
Регистрация: 26.09.2017
Сообщений: 1,665


Цитата:
Сообщение от Wanted Посмотреть сообщение
Я туда строку вставил?
её не нужно вставлять, её нужно закомментировать, поставить в начале ";"
Миниатюры
Нажмите на изображение для увеличения
Название: OM.jpg
Просмотров: 28
Размер:	47.5 Кб
ID:	200479  
koMon вне форума  
 
Непрочитано 23.03.2018, 23:16
#3498
Wanted


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


Спасибо попробую, просто я не знал что такое закомментировать.
Wanted вне форума  
 
Непрочитано 25.03.2018, 21:34
#3499
Wanted


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


Цитата:
Сообщение от koMon Посмотреть сообщение
её не нужно вставлять, её нужно закомментировать, поставить в начале ";"
Не помогло
Wanted вне форума  
 
Непрочитано 26.03.2018, 08:33
#3500
trushev


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


Цитата:
Сообщение от Wanted Посмотреть сообщение
Всем доброй ночи, помогите поправить LISP, при его использовании пропадают привязки. Помогите вернуть привязки по окончанию LISP-a.
Благодарю Вас!
Не вникая в суть подам идею. Профи меня поправят.
Функцию
Код:
[Выделить все]
 ;бесконечный вызов
(defun c:p5 (/)
  (while T (c:p2))
)
Дополнить
(defun c:p5 (/
                   Именами используемых ниже функций
                  )
   Сохранением действующих значений системных переменных
  (while T (c:p2))
   Восстановлением значений переменных
); перенести скобку в последнею строку программы

Последний раз редактировалось Кулик Алексей aka kpblc, 26.03.2018 в 08:53.
trushev вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Научите лиспу на примере (или как kpblc, VVA и компания пытаются обучить чайника лиспу)

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

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


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
LISP. Вставка в таблицу поля, соотвествующего площади примитива Profan Готовые программы 272 06.06.2021 23:12
Сейсмозащита и сейсмоизоляция существующих, построенных зд. IANationalInformAgentstvo Прочее. Архитектура и строительство 216 20.01.2015 16:51
Мониторы LCD CRT Разное 94 17.06.2008 10:51
ЮМОР 2006 =) Perezz!! Разное 1122 04.01.2007 00:46