Научите лиспу на примере (или как 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

_____________________________________________________________________________________________________________

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

gomer · 01.05.2013, 19:50

Что-то видно все профессионалами стали в лиспе, что ж апну темку. Вопрос таков, точнее не вопрос, а просьба подтвердить ситуацию: Есть функция getdist, которая нормально работает во всех случаях, кроме как в связке с action_tile, в этом случае просто возвращает nil, даже не предлагая указать расстояние. Об этом не написано ни в справке, ни у Н. Полещука, у которого, да и не только у него, припасен бубен в виде конструкции cond. Замечу, что в брикскаде getdist работает, но при нажатии Esc программа завершается несмотря на бубен. Если кому интересно, вот пример кода, который красив, но не работает:

Код:

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

 (defun test ( / *error* accept_clk cancel_clk ok1_clk step tmp)

  (vl-load-com)

  (defun *error* ()
   (princ)
  )
  (defun ok1_clk ()
	(done_dialog 2)
	(setq
	  tmp
	  (vl-catch-all-apply
			 'getdist
			 '("\nУкажите размер сетки <Отмена>: ")
	  )
	)
	(cond
	  ((= 'REAL (type tmp))
		(setq n_razm (vl-princ-to-string tmp))
	  )
	  ((vl-catch-all-error-p tmp)
		(princ (vl-catch-all-error-message tmp))
	  )
	  (T (princ (type tmp)))
	)
  )

  (defun accept_clk ()
    (done_dialog 1)
  )

  (defun cancel_clk ()
    (done_dialog 0)
  )

  (or n_razm (setq n_razm "1.00"))
  (setq step 2)


  (if (> 0 (setq dcl_id (load_dialog "test")))
	(progn
	  (alert "Ошибка загрузки диалога")
	  (exit)
	)
  )

  (while (> step 1)
	(if (null (new_dialog "dlg" dcl_id))
	  (progn
		(alert "Ошибка создания диалога")
		(exit)
	  )
	)

	(set_tile "razm" n_razm)
	(action_tile "ok1"    "(ok1_clk)")
	(action_tile "accept" "(accept_clk)")
	(action_tile "cancel" "(cancel_clk)")

	(setq step (start_dialog))
  )
  (unload_dialog dcl_id)
)

и диалог:

Код:

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

dlg: dialog {
  label="Пример";
  : row {
	: edit_box{ label="Размер сетки: "; key="razm"; edit_width=8;edit_limit=8; }
	: retirement_button { key="ok1"; label=">>";}
  }
  spacer;
  ok_cancel;
}

Кулик Алексей aka kpblc · 03.05.2013, 19:22

Шансов сейчас проверить нет, поэтому в качестве варианта: закрыть диалог, получить результат ввода, снова сформировать диалог и показать его. Кажется, другого варианта для использования dcl нету..

alega11 · 04.05.2013, 15:56

Спасибо огромное!

Up.
_________

код с копированием работает на ура.
НО очень надо чтобы инкрементирование происходило при создании новой мультивыноски.
Своих мозгов подправить код не хватает.
ОЧЕНЬ НАДО, каждый день сотни выносок вручную нумерую.
Спасибо.

perpetule · 05.05.2013, 13:42

Практически первый опыт, да и не написание, а переделка от проффи lee mac и др., но работает как хотел. Выношу на суд и доработку.
txt2att.lsp
команда вызова txt2att

Последовательно.
Чертим в модели приблизительно начинку блока, вместо атрибутов используем однострочный текст, с желаемыми св-вами.
Вызываем txt2att
Выбор рамкой и конвертация одного/нескольких однострочных текстов в атрибуты (и таг и подсказка и сод - бывшее значение содержания текста).
По выходу из выбора рамкой текста ставшего атрибутами, имеем в буфере ОС текстовую строку вида годмесяцчисло.часминутасекунда,
за сим из лиспа вызывается диалоговое окно создания блока, где по желанию используем или нет то что торчит текстовой строкой в буфере, далее работаем как обычно, вторично указывая границы создаваемого блока ,
ну и все остальные галки по желанию, как обычно. На выходе имеем готовый статичный блок с готовыми атрибутами.

Что хотелось бы добавить - имя юзверя/пользователя - в конце строки (предполагается что таковых мер будет достаточно для уникального автоматом сформированного названия блока, вопрос конечно спорный).

Код:

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

 ;;; http://www.cadtutor.net/forum/showthread.php?33866-Convert-text-to-attribute
;;;  Try this for multiple selections
;;;  Convert text to attribute
;;;  thanx david. that works like a dream
;;;  David Bethel Not woking when the text has spaces
;;;  This should deal with spaces - Lee Mac
;;;  above code dealing with space not spaces the routine can deal with txt txt but cant with txt txt txt txt
;;;  Latest code Lee Mac 27th May 2010
;;;  http://www.cadtutor.net/forum/showthread.php?33866-Convert-text-to-attribute/page3
;;;  Txt2Att  (Lee_Mac)
;;; Converts Single-line Text to Attribute Definition
;;;   ^C^C(IF (NULL C:txt2att)(LOAD "txt2att.lsp"));txt2att;
;; Txt2Att  ( Lee Mac )
;; Converts Single-line Text to Attribute Definition
;; 
;;  +  tc71  вызов диалогового окна редактора блоков, 
;;  с помещением в буфер обменыа оси текущей даты и времени
;;


(defun c:txt2att ( / StringSubst RemovePairs ss ent eLst str dx73 )
  (vl-load-com)
  ;; Lee Mac  ~  27.04.10

  (defun StringSubst ( new pat str )
    (while (vl-string-search pat str)
      (setq str (vl-string-subst new pat str))
    )
    str
  )

  (defun RemovePairs ( lst pairs )
    (vl-remove-if
      (function
        (lambda ( pair )
          (vl-position (car pair) pairs)
        )
      )
      lst
    )
  )

  (if (setq ss (ssget "_:L" '((0 . "TEXT"))))
    
    ( (lambda ( i )
        
        (while (setq ent (ssname ss (setq i (1+ i))))
          (setq eLst (entget ent)
                str  (StringSubst "_" " " (cdr (assoc 1 eLst)))
                dx73 (cdr (assoc 73 eLst)))

          (setq eLst (RemovePairs eLst '( 0 100 1 73 )))

          (if (entmake (append '( (0 . "ATTDEF") ) eLst (list (cons 70    0)
                                                              (cons 74 dx73)
                                                              (cons 1   str)
                                                              (cons 2   str)
                                                              (cons 3   str))))
            (entdel ent)
          )
        )
      )
      -1
    )
  )
(today)
(command "_BMAKE")
 (princ))                                                                                                               ;_ end of defun txt2att   далее функции
;;; 
;;; ---------------------------------------------------------------------------------------------------------------------------------------------	 
;;;   http://www.afralisp.net/autolisp/tutorials/date-and-time-stamping.php
;;;   (today)
;;;   (time)
;;; ---------------------------------------------------------------------------------------------------------------------------------------------
;;; Small Fish Michael Puckett	
;;; http://www.cadtutor.net/forum/showthread.php?45468-Copy-from-command-line&
;;;   (CurNamePath)
;;;   (SetClipBoardText "" )
;;;   (GetClipBoardText)
;;;   
;;;   
;;;   
;;;   
;;; ---------------------------------------------------------------------------------------------------------------------------------------------	 
(defun TODAY ( / d yr mo day)          ;define the function and declare all variabled local
(vl-load-com)
(setq d (rtos (getvar "CDATE") 2 6)    ;get the date and time and convert to text
          yr (substr d 3 2)            ;extract the year
          mo (substr d 5 2)            ;extract the month
	  day (substr d 7 2)           ;extract the day
)                                      ;setq
     (strcat day "-" mo "-" yr)        ;string 'em together
(SetClipBoardText d)
(princ)
)                                      ;defun
;;; ---------------------------------------------------------------------------------------------------------------------------------------------	 
(defun TIME ( / d hr m s)               ;define the function and declare all variables as local
(vl-load-com)
(setq d (rtos (getvar "CDATE") 2 6)     ;get the date and time and convert to text
hr (substr d 10 2)	                ;extract the hour
m (substr d 12 2)                       ;extract the minute
s (substr d 14 2)                       ;extract the second
)                                       ;setq
(strcat hr ":" m ":" s)                 ;string 'em together
(SetClipBoardText d)
(princ) 
)                                       ;defun
;;; 
;;; ---------------------------------------------------------------------------------------------------------------------------------------------	                                                                                                             
;;; устанавливает в переменную text и БО имя и путь активного чертежа  
;;; ---------------------------------------------------------------------------------------------------------------------------------------------
;_ begin of defun
(defun CurNamePath (/ acadx doc dwg text htmlfile result )
(vl-load-com)
(setq acadx (vlax-get-acad-object) doc (vla-get-activedocument acadx) dwg (vla-get-name doc) path (vla-get-path doc)
);setq
(princ (strcat path "\\"  dwg ))
(setq text (strcat path "\\" dwg ))
(SetClipBoardText text)
(princ "\nThe above line has been copied. You can now ")
(princ "\npaste into an email or any other application." )
(princ)
)                                                                                                             ;_ end of defun
;;; 
;;; ---------------------------------------------------------------------------------------------------------------------------------------------	 
;;; устанавливает в БО переменную text
;;; пример вызова (SetClipBoardText "" )
;;; ---------------------------------------------------------------------------------------------------------------------------------------------
(defun SetClipBoardText ( text / htmlfile result )                                    ;_ begin of defun
(vl-load-com)
;; Caller's sole responsibility is to pass a
;; text string. Anything else? Pie in face.
(setq result
(vlax-invoke
(vlax-get
(vlax-get (setq htmlfile (vlax-create-object "htmlfile")) 'ParentWindow)
'ClipBoardData
)
'SetData "Text" text)
)
(vlax-release-object htmlfile)
text
)                                                                                                             ;_ end of defun
;;; ---------------------------------------------------------------------------------------------------------------------------------------------	                                                                                                             
;;; получает из КС и устанавливает в переменную text 
;;; ---------------------------------------------------------------------------------------------------------------------------------------------
(defun GetClipBoardText( / htmlfile result )                                            ;_ begin of defun
(vl-load-com)
(setq result
(vlax-invoke
(vlax-get
(vlax-get (setq htmlfile (vlax-create-object "htmlfile")) 'ParentWindow)
'ClipBoardData
)
'GetData "Text")
)
(vlax-release-object htmlfile)
result
)                                                                                                               ;_ end of defun

дубль

Michael! · 10.05.2013, 16:42

Привет, братцы!
Вопрос по функции ssget.
Выбираю я значит некоторое количество примитивов с помощью рамки и присваиваю этот набор переменной. В набор входят линии, арки, окружности, текст, размеры. Но, из всего этого набора мне нужны только линии, арки и окружности. Значит надо исключить ненужные примитивы из набора.
Но что-то тут с именами примитивов не понятно мне - как их выцепить из набора? получается что-то вида <Entity name: 7dc84328>, а для ssdel наверное всетаки нужно только 7dc84328.
Или есть какой более простой способ?
Спасибо.
(программка приложена)

Код:

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

 

(setq ss (ssget))

(setq quent (sslength ss))
(print "quent")
(setq i 0)
	(while (< i quent)
		
		(if (= "LINE" (cdr (assoc 0 (setq elist (entget (ssname ss i))))))
			(progn
			(print (ssname ss i))
			(print i)
			); progn

				(progn
				(setq nmp (ssname ss i))
				(print nmp)
				(print i)
				(ssdel nmp ss)
				);progn
		); end if
(setq i (+ 1 i))
	); end while

Дима_ · 10.05.2013, 17:39

Цитата:

Сообщение от Michael!

Но, из всего этого набора мне нужны только линии, арки и окружности...
Или есть какой более простой способ?

Код:

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

 (ssget '((-4 . "<OR") (0 . "LINE") (0 . "ARC") (0 . "CIRCLE") (-4 . "OR>")))

gomer · 10.05.2013, 21:53

Код:

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

 (ssget '((0 . "LINE,ARC,CIRCLE")))

Michael! · 11.05.2013, 13:05

Да, это я пробовал, но видимо в синтаксисе что-то напутал и он выбирал все линии, арки и окружности во всем файле.

Круто! Спасибо! все решается оказывается так.

Jerald · 13.05.2013, 11:24

С чем может быть связано вот такое ругательство:
; error: extra cdrs in dotted pair on input

Кулик Алексей aka kpblc · 13.05.2013, 11:34

Цитата:

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

С чем может быть связано вот такое ругательство:
; error: extra cdrs in dotted pair on input

С неверным кодом, например.

Do$ · 13.05.2013, 11:41

Цитата:

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

С чем может быть связано вот такое ругательство:
; error: extra cdrs in dotted pair on input

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

Jerald · 13.05.2013, 14:16

Инструменты отладки не помогли, вот код: (код не мой, я просто пытаюсь запустить код из примера)

Код:

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

  (defun rcl ( / )

; Начальные значения списков радиусов (list rad) и центров (list cen) (setq list_rad '() list_cen '())

; Создание набора из кругов на слое HOLES

(setq nab_cir (ssget "_X" (list (cons 8 "HOLES") (cons 0 "CIRCLE"))))

; Проверка, сформировался ли набор nab cir

; (если нет, то предыдущая операция вернет nil)

(if (null nab_cir)

(progn

(princ "\пНет кругов на слое HOLES. "); сообщение об отсутствии

(princ); тихий выход

); конец progn

(progn

(setq i -1 nab_len (sslength nab_cir))

; Цикл по количеству элементов набора nab_cir

(repeat nab len

(setq i (1+ i))

; Выбор следующего примитива и получение его списка

(setq cirlist (entget (ssname nab_cir i)))

(setq radcir (cdr (assoc 40 cirlist))) .

(setq cencir (cdr (assoc 10 cirlist)))

; Добавление радиуса и точки центра к спискам list rad и list cen

(setq list rad (append list rad (list radcir)))

(setq list_cen (append list_cen (list cencir)))

); конец repeat

; Печать результирующих списков

(princ "\nРадиусы: ")

(princ list_rad)

(princ "\nЦентры: ")

(princ list cen)

); конец progn

) ; конец if

) ; конец defun

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

Точки просто так ставить не надо

Да и копирование кода выполнять внимательнее...

Код:

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

(defun rcl (/)

          ; Начальные значения списков радиусов (list rad) и центров (list cen) (setq list_rad '() list_cen '())

          ; Создание набора из кругов на слое HOLES

  (setq nab_cir (ssget "_X" (list (cons 8 "HOLES") (cons 0 "CIRCLE"))))

          ; Проверка, сформировался ли набор nab cir

          ; (если нет, то предыдущая операция вернет nil)

  (if (null nab_cir)

    (progn

      (princ "\пНет кругов на слое HOLES. ") ; сообщение об отсутствии

      (princ) ; тихий выход

      )   ; конец progn

    (progn

      (setq i       -1
            nab_len (sslength nab_cir)
            ) ;_ end of setq

          ; Цикл по количеству элементов набора nab_cir

      (repeat nab
        len

        (setq i (1+ i))

          ; Выбор следующего примитива и получение его списка

        (setq cirlist (entget (ssname nab_cir i)))

        (setq radcir (cdr (assoc 40 cirlist)))

        (setq cencir (cdr (assoc 10 cirlist)))

          ; Добавление радиуса и точки центра к спискам list rad и list cen

        (setq list_rad
               (append list_rad (list radcir))
              ) ;_ end of setq

        (setq list_cen (append list_cen (list cencir)))

        ) ; конец repeat

          ; Печать результирующих списков

      (princ "\nРадиусы: ")

      (princ list_rad)

      (princ "\nЦентры: ")

      (princ list cen)

      )   ; конец progn

    )     ; конец if

  )       ; конец defun

Do$ · 13.05.2013, 16:39

Цитата:

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

Инструменты отладки не помогли

Ну да, забыл сказать, к ним еще голова нужна

Кулик Алексей aka kpblc · 13.05.2013, 17:24

Do$, ну да, каюсь, я бы писал код по-другому:

Код:

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

 (defun rcl (/ ss lst)

  (if (setq ss (ssget "_X" '((0 . "CIRCLE") (8 . "HOLES"))))
    (mapcar
      (function
        (lambda (check)
          (princ (strcat "\n" (car check) ":\n"))
          (mapcar
            (function
              (lambda (ent)
                (princ (strcat "\n"
                               (if (listp (cdr (assoc (cdr check) (entget ent))))
                                 (strcat "("
                                         (vl-string-trim " "
                                             (apply (function strcat)            (mapcar
                                                           (function
                                                             (lambda (x)
                                                               (strcat " " (rtos x 2 4))
                                                               ) ;_ end of lambda
                                                             ) ;_ end of function
                                                           (cdr (assoc (cdr check) (entget ent)))
                                                           )) ;_ end of mapcar
                                                         ) ;_ end of vl-string-trim
                                         ")"
                                         ) ;_ end of strcat
                                 (rtos (cdr (assoc (cdr check) (entget ent))) 2 4)
                                 ) ;_ end of if
                               ) ;_ end of strcat
                       ) ;_ end of princ
                ) ;_ end of lambda
              ) ;_ end of function
            ((lambda (/ tab item)
               (repeat (setq tab  nil
                             item (sslength ss)
                             ) ;_ end setq
                 (setq tab (cons (ssname ss (setq item (1- item))) tab))
                 ) ;_ end of repeat
               ) ;_ end of lambda
             )
            ) ;_ end of mapcar
          ) ;_ end of lambda
        ) ;_ end of function
      '(("Centers" . 10) ("Radius" . 40))
      ) ;_ end of mapcar
    ) ;_ end of if
  ) ;_ end of defun

---
Добавлено: подходим к рубежу в 2000 сообщений... Тему разделять будем?

gomer · 13.05.2013, 18:41

на самом деле программа должна была бы выглядеть так:

Код:

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

 (defun c:rcl (/ nab_cir i cirlist list_rad list_cen)

  (if (setq
	dxf	(lambda (x y) (cdr (assoc x y)))
	nab_cir	(ssget "_X" (list (cons 8 "HOLES") (cons 0 "CIRCLE")))
      )

    (progn
      (repeat (sslength nab_cir)

	(setq i	(if i
		  (1+ i)
		  0
		)
	)

	(setq

	  ;; Добавление радиуса и точки центра к спискам list_rad и list_cen
	  list_rad (append
		     list_rad
		     (list (dxf
			     40
			     (setq cirlist (entget (ssname nab_cir i)))
			   )

		     )
		   )
	  list_cen (append list_cen (list (dxf 10 cirlist)))
	)
      )

      ;; Печать результирующих списков

      (princ "\nРадиусы: ")

      (princ list_rad)

      (princ "\nЦентры: ")

      (princ list_cen)

    )
    (princ "\пНет кругов на слое HOLES. ")
  )
  (princ)
)

теперь о причине ошибки, это конечно же намусоренная точка! Там их еще (ошибок) есть немало, но меня больше печалит:

Цитата:

; ошибка: излишние cdrs в точесной паре на входе

в руськой версии

Jerald · 13.05.2013, 23:21

Цитата:

Сообщение от Do$

Ну да, забыл сказать, к ним еще голова нужна

"Китайская комната" не подойтёт

Цитата:

на самом деле программа должна была бы выглядеть так:

Почти нигде не смог найти вхождений dxf в сам код программы. Хоть, помнится, как ми то способом извлекал ранее dxf-данные примитивов.

Nike · 28.05.2013, 17:24

Товарищи программисты!
Помогите если можно одну маленькую дурацкую идею запрограммировать

Хочу на кнопку F2 повесить умный лисп, который в случае если выполняется какая-то команда, например _move или _line при нажатии на F2 вставлял бы мне прозрачную указиловку, например _m2p (середина между точками) или _from (от), а при других случаях выполнял бы непосредственную функцию F2 - вывод текстового окна (_textscr).
Такое извращение возможно?

tivun · Регистрация: 05.06.2013

Здравствуйте! Помогите, пожалуйста, написать программу на автолиспе.

Кулик Алексей aka kpblc · 06.06.2013, 00:12

tivun, во-первых, картинки отлично присоединяются к посту. Во-вторых, с такой постановкой вопроса тебе прямая дорога в "Поиск исполнителей".

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

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.
Просмотров: 1973570

	Реклама i