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

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

Нужен лисп, который высчитывает уклон линии

Ответ
Поиск в этой теме
Непрочитано 14.11.2005, 09:30
Нужен лисп, который высчитывает уклон линии
ВоваН
 
Дороги, Конструкции, Тоннели
 
Сочи
Регистрация: 20.05.2004
Сообщений: 102

Нужен лисп, который высчитывает уклон линии.

Берем у выделенной линии Delta X, Delta Y и производим следующую операцию:

(Delta Y / Delta X)*1000

Результат выводим в командную строку.

Спасибо
Просмотров: 32399
 
Непрочитано 11.03.2012, 23:45
#21
Дима_

Продуман
 
Регистрация: 22.02.2007
Питер
Сообщений: 2,840


если что-то нужно - то надо описать МАТЕМАТИЧЕСКИ что такое средний уклон и усредненная длинна, если с математикой плохо - нарисовать пару примеров - чтоб было понятно что на что делить и что с чем складывать - там глядишь и програмку нарисуют.
Offtop: не создать ли нам FAQ высвечиваемый при создании новой темы в этом разделе - как правильно задать вопрос (запрос) на написание чего-либо.
__________________
Когда в руках молоток все вокруг кажется гвоздями.

Последний раз редактировалось Дима_, 12.03.2012 в 00:27.
Дима_ вне форума  
 
Непрочитано 12.03.2012, 10:40
#22
Владимир.

Проектирую
 
Регистрация: 10.01.2005
Сообщений: 3,736


Цитата:
Сообщение от sinitsin1983 Посмотреть сообщение
усредненный по длинне ????
Это зачем может быть нужно?
Просто взять точку начала и конца канавы и посчитать этот один уклон от начала до конца канавы
Владимир. вне форума  
 
Непрочитано 13.03.2012, 22:38
#23
sinitsin1983


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


математика с примером
Вложения
Тип файла: rar Desktop.rar (520.9 Кб, 172 просмотров)

Последний раз редактировалось sinitsin1983, 13.03.2012 в 23:03.
sinitsin1983 вне форума  
 
Непрочитано 14.03.2012, 10:29
#24
Дима_

Продуман
 
Регистрация: 22.02.2007
Питер
Сообщений: 2,840


Расстрою я тебя немножко - у тебя в рисунке обычные (а не "обещенные" 3D) полилинии, то есть лежат в одной плоскости, соответственно "взять высоту" (Z) можно лишь "поискав" рядом с вершиной тескт содержащий цифру и предположив, что это высота. Решение может быть только изначально кривое (т.к. вместо высоты может попасться все что угодно) - а поработав с кривым - ты через неделю попросишь "выловить блох" - и так до бесконечности - короче я его делать точно не буду.
__________________
Когда в руках молоток все вокруг кажется гвоздями.
Дима_ вне форума  
 
Непрочитано 15.03.2012, 21:45
#25
sinitsin1983


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


вот 3d
Вложения
Тип файла: dwg
DWG 2007
пример среднего уклона.dwg (628.5 Кб, 1141 просмотров)
sinitsin1983 вне форума  
 
Непрочитано 16.03.2012, 11:40
1 | #26
Дима_

Продуман
 
Регистрация: 22.02.2007
Питер
Сообщений: 2,840


Вот код:
Код:
[Выделить все]
 (vl-load-com)
(defun c:uklon()
  ((lambda (togradus ents)
     (if (and ents
              (= (cdr(assoc 0 (entget (car ents))))
                 "POLYLINE"))
         ((lambda (pt1 pt2 len)
            ((lambda (deltaz pram)
               (princ (strcat "\nДлинна: по прямой - " (rtos pram)
                              ", зигзагом - " (rtos len)
                              "; перепад высоты - " (rtos deltaz) 
                              "\nУклон: по прямой - " (rtos (togradus (/ deltaz pram)))
                              ", зигзагом - "(rtos (togradus (/ deltaz len)))".")))
             (abs (- (caddr pt1) (caddr pt2)))
             (distance pt1 pt2)))
          (vlax-curve-getstartpoint (car ents))
          (vlax-curve-getendpoint (car ents))
          (vla-get-length (vlax-ename->vla-object (car ents))))
         (princ "Что то не то выбрали."))
     (princ))
   (lambda (x) (* 180 (/ (atan x) pi)))         
   (entsel "\n Выберите 3Д полилинию: ")))
__________________
Когда в руках молоток все вокруг кажется гвоздями.
Дима_ вне форума  
 
Непрочитано 23.03.2012, 19:31
#27
Composter

Отопление и вентиляция
 
Регистрация: 31.10.2008
Москва
Сообщений: 445


http://forum.abok.ru/index.php?showtopic=66478 вот мой вариант лиспа для проставления отметок с учетом уклона
Composter вне форума  
 
Непрочитано 30.08.2015, 21:12
#28
zikyha

ВК
 
Регистрация: 12.10.2011
питер
Сообщений: 10


Товарищи думаю у многих есть такой лисп, по форуму поискал но все что то нето. Нужно что бы лисп выносил на выноске или в Командной строке уклон для прямой между двуся точками, с координатой х,y.
Програмка нужна чтоб проверять профили и самому проставлять уклоны труб. В моем понимании это будет просто Дельта Y/ Дельта X = цифра эту цифру или на выноске или в командную строку. Нужно еще возможноть задать масштаб по горизонтале и вертикали.
zikyha вне форума  
 
Непрочитано 30.08.2015, 21:25
#29
Oleg T


 
Регистрация: 27.12.2011
Сообщений: 1,458


http://forum.zwsoft.ru/viewtopic.php?t=259
Пункт 5
Под акадом тоже должно работать
Oleg T вне форума  
 
Непрочитано 30.08.2015, 21:46
#30
zikyha

ВК
 
Регистрация: 12.10.2011
питер
Сообщений: 10


не работает пишет неизвестная программа.
zikyha вне форума  
 
Непрочитано 31.08.2015, 09:35
#31
Vladimir_Sergeevich

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


zikyha, есть, но не всегда такой
я для себя писал просто с выводом в ком строку, без выносок. Ничего лишнего, одна арифметика.
Код:
[Выделить все]
 (defun c:uk ( / x1 x2)
(setq x1 (getpoint "\nпервая точка"))
(setq x2 (getpoint "\nвторая точка"))
(princ "\nуклон отрезка: ")
(princ (* (/ (- (cadr x1) (cadr x2)) (- (car x1) (car x2))) 1000)) 
(princ) 
);end

Если надо что бы это выводилось текстом - добавляй нужные запросы на положение текста, и в 5ой строке вместо princ сохранить строку в переменную для дальнейшего использования
з.ы. если масштабы по осям разные - надо, опять же, добавлять нужный запрос и в зависимости от полученного значения просчитывать разные варианты.
__________________
Не труд сделал из обезьяны человека, а лень и жажда халявы...
Vladimir_Sergeevich вне форума  
 
Непрочитано 20.10.2016, 10:38
#32
Prodiver

Проектирование газоснабжения
 
Регистрация: 20.10.2016
Сообщений: 2


Здравствуйте уважаемые форумчане. Работаю проектировщиком по газоснабжению соответственно приходится делать много километров профилей. Хочу попросить Вас о помощи. Нужен лисп для расчета уклона газопровода в промилле.Суть задачи в следующем: есть две отметки (мтекст)-одна большая, другая меньшая и длина участка (мтекст). Отметки-с двумя знаками после запятой, длина участка-с одним знаком. Указываем на экране большую отметку, меньшую отметку и длину участка. Программа считает уклон по формулебольшая отметка-меньшая отметка)х1000/длину участка, и заменяет любой указанный мтекст на значение рассчитанного уклона с двумя знаками после запятой. Разделитель именно запятая. Конечно, все это считается на простом калькуляторе или в Exсel, что я собственно и делаю. Но с липсом было бы гараздо оперативнее. В нете к сожалению ничего похожего найти не удалось.Буду признателен всем кто отзовется. Работаю на Autocad 2016х32.
Такой лисп в связке с лиспом уважаемого Composter был бы просто находкой. Хочу сказать большое спасибо Composter за его программу по простановке отметок на профиле, пользуюсь постоянно. Правда методом "научного тыка" немного подточил ее "напильником" (к сожалению лисп не знаю) под свою работу. Теперь отметка ставиться с двумя знаками, разделитель запятая и горизонтальный масштаб 1:500. Искренне надеюсь что автор автор не обидится.
Prodiver вне форума  
 
Непрочитано 20.10.2016, 14:10
#33
Vladimir_Sergeevich

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


Prodiver, например так
Код:
[Выделить все]
 (defun c:iv2 ( / ) 
(princ 
	(strcat "\nУклон: " 
		(rtos (* (/ (- (atof (vl-string-subst "." "," (vla-get-textstring (vlax-ename->vla-object (car (entsel "\nпервая отметка:")))))) 
                                          (atof (vl-string-subst "." "," (vla-get-textstring (vlax-ename->vla-object (car (entsel "\nвторая отметка:"))))))
                                 ) 
                                 ;;(getdist "\nмежду точками: ") 
				(atof (vl-string-subst "." "," (vla-get-textstring (vlax-ename->vla-object (car (entsel "\nрасстояние:")))))) 
				) 
             1000) 
		2 2)
);strcat
);princ
(princ)
);end
результат будет в командной строке выводится. работаю в акад 2010, думаю в 2016 тоже должно нормально отработать.
Облагораживать самостоятельно...
__________________
Не труд сделал из обезьяны человека, а лень и жажда халявы...
Vladimir_Sergeevich вне форума  
 
Непрочитано 21.10.2016, 01:47
#34
skkkk


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


Prodiver, нужный код есть тут в #509 (спасибо CB): Как сосчитать сумму цифр из отдельных мтекстов.
Только тот код вроде до одного знака после запятой, но там же, чуть выше написано, где что поменять, чтоб стало два. К тому же тот лисп берет разность по модулю, то есть, не важно, большую или меньшую отметку кликать первой.
P.S.: Сейчас придет trir и скажет: "Civil 3D!"
skkkk вне форума  
 
Непрочитано 22.10.2016, 13:07
#35
Do$

AutoCAD/Civil3D LISP/C#
 
Регистрация: 15.08.2008
Санкт-Петербург
Сообщений: 1,702
Отправить сообщение для Do$ с помощью Skype™


Цитата:
Сообщение от skkkk Посмотреть сообщение
P.S.: Сейчас придет trir и скажет: "Civil 3D!"
И будет прав
__________________
Толковый выбор приходит с опытом, а к нему приводит выбор бестолковый. (The Mechanic)
Do$ вне форума  
 
Непрочитано 23.10.2016, 16:19
#36
Prodiver

Проектирование газоснабжения
 
Регистрация: 20.10.2016
Сообщений: 2


Добрый вечер всем. Хочу поделится новостью, но все по порядку. Vladimir_Sergeevich, спасибо что откликнулись на просьбу. Попробовал Ваш код на Autocad 2016, к сожалению он не пошел. Команды набираются, а результат в ком. строку не выводится. А вот так случилось, что skkkk меня очень удачно "послал" по ссылке. Там действительно есть практически то, что нужно, только пришлось немного изменить кое что и в итоге все работает именно так как и нужно.Большое спасибо Всем кто помог с темой и авторам программ. Решил выложить то, чем сейчас пользуюсь, может кому пригодиться:

Код:
[Выделить все]
 (defun c:z-calc-text-value_1 (/ value ent obj)
  (vl-load-com)
  (princ
    "\nВыберите текстовые объекты среди которых будет произведененна калькуляция"
  ) ;_ end of princ
  (setq value
  (rtos
    (apply
      '(lambda (a b c) (/ (abs (* (- a b) 1000)) c.))
      (mapcar
        (function
   (lambda (a)
     (atof
       (vl-string-trim
         "%Uu {\\Ll}"
         (vl-string-subst
    "."
    ","
    (mip_MTEXT_Unformat
      (cdr (assoc 1 (entget a)))
    ) ;_Снос форматирования
         ) ;_ vl-string-subst
       ) ;_ vl-string-trim
     ) ;_ atof
   ) ;_ lambda
        ) ;_ function
        (mapcar
   '(lambda (x / obj)
      (princ (strcat "\n" x))
      (while
        (not
   (and (setq obj
        (car (entsel (princ (strcat "\r" x))))
        ) ;_ end of setq
        (vl-string-search "TEXT" (cdr (assoc 0 (entget obj))))
   ) ;_ end of and
        ) ;_ end of not
      ) ;_ end of while
      obj
    ) ;_ end of lambda
   (list
     "Текст А :"
     "Текст B :"
     "Текст C :"
   ) ;_ end of list
        ) ;_ end of mapcar
      ) ;_ mapcar
    ) ;_ apply
  ) ;_ end of rtos
  ) ;_ end of setq
  (if (vl-string-position (ascii ".") value)
    (setq value (vl-string-right-trim ".0" value))
  ) ;_ if
  
Код
(setq value (vl-string-subst "," "." value))
(princ (strcat "\nРезультат = " value))
  (alert (strcat "Результат = " value))
  (setvar "ERRNO" 0)
  (while
    (and (not (setq ent
       (car
         (nentsel
    (strcat
      "\n Выберите текстовый объект для записи значения <Выход>:"
    ) ;_ strcat
         ) ;_ entsel
       ) ;_ car
       ) ;_ setq
  ) ;_ not
  (equal (getvar "ERRNO") 7)
    ) ;_ and
     (setvar "ERRNO" 0)
  ) ;_ while
  (if (and ent
    (vlax-property-available-p
      (setq obj (vlax-ename->vla-object ent))
      'TextString
    ) ;_ vlax-property-available-p
    (vlax-write-enabled-p obj)
      ) ;_ and
    (progn
      (vlax-put-property obj 'TextString value)
      (vla-put-color obj 7) ;_Цвет текста 7
      (vlax-release-object obj)
    ) ;_ progn
  ) ;_ if
  (princ)
  ) ;_ defun
(defun mip_MTEXT_Unformat ( Mtext / text Str )
  (setq Text "")
   (while (/= Mtext "")
        (cond
          ((wcmatch (strcase (setq Str (substr Mtext 1 2))) "\\[\\{}]")
            (setq Mtext (substr Mtext 3) Text   (strcat Text Str)))
          ((wcmatch (substr Mtext 1 1) "[{}]")(setq Mtext (substr Mtext 2)))
          ((wcmatch (strcase (setq Str (substr Mtext 1 2))) "\\[LO`~]")
    (setq Mtext (substr Mtext 3)))
          ((wcmatch (strcase (substr Mtext 1 2)) "\\[ACFHQTW]")
            (setq Mtext (substr Mtext (+ 2 (vl-string-search ";" Mtext)))))
          ((wcmatch (strcase (substr Mtext 1 2)) "\\P")
            (if (or(= " " (substr Text (strlen Text)))
     (= " " (substr Mtext 3 1)))
               (setq Mtext (substr Mtext 3))
               (setq Mtext (substr Mtext 3) Text (strcat Text " "))))
   ((wcmatch (strcase (substr Mtext 1 2)) "\\S")
            (setq Str   (substr Mtext 3 (- (vl-string-search ";" Mtext) 2))
                  Text  (strcat Text (vl-string-translate "#^\\" "/^\\" Str))
                  Mtext (substr Mtext (+ 4 (strlen Str)))))
   (t (setq Text (strcat Text (substr Mtext 1 1)) Mtext (substr Mtext 2)))
   ))
  Text
)

Считает уклон газопровода в промилле и заменяет мтекст с точностью одного знака после запятой.

(vl-load-com)
(defun c:zod65( / oldMode oldMode_2 zod65_mode_zapyatie sum_dlin tek_dlin flag_1 flag_2 flag_3 cc1 cc2 pt_1 pt_2)
(defun Zoderror (msg)
(vl-cmdf)
(vla-EndUndoMark actdoc)
(setq *error* my_error)
(vl-cmdf "Undo" "" )
)
(setq actdoc (vla-get-activedocument(vlax-get-acad-object)))
(vla-startUndoMark actdoc)
(setq 	my_error	*error*
	*error*		Zoderror
)
(if (or(null zod65_mode_1)(null zod65_Uklon))(zod655))
(setq sum_dlin	0.0 tek_dlin 0.0)
(while (null flag_1)
	(if	(setq cc1(car (entsel "\n Укажите текст/мультвыноску/блок")))
		(if	(member (cdr(assoc 0 (entget cc1)))'("TEXT" "MTEXT" "MULTILEADER" "INSERT"))
			(setq flag_1 t)
		)
	)
)
(if	(equal(assoc 0 (entget cc1))'(0 . "INSERT"))
	(setq cc1(mip_MTEXT_Unformat(vla-get-textstring(car(vlax-safearray->list(vlax-variant-value(vla-GetAttributes (vlax-ename->vla-object cc1 ))))))))
	(setq cc1 (mip_MTEXT_Unformat(vla-get-textstring(vlax-ename->vla-object cc1))))
)
(if (vl-string-search "," cc1)
	(progn
		(setq 	zod65_mode_zapyatie T
				cc1(vl-string-subst "." "," cc1)
		)
	)
)
(setq cc1 (atof cc1))
(setq pt_1(getpoint "\n Укажите точку"))
(if (null pt_1) (setq tek_dlin 0.0 sum_dlin 0.0)
			(while (null flag_2)
				(princ (strcat "\n Текущая длина " (rtos (/ sum_dlin 2) 2 2) "  м"))
				(setq pt_2(getpoint "\n Укажите точку" pt_1))
				(if pt_2
					(setq	tek_dlin (DISTANCE pt_2 pt_1) sum_dlin (+ sum_dlin tek_dlin) pt_1 pt_2 tek_dlin 0.0)
					(setq	flag_2 T)
				)
			)
)
(princ (strcat "\n Текущая длина  " (rtos (/ sum_dlin 2) 2 2) "  м"))
(while (null flag_3)
	(if	(setq cc2(car (entsel "\n Укажите текст/мультвыноску/блок")))
		(if	(member (cdr(assoc 0 (entget cc2)))'("TEXT" "MTEXT" "MULTILEADER" "INSERT"))
			(setq flag_3 t)
		)
	)
)
(if (equal zod65_mode_1 "+")
(setq sum_dlin(rtos (+ cc1 (*(/ sum_dlin 2000)zod65_Uklon)) 2 2 ))
(setq sum_dlin(rtos (- cc1 (*(/ sum_dlin 2000)zod65_Uklon)) 2 2 ))
)
(if (vl-string-search "." sum_dlin)
	(cond	((equal 1 (-(strlen sum_dlin)(vl-string-search "." sum_dlin)1)) (setq sum_dlin(strcat sum_dlin "00")))
			((equal 2 (-(strlen sum_dlin)(vl-string-search "." sum_dlin)1)) (setq sum_dlin(strcat sum_dlin "")))
	)
	(setq sum_dlin(strcat sum_dlin ".000"))
)
(if zod65_mode_zapyatie (setq sum_dlin(vl-string-subst "," "."  sum_dlin)))
(if (not(equal "-"(SUBSTR sum_dlin 1 1)))
	(setq sum_dlin(strcat "" sum_dlin))
)
(if	(equal(assoc 0 (entget cc2))'(0 . "INSERT"))
	(vla-put-textstring(car(vlax-safearray->list(vlax-variant-value(vla-GetAttributes (vlax-ename->vla-object cc2 )))))sum_dlin)
	(vla-put-textstring(vlax-ename->vla-object cc2)sum_dlin)
)
)

(defun zod655( / oldMode oldMode_2)
(defun Zoderror (msg)
(vl-cmdf)
(vla-EndUndoMark actdoc)
(setq *error* my_error)
(vl-cmdf "Undo" "" )
)
(setq actdoc (vla-get-activedocument(vlax-get-acad-object)))
(vla-startUndoMark actdoc)
(setq 	my_error	*error*
	*error*		Zoderror
)

(if(not zod65_mode_1)(setq zod65_mode_1 "+"))
	(initget "+ -")
    (setq oldMode zod65_mode_1 
    zod65_mode_1 
     (getkword
       (strcat "\n Выберите [+/-] <" zod65_mode_1 ">: "))
     ); end setq
	 (if(null zod65_mode_1)(setq zod65_mode_1 oldMode))
(if (and zod65_Uklon (not(equal 'str (type zod65_Uklon))))(setq zod65_Uklon(rtos zod65_Uklon 2 2)))
(if(not zod65_Uklon)(setq zod65_Uklon "0.003"))
	(initget (strcat zod65_Uklon  " Input"))
    (setq oldMode_2 zod65_Uklon 
    zod65_Uklon 
     (getkword
       (strcat "\nSpecify mode [" zod65_Uklon "/Input] <" zod65_Uklon ">: "))
     ); end setq
	 (if(null zod65_Uklon)(setq zod65_Uklon oldMode_2))
	 (if(equal zod65_Uklon  "Input")(setq zod65_Uklon (getreal "Input new value")))
	 (if(null zod65_Uklon)(setq zod65_Uklon 0.000))
	 (if (equal 'str (type zod65_Uklon))(setq zod65_Uklon(atof zod65_Uklon)))
)

(defun c:zod655 ( / )(zod655))

;функция mip_MTEXT_Unformat взята http://kpblc.blogspot.com/2007_06_01_archive.html
(defun mip_mtext_unformat (mtext / text str)
  (setq text "")
  (while (/= mtext "")
    (cond
      ((wcmatch (strcase (setq str (substr mtext 1 2))) "\\[\\{}]")
       (setq mtext (substr mtext 3)
             text  (strcat text str)
             ) ;_ end of setq
       )
      ((wcmatch (substr mtext 1 1) "[{}]") (setq mtext (substr mtext 2)))
      ((wcmatch (strcase (setq str (substr mtext 1 2))) "\\[LO`~]")
       (setq mtext (substr mtext 3))
       )
      ((wcmatch (strcase (substr mtext 1 8)) "\\FSYMBOL")
;;;Add VVA remove Symbol
       (setq mtext (substr mtext (+ 2 (vl-string-search "}" mtext))))
       )
      ((wcmatch (strcase (substr mtext 1 2)) "\\[ACFHQTW]")
       (setq mtext (substr mtext (+ 2 (vl-string-search ";" mtext))))
       )
      ((wcmatch (substr mtext 1 3) "\\p[qxicrjd]")
;;;Add and changed by kpblc
       (setq mtext (substr mtext (+ 2 (vl-string-search ";" mtext))))
       )
      ((wcmatch (strcase (substr mtext 1 2)) "\\P")
       (if (or
             (zerop (strlen text))
             (= " " (substr text (strlen text)))
             (= " " (substr mtext 3 1))
             ) ;_ end of or
         (setq mtext (substr mtext 3))
         (setq mtext (substr mtext 3)
               text  (strcat text " ")
               ) ;_ end of setq
         ) ;_ end of if
       )
      ((wcmatch (strcase (substr mtext 1 2)) "\\S")
       (setq str   (substr mtext 3 (- (vl-string-search ";" mtext) 2))
             text  (strcat text (vl-string-translate "#^\\" "/^\\" str))
             mtext (substr mtext (+ 4 (strlen str)))
             ) ;_ end of setq
       )
      (t
       (setq text  (strcat text (substr mtext 1 1))
             mtext (substr mtext 2)
             ) ;_ end of setq
       )
      ) ;_ end of cond
    ) ;_ end of while
  text
  ) ;_ end of defun
  
(princ "\nФайл zod успешно загружен")
Считает отметки в зависимости от уклона и расстояния по горизонтали в масштабе 1:500 с заменой мтекста с точностью два знака после запятой. Если горизонтальный масштаб другой надо подобрать нужное число в строках
(setq sum_dlin(rtos (+ cc1 (*(/ sum_dlin 2000)zod65_Uklon)) 2 2 ))
(setq sum_dlin(rtos (- cc1 (*(/ sum_dlin 2000)zod65_Uklon)) 2 2 ))
(заменить 2000 на другое). Я делал это опытным путем.
Всем удачи.

Последний раз редактировалось Кулик Алексей aka kpblc, 29.05.2020 в 11:51.
Prodiver вне форума  
 
Непрочитано 07.11.2018, 18:18
#37
vladant


 
Регистрация: 14.12.2006
Tula
Сообщений: 23


подниму тему. уважаемый Prodiver писал про уклон в промилле, для себя изменил в мм, но вот что в коде нужно изменить чтобы было округление до тысячных после запятой не смог постичь. прочитал про rtos, но как он здесь работает не пойму...

Код:
[Выделить все]
 (defun c:z-calc-text-value_1 (/ value ent obj)
(vl-load-com)
(princ
"\nВыберите текстовые объекты среди которых будет произведененна калькуляция"
) ;_ end of princ
(setq value
(rtos
(apply
'(lambda (a b c) (/ (abs (* (- a b) 1)) c.))
(mapcar
(function
(lambda (a)
(atof
(vl-string-trim
"%Uu {\\Ll}"
(vl-string-subst
"."
","
(mip_MTEXT_Unformat
(cdr (assoc 1 (entget a)))
) ;_Снос форматирования
) ;_ vl-string-subst
) ;_ vl-string-trim
) ;_ atof
) ;_ lambda
) ;_ function
(mapcar
'(lambda (x / obj)
(princ (strcat "\n" x))
(while
(not
(and (setq obj
(car (entsel (princ (strcat "\r" x))))
) ;_ end of setq
(vl-string-search "TEXT" (cdr (assoc 0 (entget obj))))
) ;_ end of and
) ;_ end of not
) ;_ end of while
obj
) ;_ end of lambda
(list
"Текст А :"
"Текст B :"
"Текст C :"
) ;_ end of list
) ;_ end of mapcar
) ;_ mapcar
) ;_ apply
) ;_ end of rtos
) ;_ end of setq
(if (vl-string-position (ascii ".") value)
(setq value (vl-string-right-trim ".0" value))
) ;_ if

Код
(setq value (vl-string-subst "," "." value))
(princ (strcat "\nРезультат = " value))
(alert (strcat "Результат = " value))
(setvar "ERRNO" 0)
(while
(and (not (setq ent
(car
(nentsel
(strcat
"\n Выберите текстовый объект для записи значения <Выход>:"
) ;_ strcat
) ;_ entsel
) ;_ car
) ;_ setq
) ;_ not
(equal (getvar "ERRNO") 7)
) ;_ and
(setvar "ERRNO" 0)
) ;_ while
(if (and ent
(vlax-property-available-p
(setq obj (vlax-ename->vla-object ent))
'TextString
) ;_ vlax-property-available-p
(vlax-write-enabled-p obj)
) ;_ and
(progn
(vlax-put-property obj 'TextString value)
(vla-put-color obj 7) ;_Цвет текста 7
(vlax-release-object obj)
) ;_ progn
) ;_ if
(princ)
) ;_ defun
(defun mip_MTEXT_Unformat ( Mtext / text Str )
(setq Text "")
(while (/= Mtext "")
(cond
((wcmatch (strcase (setq Str (substr Mtext 1 2))) "\\[\\{}]")
(setq Mtext (substr Mtext 3) Text (strcat Text Str)))
((wcmatch (substr Mtext 1 1) "[{}]")(setq Mtext (substr Mtext 2)))
((wcmatch (strcase (setq Str (substr Mtext 1 2))) "\\[LO`~]")
(setq Mtext (substr Mtext 3)))
((wcmatch (strcase (substr Mtext 1 2)) "\\[ACFHQTW]")
(setq Mtext (substr Mtext (+ 2 (vl-string-search ";" Mtext)))))
((wcmatch (strcase (substr Mtext 1 2)) "\\P")
(if (or(= " " (substr Text (strlen Text)))
(= " " (substr Mtext 3 1)))
(setq Mtext (substr Mtext 3))
(setq Mtext (substr Mtext 3) Text (strcat Text " "))))
((wcmatch (strcase (substr Mtext 1 2)) "\\S")
(setq Str (substr Mtext 3 (- (vl-string-search ";" Mtext) 2))
Text (strcat Text (vl-string-translate "#^\\" "/^\\" Str))
Mtext (substr Mtext (+ 4 (strlen Str)))))
(t (setq Text (strcat Text (substr Mtext 1 1)) Mtext (substr Mtext 2)))
))
Text
)
сильно не пинать, чукча учиться только

Последний раз редактировалось Кулик Алексей aka kpblc, 29.05.2020 в 11:51.
vladant вне форума  
 
Непрочитано 08.11.2018, 03:09
#38
1958


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


Цитата:
Сообщение от vladant Посмотреть сообщение
прочитал про rtos, но как он здесь работает не пойму...
Найдите:
Код:
[Выделить все]
        ) ;_ end of rtos
и замените на:
Код:
[Выделить все]
 2 3) ;_ end of rtos
3 - это количество разрядов после запятой
1958 вне форума  
 
Непрочитано 29.05.2020, 11:25
#39
iSpawn


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


дабы не плодить темы спрошу тут. Нужен ЛИСП для расчёта угла падения угольных пластов, т.е. нужно вместо промилле чтоб выводило градусы.
iSpawn вне форума  
 
Непрочитано 29.05.2020, 13:19
#40
Krieger

инженер (КМ)
 
Регистрация: 30.10.2004
Красноярск
Сообщений: 3,825


Цитата:
Сообщение от iSpawn Посмотреть сообщение
дабы не плодить темы спрошу тут. Нужен ЛИСП для расчёта угла падения угольных пластов, т.е. нужно вместо промилле чтоб выводило градусы.
Лови:
Код:
[Выделить все]
(defun ppm->grd (ppm)
  (/ (* (atan (/ ppm 1000)) 180) pi)
	 )
__________________
Делай хорошо, плохо само получится.
Krieger вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Нужен лисп, который высчитывает уклон линии

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

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