Реклама 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.
Просмотров: 1965862
 
Непрочитано 30.09.2019, 18:37
#3841
Сергей812


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


или сохранить в экселе в текстовой формат, а потом считать в лиспе.

----- добавлено через ~15 ч. -----
и это проще всего, кстати - сохранить в текстовой файл с разделителями-табуляторами. А при чтении этого файла распарсивать считанную строку rls:
Код:
[Выделить все]
 (setq i1 (vl-string-position 9 rls))
(setq i2 (vl-string-position 9 rls 0 T))
(setq n (substr rls 1 i1))
(setq c1 (atof (substr rls (+ i1 2) (1- (- i2 i1)))))
и создавать список из точечных пар. А далее assoc и cdr по имени продукта.

Последний раз редактировалось Сергей812, 01.10.2019 в 10:57. Причина: дублирование слов
Сергей812 вне форума  
 
Автор темы   Непрочитано 01.10.2019, 15:44
#3842
Red Nova

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


Спасибо за советы
skkkk - Не сумел заставить программы Елпанова работать. Может проблема х64, а может руки крюки...

Сергей812
Цитата:
или сохранить в экселе в текстовой формат, а потом считать в лиспе.
Примерно так и сделал. Сохранил как csv файл, прочитал и выудил assoc-ом.

Код:
[Выделить все]
 ;(GetPartPrice part)
;(setq part "SPS033X3.0-1BX120")

(defun GetPartPrice ( part / tbl price)
  (setq tbl (LM:readcsv "C:\\Users\\abaghdasaryan\\Desktop\\test.csv"))
  (setq price (cadr (assoc "SPS033X3.0-1BX120" tbl)))
  )
  

;; Read CSV  -  Lee Mac
;; Parses a CSV file into a matrix list of cell values.
;; csv - [str] filename of CSV file to read
 
(defun LM:readcsv ( csv / des lst sep str )
    (if (setq des (open csv "r"))
        (progn
            (setq sep (cond ((vl-registry-read "HKEY_CURRENT_USER\\Control Panel\\International" "sList")) (",")))
            (while (setq str (read-line des))
                (setq lst (cons (LM:csv->lst str sep 0) lst))
            )
            (close des)
        )
    )
    (reverse lst)
)

;; CSV -> List  -  Lee Mac
;; Parses a line from a CSV file into a list of cell values.
;; str - [str] string read from CSV file
;; sep - [str] CSV separator token
;; pos - [int] initial position index (always zero)
 
(defun LM:csv->lst ( str sep pos / s )
    (cond
        (   (not (setq pos (vl-string-search sep str pos)))
            (if (wcmatch str "\"*\"")
                (list (LM:csv-replacequotes (substr str 2 (- (strlen str) 2))))
                (list str)
            )
        )
        (   (or (wcmatch (setq s (substr str 1 pos)) "\"*[~\"]")
                (and (wcmatch s "~*[~\"]*") (= 1 (logand 1 pos)))
            )
            (LM:csv->lst str sep (+ pos 2))
        )
        (   (wcmatch s "\"*\"")
            (cons
                (LM:csv-replacequotes (substr str 2 (- pos 2)))
                (LM:csv->lst (substr str (+ pos 2)) sep 0)
            )
        )
        (   (cons s (LM:csv->lst (substr str (+ pos 2)) sep 0)))
    )
)

(defun LM:csv-replacequotes ( str / pos )
    (setq pos 0)
    (while (setq pos (vl-string-search  "\"\"" str pos))
        (setq str (vl-string-subst "\"" "\"\"" str pos)
              pos (1+ pos)
        )
    )
    str
)
__________________
Блог
Red Nova вне форума  
 
Непрочитано 01.10.2019, 17:12
#3843
Сергей812


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


а функция преобразования атоf только точку воспринимает, похоже.. вне настроек разделителя десятичных разрядов самой винды.
Сергей812 вне форума  
 
Непрочитано 01.10.2019, 20:15
#3844
Сет


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


Вопрос, наверное, элементарный, но подскажите, как нарисовать полилинию, имеющую дуговой сегмент? По точкам.
Миниатюры
Нажмите на изображение для увеличения
Название: Безымянный.png
Просмотров: 14
Размер:	3.4 Кб
ID:	218412  
Сет вне форума  
 
Непрочитано 03.10.2019, 11:00
#3845
koMon


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


если нужно скругление, то лучше вводить 3 точки и задавать радиус и потом генерить плинию. а дальнейшая цель вообще какая?
koMon вне форума  
 
Непрочитано 03.10.2019, 11:55
#3846
Сет


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


Цитата:
Сообщение от koMon Посмотреть сообщение
если нужно скругление, то лучше вводить 3 точки и задавать радиус и потом генерить плинию. а дальнейшая цель вообще какая?
Нужно получить программно отрисованную полилинию по точкам, некоторые сегменты дугообразные.
Сет вне форума  
 
Непрочитано 03.10.2019, 12:36
#3847
Сергей812


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


а если нарисовать отдельно сегменты, а потом команду join применить и выбрать последний примитив?
Сергей812 вне форума  
 
Непрочитано 03.10.2019, 12:56
#3848
Сет


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


Цитата:
Сообщение от Сергей812 Посмотреть сообщение
а если нарисовать отдельно сегменты, а потом команду join применить и выбрать последний примитив?
Да, так можно сделать. Но думал можно как-то "красивее" эту задачу решить.
Сет вне форума  
 
Непрочитано 03.10.2019, 13:03
#3849
Vladimir_Sergeevich

рисую дороги, в перерывах курю Lisp
 
Регистрация: 20.04.2011
Пермь
Сообщений: 475
<phrase 1= Отправить сообщение для Vladimir_Sergeevich с помощью Skype™


Red Nova, очень давно на форуме скопипастил, уже не скажу у кого, но всегда работало:
Код:
[Выделить все]
 (defun html-export (path)
  ((lambda (excel)
     (vlax-invoke-method (vlax-get-property excel 'Workbooks) 'Open path)
     ((lambda (ret)
        (vlax-invoke-method excel 'Quit)
        ret)
      (mapcar '(lambda (row) (mapcar 'vlax-variant-value row))
              (vlax-safearray->list
               (vlax-variant-value
                (vlax-get-property
                 (vlax-get-property
                  (vlax-get-property
                   (vlax-get-property excel 'Worksheets) 'Item 1) 'UsedRange) 'Value))))))
   (vlax-create-object "excel.application")))
это чудо благополучно жрало как *.xls, так и *.xlsx
Сет, вычисляй центр кривой и задавайся кривизной
Код:
[Выделить все]
 (defun arc-get-bulge (p1 p2 pc / ang) ;;;* Возвращает кривизну дуги
	(if (< (abs (- (angle pc p2) (angle pc p1) ) ) pi)
		(_dwgru-trigon-tan (/ (- (angle pc p2) (angle pc p1)) 4)) 
		(_dwgru-trigon-tan (/ (- (* 2 pi) (- (angle pc p1) (angle pc p2))) 4))	
	)
)
__________________
Не труд сделал из обезьяны человека, а лень и жажда халявы...
Vladimir_Sergeevich вне форума  
 
Непрочитано 03.10.2019, 17:25
#3850
koMon


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


Цитата:
Сообщение от Сет Посмотреть сообщение
Нужно получить программно отрисованную полилинию по точкам, некоторые сегменты дугообразные.
если точки будут вводиться мышью, то можно:
1. по вводимым точкам динамически отрисовывать плинию
2. при этом для конвертации какого-то угла в дугу нужно сделать перехватчик указания на это действие и как-то задавать радиус дугового сегмента. в результате будут пересчитаны конец и начало двух последних сегментов и между ними будет вставлен дуговой сегмент. можно даже сделать динамические изменения для направления дугового сегмента и радиуса.
3. это должно выглядеть красиво
4. но потребует написания нешуточного лиспа.

если генерить плинию по координатам из файла - это много упростит лисп имхо, но считать всё равно придётся.
koMon вне форума  
 
Автор темы   Непрочитано 12.10.2019, 06:28
#3851
Red Nova

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


Цитата:
Сообщение от Vladimir_Sergeevich Посмотреть сообщение
Red Nova, очень давно на форуме скопипастил, уже не скажу у кого, но всегда работало:
Код:
(defun html-export (path)
((lambda (excel)
(vlax-invoke-method (vlax-get-property excel 'Workbooks) 'Open path)
((lambda (ret)
(vlax-invoke-method excel 'Quit)
ret)
(mapcar '(lambda (row) (mapcar 'vlax-variant-value row))
(vlax-safearray->list
(vlax-variant-value
(vlax-get-property
(vlax-get-property
(vlax-get-property
(vlax-get-property excel 'Worksheets) 'Item 1) 'UsedRange) 'Value))))))
(vlax-create-object "excel.application")))
это чудо благополучно жрало как *.xls, так и *.xlsx
Спасидо Vladimir_Sergeevich, работает
__________________
Блог
Red Nova вне форума  
 
Непрочитано 16.10.2019, 07:48
#3852
Vladimir_Sergeevich

рисую дороги, в перерывах курю Lisp
 
Регистрация: 20.04.2011
Пермь
Сообщений: 475
<phrase 1= Отправить сообщение для Vladimir_Sergeevich с помощью Skype™


Приветствую, коллеги!
Мастера, гуру, научите плохому!
Два вопроса:
1. Как лучше обрабатывать нажатие ESC при обработке (grread)? а. *error*, b. vl-catch-all-apply
2. Это вообще адекватное решение, перерисовывать выноску с отловом точки через grread?

С подачи koMon написал себе небольшую функцию... скрестив её с одной из своих программок по обработке плана получилось совсем красота, но не до конца...
Код:
[Выделить все]
 (defun sad-parse-ml-line ( mlObj / err temp originPt originDl mlBasePt mlDestPoint pt_variant fl)
	(defun dir2pt (ang / ) (list (cos ang) (sin ang) 0)) 
	(defun pt2dir (pt / ang)
	;;; input - 2d vector
	;;; return - direction in rad
		(setq ang (atan (/ (cadr pt) (car pt)))	)
		(cond 
			((< (car pt) 0) (setq ang (+ ang (* pi 1))))
			((and (>= (car pt) 0) < (cadr pt) 0) (setq ang (+ ang (* pi 2)))) 
		)
		ang
	)
	(defun 2ptVariant (pt1 pt2 /  )
	;;;input - 2 points
	;;;output - vla-variant
		(vlax-make-variant
			(vlax-safearray-fill 
				(vlax-make-safearray 
					vlax-vbDouble 
					'(0 . 5) 
				) 
				(append pt1 pt2)
			) 	
		) 
	)
	(defun dlDir (obj ptBase ptEnd / dlVec txtVec rez alf)
	;;;
	;;;return - vla-variant - DogLeg's vector
		(setq 
			txtVec (vla-get-TextRotation obj) ;; dirction text
			dlVec (angle ptEnd ptBase)
		)
		(if ;;angle betveen vecs
			(> 	(setq alf (abs (- txtVec dlVec) )) pi	) 
			(setq alf (abs (- dlVec txtVec) )) 
		)
		(if (> alf pi) (setq alf (- (* pi 2) alf)))
		(if (< alf (* pi 0.5 ) )
			(setq rez (dir2pt (+ txtVec pi)))
			(setq rez (dir2pt txtVec))
		)
		(vlax-3d-point rez)
	)
	(setq 
		err *error*
		temp (vlax-safearray->list (vlax-variant-value (vla-GetLeaderLineVertices mlObj 0)))
		mlBasePt (list (car temp) (cadr temp) (caddr temp))
		temp (cdr (cdr (cdr temp)))
		originPt (list (car temp) (cadr temp) (caddr temp))
		originDl (vla-GetDoglegDirection mlObj 0)
		fl t
	)
	(defun *error* (msg) 
		(vla-SetDoglegDirection mlObj 0 originDl)
		(vla-SetLeaderLineVertices mlObj 0 (2ptVariant mlBasePt originPt))
		(setq *error* err)
		(princ "*Прервано*")
	)
	(while fl
		(setq temp (grread t 12 0))
		(if (or (= (car temp) 5) (= (car temp) 3)) 
		(progn
			(vla-SetLeaderLineVertices mlObj 0 (2ptVariant mlBasePt (cadr temp))) 
			(vla-SetDoglegDirection mlObj 0 (dlDir mlObj mlBasePt (cadr temp)))
		))
		(if (or (= (car temp) 3) (= (car temp) 25)) (setq fl nil))
	) ;;while
	(if (not (or (/= (car temp) 3) (/= (car temp) 25))) (vla-SetLeaderLineVertices mlObj 0 (2ptVariant mlBasePt originPt)))
	(setq *error* err)
	mlObj
)	
Собственно тут это дело обрабатывается эррором. Если использовать как самодостаточную программу навесив выбор мультивыноски - то наверно совсем норм пойдет (только зачем - не могу придумать). В моем же случае это только завершающий штрих большего дела. Итого: выноска уже построена программой, нажат ESC и все вернулось к базовым точкам исходных объектов... на этом код обрывается.
По идее, после построения выноски исходный объект (раньше был текст, сейчас блок с атрибутом) затирается. Теперь же при отмене и блок на месте и выноска сверху сидит. Как то бы продолжить выполнение кода после обрыва в этой функции...

Offtop: да начнется закидывание помидорами

p.s. версия с vl-catch-all-apply выглядит веселей...
Код:
[Выделить все]
 (defun sad-parse-ml-line ( mlObj / temp originPt originDl mlBasePt mlDestPoint pt_variant fl) ;|двигаем выноску
	*аргумент - vla-object мультивыноски
	*возвращет - vla-object мультивыноски или nil при нажатии esc
	|;
	(defun dir2pt (ang / ) (list (cos ang) (sin ang) 0)) 
	(defun pt2dir (pt / ang)
	;;; input - 2d vector
	;;; return - direction in rad
		(setq ang (atan (/ (cadr pt) (car pt)))	)
		(cond 
			((< (car pt) 0) (setq ang (+ ang (* pi 1))))
			((and (>= (car pt) 0) < (cadr pt) 0) (setq ang (+ ang (* pi 2)))) 
		)
		ang
	)
	(defun 2ptVariant (pt1 pt2 /  )
	;;;input - 2 points
	;;;output - vla-variant
		(vlax-make-variant
			(vlax-safearray-fill 
				(vlax-make-safearray 
					vlax-vbDouble 
					'(0 . 5) 
				) 
				(append pt1 pt2)
			) 	
		) 
	)
	(defun dlDir (obj ptBase ptEnd / dlVec txtVec rez alf)
	;;;
	;;;return - vla-variant - DogLeg's vector
		(setq 
			txtVec (vla-get-TextRotation obj) ;; dirction text
			dlVec (angle ptEnd ptBase)
		)
		(if ;;angle betveen vecs
			(> 	(setq alf (abs (- txtVec dlVec) )) pi	) 
			(setq alf (abs (- dlVec txtVec) )) 
		)
		(if (> alf pi) (setq alf (- (* pi 2) alf)))
		(if (< alf (* pi 0.5 ) )
			(setq rez (dir2pt (+ txtVec pi)))
			(setq rez (dir2pt txtVec))
		)
		(vlax-3d-point rez)
	)
	(setq 
		temp (vlax-safearray->list (vlax-variant-value (vla-GetLeaderLineVertices mlObj 0)))
		mlBasePt (list (car temp) (cadr temp) (caddr temp))
		temp (cdr (cdr (cdr temp)))
		originPt (list (car temp) (cadr temp) (caddr temp))
		originDl (vla-GetDoglegDirection mlObj 0)
		fl t
	)
	(defun *error* (msg) 
		(vla-SetDoglegDirection mlObj 0 originDl)
		(vla-SetLeaderLineVertices mlObj 0 (2ptVariant mlBasePt originPt))
		(setq *error* err)
		(princ "*Прервано*")
	)
	(while fl
		(if (vl-catch-all-error-p (setq temp (vl-catch-all-apply 'grread '(t 12 0))))
			(progn ;;ESC
				(vla-SetDoglegDirection mlObj 0 originDl)
				(vla-SetLeaderLineVertices mlObj 0 (2ptVariant mlBasePt originPt))
				(setq fl nil mlObj nil)
			) 
			(progn 
				(if (or (= (car temp) 5) (= (car temp) 3)) 
					(progn
						(vla-SetLeaderLineVertices mlObj 0 (2ptVariant mlBasePt (cadr temp))) 
						(vla-SetDoglegDirection mlObj 0 (dlDir mlObj mlBasePt (cadr temp)))
				))
				(if (or (= (car temp) 3) (= (car temp) 25)) (setq fl nil))
			)
		)

	) ;;while
	mlObj
)	
p.p.s.
по первому вопросу уже сам отдаю предпочтение vl-catch-all-apply.
Привязал функцию уже ко второму костылю и радуюсь как младенец...
А второй вопрос остается на повестке дня
__________________
Не труд сделал из обезьяны человека, а лень и жажда халявы...

Последний раз редактировалось Vladimir_Sergeevich, 16.10.2019 в 11:42.
Vladimir_Sergeevich вне форума  
 
Непрочитано 17.10.2019, 09:24
#3853
koMon


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


Offtop: Эммммм...
Ну вот ведь не зря говорят: "Не делай людям добра, вернрётся злом сторицей."
Цитата:
Сообщение от Vladimir_Sergeevich Посмотреть сообщение
научите плохому!
Vladimir_Sergeevich, при всей моей толерастной индифферентности, звучит так, что ты записал меня в отряд мальчишей-плохишей
Цитата:
Сообщение от Vladimir_Sergeevich Посмотреть сообщение
1. Как лучше обрабатывать нажатие ESC
...
Цитата:
Сообщение от Vladimir_Sergeevich Посмотреть сообщение
2. Это вообще адекватное решение, перерисовывать выноску с отловом точки через grread?
Не рассматривая технический момент адекватности решения, придумалась вот мне такая притча.
Имеем два персонажа. Утопающий и спасающий на водах. Ключевой момент - утопающий без спасжилета. Ну естественно спасающий спас-таки утопающего. И вот после счастья пш, утопающий озадачивается юридическим, так сказать, вопросом: "Спасающий был без спасжилета, что является грубейшим нарушением текущего законодательства по вопросу нахождения в водном пространстве. А подам-ка я на него в суд и стребую с него компенсацию за какой-то там ущерб!.."
koMon вне форума  
 
Непрочитано 17.10.2019, 11:03
#3854
Vladimir_Sergeevich

рисую дороги, в перерывах курю Lisp
 
Регистрация: 20.04.2011
Пермь
Сообщений: 475
<phrase 1= Отправить сообщение для Vladimir_Sergeevich с помощью Skype™


koMon, та я без злого умысла. мне раньше не приходила идея пользовать grread в подобных целях... вот за идею то, я премного благодарен
__________________
Не труд сделал из обезьяны человека, а лень и жажда халявы...
Vladimir_Sergeevich вне форума  
 
Непрочитано 17.10.2019, 12:43
#3855
ShaggyDoc

Thượng Tá Quân Đội Nhân Dân Việt Nam
 
Регистрация: 14.03.2005
44d32'44"С, 33d26'51"В
Сообщений: 13,381


Цитата:
Сообщение от Vladimir_Sergeevich Посмотреть сообщение
уже сам отдаю предпочтение vl-catch-all-apply.
Привязал функцию уже ко второму костылю и радуюсь как младенец...
Вообще-то использовать *error* давным давно (с появления vl-) не стоит.

В этом случае по ESC происходит прерывание всей программы и можно только попытаться восстановить какие-то настройки.

А надо иметь конструкцию наподобие
Код:
[Выделить все]
try
// попытка каких-то действий
except
// действия при ошибке
end;
Это как раз можно сделать с помощью семейства vl-catch. Но если сначала в первой, а потом в сотнях программ начинать их применять "снизу", непременно запутаешься и будут уже сотни ошибок. Лучше сделать библиотечную функцию обертку. Например
Код:
[Выделить все]
 
(defun ru-error-catch  (protected_expression on_error_expression / catch_error_result)
;|
Пример вызова
(ru-error-catch
    (function (lambda ()
                ;;; защищаемое выражение  
                (
                
                )
                ;;; То что вернет - будет результатом
              )
    )
    (function
      (lambda (err_msg)
        ;; если надо - выводим сообщение. err_msg подставит Автокад
        (princ (strcat "\nОШИБКА такой-то функции: " err_msg))
        ;; возвращаем NIL при ошибке
        nil
      ) 
    ) 
  )

|;
  
  (setq catch_error_result
         (vl-catch-all-apply protected_expression)
  ) 
  (if (and (vl-catch-all-error-p catch_error_result)
           on_error_expression
      ) 
    (apply on_error_expression
           (list (vl-catch-all-error-message catch_error_result))
    ) 
    catch_error_result
  ) 
) 

ShaggyDoc вне форума  
 
Непрочитано 23.10.2019, 18:28
#3856
Browning Zed


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


Господа, подскажите как правильно изменить лисп для требуемой цели. Код ниже маскирует MTEXT и работает по алгоритму: выбираем рамкой объекты, затем подтверждаем выбор, получаем замаскированный текст. Как сделать следующее - текст выбирается путем указания единственной точки и маскируется без подтверждения выбора, команда зацикливается до тех пор пока не будет отменена по эскейпу или ПКМ. Также, если MTEXT был выбран ранее, происходит его маскировка, и команда завершается.
Код:
[Выделить все]
(defun c:mblank ( / js n dxf_ent)
	(setq js (ssget '((0 . "MTEXT"))))
	(cond
		(js
			(repeat (setq n (sslength js))
				(setq dxf_ent (entget (ssname js (setq n (1- n)))))
				(entmod (append dxf_ent '((90 . 1) (63 . 8) (45 . 1.1) (441 . 0))))
			)
		)
	)
)

Последний раз редактировалось Browning Zed, 23.10.2019 в 18:37.
Browning Zed вне форума  
 
Непрочитано 23.10.2019, 19:31
1 | #3857
skkkk


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


С использованием функции mip:entsel от VVA (включена в код):
Код:
[Выделить все]
 (defun c:ciclemblank ( / js flag ent n dxf_ent)
	(setq js T)
	(while js
		(if	(setq js (ssget "_I" '((0 . "MTEXT"))))
			(progn 
				(setq flag T)
				(sssetfirst nil nil)
			)
			(progn 
				(setq ent (mip:entsel "\nВыберите объект:" '("MTEXT") nil))
				(if ent (setq js (ssadd) js  (ssadd ent js)))
			)
		)
		(cond
			(js
				(repeat (setq n (sslength js))
					(setq dxf_ent (entget (ssname js (setq n (1- n)))))
					(entmod (append dxf_ent '((90 . 1) (63 . 8) (45 . 1.1) (441 . 0))))
				)
			)
		)
		(if flag (setq js nil))
	)
)


(defun mip:entsel (promt filter entlist / key n newentlist ent_point promt)
;;;Функция mip:entsel
;;;Еденичный выбор объекта, замена функции entsel
;;;Возвращает entity name выбранного примитива или nil, точку указания запоминает в переменной LASTPOINT
;;;Параметры:
;;;promt - предложение выбрать объект (string)
;;;filter - фильтр объектов для выбора вида '("LINE" "LWPOLYLINE")
;;;entlist - список примитивов которые не надо выбирать (либо список entity name, либо PICKSET)
;;;
;;;Примеры:
;;;(mip:entsel "\nВыберите объекты" '("LINE" "LWPOLYLINE") nil)
;;;(mip:entsel "\nВыберите объекты" nil nil)
;;;(setq aa nil) (mip:entsel "\nВыберите объекты" '("LINE" "LWPOLYLINE") (while (setq a (car (entsel))) (setq aa (append aa (list a)))))
;;;(mip:entsel "\nВыберите объекты" '("LINE" "LWPOLYLINE") (ssget))
  (setq key T n 0 newentlist nil)
  (if (eq (type entlist) 'PICKSET)
    (progn
    	(while (setq a (ssname entlist n)) (setq newentlist (append newentlist (list a)) n (1+ n)))
    	(setq entlist newentlist)
    );progn
   );if
    (while key
    	(if (or (setq ent_point (entsel promt)) (= (getvar "ERRNO") 7))
	  	(if (or (eq (type ent_point) 'LIST) (not ent_point))
		  (if ent_point
		    (if (member (setq ent (car ent_point)) entlist)
		      (princ "\nПримитив уже выбран")
		      (if filter
			      (if (not (member (cdr (assoc 0 (entget ent))) filter))
				(progn (setq str "\nНеверный выбор, выберите: ")
				  (princ (substr (setq str (foreach n filter (setq str (strcat str n ", ")))) 1 (- (strlen str) 2)))
				);progn
				(setq key nil)
			      );if
				(setq key nil)
			);if
		    );if
		    (setq key T)
		  );if
	    	(setq key nil)
	    );if
	  (setq key nil)
      	);if
     );while
  (if (eq (type ent_point) 'LIST)
    (progn (setvar "LASTPOINT" (cadr ent_point)) ent)
    ent_point
  );if
);defun

(princ "C:CICLEMBLANK")(princ)

Последний раз редактировалось skkkk, 23.10.2019 в 19:52.
skkkk вне форума  
 
Непрочитано 23.10.2019, 20:49
#3858
Browning Zed


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


Спасибо большое, все работает. Не подскажете, сложно ли будет связать ваш код с лиспом который преобразует Text в MText, чтобы если был выбран простой текст он сначала конвертировался в MText, а потом сразу же маскировался?
Код:
[Выделить все]
 (defun c:текст2ћтекст (/		nameset	  setlength namtxtrun txtrun
	      p_text	p_kord	  p_sloy    p_styl    p_ugol
	      p_heig	ugol	  deltX	    deltY     n_kord
	      spis_st
	     )
  (setq nameset (ssget "_:L" '((0 . "TEXT"))))
  (setq setlength (sslength nameset))
  (setq i -1)
  (repeat setlength
    (setq i (1+ i))
    (setq namtxtrun (ssname nameset i))
    (setq txtrun (entget namtxtrun))
    (setq p_text (assoc 1 txtrun))
    (setq p_kord (cdr (assoc 10 txtrun)))
    (setq p_sloy (assoc 8 txtrun))
    (setq p_styl (assoc 7 txtrun))
    (setq p_ugol (assoc 50 txtrun))
    (setq p_heig (assoc 40 txtrun))
    (setq ugol (- (* 2 pi) (cdr p_ugol)))
    (setq deltX (* (cdr p_heig) (sin ugol)))
    (setq deltY (* (cdr p_heig) (cos ugol)))
    (setq n_kord (list 10
		       (+ (car p_kord) deltX)
		       (+ (cadr p_kord) deltY)
		       (last p_kord)
		 )
    )
    (setq spis_st (list	'(0 . "MTEXT")	 '(100 . "AcDbEntity")
			p_sloy		 '(100 . "AcDbMText")
			n_kord		 p_heig
			p_text		 p_ugol
			p_styl
		       )
    )
    (entmake spis_st)
    (entdel namtxtrun)
  )
)
Browning Zed вне форума  
 
Непрочитано 24.10.2019, 15:06
1 | #3859
koMon


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


Цитата:
Сообщение от Browning Zed Посмотреть сообщение
текст выбирается путем указания единственной точки и маскируется без подтверждения выбора, команда зацикливается до тех пор пока не будет отменена по эскейпу или ПКМ. Также, если MTEXTы (ТЕКСТы) были выбраны ранее, происходит его их маскировка, и команда завершается.
Код:
[Выделить все]
 
;****************************************************************************************************************************

(vl-load-com)

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

(defun text_to_mtext (text_entity / ) 
	(entmakex (subst '(100 . "AcDbMText")
			 		 '(100 . "AcDbText")
			 		  (append '((0 . "MTEXT"))
			 				   (reverse
							   	   (cdr
										(reverse
			 				   				(vl-remove-if-not '(lambda (every_dxf_group)
			 														(member (car every_dxf_group) '(100 10 67 410 8 40 50 1 7))
			 												   )
			 												   (entget text_entity)
			 					 			)
			 			   	   			)
								   )
							   )
							   '((71 . 7))
			 		  )
			  )
	)
)

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

(defun pick_entity_function ( pick_prompt group_0_list / entity_not_picked picked_entity)
	(while (null entity_not_picked)
		(setq picked_entity (vl-catch-all-apply 'entsel (list pick_prompt)))
		(cond
			(
				(null picked_entity)
			)
			(
				(vl-catch-all-error-p picked_entity)
					(setq entity_not_picked t)
					nil
			)
			(
				t
					(if (member (cdr (assoc 0 (entget (car picked_entity)))) group_0_list)
						(progn
							(setq entity_not_picked t)
							(car picked_entity)
						)
					)
			)
		)
	)
)

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

(defun set_mtext_background_mask (mtext_entity / )
	(entmod (append (entget mtext_entity) '((90 . 1) (63 . 8) (45 . 1.1))))
)
;	441 Transparency of background fill color (not implemented)

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

(defun check_entity_selected (entity_selected /)
	(cond
		(
			(= "MTEXT" (cdr (assoc 0 (entget entity_selected))))
				(set_mtext_background_mask entity_selected)
		)
		(
			(= "TEXT" (cdr (assoc 0 (entget entity_selected))))
				(set_mtext_background_mask (text_to_mtext entity_selected))
				(vla-erase (vlax-ename->vla-object entity_selected))
		)
		(
			t
		)
	)
)

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


(defun c:add_mtext_bgmask (/ command_not_stopped picked_entity afore_sset)
	(while (null command_not_stopped)
		(cond
			(
				(setq afore_sset (cadr (ssgetfirst)))
					(while (setq picked_entity (ssname afore_sset 0))
						(check_entity_selected picked_entity)
						(ssdel picked_entity afore_sset)
					)
					(sssetfirst)
					(setq command_not_stopped t)
			)
			(
				picked_entity
					(check_entity_selected picked_entity)
					(setq command_not_stopped t)
			)
			(
				(setq picked_entity (pick_entity_function "\nВыберите МТекст/Текст для маскирования: " '("TEXT" "MTEXT")))
					(check_entity_selected picked_entity)
					(setq picked_entity nil)
			)
			(
				t
					(setq command_not_stopped t)
			)
		)
	)
	(princ)
)

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

Последний раз редактировалось koMon, 24.10.2019 в 16:24.
koMon вне форума  
 
Непрочитано 24.10.2019, 18:49
#3860
Browning Zed


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


koMon, спасибо, сэнсэй, всё круто!
И, закрывая тему, подскажите плиз, как будет выглядеть подобный алгоритм для обратной операции - демаскировки Мтекста?

Последний раз редактировалось Browning Zed, 24.10.2019 в 19:42.
Browning Zed вне форума  
Ответ
Вернуться   Форум 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