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

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > !!! Help plz !!! Lisp

!!! Help plz !!! Lisp

Ответ
Поиск в этой теме
Непрочитано 10.02.2004, 09:42 #1
!!! Help plz !!! Lisp
plaz
 
Проектирование обустройства нефтяных месторождений
 
Самара
Регистрация: 28.08.2003
Сообщений: 352

Помогите пожалуйста!!!
Срочно нужен лисп:
Есть - два single текста, в каждом есть число.
Хочу - показав их по очереди получить в командной строке значение абс. разницы
Идеал - получить это значение в третьем single тексте, но с возможностью прибавить к этой разнице фиксированное число (он тоже существует, его тоже можно указать)

[sm1400]
[ATTACH]1076395376.jpg[/ATTACH]
Просмотров: 6379
 
Непрочитано 10.02.2004, 10:41
#2
Apelsinov

Проектировщик ВК. LISP-любитель.
 
Регистрация: 15.12.2003
Москва
Сообщений: 1,186
<phrase 1=


На авторство не претендую, это лисп Эдуарда.
Код:
[Выделить все]
(defun C:sumtext(/ gv symv ciflist sumcif tvsum zntext1
		 		  zntext cifra tbazv
		 		  )
  (setq gv(getvar "dimzin"))
  (setvar "dimzin" 3)
  (setvar "cmdecho" 0)
  (setvar "blipmode" 0)
  (command "undo" "M")
  (initget "+ - / *")
  (if(eq(setq symv(getkword "\n Введите знак операции:"))nil)
    (setq symv "+")
    );if
  (setq ciflist '()
        sumcif nil
		 )
  (while
    (not
      (eq (setq zntext1 (entsel "\nВыберите число:"))nil)
      )
  (setq tvsum (cdr(assoc 40 (entget(car zntext1)))));высота текста
   (if
     (or
       (= tvsum 0)(eq tvsum nil))
     (progn
     (setq tvsum (getvar "textsize"))
     )
     );if
     (setq zntext(entget(car zntext1))
        zntext(cdr(assoc 1 zntext))
		 cifra (vl-string-translate "," "." zntext))
    (if    
       (eq  (read cifra) nil)
      (progn (setq cifra (cdr(assoc 42 (entget(car zntext1)))))
		 );progn
      (progn (setq cifra (float(read cifra))))
      );if
        (setq ciflist (cons cifra ciflist)
       );setq
    (command "erase" (car zntext1)"")
    );while
  (setq ciflist (reverse ciflist))
  (command "undo" "B")
  (cond
  (
   (eq symv "+")
    (setq sumcif (apply '+ ciflist))
   )
(
   (eq symv "-")
    (setq sumcif (apply '- ciflist))
   )
  (
   (eq symv "/")
    (setq sumcif (apply '/ ciflist))
   )
   
  (
   (eq symv "*")
    (setq sumcif (apply '* ciflist))
   )
  );cond
  (setq sumcif(rtos sumcif 2 3)
		  )
  (setq tbazv (getpoint "\n Ведите точку вставки результата:"))
  (setq tbazv (list(nth 0 tbazv)(nth 1 tbazv)))  
  (command "text" tbazv tvsum 0 sumcif)
  (setvar "dimzin" gv)
  (princ)
 );defun
Apelsinov вне форума  
 
Автор темы   Непрочитано 10.02.2004, 18:15
#3
plaz

Проектирование обустройства нефтяных месторождений
 
Регистрация: 28.08.2003
Самара
Сообщений: 352


А попроще ничего нет :?:
plaz вне форума  
 
Непрочитано 10.02.2004, 21:54
#4
Arkady

AutoCad Development and Support
 
Регистрация: 21.08.2003
Israel
Сообщений: 183
Отправить сообщение для Arkady с помощью Skype™


Код:
[Выделить все]
  (defun dxf (code elist / ret)
    (cond
      ( (= (type elist) 'LIST) (setq ret (cdr (assoc code elist))) )
      ( (= (type elist) 'ENAME) (setq ret (cdr (assoc code (entget elist)))) )
      (T (setq ret nil))
    )
    ret
  )

  (setq #putdxf# T)
  (defun putdxf (code value elist / ret)
    (cond
      ( (= (type elist) 'LIST)  (setq ret elist))
      ( (= (type elist) 'ENAME) (setq ret (entget elist)))
      (T (setq ret nil))
    )
    (if ret (progn
      (if (assoc code ret) 
          (setq ret (subst (cons code value) (assoc code ret) ret))
          (setq ret (append ret (list (cons code value))))
      )
    ))
    ret
  )
(defun c:absdiff( )
  (setq txt1 (entsel "\nPick First Text :"))
  (if (not txt1) (exit))
  (if (/= (dxf 0 (car txt1)) "TEXT")(exit))
  (if (= (dxf 1 (car txt1)) "" )(exit))
  (setq val1 (read (dxf 1 (car txt1))))
  (if (and (/= (type val1) 'REAL)(/= (type val1) 'INT))(progn
     (alert "This is not NUMBER")
     (exit)
  ))

  (setq txt2 (entsel "\nPick Second Text :"))
  (if (not txt2) (exit))
  (if (/= (dxf 0 (car txt2)) "TEXT")(exit))
  (if (= (dxf 1 (car txt2)) "" )(exit))
  (setq val2 (read (dxf 1 (car txt2))))
  (if (and (/= (type val2) 'REAL)(/= (type val2) 'INT))(progn
     (alert "This is not NUMBER")
     (exit)
  ))

  (setq diff (abs (- val1 val2)))
  (setq p1 (dxf 10 (car txt1)))
  (setq p2 (dxf 10 (car txt2)))
  (setq p3 (polar p2 (angle p1 p2)(distance p1 p2)))
  (setq elast (entlast))
  (setvar "CMDECHO" 0)
  (command "_.LAYER" "U" (dxf 8 (car txt2)) "")
  (command "COPY" txt2 "" p2 p3)
  (setq txt3 (entlast))
  (if (/= txt3 elast)(progn
     (setq ed (putdxf 1 (rtos diff) txt3))
     (entmod ed)
  ))
  (princ) 
)
Arkady вне форума  
 
Непрочитано 11.02.2004, 09:59
#5
Pilot

Проектировщик свиноводство
 
Регистрация: 21.08.2003
Сообщений: 2,260


Цитата:
Сообщение от plaz
А попроще ничего нет?
Это удел гениев - решать сложные задачи простыми методами. Но дело в том, что "простота" - понятие относительное.
Pilot вне форума  
 
Непрочитано 13.02.2004, 09:22
#6
Эдуард

строительство
 
Регистрация: 16.01.2004
Петербург
Сообщений: 165
<phrase 1=


Apelsinov: "....это код Эдуарда"
Следует читать -"Это древний код Эдуарда".
Эдуард вне форума  
 
Непрочитано 13.02.2004, 11:33
#7
Apelsinov

Проектировщик ВК. LISP-любитель.
 
Регистрация: 15.12.2003
Москва
Сообщений: 1,186
<phrase 1=


Эдуард, боишься что кто-то посмотрев на него усомнится в твоих теперешних способностях? Вряд ли!
Впрочем, за язык тебя никто не тянул, оптимизируй его, и родина тебя не забудет
Apelsinov вне форума  
 
Непрочитано 15.02.2004, 23:15
#8
Startrek

AutoCAD/AutoLISP
 
Регистрация: 27.08.2003
Seattle/USA
Сообщений: 1,133


(defun c:abstxt ()
(princ "\nSelect First String Number: ")
(setq txt1(entget (car (entsel))))
(setq line1 (cdr (assoc 1 txt1)))
(setq num1 (atof line1))
(if (= num1 0.0)
(progn
(alert "\nSelected string is not a number")
(quit)
)
)
(princ "\nSelect Second String Number: ")
(setq txt2(entget (car (entsel))))
(setq line2 (cdr (assoc 1 txt2)))
(setq num2 (atof line2))
(if (= num2 0.0)
(progn
(alert "\nSelected string is not a number")
(quit)
)
)
(setq pt (getpoint"\nInsertion point for resulting text: "))
(command "text" pt "" pause (rtos (abs (- num1 num2)) 2 3 ))
(princ)
)
Startrek вне форума  
 
Непрочитано 16.02.2004, 14:46
#9
vk

сисадмин
 
Регистрация: 26.08.2003
Самара
Сообщений: 1,022
<phrase 1=


Еще одна похожая прога:
Код:
[Выделить все]
(defun tminus (/ *error* t1 t2)
  (defun *error* (msg)
    (if (and t2
             (= (type t2) 'VLA-OBJECT)
             (null (vlax-object-released-p t2))
        ) ;_  and
      (progn
        (vla-erase t2)
        (vlax-release-object t2)
      ) ;_  progn
    ) ;_  if
    (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
    (princ)
  ) ;_  defun
  (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
  (if (and (mapcar '(lambda (x) (= (cdr (assoc 0 (entget x))) "TEXT"))
                   (list (setq t1 (car (entsel "\nПервое число >")))
                         (setq t2 (car (entsel "\nВторое число >")))
                   ) ;_  list
           ) ;_  mapcar
      ) ;_  and
    (progn
      (setq t2 (vla-copy (vlax-ename->vla-object t2)))
      (vla-put-textstring
        t2
        (rtos (abs (- ;_ действие - + * /
                     (if (setq t1 (distof (vl-string-subst
                                             "."
                                             ","
                                             (vla-get-textstring (vlax-ename->vla-object t1))
                                           ) ;_  vl-string-subst
                                   ) ;_  distof
                         ) ;_  setq
                       t1
                       (progn (princ "\nНе число!") (exit))
                     ) ;_  if
                     (if (setq t1 (distof (vl-string-subst "." "," (vla-get-textstring t2))))
                       t1
                       (progn (princ "\nНе число!") (exit))
                     ) ;_  if
                   ) ;_  -
              ) ;_  abs
        ) ;_  rtos
      ) ;_  vla-get-textstring
      (command "_move"
               (vlax-vla-object->ename t2)
               ""
               (vlax-safearray->list (vlax-variant-value (vla-get-insertionpoint t2)))
               pause
      ) ;_  command
      (vlax-release-object t2)
    ) ;_  progn
  ) ;_  if
  (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
  (princ)
) ;_  defun
(vl-load-com)
vk вне форума  
 
Автор темы   Непрочитано 17.02.2004, 07:58
#10
plaz

Проектирование обустройства нефтяных месторождений
 
Регистрация: 28.08.2003
Самара
Сообщений: 352


Спасибо всем кто откликнулся!

2 Arcady: При запуске программы выскакивает ошибка
;error: too few arguments

2 All: А как модифицировать программу чтобы результат выводился не в новом тексте, а в существующем, и что бы после запятой было только два знака
plaz вне форума  
 
Непрочитано 17.02.2004, 08:20
#11
Startrek

AutoCAD/AutoLISP
 
Регистрация: 27.08.2003
Seattle/USA
Сообщений: 1,133


Этот вариант округлит до двух знаков. А со второй частью надо немного повозится, но не сегодня - иду спать, у нас тут поздно а завтра рано (4:30) вставать :shock:

(defun c:abstxt ()
(princ "\nSelect First String Number: ")
(setq txt1(entget (car (entsel))))
(setq line1 (cdr (assoc 1 txt1)))
(setq num1 (atof line1))
(if (= num1 0.0)
(progn
(alert "\nSelected string is not a number")
(quit)
)
)
(princ "\nSelect Second String Number: ")
(setq txt2(entget (car (entsel))))
(setq line2 (cdr (assoc 1 txt2)))
(setq num2 (atof line2))
(if (= num2 0.0)
(progn
(alert "\nSelected string is not a number")
(quit)
)
)
(setq pt (getpoint"\nInsertion point for resulting text: "))
(command "text" pt "" pause (rtos (abs (- num1 num2)) 2 2 ))
(princ)
Startrek вне форума  
 
Непрочитано 17.02.2004, 17:13
#12
vk

сисадмин
 
Регистрация: 26.08.2003
Самара
Сообщений: 1,022
<phrase 1=


Пока Startrek спит, предложу свой вариант с изменениями:
Код:
[Выделить все]
(defun c:2tminus (/ *error* t1 t2 prec)
  (defun *error* (msg)
    (if (and t2
             (= (type t2) 'VLA-OBJECT)
             (null (vlax-object-released-p t2))
        ) ;_  and
      (progn
        (vla-erase t2)
        (vlax-release-object t2)
      ) ;_  progn
    ) ;_  if
    (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
    (princ)
  ) ;_  defun
  (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
  (setq prec (getvar "luprec"))
  (setvar "luprec" 2) ; точность
  (if (and (mapcar '(lambda (x) (= (cdr (assoc 0 (entget x))) "TEXT"))
                   (list (setq t1 (car (entsel "\nПервое число >")))
                         (setq t2 (car (entsel "\nВторое число >")))
                   ) ;_  list
           ) ;_  mapcar
      ) ;_  and
    (progn
      (setq t2 (vlax-ename->vla-object t2))
      (vla-put-textstring
        t2
        (rtos (abs (- ;_ действие - + * /
                     (if (setq t1 (distof (vl-string-subst
                                             "."
                                             ","
                                             (vla-get-textstring (vlax-ename->vla-object t1))
                                           ) ;_  vl-string-subst
                                   ) ;_  distof
                         ) ;_  setq
                       t1
                       (progn (princ "\nНе число!") (exit))
                     ) ;_  if
                     (if (setq t1 (distof (vl-string-subst "." "," (vla-get-textstring t2))))
                       t1
                       (progn (princ "\nНе число!") (exit))
                     ) ;_  if
                   ) ;_  -
              ) ;_  abs
        ) ;_  rtos
      ) ;_  vla-get-textstring
      (vlax-release-object t2)
    ) ;_  progn
  ) ;_  if
  (setvar "luprec" prec)
  (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
  (princ)
) ;_  defun
(vl-load-com)
vk вне форума  
 
Непрочитано 17.02.2004, 17:43
#13
Startrek

AutoCAD/AutoLISP
 
Регистрация: 27.08.2003
Seattle/USA
Сообщений: 1,133


С добрым утром (вечером) :P
Startrek вне форума  
 
Автор темы   Непрочитано 19.02.2004, 08:11
#14
plaz

Проектирование обустройства нефтяных месторождений
 
Регистрация: 28.08.2003
Самара
Сообщений: 352


2 vk: Спасибо почти то что надо, вот только результат нужен не во втором тексте а в третьем.
[ATTACH]1077167515.jpg[/ATTACH]
plaz вне форума  
 
Непрочитано 19.02.2004, 20:44
#15
vk

сисадмин
 
Регистрация: 26.08.2003
Самара
Сообщений: 1,022
<phrase 1=


Перечитал ветку заново.... Третий текст (новый) можно вернуть, в моем последнем варианте немного изменена строка
Код:
[Выделить все]
(setq t2 (vla-copy (vlax-ename->vla-object t2)))
и удален фрагмент
Код:
[Выделить все]
      (command "_move" 
               (vlax-vla-object->ename t2) 
               "" 
               (vlax-safearray->list (vlax-variant-value (vla-get-insertionpoint t2))) 
               pause 
      ) ;_  command
Если вернуть их - результат должен выводиться в отдельный примитив TEXT.

:?: В первом постинге
Цитата:
...прибавить к этой разнице фиксированное число (он тоже существует, его тоже можно указать)
его каждый раз надо указывать или как? В смысле, недопонимаю выражение "фиксированное число" :?:
vk вне форума  
 
Автор темы   Непрочитано 27.03.2004, 19:14
#16
plaz

Проектирование обустройства нефтяных месторождений
 
Регистрация: 28.08.2003
Самара
Сообщений: 352


2 vk: Активно пользую твою программу, еще раз спасибо. Есть небольшие проблемы: Как заставить прогу выполняться не один раз, а до тех пор пока не надоест ( ). Поставил загрузку на кнопочку - работает, ставлю * перед ^c^c, начинается непрерывный цикл. Я так понимаю надо циклить в самой проге, а где не знаю

На счет фиксированного числа. К результату вычислений мне надо, например, прибавить 0,12 на протяжении всей работы программы.
plaz вне форума  
 
Непрочитано 27.03.2004, 21:02
#17
vk

сисадмин
 
Регистрация: 26.08.2003
Самара
Сообщений: 1,022
<phrase 1=


Ну давай по порядку.

Зациклить конечно можно и в проге, однако рассмотрим два сценария:
1) дополнительный запрос программы на продолжение или прекращение работы. Соответственно на каждом прогоне будет задаваться вопрос, который требует ответа.
2) прекращение программы по "пустому" вводу при указании примитива

Второй вариант кажется более предпочтительным. Тогда можно не заморачиваясь, просто заменить if на while в строке
Код:
[Выделить все]
(if (and (mapcar ....
Однако, возникнут небольшие проблемы, связанные с UNDO (откат не по одному действию, а всего с момента запуска проги). Чтоб избежать их, можно перенести метки UNDO-группы (vla-startundomark (vla-get-activedocument (vlax-get-acad-object))) и (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))внутрь цикла. Туда же запихнуть и установку-восстановление LUPREC. Кстати с функцией while уже не нужна будет функция progn.

Постоянное число добавить...
Если это не вводимое с клавы или выбираемое на экране число, то очень просто - строку (rtos (abs (- дополним до вида (rtos (+ 0.12 (abs (- , естественно не забываем в нужном месте поставить дополнительно закрывающую скобку
В противном случае это число придется указывать не третьим, а скорее нулевым, тоесть, до указания первого числа. Соответственно, делать это надо до цикла. Аналогично первому или второму тексту, проверяем его, выцепляем числовое значение и через переменную передаем его в функцию (+ ...)

Надеюсь, не сильно намудрил :?:

PS: только сейчас заметил, что забыл включить восстановление LUPREC в *error*. Надо добавить строку
(setvar "luprec" prec)
vk вне форума  
 
Автор темы   Непрочитано 29.03.2004, 09:44
#18
plaz

Проектирование обустройства нефтяных месторождений
 
Регистрация: 28.08.2003
Самара
Сообщений: 352


Спасибо, все предельно понятно! Работает отлично. Но осталось пару непоняток:

Цитата:
Сообщение от vk
Туда же запихнуть и установку-восстановление LUPREC.
Имеется ввиду
(setvar "luprec" prec)

добавть не в (defun *error*..., а в цикл :?:

Цитата:
Сообщение от vk
Кстати с функцией while уже не нужна будет функция progn.
А если ее оставить, хуже не будет? Там их много, боюсь удалить лишнее
plaz вне форума  
 
Автор темы   Непрочитано 29.03.2004, 10:13
#19
plaz

Проектирование обустройства нефтяных месторождений
 
Регистрация: 28.08.2003
Самара
Сообщений: 352


Еще один вопрос в догонку:
Программа написана на каком языке? VisualLisp?
Если "ДА", то в R14 работать не будет.
plaz вне форума  
 
Автор темы   Непрочитано 29.03.2004, 10:25
#20
plaz

Проектирование обустройства нефтяных месторождений
 
Регистрация: 28.08.2003
Самара
Сообщений: 352


2 Startrek: Че то не срабатывает програмуля. Во первых, не хватает одной ) в конце (но это лирика 8) ), Самое главное, что вместо результата вставляет \, а сам результат вставляет уже после завершения работы команды text, на что ессесвено Acad пишет:
Код:
[Выделить все]
Enter text: \
Command: 1.78 Unknown command "1.78".  Press F1 for help.
plaz вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > !!! Help plz !!! Lisp

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

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