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

Red Nova · 20.07.2008, 20:12

Со школы не ладится у меня с программированием. Все предметы щелкал, а на экзамене по информатике (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

_____________________________________________________________________________________________________________

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

koMon · 16.02.2025, 21:38

(foreach l1_element l1 (setq l2 (vl-remove l1_element l2)))

Gretech89 · 17.02.2025, 09:23

Кулик Алексей aka kpblc, koMon, спасибо, всё как надо!

Gretech89 · 18.02.2025, 11:17

Подскажите, пожалуйста, можно ли избавиться от комбинации foreach-foreach и имеет ли смысл? При большом кол-ве объектов (линий) этот фрагмент кода изрядно подвисает.
И объясните еще для чего "reverse res"? Без переворота списка наблюдаю некорректную работу в коде, но не могу понять почему

Код:

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

 (setq result_ent ((lambda (/ res)
	(foreach a block_cont_1 
		(foreach x block_cont_2
		  (if
		       	(and
		       		(equal (car (vlax-get a 'startpoint)) (car (vlax-get x 'startpoint)) 1e-4)
		       		(equal (cadr (vlax-get a 'startpoint)) (cadr (vlax-get x 'startpoint)) 1e-4)
		       	)
				(setq res (cons x res))
		  )
		)
	)
		    		(reverse res)
		))
   )

Кулик Алексей aka kpblc · 18.02.2025, 13:54

Без проверки работоспособности:

Код:

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

 
(setq result_ent (apply (function append) 
                        (mapcar 
                          (function 
                            (lambda (x) 
                              (vl-remove-if-not 
                                (function 
                                  (lambda (item) 
                                    (and 
                                      (equal (car (vlax-get item 'startpoint)) (car (vlax-get x 'startpoint)) 1e-4)
                                      (equal (cadr (vlax-get item 'startpoint)) (cadr (vlax-get x 'startpoint)) 1e-4)
                                    )
                                  )
                                )
                                block_cont_1
                              )
                            )
                          )
                          block_cont_2
                        )
                 )
)

Хотя я бы сделал отдельную функцию на получение 2-мерной стартовой точки и использовал бы ее:

Код:

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

 (defun fun_get-startpoint-2d (ent / res) 
  (setq res (vlax-get ent 'startpoint))
  (list (car res) (cadr res))
)

(setq result_ent (apply (function append) 
                        (mapcar 
                          (function 
                            (lambda (x) 
                              (vl-remove-if-not 
                                (function 
                                  (lambda (item) 
                                    (equal (fun_get-startpoint-2d item) (fun_get-startpoint-2d x) 1e-4)
                                  )
                                )
                                block_cont_1
                              )
                            )
                          )
                          block_cont_2
                        )
                 )
)

P.S. reverse нужен, потому что у тебя идет cons - он достаточно сильно отличается от append

Gretech89 · 18.02.2025, 14:38

Кулик Алексей aka kpblc, работоспособность подтвердилась! Спасибо

Забавно, но время обработки почти такое же. Видать систему не обманешь.

Кулик Алексей aka kpblc · 18.02.2025, 14:55

Ну так я и мозг-то особо не подключал ) Если я правильно понял, то надо оставить отрезки, у которых совпадают начальные вершины? Если да, то можно block_cont_1 и block_cont_2 объединить и проходить уже по объединенному списку. Можно заменить элементы - сначала двумерные координаты, потом указатель на примитив, и обрабатывать на основании координат (не понадобится постоянно вычислять значения). Можно в процессе проходки по объединенному списку попробовать исключать из него уже обработанные варианты, можно... Пока что фантазия закончилась. И на написание кода сейчас меня 100% не хватит - сижу в другой задачке, и это надолго

Gretech89 · 18.02.2025, 15:45

Кулик Алексей aka kpblc, понято, спасибо за идеи, поэкспериментирую)

koMon · 18.02.2025, 16:20

Gretech89,
с одним foreach

Код:

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

 
(setq result_ent nil)
 (foreach l1 block_cont_1
	(if (vl-some '(lambda (l2) (equal (mapcar '+ '(0 0) (vlax-get l1 'startpoint))
									  (mapcar '+ '(0 0) (vlax-get l2 'startpoint))
									  1e-4
							   )
				  )
				  block_cont_2
		)
		(setq result_ent (append result_ent (list l1)))
	)
)

----- добавлено через ~2 мин. -----
Кулик Алексей aka kpblc,
Алексей почему ты используешь function вместо апострОфов, что-то религиозное?

Кулик Алексей aka kpblc · 18.02.2025, 16:32

Апостроф в компилированном коде немного медленнее, насколько я помню. Ну и мне пару раз хватило словить ошибку PPT при форматировании кода

koMon · 18.02.2025, 17:07

Gretech89,
1+

Код:

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

 
(apply 'and
	(mapcar '(lambda (l1) (if (vl-some '(lambda (l2) (equal (mapcar '+ '(0 0) (vlax-get l1 'startpoint))
									       					(mapcar '+ '(0 0) (vlax-get l2 'startpoint))
							  								1e-4
						  							 )
					    				)
					    				block_cont_1
				  			  )
				  			  l1
			      		  )
		  	 )
		  	 block_cont_2
	)
)

Gretech89 · 19.02.2025, 11:16

koMon, интересный вариант) а как сюда включить еще проверку конечных вершин endpoint-endpoint?

koMon · 19.02.2025, 11:31

Gretech89,
я так думаю может так

Код:

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

 
(apply 'and
	(mapcar '(lambda (l1) (if (vl-some '(lambda (l2) (equal (list (mapcar '+ '(0 0) (vlax-get l1 'startpoint)) (mapcar '+ '(0 0) (vlax-get l1 'endpoint)))
									       					(list (mapcar '+ '(0 0) (vlax-get l2 'startpoint)) (mapcar '+ '(0 0) (vlax-get l2 'endpoint)))
							  								1e-4
						  							 )
					    				)
					    				block_cont_1
				  			  )
				  			  l1
			      		  )
		  	 )
		  	 block_cont_2
	)
)

Gretech89 · 20.02.2025, 11:30

Цитата:

Сообщение от koMon

я так думаю может так

Благодарю! Я добавил все варианты как могут стыковаться отрезки друг с другом и завернул в цикл, чтобы находить полные цепочки отрезков, которые растут от линий из списка "block_cont_1". На выходе получаем список с несостыкованными отрезками (block_cont_2).

Код:

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

 (while block_cont_1
   (setq result_ent ((lambda (/ res)
	(apply 'and
	(mapcar '(lambda (l1) (if (vl-some '(lambda (l2)
					      (or
					      (equal (mapcar '+ '(0 0) (vlax-get l1 'startpoint)) (mapcar '+ '(0 0) (vlax-get l2 'startpoint)) 1e-4)
					      (equal (mapcar '+ '(0 0) (vlax-get l1 'endpoint)) (mapcar '+ '(0 0) (vlax-get l2 'endpoint)) 1e-4)
					      (equal (mapcar '+ '(0 0) (vlax-get l1 'startpoint)) (mapcar '+ '(0 0) (vlax-get l2 'endpoint)) 1e-4)
					      (equal (mapcar '+ '(0 0) (vlax-get l1 'endpoint)) (mapcar '+ '(0 0) (vlax-get l2 'startpoint)) 1e-4)
					      )
					    )
					    block_cont_1
				  			  )
				  (setq res (cons l1 res))
			      		  )
		  	 )
		  	 block_cont_2
	)
	)
		    (reverse res)
		    ))
   )
  (setq block_cont_2 (vl-remove-if '(lambda(x) (member x result_ent)) block_cont_2))
  (setq block_cont_1 result_ent)
)

koMon · 20.02.2025, 11:43

Gretech89,
в чём главная идея? есть два сравниваемых списка контуров из отрезков. начинаем сравнивать, находим несовпадающие отрезки и выводим только их в список или ?

Gretech89 · 20.02.2025, 15:45

koMon, да, в целом верно. То, что не совпадает, после удаляем. Цель: оставить контуры и удалить всё лишнее.

koMon · 20.02.2025, 16:03

Gretech89,
я бы не делал циклы, потому что mapcar сделает всё и сразу как например ниже

Код:

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

 
(defun coincide (line_1 line_2)
	(apply 'or (mapcar '(lambda (what) (equal what
					   (list (mapcar '+ '(0 0) (vlax-get line_2 'startpoint)) (mapcar '+ '(0 0) (vlax-get line_2 'endpoint)))
					   1e-4
				    )
		   	    )
			    (list (list (mapcar '+ '(0 0) (vlax-get line_1 'startpoint)) (mapcar '+ '(0 0) (vlax-get line_1 'endpoint)))
			          (list (mapcar '+ '(0 0) (vlax-get line_1 'endpoint)) (mapcar '+ '(0 0) (vlax-get line_1 'startpoint)))
			    )
	    	   )
	)
)
(setq coincident_lines (mapcar '(lambda (line_1) (if (vl-some '(lambda (line_2) (coincide line_1 line_2)) block_cont_1) line_1)) block_cont_2))
(setq non_coincident_lines (vl-remove nil (mapcar '(lambda (line_1 line_2) (if (and line_1 line_2) line_2 nil)) (mapcar 'not coincident_lines_list) block_cont_2)))
(setq coincident_lines (vl-remove nil coincident_lines))

Gretech89 · 21.02.2025, 20:01

Цитата:

Сообщение от koMon

я бы не делал циклы, потому что mapcar сделает всё и сразу как например ниже

Что-то не получается.. Возможно что-то не так делаю. "coincident_lines_list" - не опечатка?
Прикрепил файлик, на котором тестил.

Код:

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

 (vlax-for block_def (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))

     (setq block_cont_1 ((lambda (/ res)
			(vlax-for block_entry block_def
			(if
				 	(and
						(= "AcDbLine" (vla-get-objectname block_entry))
						(not (equal 8.9859 (vla-get-length block_entry) 1e-4))
					)
						(setq res (cons block_entry res))
			)
			)
				    		(reverse res)
				)
				)
		)

     (setq block_cont_2 ((lambda (/ res)
			(vlax-for block_entry block_def
			(if
				 	(and
						(= "AcDbLine" (vla-get-objectname block_entry))
						(equal 8.9859 (vla-get-length block_entry) 1e-4)
					)
						(setq res (cons block_entry res))
			)
			)
				    		(reverse res)
				)
				)
		)

(defun coincide (line_1 line_2)
	(apply 'or (mapcar '(lambda (what) (equal what
					   (list (mapcar '+ '(0 0) (vlax-get line_2 'startpoint)) (mapcar '+ '(0 0) (vlax-get line_2 'endpoint)))
					   1e-4
				    )
		   	    )
			    (list (list (mapcar '+ '(0 0) (vlax-get line_1 'startpoint)) (mapcar '+ '(0 0) (vlax-get line_1 'endpoint)))
			          (list (mapcar '+ '(0 0) (vlax-get line_1 'endpoint)) (mapcar '+ '(0 0) (vlax-get line_1 'startpoint)))
			    )
	    	   )
	)
)

(setq coincident_lines (mapcar '(lambda (line_1) (if (vl-some '(lambda (line_2) (coincide line_1 line_2)) block_cont_1) line_1)) block_cont_2))
(setq non_coincident_lines (vl-remove nil (mapcar '(lambda (line_1 line_2) (if (and line_1 line_2) line_2 nil)) (mapcar 'not coincident_lines_list) block_cont_2)))
(setq coincident_lines (vl-remove nil coincident_lines))  

(if non_coincident_lines
	(repeat (length non_coincident_lines)
		 (if (not (vlax-erased-p (car non_coincident_lines)))
		   (progn
		 (vla-delete (car non_coincident_lines))
		 (setq non_coincident_lines (cdr non_coincident_lines))
		   )
		   (setq non_coincident_lines (cdr non_coincident_lines))
		   )
	)
)

     )

koMon · 21.02.2025, 20:05

Цитата:

Сообщение от Gretech89

не опечатка?

100п опечатка

koMon · 21.02.2025, 21:57

Gretech89,
если я правильно понимаю, то нужно в блоке найти сцепленные отрезки, при этом удалив отдельностоящие от сцепленных. и отдельностоящих и сцепленных может быть не одна группа или одна штука. то что я предложил ни при каких условиях этого не сделает, потому что нацелено на поиск совпадающих отрезков по вершинам только. см. ниже.

Нажмите на изображение для увеличения
Название: GT.jpg
Просмотров: 17
Размер: 67.8 Кб
ID: 266916

Кулик Алексей aka kpblc · 21.02.2025, 22:09

Вы еще сюды добавьте коллинеарные отрезки ))

20.07.2008, 20:12	1 \|
Научите лиспу на примере (или как kpblc, VVA и компания пытаются обучить чайника лиспу) Red Nova ՃԱՐՏԱՐԱԳԵՏ, տ.գ.թ. Торонто Регистрация: 23.10.2007 Сообщений: 1,990 Со школы не ладится у меня с программированием. Все предметы щелкал, а на экзамене по информатике (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.
Просмотров: 2047400

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
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