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

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Копирование данных для спецификаций из выносок СПДС в таблицу из мтекстов

Копирование данных для спецификаций из выносок СПДС в таблицу из мтекстов

Ответ
Перейти к новому Перейти к новому  
Поиск в этой теме
Непрочитано 23.09.2008, 22:49 #1
Копирование данных для спецификаций из выносок СПДС в таблицу из мтекстов
Red Nova
 
ՃԱՐՏԱՐԱԳԵՏ, Տ.Գ.Թ.
 
Торонто
Регистрация: 23.10.2007
Сообщений: 1,974
Если кто еще не знает, то тут VVA по моей просьбе создал программу для подсчета масс в спецификациях из мтекстов. Программой я очень доволен, все не нарадуюсь. Но как говорится аппетит приходит во время еды. И теперь хотелось бы пойти еще дальше и автоматизировать создание самой спецификации (которую уже потом можно рассчитывать лиспом от VVA). Ведь по большей части на чертеже всегда присутствуют выноски в которых уже есть информация по спецификации, или хотя бы ее часть. Что если одной командой собрать всю информацию из выносок и вписать в шаблон спецификации.
Суть такова.
Я пользуюсь СПДС. Для маркировки позиций использую выноски СПДС. Выноски СПДС имеют две строки, в верхней пишется номер позиции, в нижней данные о профиле.
Предполагаемый лисп должен выбирать все позиционные выноски СПДС имеющиеся в файле (можно и выбрать рамкой часть файла), создавать список из двух столбцов (номер позиции и профиль), затем многократно фильтровать ненужные данные и дублирующие позиции. Полученный список упорядочивается. Затем рамкой выбирается шаблон для спецификации (напомню он из мтекстов), в выбранные строки вписываются данные из упорядоченного списка.

Теперь попробую на конкретном файле объяснить алгоритм более подробно.
Запускаем лисп, создается список с данными из выносок. Затем фильтруем мусор. Для этого надо сперва ввести в лисп пояснение – как выбрать полезные выноски. Дадим определение пригодных для спецификации выносок.
Они должны удовлетворять следующим пунктам.
1. Обе строки выноски содержат информацию.
2. Верхняя строка выноски должна содержать информацию нумерационного характера, нумерация отсчитывается по цифрам и по буквам латинского и русского алфавитов. Можно использовать знак ‘ и “. Допускаемые записи могут иметь такой вид – 1, 2, 3, 4, // а, б, в, г, // a, b, c, d, // 1a, 1b, 1c, // 1, 1’, 1”, 2, 2’ // a1, a2, a3, b, b1, ... (Впрочем для первого приближения можно оставить только 1, 2, 3, 4)
3. Нижняя строка должна начинаться на определенные символы, вот их список
- Знак “-”, слова “Лист” и “Полоса”
- Слово “Труба”, “Тр.” и знак трубы из шрифтов СПДС
- Слово “Уголок” и аналогичные символы из шрифтов СПДС
- Слово “Двутавр” и аналогичные символы из шрифтов СПДС
- Слово “Швеллер” и аналогичные символы из шрифтов СПДС
- Слово “Фланец”, то же “Фл.”
- Стандартный знак диаметра и знак диаметра из шрифтов СПДС
4. Есть и другие критерии, но о них пока не стоит говорить.

Теперь необходимо отсеять дублирующие позиции, но делать это надо так, чтобы отсеять менее информативные выноски. Скажем имеем две выноски первая строка которых имеет тот же номер, а втора строка различается, предположим вотрые строки имеют следующее содержание:
“Тр. Ø89х3.5, L=2500”
“Тр. Ø89х3.5”
Из этих строк выбирается первая, как более информативная, вторая отбрасывается. Если по проще, то для дальнейших действий берем выноску с более длинной второй строкой.

Поскольку информация о профиле вписывается в двух столбцах (Профиль отдельно, длина отдельно) то нам теперь нам надо определится с ними.
Предположим верхняя строка выноски содержит цифру 25. Если нижняя строка выноски не содержит запятых, (на пример “Тр. Ø89х3.5”) то считаем что выноска не несет информацию о длине профиля, тогда в списке соответствующая строка записывается как
(25, Тр. Ø89х3.5, -). Если же запятая есть (на пример “Тр. 89х3.5, L=2500”) То считаем что выноска несет информацию о длине профиля, тогда в списке соответствующая строка записывается как (25, Тр. 89х3.5, L=2500). Если выноска содержит две и более запятых, (на пример “Тр. Ø89х3.5, L=2500, шаг 200”) то отбрасываем информацию идущую после второй запятой.
Далее упорядочиваем список (по номерам позиций).
Если все прошло как планировалось, то применительно к файлу примера список будет такой.
(1, -10х100x100, -)
(2, Тр. Ø89х3.5, L=2500)
(3, “знак уголка шрифта СПДС”75х5, L=800)
(4, “знак двутавра шрифта СПДС”20, -)
(5, “знак швеллера шрифта СПДС”12, L=960)
(6, Ø12 А500c, ΣL=24000)
(7, Ø20 А500c, L=980)

В спецификации есть также столбик с ГОСТ-ом. Чтобы он вписывался автоматически для каждого профиля надо заранее определится с ГОСТ-ом, и записать его в лисп. Так в нашем примере нужно записать следующие госты
Если обозначение профиля начинается на символ “-”, слово “Лист” то это соответствует ГОСТу “ГОСТ 19903-74”
Если обозначение профиля начинается на слова “Труба”или “Тр.” то это соответствует ГОСТу “ГОСТ 10704-91”
Если обозначение профиля начинается на cлово “Уголок” или аналогичные символы из шрифтов СПДС то это соответствует ГОСТу “ГОСТ 8509-93”
Если обозначение профиля начинается на cлово “Двутавр” или аналогичные символы из шрифтов СПДС
то это соответствует ГОСТу “ГОСТ 8239-89”
Если обозначение профиля начинается на слово “Швеллер” или аналогичные символы из шрифтов СПДС
то это соответствует “ГОСТ 8240-97”
Если обозначение профиля начинается на стандартный знак диаметра и знак диаметра из шрифтов СПДС то это соответствует ГОСТу “ГОСТ 5781-82”

Итак добавив ГОСТы к спискам они должны стать такими:
(ГОСТ 19903-74, 1, -10х100x100, -)
(ГОСТ 10704-91, 2, Тр. Ø89х3.5, L=2500)
(ГОСТ 8509-93, 3, “знак уголка шрифта СПДС”75х5, L=800)
(ГОСТ 8239-89, 4, “знак двутавра шрифта СПДС”20, -)
(ГОСТ 8240-97, 5, “знак швеллера шрифта СПДС”12, L=960)
(ГОСТ 5781-82, 6, Ø12 А500c, ΣL=24000)
(ГОСТ 5781-82, 7, Ø20 А500c, L=980)

Формирование списка законченно. Теперь нужно рамкой отметить шаблон спецификации, в которой 4 столбца и n-ное количество строк. Данные их списка вписываются в мтексы спецификации как указанно в файле примера. Если строк выбрано больше чем у списка, то в мтексты лишних строк вписываются символы ###, если строк выбрано меньше чем у списка, то выходит сообщение об ошибке.

Ну вот и все. Больно длинно у меня получилось для первых объяснений. Если вы дошли до этого предложения, то у вас железное терпение. Надеюсь что кому-то эта белиберда покажется интересной.

В конце скажу что крыс сделал первый шаг, и создал лисп формирующий список их строк выносок СПДС. Вот он.


Код:
[Выделить все] 
(defun c:get-notes-activex (/ adoc lst)
;; Через ActiveX
  (vl-load-com)
  (vla-startundomark
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
    ) ;_ end of vla-StartUndoMark
  (vlax-for ent (vla-get-modelspace adoc)
    (if (= (vla-get-objectname ent) "mcsDbObjectNotePosition")
      (setq lst (cons ent lst))
      ) ;_ end of if
    ) ;_ end of vlax-for
  ;; Теперь делай со списком чего хотишь
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun

(defun c:get-notes-ent (/ adoc lst _dwgru-conv-pickset-to-list)
;; Через ent*

  (defun _dwgru-conv-pickset-to-list (value / tab item)
    (repeat (setq tab  nil
                  item (sslength value)
                  ) ;_ end setq
      (setq tab (cons (ssname value (setq item (1- item))) tab))
      ) ;_ end repeat
    ) ;_ end defun

  (vl-load-com)
  (vla-startundomark
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
    ) ;_ end of vla-StartUndoMark
  (setq lst (vl-remove-if-not
              '(lambda (x) (= (cdr (assoc 0 (entget x))) "spdsNotePosition"))
              (_dwgru-conv-pickset-to-list (ssget "_X"))
              ) ;_ end of vl-remove-if-not
        ) ;_ end of setq
  ;; Теперь делай со списком чего хотишь
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun

Вложения
Тип файла: dwg
DWG 2004		 Выноски СПДС.dwg (76.0 Кб, 10208 просмотров)

__________________
Блог
Просмотров: 37061
 
Непрочитано 23.09.2008, 23:27
#2
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 36,746

Я разбирался только с узловыми выносками, и там добраться до текста (если рассматривать только lsp) можно только через ent*-методы. Остальные элементы не ковырял.
По идее получить данные о первой и второй строк указанной выноски можно так:
Код:
[Выделить все] 
(setq obj (car (entsel))) (mapcar 'cdr (vl-remove-if-not '(LAMBDA(x)(=(car x) 300))(member '(301 . "Первая строка") (entget obj))))
---
Добавлено:
Расписывать логику лениво, хватай код:
Код:
[Выделить все] 
(defun test (/ selset lst)

  (defun _dwgru-conv-pickset-to-list (value / tab item)
    (repeat (setq tab  nil
                  item (sslength value)
                  ) ;_ end setq
      (setq tab (cons (ssname value (setq item (1- item))) tab))
      ) ;_ end repeat
    ) ;_ end defun

  (if
    (and (setq selset (ssget))
         (setq
           selset (vl-remove-if-not
                    (function (lambda (x)
                                (= (cdr (assoc 0 (entget x))) "spdsNotePosition")
                                ) ;_ end of LAMBDA
                              ) ;_ end of function
                    (_dwgru-conv-pickset-to-list selset)
                    ) ;_ end of vl-remove-if-not
           ) ;_ end of setq
         ) ;_ end of and
     (setq
       lst
        (vl-sort
          (vl-remove-if
            (function
              (lambda (a)
                (= (cadr a) "")
                ) ;_ end of lambda
              ) ;_ end of function
            (mapcar (function
                      (lambda (obj)
                        (mapcar (function cdr)
                                (vl-remove-if-not
                                  (function
                                    (lambda (x)
                                      (= (car x) 300)
                                      ) ;_ end of lambda
                                    ) ;_ end of function
                                  (member '(301 . "Первая строка") (entget obj))
                                  ) ;_ end of vl-remove-if-not
                                ) ;_ end of mapcar
                        ) ;_ end of LAMBDA
                      ) ;_ end of function
                    selset
                    ) ;_ end of mapcar
            ) ;_ end of vl-remove-if
          (function (lambda (a b) (< (car a) (car b))))
          ) ;_ end of vl-sort
       ) ;_ end of setq
     ) ;_ end of if
  lst
  ) ;_ end of defun
Одно "но". Этот вариант больше подходит для обработки блоков и внешних ссылок, т.к. СПДС их не обрабатывает. А для текущего файла можно попробовать использовать таблицы СПДС и программирование в них.
И еще. Тут критичным является код, выделенный полужирным. Если разработчики в одной из следующих версий поменяют DXF-представление своих примитивов (а кто им запретит?), код станет нерабочим.
P.S. Естественно, СПДС-ка должна быть загружена. Для варианта загрузки только ObjectEnabler'a не проверял.
__________________

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Последний раз редактировалось Кулик Алексей aka kpblc, 23.09.2008 в 23:36.
Кулик Алексей aka kpblc вне форума  
 
Автор темы   Непрочитано 24.09.2008, 10:06
#3
Red Nova

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

Кулик Алексей aka kpblc,
Спасибо, список из содержаний позиционных выносок создается. А можно включить в выбор кроме позиционных выносок еще и гребенчатые и цепные выноски?
__________________
Блог
Red Nova вне форума  
 
Непрочитано 24.09.2008, 10:13
#4
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 36,746

Наверное, можно. Но как там разбираться с количеством стрелок - пока не знаю (ковырять надо)
__________________

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 24.09.2008, 10:27
#5
DEM

YngIngKllr
 
Регистрация: 29.03.2005
СПб
Сообщений: 12,783

Вообще то тут вроде
(301 . "Количество линий-выносок") (90 . 4))
__________________
Шаг 12й......
Мои публикации
DEM вне форума  
 
Автор темы   Непрочитано 24.09.2008, 10:31
#6
Red Nova

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

Кулик Алексей aka kpblc,
А зачем разбираться с количеством стрелок? Нам надо только прочитать содержание верхней и нежней строки и добавить их в список.
__________________
Блог
Red Nova вне форума  
 
Непрочитано 24.09.2008, 10:31
#7
DEM

YngIngKllr
 
Регистрация: 29.03.2005
СПб
Сообщений: 12,783

Только тут конечно вопрос следующий
Выполнять ли автоматическое изменение спецификации или только при выполнении команды.
Часть объектов по любому выносками не обозначаем, как быть с их подсчетом.
В общем ньюансов много, сам пользуюсь PS-конструкции для этого дела, но тоже пока система не доработана.
Самому лезть и корректировать что то нету возможности ни времени ни возможности т.к. все файлы уже с компилированы, да и OBJECT-ARX технологиями не владею.
__________________
Шаг 12й......
Мои публикации
DEM вне форума  
 
Непрочитано 24.09.2008, 10:41
#8
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 36,746

Цитата:
Сообщение от Red Nova Посмотреть сообщение
Кулик Алексей aka kpblc,
А зачем разбираться с количеством стрелок? Нам надо только прочитать содержание верхней и нежней строки и добавить их в список.
Как зачем? А подсчет ты не планируешь выполнять?
__________________

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Автор темы   Непрочитано 24.09.2008, 10:43
#9
Red Nova

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

DEM,
Цитата:
Выполнять ли автоматическое изменение спецификации или только при выполнении команды.
Тут все ясно. Только при выполнении команды, так как некие выноски могут быть просто удалены и заменены другими.
Цитата:
Часть объектов по любому выносками не обозначаем, как быть с их подсчетом.
В первом посте я писал про фильтрацию неподходящих выносок.
Цитата:
Выноски должны удовлетворять следующим пунктам.
1. Обе строки выноски содержат информацию.
2. Верхняя строка выноски должна содержать информацию нумерационного характера, нумерация отсчитывается по цифрам и по буквам латинского и русского алфавитов. Можно использовать знак ‘ и “. Допускаемые записи могут иметь такой вид – 1, 2, 3, 4, // а, б, в, г, // a, b, c, d, // 1a, 1b, 1c, // 1, 1’, 1”, 2, 2’ // a1, a2, a3, b, b1, ... (Впрочем для первого приближения можно оставить только 1, 2, 3, 4)
3. Нижняя строка должна начинаться на определенные символы, вот их список
- Знак “-”, слова “Лист” и “Полоса”
- Слово “Труба”, “Тр.” и знак трубы из шрифтов СПДС
- Слово “Уголок” и аналогичные символы из шрифтов СПДС
- Слово “Двутавр” и аналогичные символы из шрифтов СПДС
- Слово “Швеллер” и аналогичные символы из шрифтов СПДС
- Слово “Фланец”, то же “Фл.”
- Стандартный знак диаметра и знак диаметра из шрифтов СПДС
4. Есть и другие критерии, но о них пока не стоит говорить.
__________________
Блог
Red Nova вне форума  
 
Автор темы   Непрочитано 24.09.2008, 10:48
#10
Red Nova

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

Кулик Алексей aka kpblc,
Посмотри файл прикрепленный в первом посте (отмечено желтой рамкой). Искомый лисп должен заполнять только строки спецификации которые содержат информацию о профиле (Номер позиции, ГОСТ, Профиль, Длина). Графу количество заполнять не требуется, это уже надо вручную, иначе больно муторно. Расчет спецификации выполняется далее лиспом от VVA
__________________
Блог
Red Nova вне форума  
 
Непрочитано 24.09.2008, 10:51
#11
DEM

YngIngKllr
 
Регистрация: 29.03.2005
СПб
Сообщений: 12,783

Red Nova
Я говорбю про необозначенные объекты, ты ведь не все будешь на чертеже обозначать.
__________________
Шаг 12й......
Мои публикации
DEM вне форума  
 
Автор темы   Непрочитано 24.09.2008, 11:00
#12
Red Nova

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

DEM,
Ну так это по старинке, ручками, но опыт показывает что почти все отображено в выносках.
__________________
Блог
Red Nova вне форума  
 
Непрочитано 24.09.2008, 11:07
#13
DEM

YngIngKllr
 
Регистрация: 29.03.2005
СПб
Сообщений: 12,783

Ну тогда вопрос следующего плана для работы с какой частью проекта тебе это надо КМ или КЖ.
А то может проще PS -конструкции использовать.
__________________
Шаг 12й......
Мои публикации
DEM вне форума  
 
Автор темы   Непрочитано 24.09.2008, 11:28
#14
Red Nova

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

В общем больше для КМ, но и для КЖ без проблем пойдет. PS я как-то ставил. Тогда интересного мало нашел. Правда спецификации не смотрел.
__________________
Блог
Red Nova вне форума  
 
Непрочитано 24.09.2008, 12:17
#15
DEM

YngIngKllr
 
Регистрация: 29.03.2005
СПб
Сообщений: 12,783

В общем вот что можно делать с помощью PS-конструкции.
По хорошему можно еще по копаться в файлах настроек, и сделать более оптимальным заполнение спецификаций.
Почти тоже самое можно делать с помощью СПДС, только использовать объектов СПДС, как мне кажется сбор информации с четежа с помощью выносок несколько не корректен, т.к. не не всегда все обозначаем.
Лучше построить систему на блоках и объектах СПДС или же PS-конструкции.
Вложения
Тип файла: dwg
DWG 2004		 Пример.dwg (82.6 Кб, 4786 просмотров)
__________________
Шаг 12й......
Мои публикации
DEM вне форума  
 
Автор темы   Непрочитано 24.09.2008, 13:36
#16
Red Nova

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

DEM,
Дойдут руки поставлю PS еще раз. Но меня в общем вполне устаревает лисп от VVA для расчета спецификаций.
Цитата:
использовать объектов СПДС, как мне кажется сбор информации с четежа с помощью выносок несколько не корректен, т.к. не не всегда все обозначаем.
Смысл в том чтобы не проделывать одну и ту же работу дважды. Если уже обозначил позиции в выносках, то почему бы не скопировать эту информацию в спецификацию одной командой? Если же некоторые позиции пропущены, то так или иначе придется один раз их заполнить. Эти позиции можно добавить в спецификацию вручную. А выноски СПДС просто очень удобны для проставления позиций. Идея с блоками реализована в VetCAD, но эти блоки менее удобны чем выноски СПДС.
Если удастся создать корректный алгоритм фильтрации для выносок СПДС, то проблем не вижу. Просто делая проект надо помнить, что далее все выноски будут обработаны лиспом, а значит при проставлении выносок позиций надо следовать некоторым правилам.
P.S. Я долго искал, но так и не нашел в СПДС возможности рассчитывать массы спецификаций. Может я что-то пропустил?
__________________
Блог
Red Nova вне форума  
 
Непрочитано 24.09.2008, 14:40
#17
DEM

YngIngKllr
 
Регистрация: 29.03.2005
СПб
Сообщений: 12,783

Red Nova
ВСе равно по моему мнению данный путь несколько тупиковый, все таки использование объектов более целесообразно, их просто проще подсчитать.
__________________
Шаг 12й......
Мои публикации
DEM вне форума  
 
Автор темы   Непрочитано 24.09.2008, 16:04
#18
Red Nova

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

kpblc,
Получается включить в набор гребенчатые и цепные выноски? Как у тебя со свободным временем. Надеюсь я не очень тебе мешаю своими просьбами?
DEM, А по моему наоборот. Выноски СПДС по любому удобнее использовать чем блоки. А подсчитать и их можно.
__________________
Блог
Red Nova вне форума  
 
Непрочитано 24.09.2008, 16:23
#19
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 36,746

Red Nova, у меня просто сейчас шансов нет заняться (ADT, собака, никак не сдается - надо его выдрессировать).
__________________

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Автор темы   Непрочитано 24.09.2008, 17:12
#20
Red Nova

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

крыс
Обломался...
Может если подожду свободное время у тебя все же появится? Ато аппетит то уже проснулся.
__________________
Блог
Red Nova вне форума  
 
Непрочитано 24.09.2008, 19:43
#21
DEM

YngIngKllr
 
Регистрация: 29.03.2005
СПб
Сообщений: 12,783

Цитата:
Сообщение от Red Nova Посмотреть сообщение
крыс
Обломался...
Может если подожду свободное время у тебя все же появится? Ато аппетит то уже проснулся.
А ты что думаешь стандартными средствами СПДС-ки это нельзя сделать??
Скоро примерчик будет тебе(только не от меня)
__________________
Шаг 12й......
Мои публикации
DEM вне форума  
 
Автор темы   Непрочитано 25.09.2008, 09:21
#22
Red Nova

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

крыс
Когда руки дойдут добавь пожалуйста возможность захватывать кроме позиционных еще гребенчатые и цепные выноски. А дальше я попытаюсь сам с фильтрами разобраться в топике Научите лиспу на примере (или как kpblc, VVA и компания пытаются обучить чайника лиспу)
__________________
Блог
Red Nova вне форума  
 
Непрочитано 01.10.2008, 18:45
#23
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

Red Nova, чувствуется веткадом начало веять
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Автор темы   Непрочитано 01.10.2008, 18:55
#24
Red Nova

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

Есть кординальные различия. Но о них позже, когда лисп будет готов. Кстати, создание лиспа продолжилась по ссылке с #22.
__________________
Блог
Red Nova вне форума  
 
Непрочитано 01.10.2008, 22:47
#25
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 36,746

"Продолжилось" - мягко сказано...
__________________

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Автор темы   Непрочитано 02.10.2008, 19:18
#26
Red Nova

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

Дай бог до конца дойти.
__________________
Блог
Red Nova вне форума  
 
Автор темы   Непрочитано 07.10.2008, 10:17
#27
Red Nova

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

Получилось так, что тема продолжила развиваться в топике Научите лиспу на примере (или как kpblc, VVA и компания пытаются обучить чайника лиспу), там разработка заняла 8 листов, и по ходу дела в не поучаствовали многие программисты. Лисп пока ней закончен, но чтобы не забивать указанную тему лишней информацией было решено все же вернуть дальнейшие действия сюда.

Тут я приведу ссылки на самые важные посты, которые пригодятся далее.
Код от kpblc, для преобразования выносок СПДС в список.#472
Код для упорядочивания списков от VVA#518
И последняя версия главного лиспа, который фильтрует и видоизменяет список полученный кодом от kpblc, который разработал CB#544

На данный момент этот лисп позволяет получить такой список.
Код:
[Выделить все] 
(("1" "-10х100x100" "-") ("2" "Швеллер 12" "L=1000") ("8" "Полоса -4х50" 
"L=1000") ("14" "Уголок 75х5" "L="))
Последним шагом перед введением этой информации в спецификацию должно быть добавление информации о ГОСТе профилей. Алгоритм указан тут
__________________
Блог
Red Nova вне форума  
 
Непрочитано 07.10.2008, 13:40
#28
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

>Red Nova
Я смотрю ты заскучал, хотя и говорил
Цитата:
...буду пробовать. Ждите вопросов...
1. Для начала нужно создать ассоциативный список. Я начинаю - ты заканчиваешь.
Код:
[Выделить все] 
(apply 'append
       (mapcar
         '(lambda (x y)
            (mapcar
              '(lambda (z)
                 (cons z y)
               ) ;_ end of lambda
              x
            ) ;_ end of mapcar
          ) ;_ end of lambda
         (list '("Лист -" "Лист-" "Фл")
               '("Лист чечевица" "Лист ромб")
               '("-")
               '("Полоса")
               '("Уголок")
;;;продолжение здесь
         ) ;_ end of list
         (list "ГОСТ 19903-74"
               "ГОСТ 8568-77"
               '("ГОСТ 19903-74" "ГОСТ 103-76")
               "ГОСТ 103-76"
               '("ГОСТ 8509-93" "ГОСТ 8510-86")
;;;продолжение здесь
         ) ;_ end of list
       ) ;_ end of mapcar
) ;_ end of apply
CB вне форума  
 
Автор темы   Непрочитано 07.10.2008, 13:50
#29
Red Nova

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

CB,
Я планировал дома разобрать. На работе никак дел не поубавиться. Чтобы ответить осмысленно вечером все обмозгую.
Хотя уже знаю, что будут проблеммы с этим
Цитата:
ГОСТ 19903-74 соответствует профилям начинающимся на символы “-”, “лист -”, “лист-”, “Фл”, Причем если профиль начинается на “-”, то должно проверяться условие, что третья строка подсписка содержит только “-”, если она содержат что-то другое, то это другой гост, о нем далее.

ГОСТ 103-76 соответствует профилям начинающимся на символы “-”, “Полоса”, сюда для символа “-” попадают все позиции не вошедши в предыдущий гост.
К примеру
("1" "-10х100x100" "-") ("2" "-5х50" "L=1000")
("ГОСТ 19903-74" "1" "-10х100x100" "-") ("ГОСТ 103-76" "2" "-5х50" "L=1000")
и с этим
Цитата:
ГОСТ 8509-93 соответствует профилям начинающимся на “Уголок”, “\\U+E720”, и содержащим далее в тексте только один символ “х” (В англ и рус правописании)

ГОСТ 8510-86 соответствует профилям начинающимся на “Уголок”, “\\U+E720”, и содержащим далее в тексте два символа “х” (В англ и рус правописании)
К примеру
("1" "Уголок 75х5" "-") ("2" "Уголок 80х50х5" "-")
Станет
("ГОСТ 8509-93" "1" "Уголок 75х5" "-") ("ГОСТ 8510-86" "2" "Уголок 80х50х5" "-")
__________________
Блог
Red Nova вне форума  
 
Автор темы   Непрочитано 07.10.2008, 21:09
#30
Red Nova

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

CB,
Блин. Уже полтора часа бъюсь об стенку и все не пойму как работает лямбда внутри лямбды. Хотя по отдельности все функции понемаю.
__________________
Блог
Red Nova вне форума  
 
Непрочитано 08.10.2008, 00:16
#31
Sleekka

-
 
Регистрация: 24.07.2005
Москва
Сообщений: 1,455

Цитата:
Блин. Уже полтора часа бъюсь об стенку и все не пойму как работает лямбда внутри лямбды. Хотя по отдельности все функции понемаю.
Цикл в цикле когда нибудь запускал? если нет, то полтора часа - это мало - надо больше.
Sleekka вне форума  
 
Непрочитано 08.10.2008, 17:20
#32
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,799
<phrase 1= Отправить сообщение для VVA с помощью Skype™

Выделили цветом, должно стать понятнее
Код:
[Выделить все] 
(apply 'append
       (mapcar
         '(lambda (x y)
            (mapcar
              '(lambda (z)
                 (if (listp y)
                   (append (list z) y)
                   (list z y)
                 ) ;_ end of if
               ) ;_ end of lambda
              x
            ) ;_ end of mapcar
          ) ;_ end of lambda
         (list '("Лист -" "Лист-" "Фл")          ;;; 1
               '("Лист чечевица" "Лист ромб")    ;;; 2
               '("-")                            ;;; 3
               '("Полоса")                       ;;; 4
               '("Уголок")                       ;;; 5
;;;продолжение здесь
) ;_ end of list
         (list "ГОСТ 19903-74"                   ;;; 1
               "ГОСТ 8568-77"                    ;;; 2
               '("ГОСТ 19903-74" "ГОСТ 103-76")  ;;; 3
               "ГОСТ 103-76"                     ;;; 4
               '("ГОСТ 8509-93" "ГОСТ 8510-86")  ;;; 5
;;;продолжение здесь
) ;_ end of list
 ;_ end of list
       ) ;_ end of mapcar
) ;_ end of apply
Возьмем к примеру первые элементы двух списков
("Лист -" "Лист-" "Фл") ;;; 1
"ГОСТ 19903-74" ;;; 1
Тогда для '(lambda (x y)
x=("Лист -" "Лист-" "Фл") ;;; 1
y="ГОСТ 19903-74" ;;; 1
Заметь, что элементы 1-го списка - списки
Для (lambda (z) поочередно подставляются элементы x, т.е.
z= "Лист -"
z= "Лист-"
z= "Фл"
и все они собираются в список с y, т.е. "ГОСТ 19903-74"
Получаем список из элементов
("Лист -" "ГОСТ 19903-74")
("Лист-" "ГОСТ 19903-74")
("Фл" "ГОСТ 19903-74")
Внес в код небольшую модификацию для получения однородного списка (раньше мог быть список или точечная пара). Изменения выделил жирным

В общем весь этот код сводится с получению этого списка
Код:
[Выделить все] 
(setq lst '(
            ("Лист -" "ГОСТ 19903-74")
            ("Лист-" "ГОСТ 19903-74")
            ("Фл" "ГОСТ 19903-74")
            ("Лист чечевица" "ГОСТ 8568-77")
            ("Лист ромб" "ГОСТ 8568-77")
            ("-" "ГОСТ 19903-74" "ГОСТ 103-76")
            ("Полоса" "ГОСТ 103-76")
            ("Уголок" "ГОСТ 8509-93" "ГОСТ 8510-86")
            ;;;Добавляй сюда списки
           )
) ;_ end of setq
__________________
Как использовать код на Лиспе читаем здесь
VVA на форуме  
 
Автор темы   Непрочитано 08.10.2008, 20:18
#33
Red Nova

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

VVA,
Спасибо. Теперь понял. Тогда, продолжив этот список для всех гостов, получим
Код:
[Выделить все] 
(apply 'append
       (mapcar
         '(lambda (x y)
            (mapcar
              '(lambda (z)
                 (if (listp y)
                   (append (list z) y)
                   (list z y)
                 ) ;_ end of if
               ) ;_ end of lambda
              x
            ) ;_ end of mapcar
          ) ;_ end of lambda
         (list '("Лист -" "Лист-" "Фл")          
               '("Лист чечевица" "Лист ромб")    
               '("-")                            
               '("Полоса")                       
               '("Уголок" "\\U+E720") 
               '("\\U+E72E")                         
               '("Тр" "Tp" "Тp" "Tр")  
               '("Двутавр" "\\U+E729")     
               '("Швеллер" "\\U+E725")     
               '("%%c" "\\U+E712")     
;;;продолжение здесь 
) ;_ end of list
         (list "ГОСТ 19903-74"                   
               "ГОСТ 8568-77"                    
               '("ГОСТ 19903-74" "ГОСТ 103-76")  
               "ГОСТ 103-76"                     
               '("ГОСТ 8509-93" "ГОСТ 8510-86") 
               "ГОСТ 30245-03"  
               "ГОСТ 10704-91"  
               "ГОСТ 8239-89"  
               "ГОСТ 8240-97"  
               "ГОСТ 5781-82"  
;;;продолжение здесь
) ;_ end of list
 ;_ end of list
       ) ;_ end of mapcar
) ;_ end of apply
А что делать дальше?
__________________
Блог
Red Nova вне форума  
 
Непрочитано 08.10.2008, 23:37
#34
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

>Red Nova
Весь день был в командировке, так что к машине добрался только сейчас... VVA объяснил работу кода очень доступно и понятно, правда
Цитата:
небольшая модификация для получения однородного списка
совсем не обязательна. Какая разница для получения второго элемента - либо cdr для списка точечная пара, либо cаdr для простого списка? Зато вместо одной ф-ии cond применяются две, причем одна из них медленная...
Списки ты составил почти правильно, даже нашел засаду для подсписка '("Уголок"), которую я специально устроил... Правда есть и одна неточность, про которую ты наверняка не мог знать. Это подсписок '("Тр" "Tp" "Тp" "Tр"). Я понимаю , что ты хотел решить проблему, что слово Тр может быть написано и русскими буквами и английскими, но:
во-первых - зту проблему нужно было решать раньше, т.к. если в слове Тр будет хоть одна английская буква, список отфильтруется на этапе фильтрации;
во-вторых эта проблема легко решается с помощью функции
Код:
[Выделить все] 
(vl-string-translate "Tp" "Тр" тестируемая строка)
Здесь первая "Tp" - символы которые надо заменить (т.е. написанные по английски), вторая "Tp" - символы на которые надо заменить (т.е. на русские), причем первый символ первого теста должен соответствавать первому символ второго теста, второй - второму и т.д. В итоге на выходе ф-ции будет всегда слово Тр на русском языке. Именно оно и должно быть в подсписке.
Теперь продолжаем.
Попробуй сделать сам следующее
1. Создаем глобальную переменную
Код:
[Выделить все] 
(setq lst '(("1" "-10х100x100" "-")
            ("3" "Уголок 75х5" "-")
            ("5" "Лист ромб -10х100x300" "-")
            ("9" "Полоса -4х50" "U+03A3L=10000")
           )
) ;_ end of setq
2. Создаем глобальную переменную
Код:
[Выделить все] 
(setq LST-AS (код для получения ассоциативного спмска))
3. Теперь с помощью mapcar и функции для lambda
Код:
[Выделить все] 
(car
  (vl-remove-if-not
    '(lambda (STR)
       (wcmatch (cadr EL-LST) (strcat (car STR) "*"))
     ) ;_ end of lambda
    LST-AS
  ) ;_ end of vl-remove-if-not
) ;_ end of car
(небольшие подсказки - использовать список lst, EL-LST это имя аргумента для lambda в mapcar'е) нужно для списка lst получить такой список
Код:
[Выделить все] 
 
(("-" "ГОСТ 19903-74" "ГОСТ 103-76") ("Уголок" "ГОСТ 8509-93" "ГОСТ 8510-86") ("Лист ромб" . "ГОСТ 8568-77") ("Полоса" . "ГОСТ 103-76"))
Ну и проверить на списке lst с другими "комплектациями" подсписков.
Ну пока хватит, что то я сегодня запарился...
CB вне форума  
 
Автор темы   Непрочитано 09.10.2008, 21:13
#35
Red Nova

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

Хотя не до конца понял алгоритм, но судя по твоим указаниям код должен быть таким : Но естественно не работает
Код:
[Выделить все] 
(setq lst '(("1" "-10х100x100" "-")
            ("3" "Уголок 75х5" "-")
            ("5" "Лист ромб -10х100x300" "-")
            ("9" "Полоса -4х50" "U+03A3L=10000")
           )
) ;_ end of setq lst

setq LST-AS (
(apply 'append
       (mapcar
         '(lambda (x y)
            (mapcar
              '(lambda (z)
                 (if (listp y)
                   (append (list z) y)
                   (list z y)
                 ) ;_ end of if
               ) ;_ end of lambda
              x
            ) ;_ end of mapcar
          ) ;_ end of lambda
         (list '("Лист -" "Лист-" "Фл")          
               '("Лист чечевица" "Лист ромб")    
               '("-")                            
               '("Полоса")                       
               '("Уголок" "\\U+E720") 
               '("\\U+E72E")                         
               '("Тр" "Tp" "Тp" "Tр")  
               '("Двутавр" "\\U+E729")     
               '("Швеллер" "\\U+E725")     
               '("%%c" "\\U+E712")     
) ;_ end of list
         (list "ГОСТ 19903-74"                   
               "ГОСТ 8568-77"                    
               '("ГОСТ 19903-74" "ГОСТ 103-76")  
               "ГОСТ 103-76"                     
               '("ГОСТ 8509-93" "ГОСТ 8510-86") 
               "ГОСТ 30245-03"  
               "ГОСТ 10704-91"  
               "ГОСТ 8239-89"  
               "ГОСТ 8240-97"  
               "ГОСТ 5781-82"  
) ;_ end of list
 ;_ end of list
       ) ;_ end of mapcar
) ;_ end of apply
) ;_ end of setq LST-AS



(defun test ()
   (mapcar 
     '(lambda (EL-LST) 
          (car
           (vl-remove-if-not
            '(lambda (STR)
                (wcmatch (cadr EL-LST) (strcat (car STR) "*"))
              ) ;_ end of lambda
             LST-AS
           ) ;_ end of vl-remove-if-not
         ) ;_ end of car
       ) ;_ end of lambda
         'lst
   ) ;_ end of mapcar 
) ;_ end of defun
__________________
Блог
Последний раз редактировалось Red Nova, 09.10.2008 в 22:44.
Red Nova вне форума  
 
Непрочитано 10.10.2008, 13:24
#36
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

>Red Nova
Цитата:
setq LST-AS (
(apply 'append
....................
Цитата:
(defun test ()
.................
'lst ;;; апострофа не должно быть
) ;_ end of mapcar
) ;_ end of defun
А так правильно... Значит на этом зтапе мы имеем:
Код:
[Выделить все] 
(setq lst '(("1" "-10х100x100" "-")
            ("3" "Уголок 75х5" "-")
            ("5" "Лист ромб -10х100x300" "-")
            ("9" "Полоса -4х50" "U+03A3L=10000")
           )
) ;_ end of setq lst
(setq LST-AS
       (apply
         'append
         (mapcar
           '(lambda (X Y)
              (mapcar
                '(lambda (Z)
                   (cons Z Y)
                 ) ;_ end of lambda
                X
              ) ;_ end of mapcar
            ) ;_ end of lambda
           (list (list "Лист -" "Лист-" "Фл")
                 (list "Лист чечевица" "Лист ромб")
                 (list "-")
                 (list "Полоса")
                 (list "Уголок" "\\U+E720")
                 (list "\\U+E72E")
                 (list "Тр")
                 (list "Двутавр" "\\U+E729")
                 (list "Швеллер" "\\U+E725")
                 (list "%%c" "\\U+E712")
           ) ;_ end of list
           (list "ГОСТ 19903-74"
                 "ГОСТ 8568-77"
                 (list "ГОСТ 19903-74" "ГОСТ 103-76")
                 "ГОСТ 103-76"
                 (list "ГОСТ 8509-93" "ГОСТ 8510-86")
                 "ГОСТ 30245-03"
                 "ГОСТ 10704-91"
                 "ГОСТ 8239-89"
                 "ГОСТ 8240-97"
                 "ГОСТ 5781-82"
           ) ;_ end of list
         ) ;_ end of mapcar
       ) ;_ end of apply
) ;_ end of setq LST-AS
(defun test ()
  (mapcar
    '(lambda (EL-LST / EL-AS)
       (setq EL-AS
              (car
                (vl-remove-if-not
                  '(lambda (STR)
                     (wcmatch (cadr EL-LST) (strcat (car STR) "*"))
                   ) ;_ end of lambda
                  LST-AS
                ) ;_ end of vl-remove-if-not
              ) ;_ end of car
       ) ;_ end of setq
 
;;;Здесь будет продолжение
     ) ;_ end of lambda
    lst
  ) ;_ end of mapcar
) ;_ end of defun
Т.е. - ф-ция mapcar последовательно передает своей (lambda (EL-LST / EL-AS)...)элементы из lst, которые внутри ее идентифицируются как переменная EL-LST.
В зависимости от EL-LST вычисляется локальная переменная EL-AS, которая на данном зтапе и есть результат выполнения ф-ции lambda. Однако переменная EL-AS не является целью - она лишь средство для дальнейшей обработки. Нам нужнен второй или третий элемент EL-AS. Если бы не было специальных условий для "-","Уголок" и "\\U+E720", то все было бы совсем просто:
Код:
[Выделить все] 
(setq EL-LST '("5" "Лист ромб -10х100x300" "-"))
(setq EL-AS '("Лист ромб" . "ГОСТ 8568-77"))
(cons (cdr EL-AS) EL-LST)
;;;-> ("ГОСТ 8568-77" "5" "Лист ромб -10х100x300" "-")
Т.к. условия есть, а нам нужно получить только одно конкретное слово из EL-AS (а оно может таким: ("-" "ГОСТ 19903-74" "ГОСТ 103-76")) ), используем ф-ию cond.
Код:
[Выделить все] 
(defun test ()
  (mapcar
    '(lambda (EL-LST / EL-AS)
       (setq EL-AS
              (car
                (vl-remove-if-not
                  '(lambda (STR)
                     (wcmatch (cadr EL-LST) (strcat (car STR) "*"))
                   ) ;_ end of lambda
                  LST-AS
                ) ;_ end of vl-remove-if-not
              ) ;_ end of car
       ) ;_ end of setq
       (cons
         (cond
           ((equal (car EL-AS) "-")
            1_ф-ция_выбора_конкретрого_ГОСТА
           )
           ((member (car EL-AS) '("Уголок" "\\U+E720"))
            2_ф-ция_выбора_конкретрого_ГОСТА
           )
           (t (cdr EL-AS))
         ) ;_ end of cond
         EL-LST
       ) ;_ end of cons
     ) ;_ end of lambda
    lst
  ) ;_ end of mapcar
) ;_ end of defun
;;;(test)
;;;((nil "1" "-10х100x100" "-") (nil "3" "Уголок 75х5" "-") ("ГОСТ 8568-77" "5" "Лист ромб -10х100x300" "-") ("ГОСТ 103-76" "9" "Полоса -4х50" "U+03A3L=10000"))
Осталась совсем мелочь - сделать ф-ции_выбора_конкретрого_ГОСТА
1. Ф-ция для "-" :
Код:
[Выделить все] 
(if (equal (caddr EL-LST) "-")
  (cadr EL-AS)
  (caddr EL-AS)
) ;_ end of if
2. Ф-ция для "Уголок" и "\\U+E720" :
Код:
[Выделить все] 
(if
  ((lambda (STR)
     (equal
       (vl-string-position (ascii "x") STR)
       (vl-string-position (ascii "x") STR nil t)
     ) ;_ end of equal
   ) ;_ end of lambda
    (vl-string-translate "х" "x" (cadr EL-LST))
  )
   (cadr EL-AS)
   (caddr EL-AS)
) ;_ end of if
Вставляй их в test и проверяй ее работу...
CB вне форума  
 
Автор темы   Непрочитано 10.10.2008, 14:55
#37
Red Nova

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

Спасибо, все работает
Соединив все коды, на данный момент имеем
Код:
[Выделить все] 
(defun C:ntt ( / CB-filtr lst) ;note to text
  (defun CB-filtr (lst)
    (setq lst
           (vl-remove-if
             '(lambda (x)
                (or
                  (not (equal (length x) 2))
                  (member "" x)
                  (not
                    (wcmatch
                      (vl-string-translate "Tp" "Тр" (cadr x))
                      "\\U+E72E*,Труба*,Тр.*,Лист*,Полоса*,\\U+E720*,Уголок*,\\U+E725*,Швеллер*,\\U+E729*,Двутавр*,Фланец*,Фл.*,-*,%%c*,\\U+E712*,#%%c*,# %%c*,##%%c*,## %%c*,#\\U+E712*,# \\U+E712*,##\\U+E712*,## \\U+E712*"
                    ) ;_ end of wcmatch
                  ) ;_ end of not
                  (not
                    (or
                      (and
                        (wcmatch (car x) "@*")
                        (wcmatch (vl-string-right-trim "1234567890'\"" (car x))
                                 "@"
                        ) ;_ end of wcmatch
                      ) ;_ end of and
                      (and (wcmatch (car x) "#*")
                           (wcmatch (vl-string-left-trim "1234567890" (car x))
                                    ",@,@',@\",',\""
                           ) ;_ end of wcmatch
                      ) ;_ end of and
                    ) ;_ end of or
                  ) ;_ end of not
                ) ;_ end of or
              ) ;_ end of lambda
             lst
           ) ;_ end of vl-remove-if
    ) ;_ end of setq
    (setq lst
           ((lambda (lst / poz temp)
              (defun poz (str pat / p n)
                (while (setq n (vl-string-search pat str n))
                  (setq p (cons n p)
                        n (1+ n)
                  ) ;_ end of setq
                ) ;_ end of while
                p
              ) ;_ end of defun
              (while lst
                (setq
                  temp
                   (cons
                     ((lambda (lst-temp / n)
                        (list
                          (car lst-temp)
                          (vl-string-left-trim
                            "1234567890 "
                            (if (or
                                  (equal (length
                                           (setq n (poz (cadr lst-temp) ","))
                                         ) ;_ end of length
                                         2
                                  ) ;_ end of equal
                                  (not (wcmatch (cadr lst-temp) "*L=*"))
                                ) ;_ end of or
                              (substr (cadr lst-temp)
                                      1
                                      (if (wcmatch (cadr lst-temp) "*L=*")
                                        (car n)
                                        (car (reverse n))
                                      ) ;_ end of if
                              ) ;_ end of substr
                              (cadr lst-temp)
                            ) ;_ end of if
                          ) ;_ end of vl-string-left-trim
                        ) ;_ end of list
                      ) ;_ end of lambda
                       (car
                         (vl-sort
                           (vl-remove-if-not
                             '(lambda (x) (equal (caar lst) (car x)))
                             lst
                           ) ;_ end of vl-remove-if-not
                           '(lambda (str1 str2)
                              (> (length (poz (cadr str1) ","))
                                 (length (poz (cadr str2) ","))
                              ) ;_ end of >
                            ) ;_ end of lambda
                         ) ;_ end of vl-sort
                       ) ;_ end of car
                     )
                     temp
                   ) ;_ end of cons
                ) ;_ end of setq
                (setq lst
                       (vl-remove-if '(lambda (x) (equal (caar lst) (car x))) lst)
                ) ;_ end of setq
                (reverse temp)
              ) ;_ end of while
            ) ;_ end of lambda
             lst
           )
    ) ;_ end of setq
  ) ;_ end of defun
  (setq lst (mapcar '(lambda (x)
                       (list (vl-string-trim " " (car x))
                             (vl-string-trim " " (cadr x))
                       ) ;_ end of list
                     ) ;_ end of lambda
;;;                    lst
                    (_dwgru-get-spds-text-and-range) ; из #472 
            ) ;_ end of mapcar
        lst (CB-filtr lst)
        lst (mapcar
              '(lambda (x / p)
                 (if (setq p (vl-string-position (ascii ",") (cadr x)))
                   (list
                     (car x)
                     (substr (cadr x) 1 p)
                     (vl-string-left-trim " " (substr (cadr x) (+ 2 p)))
                   ) ;_ end of list
                   (if (wcmatch (cadr x) "-*,Лист*,Фл*")
                     (append x '("-"))
                     (append x '("L="))
                   ) ;_ end of if
                 ) ;_ end of if
               ) ;_ end of lambda
              lst
            ) ;_ end of mapcar
  ) ;_ end of setq
(setq lst 
 (mapcar
    '(lambda (x) (nth x lst))
    (vl-sort-i
      ((lambda (lst)
         (mapcar
           '(lambda (str1 str2)
              (if (wcmatch str2 "@*")
                (strcat (substr str2 1 1) str1 (substr str2 2))
                (strcat str1 str2)
              ) ;_ end of if
            ) ;_ end of lambda
           (mapcar
             '(lambda (x / str)
                (setq str "0")
                (repeat x
                  (setq str (strcat str "0"))
                ) ;_ end of repeat
                str
              ) ;_ end of lambda
             ((lambda (a)
                (mapcar '(lambda (x) (- (apply 'max a) x)) a)
              ) ;_ end of lambda
               (mapcar
                 '(lambda (str)
                    (length
                      (vl-remove-if-not
                        '(lambda (x)
                           (wcmatch x "#")
                         ) ;_ end of lambda
                        (mapcar 'chr (vl-string->list str))
                      ) ;_ end of vl-remove-if-not
                    ) ;_ end of length
                  ) ;_ end of lambda
                 lst
               ) ;_ end of mapcar
             )
           ) ;_ end of mapcar
           lst
         ) ;_ end of mapcar
       ) ;_ end of lambda
        (mapcar 'strcase (mapcar 'car lst))
      )
      '<
    ) ;_ end of vl-sort-i
  ) ;_ end of mapcar
 ) ;_ end of setq




(setq LST-AS
       (apply
         'append
         (mapcar
           '(lambda (X Y)
              (mapcar
                '(lambda (Z)
                   (cons Z Y)
                 ) ;_ end of lambda
                X
              ) ;_ end of mapcar
            ) ;_ end of lambda
           (list (list "Лист -" "Лист-" "Фл")
                 (list "Лист чечевица" "Лист ромб")
                 (list "-")
                 (list "Полоса")
                 (list "Уголок" "\\U+E720")
                 (list "\\U+E72E")
                 (list "Тр")
                 (list "Двутавр" "\\U+E729")
                 (list "Швеллер" "\\U+E725")
                 (list "%%c" "\\U+E712")
           ) ;_ end of list
           (list "ГОСТ 19903-74"
                 "ГОСТ 8568-77"
                 (list "ГОСТ 19903-74" "ГОСТ 103-76")
                 "ГОСТ 103-76"
                 (list "ГОСТ 8509-93" "ГОСТ 8510-86")
                 "ГОСТ 30245-03"
                 "ГОСТ 10704-91"
                 "ГОСТ 8239-89"
                 "ГОСТ 8240-97"
                 "ГОСТ 5781-82"
           ) ;_ end of list
         ) ;_ end of mapcar
       ) ;_ end of apply
) ;_ end of setq LST-AS



  (mapcar
    '(lambda (EL-LST / EL-AS)
       (setq EL-AS
              (car
                (vl-remove-if-not
                  '(lambda (STR)
                     (wcmatch (cadr EL-LST) (strcat (car STR) "*"))
                   ) ;_ end of lambda
                  LST-AS
                ) ;_ end of vl-remove-if-not
              ) ;_ end of car
       ) ;_ end of setq
    (cons
     (car EL-LST)
       (cons
         (cond
           ((equal (car EL-AS) "-")
           (if (equal (caddr EL-LST) "-")
            (cadr EL-AS)
            (caddr EL-AS)
           ) ;_ end of if
           )
           ((member (car EL-AS) '("Уголок" "\\U+E720"))
             (if
               ((lambda (STR)
                  (equal
                    (vl-string-position (ascii "x") STR)
                    (vl-string-position (ascii "x") STR nil t)
                  ) ;_ end of equal
                ) ;_ end of lambda
                 (vl-string-translate "х" "x" (cadr EL-LST))
               )
                (cadr EL-AS)
                (caddr EL-AS)
             ) ;_ end of if
           )
           (t (cdr EL-AS))
         ) ;_ end of cond
         (cdr EL-LST)
       ) ;_ end of cons
      ) ;_ end of cons
     ) ;_ end of lambda
    lst
  ) ;_ end of mapcar
) ;_ end of defun ntt
Теперь требуется переписать содержание этого списка в существующий шаблон спецификации. То есть, когда закончили выбирать все выноски, нажимаем enter, отмечаем рамкой шаблон спецификации из мтекстов или текстов, который содержит обязательно четыре столбца и n-ное количество строк. После чего данные вписываются в спецификацию. Принцип вписывания довольно прост (по крайней мере его логика). Элементы первого подсписка должны по очереди вписаться в мтексты первой строки, и так далее.
В качестве ориентира служат координаты мтекстов. Тут (кстати именно этим кодом я потом буду рассчитывать полученную спецификацию)VVA в коде применяет нечто подобное, там учтена возможность неидеального совпадения координат мтекстов.
Если отмечая шаблон мы захватим более или менее четырех столбцов, выходит сообщение об ошибке, то же происходит, если выбрать меньше строк чем есть элементов в списке. Но если выбрать больше строк чем требуется, то лисп должен заполнить все верхние строки нормально, а в лишние записать ####.


P.S. Я кстати добавил Тр.*,Tp.*,Тp.*,Tр.* в первый фильтр, (так и не понял куда твоу функцию вклеить, так вышло даже проще).
__________________
Блог
Последний раз редактировалось Red Nova, 13.10.2008 в 09:21.
Red Nova вне форума  
 
Непрочитано 10.10.2008, 17:26
#38
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

>Red Nova
1. "Вклеить" функцию нужно здесь:
Код:
[Выделить все] 
.........................
                    (wcmatch
                      (vl-string-translate "Tp" "Тр" (cadr x))
                      "\\U+E72E*,Труба*,Тр.*,Лист*,Полоса*,\\U+E720*,Уголок*,\\U+E725*,Швеллер*,\\U+E729*,Двутавр*,Фланец*,Фл.*,-*,%%c*,\\U+E712*,#%%c*,# %%c*,##%%c*,## %%c*,#\\U+E712*,# \\U+E712*,##\\U+E712*,## \\U+E712*"
                    ) ;_ end of wcmatch
..................................................
Кстати, сюда же можно воткнуть и замену х, соответственно убрав эту замену отсюда:
Имеется:
Код:
[Выделить все] 
             (if
               ((lambda (STR)
                  (equal
                    (vl-string-position (ascii "x") STR)
                    (vl-string-position (ascii "x") STR nil t)
                  ) ;_ end of equal
                ) ;_ end of lambda
                 (vl-string-translate "х" "x" (cadr EL-LST))
               )
                (cadr EL-AS)
                (caddr EL-AS)
             ) ;_ end of if
Должно быть:
Код:
[Выделить все] 
              (if
                   (equal
                    (vl-string-position (ascii "x") (cadr EL-LST))
                    (vl-string-position (ascii "x") (cadr EL-LST) nil t)
                  ) ;_ end of equal
                (cadr EL-AS)
                (caddr EL-AS)
             ) ;_ end of if
Потренируйся...
2. Так, как ты соединил, не будет работать окончательная сортировка
Имеется:
Код:
[Выделить все] 
............................
  ) ;_ end of setq
  (mapcar
    '(lambda (x) (nth x lst))
    (vl-sort-i
............................
      '<
    ) ;_ end of vl-sort-i
  ) ;_ end of mapcar
.............................
Должно быть:
Код:
[Выделить все] 
............................
  ) ;_ end of setq
(setq lst
  (mapcar
    '(lambda (x) (nth x lst))
    (vl-sort-i
............................
      '<
    ) ;_ end of vl-sort-i
  ) ;_ end of mapcar
 ) ;_ end of setq
.............................
CB вне форума  
 
Автор темы   Непрочитано 10.10.2008, 20:18
#39
Red Nova

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

Поправил #37. Назвал команду ntt (note to text).
Странное дело. Обнаружил что на домашнем компе лисп по сих пор работает неправильно, хотя на работе все нормально. Это касается позиций с именами типа a2 a3 a4...b2 b3 b4... . Они вообще не попадают в список. Я и раньше встречал такого типа мистические несоответствия. Тогда так и не удалось с этим справиться. Может есть возможность как-то модифицировать код так, чтобы он делал то же но чуть по другому. Может тогда все наладится?
__________________
Блог
Последний раз редактировалось Red Nova, 10.10.2008 в 20:31.
Red Nova вне форума  
 
Автор темы   Непрочитано 10.10.2008, 20:51
#40
Red Nova

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

Вот пример в котором показано как заполнить шаблон спецификации из полученного списка.
(Оказывается я перепутал первые два столбца метсами. Вместо ГОСТ, Позиция должно быть Позиция потом ГОСТ).
Вложения
Тип файла: dwg
DWG 2004		 Спецификация.dwg (83.7 Кб, 1245 просмотров)
__________________
Блог
Red Nova вне форума  
 
Автор темы   Непрочитано 11.10.2008, 19:47
#41
Red Nova

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

Пробовал написать функцию для того чтобы поменять первые два элемента подсписков местами. Что я делаю не правильно.
Код:
[Выделить все] 
(defune test1 (/ lst lst1 lst2 lst3)

(setq lst '(("ГОСТ 19903-74" "1" "-10х100x100" "-") ("ГОСТ 19903-74" "2" "Лист 
-10х100x100" "-") ("ГОСТ 19903-74" "3" "Фл. ?300х8" "-"))
) ;_ end of setq

(setq lst1
(mapcar
‘car
lst
) ;_ end of mapcar
) ;_ end of setq

(setq lst2
(mapcar
‘cadr
lst
) ;_ end of mapcar
) ;_ end of setq

(setq lst3
(mapcar
‘(cdr(cdr))
lst
) ;_ end of mapcar
) ;_ end of setq


(setq lst
(mapcar
'(lambda ( x y z)
(append ('x 'y 'z))
) ;_ end of lambda
lst2 lst1 lst3
) ;_ end of mapcar
) ;_ end of defun
__________________
Блог
Последний раз редактировалось Red Nova, 11.10.2008 в 20:42.
Red Nova вне форума  
 
Непрочитано 11.10.2008, 23:27
#42
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

> Red Nova
Код:
[Выделить все] 
(mapcar
  '(lambda (x)
     (cons (cadr x) (cons (car x) (cddr x)))
   )
  lst
)
Только менять нужно не здесь - сколько же можно издеваться и насиловать этот несчастный список ...
Код:
[Выделить все] 
       ) ;_ end of setq
    (cons
     (car EL-LST)
       (cons
         (cond
           ((equal (car EL-AS) "-")
           (if (equal (caddr EL-LST) "-")
            (cadr EL-AS)
            (caddr EL-AS)
           ) ;_ end of if
           )
           ((member (car EL-AS) '("Уголок" "\\U+E720"))
             (if
               ((lambda (STR)
                  (equal
                    (vl-string-position (ascii "x") STR)
                    (vl-string-position (ascii "x") STR nil t)
                  ) ;_ end of equal
                ) ;_ end of lambda
                 (vl-string-translate "х" "x" (cadr EL-LST))
               )
                (cadr EL-AS)
                (caddr EL-AS)
             ) ;_ end of if
           )
           (t (cdr EL-AS))
         ) ;_ end of cond
         (cdr EL-LST)
       ) ;_ end of cons
      ) ;_ end of cons
     ) ;_ end of lambda
CB вне форума  
 
Автор темы   Непрочитано 12.10.2008, 10:57
#43
Red Nova

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

Спасибо
Цитата:
Только менять нужно не здесь - сколько же можно издеваться и насиловать этот несчастный список ...
Знаю конечно же. Просто разбираться в твоем коде для меня было нереально, а попробовать написать функцию было еще возможно. А почему мой вариант не работал?
__________________
Блог
Red Nova вне форума  
 
Автор темы   Непрочитано 12.10.2008, 22:01
#44
Red Nova

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

Подскажите какими функциями надо орудовать для записи полученного списка в мтексты (как в показанно #40).
__________________
Блог
Red Nova вне форума  
 
Непрочитано 13.10.2008, 15:20
#45
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

Без проверки на то, что при выбора шаблона могут быть выделены не четыре колонки, а 3 или 5... Цифрой, выделенной красным цветом (в данном случае это 1мм) можно регулировать условие, при котором считается, что тексты находятся на одной строке...
Код:
[Выделить все] 
(defun fill-sp (lst)
  (mapcar
    '(lambda (A B)
       ((lambda (dxf)
          (entmod
            (subst (cons 1 A)
                   (assoc 1 dxf)
                   dxf
            ) ;_ end of subst
          ) ;_ end of entmod
        ) ;_ end of lambda
         (entget B)
       )
     ) ;_ end of lambda
    (apply 'append lst)
    ((lambda (/ sset)
       (princ "\nВыберите шаблон спецификации: ")
       (if (setq sset (ssget '((0 . "*TEXT"))))
         (vl-sort
           (vl-sort
             (vl-remove-if
               (function listp)
               (mapcar (function cadr)
                       (ssnamex sset)
               ) ;_ end of mapcar
             ) ;_ end of vl-remove-if
             '(lambda (a b)
                (> (caddr (assoc '10 (entget a)))
                   (caddr (assoc '10 (entget b)))
                ) ;_ on Y
              ) ;_ end of lambda
           ) ;_ end of vl-sort
           '(lambda (a b)
              (and
                (equal (caddr (assoc '10 (entget a)))
                       (caddr (assoc '10 (entget b)))
                       1.
                ) ;_ end of equal
                (< (cadr (assoc '10 (entget a)))
                   (cadr (assoc '10 (entget b)))
                ) ;_ end of <
              ) ;_ end of and
            ) ;_ end of lambda
         ) ;_ end of vl-sort
       ) ;_ end of if
     ) ;_ end of lambda
    )
  ) ;_ end of mapcar
  (princ)
) ;_ end of defun
CB вне форума  
 
Автор темы   Непрочитано 13.10.2008, 15:43
#46
Red Nova

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

Спасибо. Не очень уверен что я соеденил функции как надо.
Код:
[Выделить все] 
(defun C:ntt ( / CB-filtr lst) ;note to text
  (defun CB-filtr (lst)
    (setq lst
           (vl-remove-if
             '(lambda (x)
                (or
                  (not (equal (length x) 2))
                  (member "" x)
                  (not
                    (wcmatch
                      (vl-string-translate "Tp" "Тр" (cadr x))
                      "\\U+E72E*,Труба*,Тр.*,Лист*,Полоса*,\\U+E720*,Уголок*,\\U+E725*,Швеллер*,\\U+E729*,Двутавр*,Фланец*,Фл.*,-*,%%c*,\\U+E712*,#%%c*,# %%c*,##%%c*,## %%c*,#\\U+E712*,# \\U+E712*,##\\U+E712*,## \\U+E712*"
                    ) ;_ end of wcmatch
                  ) ;_ end of not
                  (not
                    (or
                      (and
                        (wcmatch (car x) "@*")
                        (wcmatch (vl-string-right-trim "1234567890'\"" (car x))
                                 "@"
                        ) ;_ end of wcmatch
                      ) ;_ end of and
                      (and (wcmatch (car x) "#*")
                           (wcmatch (vl-string-left-trim "1234567890" (car x))
                                    ",@,@',@\",',\""
                           ) ;_ end of wcmatch
                      ) ;_ end of and
                    ) ;_ end of or
                  ) ;_ end of not
                ) ;_ end of or
              ) ;_ end of lambda
             lst
           ) ;_ end of vl-remove-if
    ) ;_ end of setq
    (setq lst
           ((lambda (lst / poz temp)
              (defun poz (str pat / p n)
                (while (setq n (vl-string-search pat str n))
                  (setq p (cons n p)
                        n (1+ n)
                  ) ;_ end of setq
                ) ;_ end of while
                p
              ) ;_ end of defun
              (while lst
                (setq
                  temp
                   (cons
                     ((lambda (lst-temp / n)
                        (list
                          (car lst-temp)
                          (vl-string-left-trim
                            "1234567890 "
                            (if (or
                                  (equal (length
                                           (setq n (poz (cadr lst-temp) ","))
                                         ) ;_ end of length
                                         2
                                  ) ;_ end of equal
                                  (not (wcmatch (cadr lst-temp) "*L=*"))
                                ) ;_ end of or
                              (substr (cadr lst-temp)
                                      1
                                      (if (wcmatch (cadr lst-temp) "*L=*")
                                        (car n)
                                        (car (reverse n))
                                      ) ;_ end of if
                              ) ;_ end of substr
                              (cadr lst-temp)
                            ) ;_ end of if
                          ) ;_ end of vl-string-left-trim
                        ) ;_ end of list
                      ) ;_ end of lambda
                       (car
                         (vl-sort
                           (vl-remove-if-not
                             '(lambda (x) (equal (caar lst) (car x)))
                             lst
                           ) ;_ end of vl-remove-if-not
                           '(lambda (str1 str2)
                              (> (length (poz (cadr str1) ","))
                                 (length (poz (cadr str2) ","))
                              ) ;_ end of >
                            ) ;_ end of lambda
                         ) ;_ end of vl-sort
                       ) ;_ end of car
                     )
                     temp
                   ) ;_ end of cons
                ) ;_ end of setq
                (setq lst
                       (vl-remove-if '(lambda (x) (equal (caar lst) (car x))) lst)
                ) ;_ end of setq
                (reverse temp)
              ) ;_ end of while
            ) ;_ end of lambda
             lst
           )
    ) ;_ end of setq
  ) ;_ end of defun
  (setq lst (mapcar '(lambda (x)
                       (list (vl-string-trim " " (car x))
                             (vl-string-trim " " (cadr x))
                       ) ;_ end of list
                     ) ;_ end of lambda
;;;                    lst
                    (_dwgru-get-spds-text-and-range) ; из #472 
            ) ;_ end of mapcar
        lst (CB-filtr lst)
        lst (mapcar
              '(lambda (x / p)
                 (if (setq p (vl-string-position (ascii ",") (cadr x)))
                   (list
                     (car x)
                     (substr (cadr x) 1 p)
                     (vl-string-left-trim " " (substr (cadr x) (+ 2 p)))
                   ) ;_ end of list
                   (if (wcmatch (cadr x) "-*,Лист*,Фл*")
                     (append x '("-"))
                     (append x '("L="))
                   ) ;_ end of if
                 ) ;_ end of if
               ) ;_ end of lambda
              lst
            ) ;_ end of mapcar
  ) ;_ end of setq
(setq lst 
 (mapcar
    '(lambda (x) (nth x lst))
    (vl-sort-i
      ((lambda (lst)
         (mapcar
           '(lambda (str1 str2)
              (if (wcmatch str2 "@*")
                (strcat (substr str2 1 1) str1 (substr str2 2))
                (strcat str1 str2)
              ) ;_ end of if
            ) ;_ end of lambda
           (mapcar
             '(lambda (x / str)
                (setq str "0")
                (repeat x
                  (setq str (strcat str "0"))
                ) ;_ end of repeat
                str
              ) ;_ end of lambda
             ((lambda (a)
                (mapcar '(lambda (x) (- (apply 'max a) x)) a)
              ) ;_ end of lambda
               (mapcar
                 '(lambda (str)
                    (length
                      (vl-remove-if-not
                        '(lambda (x)
                           (wcmatch x "#")
                         ) ;_ end of lambda
                        (mapcar 'chr (vl-string->list str))
                      ) ;_ end of vl-remove-if-not
                    ) ;_ end of length
                  ) ;_ end of lambda
                 lst
               ) ;_ end of mapcar
             )
           ) ;_ end of mapcar
           lst
         ) ;_ end of mapcar
       ) ;_ end of lambda
        (mapcar 'strcase (mapcar 'car lst))
      )
      '<
    ) ;_ end of vl-sort-i
  ) ;_ end of mapcar
 ) ;_ end of setq




(setq LST-AS
       (apply
         'append
         (mapcar
           '(lambda (X Y)
              (mapcar
                '(lambda (Z)
                   (cons Z Y)
                 ) ;_ end of lambda
                X
              ) ;_ end of mapcar
            ) ;_ end of lambda
           (list (list "Лист -" "Лист-" "Фл")
                 (list "Лист чечевица" "Лист ромб")
                 (list "-")
                 (list "Полоса")
                 (list "Уголок" "\\U+E720")
                 (list "\\U+E72E")
                 (list "Тр")
                 (list "Двутавр" "\\U+E729")
                 (list "Швеллер" "\\U+E725")
                 (list "%%c" "\\U+E712")
           ) ;_ end of list
           (list "ГОСТ 19903-74"
                 "ГОСТ 8568-77"
                 (list "ГОСТ 19903-74" "ГОСТ 103-76")
                 "ГОСТ 103-76"
                 (list "ГОСТ 8509-93" "ГОСТ 8510-86")
                 "ГОСТ 30245-03"
                 "ГОСТ 10704-91"
                 "ГОСТ 8239-89"
                 "ГОСТ 8240-97"
                 "ГОСТ 5781-82"
           ) ;_ end of list
         ) ;_ end of mapcar
       ) ;_ end of apply
) ;_ end of setq LST-AS




(setq lst 
  (mapcar
    '(lambda (EL-LST / EL-AS)
       (setq EL-AS
              (car
                (vl-remove-if-not
                  '(lambda (STR)
                     (wcmatch (cadr EL-LST) (strcat (car STR) "*"))
                   ) ;_ end of lambda
                  LST-AS
                ) ;_ end of vl-remove-if-not
              ) ;_ end of car
       ) ;_ end of setq
    (cons
     (car EL-LST)
       (cons
         (cond
           ((equal (car EL-AS) "-")
           (if (equal (caddr EL-LST) "-")
            (cadr EL-AS)
            (caddr EL-AS)
           ) ;_ end of if
           )
           ((member (car EL-AS) '("Уголок" "\\U+E720"))
             (if
               ((lambda (STR)
                  (equal
                    (vl-string-position (ascii "x") STR)
                    (vl-string-position (ascii "x") STR nil t)
                  ) ;_ end of equal
                ) ;_ end of lambda
                 (vl-string-translate "х" "x" (cadr EL-LST))
               )
                (cadr EL-AS)
                (caddr EL-AS)
             ) ;_ end of if
           )
           (t (cdr EL-AS))
         ) ;_ end of cond
         (cdr EL-LST)
       ) ;_ end of cons
      ) ;_ end of cons
     ) ;_ end of lambda
    lst
  ) ;_ end of mapcar
) ;_ end of setq


  (mapcar
    '(lambda (A B)
       ((lambda (dxf)
          (entmod
            (subst (cons 1 A)
                   (assoc 1 dxf)
                   dxf
            ) ;_ end of subst
          ) ;_ end of entmod
        ) ;_ end of lambda
         (entget B)
       )
     ) ;_ end of lambda
    (apply 'append lst)
    ((lambda (/ sset)
       (princ "\nВыберите шаблон спецификации: ")
       (if (setq sset (ssget '((0 . "*TEXT"))))
         (vl-sort
           (vl-sort
             (vl-remove-if
               (function listp)
               (mapcar (function cadr)
                       (ssnamex sset)
               ) ;_ end of mapcar
             ) ;_ end of vl-remove-if
             '(lambda (a b)
                (> (caddr (assoc '10 (entget a)))
                   (caddr (assoc '10 (entget b)))
                ) ;_ on Y
              ) ;_ end of lambda
           ) ;_ end of vl-sort
           '(lambda (a b)
              (and
                (equal (caddr (assoc '10 (entget a)))
                       (caddr (assoc '10 (entget b)))
                       1.
                ) ;_ end of equal
                (< (cadr (assoc '10 (entget a)))
                   (cadr (assoc '10 (entget b)))
                ) ;_ end of <
              ) ;_ end of and
            ) ;_ end of lambda
         ) ;_ end of vl-sort
       ) ;_ end of if
     ) ;_ end of lambda
    )
  ) ;_ end of mapcar
  (princ)

 
) ;_ end of defun ntt
Вложения
Тип файла: dwg
DWG 2004		 Спецификация2.dwg (68.5 Кб, 1003 просмотров)
__________________
Блог
Последний раз редактировалось Red Nova, 13.10.2008 в 17:38.
Red Nova вне форума  
 
Непрочитано 13.10.2008, 16:41
#47
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

Код:
[Выделить все] 
...............................................
                 "ГОСТ 5781-82"
           ) ;_ end of list
         ) ;_ end of mapcar
       ) ;_ end of apply
) ;_ end of setq LST-AS
 
 
(setq lst
  (mapcar
    '(lambda (EL-LST / EL-AS)
       (setq EL-AS
..............................................
      ) ;_ end of cons
     ) ;_ end of lambda
    lst
  ) ;_ end of mapcar
) ;_ end of setq
 
 
  (mapcar
    '(lambda (A B)
.............................
CB вне форума  
 
Автор темы   Непрочитано 13.10.2008, 17:35
#48
Red Nova

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

Спасибо. Исправил #46
А можно сделать так, чтобы во все мтексты, которые лишние (то есть если выбранных строк больше чем позиций) вписывалось ##, ато теперь они не трогаются
__________________
Блог
Red Nova вне форума  
 
Автор темы   Непрочитано 13.10.2008, 22:23
#49
Red Nova

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

Еще есть одна просьба по поводу выбора мтекстов. Хотя это не так принципиально, и лисп в общем точно решает поставленную цель. Но хотелось бы чтобы при выборе мтекстов чертилась рамка (разумеется она потом должна удалиться) и был включен оснап. Если это сложно реализовать, то и так как сейчас пойдет разумеется.
__________________
Блог
Red Nova вне форума  
 
Непрочитано 14.10.2008, 10:36
#50
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

>Red Nova #48
Замени последнюю ф-цию на эту
Код:
[Выделить все] 
((lambda (/ b1 a1 a2 a3)
   (mapcar
     '(lambda (B A / b1 a1 a2 a3)
        ((lambda (dxf)
           (entmod
             (subst (cons 1 A)
                    (assoc 1 dxf)
                    dxf
             ) ;_ end of subst
           ) ;_ end of entmod
         ) ;_ end of lambda
          (entget B)
        )
      ) ;_ end of lambda
     (setq b1
            ((lambda (/ sset)
               (princ "\nВыберите шаблон спецификации: ")
               (if (setq sset (ssget '((0 . "*TEXT"))))
                 (vl-sort
                   (vl-sort
                     (vl-remove-if
                       (function listp)
                       (mapcar (function cadr)
                               (ssnamex sset)
                       ) ;_ end of mapcar
                     ) ;_ end of vl-remove-if
                     '(lambda (a b)
                        (> (caddr (assoc '10 (entget a)))
                           (caddr (assoc '10 (entget b)))
                        ) ;_ on Y
                      ) ;_ end of lambda
                   ) ;_ end of vl-sort
                   '(lambda (a b)
                      (and
                        (equal (caddr (assoc '10 (entget a)))
                               (caddr (assoc '10 (entget b)))
                               1.
                        ) ;_ end of equal
                        (< (cadr (assoc '10 (entget a)))
                           (cadr (assoc '10 (entget b)))
                        ) ;_ end of <
                      ) ;_ end of and
                    ) ;_ end of lambda
                 ) ;_ end of vl-sort
               ) ;_ end of if
             ) ;_ end of lambda
            )
     ) ;_ end of setq
     (progn
       (setq a1 (apply 'append lst)
             a1
                (append
                  a1
                  (if (not (minusp (setq a2 (- (length b1) (length a1)))))
                    (append (repeat a2 (setq a3 (cons "XX" a3))))
                  ) ;_ end of if
                ) ;_ end of append
       ) ;_ end of setq
     ) ;_ end of progn
   ) ;_ end of mapcar
 ) ;_ end of lambda
)
>Red Nova #49
Абсолютно не понял на кой ...
Как я догадываюсь, что следующим шагом должна по идее последовать просьба типа такой - а можно сделать так, что если выбранных позиций больше чем выбранных мтекстов, то дорисовать спецификацию и добавить недостающие в ней строки...
CB вне форума  
 
Непрочитано 14.10.2008, 10:42
#51
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 36,746

И, если количество строк больше Х (или высота таблицы больше N мм), нарисовать "рядом" еще одну таблицу, продолжающую спецификацию
__________________

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Автор темы   Непрочитано 14.10.2008, 14:26
#52
Red Nova

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

Я же написал.
Цитата:
Если это сложно реализовать, то и так как сейчас пойдет разумеется.
Просто лисп для расчета спеки от VVA так работает, хотелось однообразия. Но это не важно.
За #48 спасибо.
Вот видеоролик с примером работы лиспов от CB и VVA.
Вложения
Тип файла: rar Пример ntt+spec5d.rar (131.5 Кб, 586 просмотров)
__________________
Блог
Последний раз редактировалось Red Nova, 14.10.2008 в 14:36.
Red Nova вне форума  
 
Автор темы   Непрочитано 14.10.2008, 14:46
#53
Red Nova

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

Последний вариант
Код:
[Выделить все] 
(defun C:ntt ( / CB-filtr lst) ;note to text
  (defun CB-filtr (lst)
    (setq lst
           (vl-remove-if
             '(lambda (x)
                (or
                  (not (equal (length x) 2))
                  (member "" x)
                  (not
                    (wcmatch
                      (vl-string-translate "Tp" "Тр" (cadr x))
                      "\\U+E72E*,Труба*,Тр.*,Лист*,Полоса*,\\U+E720*,Уголок*,\\U+E725*,Швеллер*,\\U+E729*,Двутавр*,Фланец*,Фл.*,-*,%%c*,\\U+E712*,#%%c*,# %%c*,##%%c*,## %%c*,#\\U+E712*,# \\U+E712*,##\\U+E712*,## \\U+E712*"
                    ) ;_ end of wcmatch
                  ) ;_ end of not
                  (not
                    (or
                      (and
                        (wcmatch (car x) "@*")
                        (wcmatch (vl-string-right-trim "1234567890'\"" (car x))
                                 "@"
                        ) ;_ end of wcmatch
                      ) ;_ end of and
                      (and (wcmatch (car x) "#*")
                           (wcmatch (vl-string-left-trim "1234567890" (car x))
                                    ",@,@',@\",',\""
                           ) ;_ end of wcmatch
                      ) ;_ end of and
                    ) ;_ end of or
                  ) ;_ end of not
                ) ;_ end of or
              ) ;_ end of lambda
             lst
           ) ;_ end of vl-remove-if
    ) ;_ end of setq
    (setq lst
           ((lambda (lst / poz temp)
              (defun poz (str pat / p n)
                (while (setq n (vl-string-search pat str n))
                  (setq p (cons n p)
                        n (1+ n)
                  ) ;_ end of setq
                ) ;_ end of while
                p
              ) ;_ end of defun
              (while lst
                (setq
                  temp
                   (cons
                     ((lambda (lst-temp / n)
                        (list
                          (car lst-temp)
                          (vl-string-left-trim
                            "1234567890 "
                            (if (or
                                  (equal (length
                                           (setq n (poz (cadr lst-temp) ","))
                                         ) ;_ end of length
                                         2
                                  ) ;_ end of equal
                                  (not (wcmatch (cadr lst-temp) "*L=*"))
                                ) ;_ end of or
                              (substr (cadr lst-temp)
                                      1
                                      (if (wcmatch (cadr lst-temp) "*L=*")
                                        (car n)
                                        (car (reverse n))
                                      ) ;_ end of if
                              ) ;_ end of substr
                              (cadr lst-temp)
                            ) ;_ end of if
                          ) ;_ end of vl-string-left-trim
                        ) ;_ end of list
                      ) ;_ end of lambda
                       (car
                         (vl-sort
                           (vl-remove-if-not
                             '(lambda (x) (equal (caar lst) (car x)))
                             lst
                           ) ;_ end of vl-remove-if-not
                           '(lambda (str1 str2)
                              (> (length (poz (cadr str1) ","))
                                 (length (poz (cadr str2) ","))
                              ) ;_ end of >
                            ) ;_ end of lambda
                         ) ;_ end of vl-sort
                       ) ;_ end of car
                     )
                     temp
                   ) ;_ end of cons
                ) ;_ end of setq
                (setq lst
                       (vl-remove-if '(lambda (x) (equal (caar lst) (car x))) lst)
                ) ;_ end of setq
                (reverse temp)
              ) ;_ end of while
            ) ;_ end of lambda
             lst
           )
    ) ;_ end of setq
  ) ;_ end of defun
  (setq lst (mapcar '(lambda (x)
                       (list (vl-string-trim " " (car x))
                             (vl-string-trim " " (cadr x))
                       ) ;_ end of list
                     ) ;_ end of lambda
;;;                    lst
                    (_dwgru-get-spds-text-and-range) ; из #472 
            ) ;_ end of mapcar
        lst (CB-filtr lst)
        lst (mapcar
              '(lambda (x / p)
                 (if (setq p (vl-string-position (ascii ",") (cadr x)))
                   (list
                     (car x)
                     (substr (cadr x) 1 p)
                     (vl-string-left-trim " " (substr (cadr x) (+ 2 p)))
                   ) ;_ end of list
                   (if (wcmatch (cadr x) "-*,Лист*,Фл*")
                     (append x '("-"))
                     (append x '("L="))
                   ) ;_ end of if
                 ) ;_ end of if
               ) ;_ end of lambda
              lst
            ) ;_ end of mapcar
  ) ;_ end of setq
(setq lst 
 (mapcar
    '(lambda (x) (nth x lst))
    (vl-sort-i
      ((lambda (lst)
         (mapcar
           '(lambda (str1 str2)
              (if (wcmatch str2 "@*")
                (strcat (substr str2 1 1) str1 (substr str2 2))
                (strcat str1 str2)
              ) ;_ end of if
            ) ;_ end of lambda
           (mapcar
             '(lambda (x / str)
                (setq str "0")
                (repeat x
                  (setq str (strcat str "0"))
                ) ;_ end of repeat
                str
              ) ;_ end of lambda
             ((lambda (a)
                (mapcar '(lambda (x) (- (apply 'max a) x)) a)
              ) ;_ end of lambda
               (mapcar
                 '(lambda (str)
                    (length
                      (vl-remove-if-not
                        '(lambda (x)
                           (wcmatch x "#")
                         ) ;_ end of lambda
                        (mapcar 'chr (vl-string->list str))
                      ) ;_ end of vl-remove-if-not
                    ) ;_ end of length
                  ) ;_ end of lambda
                 lst
               ) ;_ end of mapcar
             )
           ) ;_ end of mapcar
           lst
         ) ;_ end of mapcar
       ) ;_ end of lambda
        (mapcar 'strcase (mapcar 'car lst))
      )
      '<
    ) ;_ end of vl-sort-i
  ) ;_ end of mapcar
 ) ;_ end of setq




(setq LST-AS
       (apply
         'append
         (mapcar
           '(lambda (X Y)
              (mapcar
                '(lambda (Z)
                   (cons Z Y)
                 ) ;_ end of lambda
                X
              ) ;_ end of mapcar
            ) ;_ end of lambda
           (list (list "Лист -" "Лист-" "Фл")
                 (list "Лист чечевица" "Лист ромб")
                 (list "-")
                 (list "Полоса")
                 (list "Уголок" "\\U+E720")
                 (list "\\U+E72E")
                 (list "Тр")
                 (list "Двутавр" "\\U+E729")
                 (list "Швеллер" "\\U+E725")
                 (list "%%c" "\\U+E712")
           ) ;_ end of list
           (list "ГОСТ 19903-74"
                 "ГОСТ 8568-77"
                 (list "ГОСТ 19903-74" "ГОСТ 103-76")
                 "ГОСТ 103-76"
                 (list "ГОСТ 8509-93" "ГОСТ 8510-86")
                 "ГОСТ 30245-03"
                 "ГОСТ 10704-91"
                 "ГОСТ 8239-89"
                 "ГОСТ 8240-97"
                 "ГОСТ 5781-82"
           ) ;_ end of list
         ) ;_ end of mapcar
       ) ;_ end of apply
) ;_ end of setq LST-AS




(setq lst 
  (mapcar
    '(lambda (EL-LST / EL-AS)
       (setq EL-AS
              (car
                (vl-remove-if-not
                  '(lambda (STR)
                     (wcmatch (cadr EL-LST) (strcat (car STR) "*"))
                   ) ;_ end of lambda
                  LST-AS
                ) ;_ end of vl-remove-if-not
              ) ;_ end of car
       ) ;_ end of setq
    (cons
     (car EL-LST)
       (cons
         (cond
           ((equal (car EL-AS) "-")
           (if (equal (caddr EL-LST) "-")
            (cadr EL-AS)
            (caddr EL-AS)
           ) ;_ end of if
           )
           ((member (car EL-AS) '("Уголок" "\\U+E720"))
             (if
               ((lambda (STR)
                  (equal
                    (vl-string-position (ascii "x") STR)
                    (vl-string-position (ascii "x") STR nil t)
                  ) ;_ end of equal
                ) ;_ end of lambda
                 (vl-string-translate "х" "x" (cadr EL-LST))
               )
                (cadr EL-AS)
                (caddr EL-AS)
             ) ;_ end of if
           )
           (t (cdr EL-AS))
         ) ;_ end of cond
         (cdr EL-LST)
       ) ;_ end of cons
      ) ;_ end of cons
     ) ;_ end of lambda
    lst
  ) ;_ end of mapcar
) ;_ end of setq


((lambda (/ b1 a1 a2 a3)
   (mapcar
     '(lambda (B A / b1 a1 a2 a3)
        ((lambda (dxf)
           (entmod
             (subst (cons 1 A)
                    (assoc 1 dxf)
                    dxf
             ) ;_ end of subst
           ) ;_ end of entmod
         ) ;_ end of lambda
          (entget B)
        )
      ) ;_ end of lambda
     (setq b1
            ((lambda (/ sset)
               (princ "\nВыберите шаблон спецификации: ")
               (if (setq sset (ssget '((0 . "*TEXT"))))
                 (vl-sort
                   (vl-sort
                     (vl-remove-if
                       (function listp)
                       (mapcar (function cadr)
                               (ssnamex sset)
                       ) ;_ end of mapcar
                     ) ;_ end of vl-remove-if
                     '(lambda (a b)
                        (> (caddr (assoc '10 (entget a)))
                           (caddr (assoc '10 (entget b)))
                        ) ;_ on Y
                      ) ;_ end of lambda
                   ) ;_ end of vl-sort
                   '(lambda (a b)
                      (and
                        (equal (caddr (assoc '10 (entget a)))
                               (caddr (assoc '10 (entget b)))
                               1.
                        ) ;_ end of equal
                        (< (cadr (assoc '10 (entget a)))
                           (cadr (assoc '10 (entget b)))
                        ) ;_ end of <
                      ) ;_ end of and
                    ) ;_ end of lambda
                 ) ;_ end of vl-sort
               ) ;_ end of if
             ) ;_ end of lambda
            )
     ) ;_ end of setq
     (progn
       (setq a1 (apply 'append lst)
             a1
                (append
                  a1
                  (if (not (minusp (setq a2 (- (length b1) (length a1)))))
                    (append (repeat a2 (setq a3 (cons "XX" a3))))
                  ) ;_ end of if
                ) ;_ end of append
       ) ;_ end of setq
     ) ;_ end of progn
   ) ;_ end of mapcar
 ) ;_ end of lambda
)

 
) ;_ end of defun ntt
__________________
Блог
Red Nova вне форума  
 
Непрочитано 14.10.2008, 15:43
#54
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

Все равно не понял - зачем чертить рамку с включенным osnap'ом, а потом тут же ее убивать? Естественно это сделать совсем не сложно, но зачем?
Теперь объясни, что будет если ты отфильтруешь например 15 выносок, а строк в спецификации будет 10? Куда девать оставшиеся 5? Ведь нет даже простой инфы о количестве элементов в отфильтрованном списке...
CB вне форума  
 
Автор темы   Непрочитано 14.10.2008, 15:53
#55
Red Nova

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

Цитата:
Все равно не понял - зачем чертить рамку с включенным osnap'ом, а потом тут же ее убивать
Просто VVA как-то сделал такое, и мне понравилось, но это конечно же мелочи и рассчитаны на любителя. А главное это то что все работает
Цитата:
Теперь объясни, что будет если ты отфильтруешь например 15 выносок, а строк в спецификации будет 10? Куда девать оставшиеся 5?
Хорошо бы было если бы в таком случае выходило сообщение о соответствующем несоответствии. Такого рода сообщение можно предусмотреть и на случаи несоответствия количества столбцов (когда не 4)
__________________
Блог
Red Nova вне форума  
 
Непрочитано 14.10.2008, 22:07
#56
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

Command: (LOAD "C:/Documents and Settings/Admin/Рабочий стол/Копия summa.lsp")
C:NTT

Command: NTT
; error: no function definition: _DWGRU-GET-SPDS-TEXT-AND-RANGE
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Автор темы   Непрочитано 14.10.2008, 23:22
#57
Red Nova

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

http://forum.dwg.ru/showpost.php?p=290874&postcount=472
__________________
Блог
Red Nova вне форума  
 
Автор темы   Непрочитано 15.10.2008, 15:09
#58
Red Nova

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

CB
Вот и применил заветный лисп в первый раз. Работу облегчает заметно.
Вот что обнаружил.
Имею две выноски с одинаковой позицией
Код:
[Выделить все] 
“1” “Ø10 А500с, L=1550”
“1” “ Ø10 А500с, шаг 150”
По задумке из этих двух в спецификацию должна пройти первая, и должно было записаться
Код:
[Выделить все] 
“1” “ГОСТ 5781-82” “Ø10 А500с” “L=1550”
Но проходит вторая выноска, и в конце получаем
Код:
[Выделить все] 
“1” “ГОСТ 5781-82” “Ø10 А500с” “L=”
В остальном все работает как надо.
__________________
Блог
Последний раз редактировалось Red Nova, 15.10.2008 в 20:50.
Red Nova вне форума  
 
Непрочитано 15.10.2008, 17:43
#59
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

Не понял почему у тебя хоть что-то проходит? Они должны отфильтроваться.
Цитата:
строка должна начинаться на определенные символы, вот их список
- Знак “-”, слова “Лист” и “Полоса”
- Слово “Труба”, “Тр.” и знак трубы из шрифтов СПДС
- Слово “Уголок” и аналогичные символы из шрифтов СПДС
- Слово “Двутавр” и аналогичные символы из шрифтов СПДС
- Слово “Швеллер” и аналогичные символы из шрифтов СПДС
- Слово “Фланец”, то же “Фл.”
- Стандартный знак диаметра и знак диаметра из шрифтов СПДС
- Символ квадратной трубы из шрифтов СПДС
CB вне форума  
 
Автор темы   Непрочитано 15.10.2008, 19:03
#60
Red Nova

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

Блин, на форуме знак диаметра отобразился как буква Ш, а я не заметил.
__________________
Блог
Red Nova вне форума  
 
Непрочитано 16.10.2008, 09:47
#61
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

Только что проверил на таком лиспе (т.к. нет СПДС)
Код:
[Выделить все] 
(defun ntt (lst / CB-filtr lst);note to text
  (defun CB-filtr (lst)
    (setq lst
           (vl-remove-if
             '(lambda (x)
                (or
                  (not (equal (length x) 2))
                  (member "" x)
                  (not
                    (wcmatch
                      (vl-string-translate "Tp" "Тр" (cadr x))
                      "\\U+E72E*,Труба*,Тр.*,Лист*,Полоса*,\\U+E720*,Уголок*,\\U+E725*,Швеллер*,\\U+E729*,Двутавр*,Фланец*,Фл.*,-*,%%c*,\\U+E712*,#%%c*,# %%c*,##%%c*,## %%c*,#\\U+E712*,# \\U+E712*,##\\U+E712*,## \\U+E712*"
                    ) ;_ end of wcmatch
                  ) ;_ end of not
                  (not
                    (or
                      (and
                        (wcmatch (car x) "@*")
                        (wcmatch (vl-string-right-trim "1234567890'\"" (car x))
                                 "@"
                        ) ;_ end of wcmatch
                      ) ;_ end of and
                      (and (wcmatch (car x) "#*")
                           (wcmatch (vl-string-left-trim "1234567890" (car x))
                                    ",@,@',@\",',\""
                           ) ;_ end of wcmatch
                      ) ;_ end of and
                    ) ;_ end of or
                  ) ;_ end of not
                ) ;_ end of or
              ) ;_ end of lambda
             lst
           ) ;_ end of vl-remove-if
    ) ;_ end of setq
    (setq lst
           ((lambda (lst / poz temp)
              (defun poz (str pat / p n)
                (while (setq n (vl-string-search pat str n))
                  (setq p (cons n p)
                        n (1+ n)
                  ) ;_ end of setq
                ) ;_ end of while
                p
              ) ;_ end of defun
              (while lst
                (setq
                  temp
                   (cons
                     ((lambda (lst-temp / n)
                        (list
                          (car lst-temp)
                          (vl-string-left-trim
                            "1234567890 "
                            (if (or
                                  (equal (length
                                           (setq n (poz (cadr lst-temp) ","))
                                         ) ;_ end of length
                                         2
                                  ) ;_ end of equal
                                  (not (wcmatch (cadr lst-temp) "*L=*"))
                                ) ;_ end of or
                              (substr (cadr lst-temp)
                                      1
                                      (if (wcmatch (cadr lst-temp) "*L=*")
                                        (car n)
                                        (car (reverse n))
                                      ) ;_ end of if
                              ) ;_ end of substr
                              (cadr lst-temp)
                            ) ;_ end of if
                          ) ;_ end of vl-string-left-trim
                        ) ;_ end of list
                      ) ;_ end of lambda
                       (car
                         (vl-sort
                           (vl-remove-if-not
                             '(lambda (x) (equal (caar lst) (car x)))
                             lst
                           ) ;_ end of vl-remove-if-not
                           '(lambda (str1 str2)
                              (> (length (poz (cadr str1) ","))
                                 (length (poz (cadr str2) ","))
                              ) ;_ end of >
                            ) ;_ end of lambda
                         ) ;_ end of vl-sort
                       ) ;_ end of car
                     )
                     temp
                   ) ;_ end of cons
                ) ;_ end of setq
                (setq lst
                       (vl-remove-if '(lambda (x) (equal (caar lst) (car x))) lst)
                ) ;_ end of setq
                (reverse temp)
              ) ;_ end of while
            ) ;_ end of lambda
             lst
           )
    ) ;_ end of setq
  ) ;_ end of defun
  (setq lst (mapcar '(lambda (x)
                       (list (vl-string-trim " " (car x))
                             (vl-string-trim " " (cadr x))
                       ) ;_ end of list
                     ) ;_ end of lambda
               lst
;;;                    (_dwgru-get-spds-text-and-range) ; из #472 
            ) ;_ end of mapcar
        lst (CB-filtr lst)
        lst (mapcar
              '(lambda (x / p)
                 (if (setq p (vl-string-position (ascii ",") (cadr x)))
                   (list
                     (car x)
                     (substr (cadr x) 1 p)
                     (vl-string-left-trim " " (substr (cadr x) (+ 2 p)))
                   ) ;_ end of list
                   (if (wcmatch (cadr x) "-*,Лист*,Фл*")
                     (append x '("-"))
                     (append x '("L="))
                   ) ;_ end of if
                 ) ;_ end of if
               ) ;_ end of lambda
              lst
            ) ;_ end of mapcar
  ) ;_ end of setq
  (setq lst
         (mapcar
           '(lambda (x) (nth x lst))
           (vl-sort-i
             ((lambda (lst)
                (mapcar
                  '(lambda (str1 str2)
                     (if (wcmatch str2 "@*")
                       (strcat (substr str2 1 1) str1 (substr str2 2))
                       (strcat str1 str2)
                     ) ;_ end of if
                   ) ;_ end of lambda
                  (mapcar
                    '(lambda (x / str)
                       (setq str "0")
                       (repeat x
                         (setq str (strcat str "0"))
                       ) ;_ end of repeat
                       str
                     ) ;_ end of lambda
                    ((lambda (a)
                       (mapcar '(lambda (x) (- (apply 'max a) x)) a)
                     ) ;_ end of lambda
                      (mapcar
                        '(lambda (str)
                           (length
                             (vl-remove-if-not
                               '(lambda (x)
                                  (wcmatch x "#")
                                ) ;_ end of lambda
                               (mapcar 'chr (vl-string->list str))
                             ) ;_ end of vl-remove-if-not
                           ) ;_ end of length
                         ) ;_ end of lambda
                        lst
                      ) ;_ end of mapcar
                    )
                  ) ;_ end of mapcar
                  lst
                ) ;_ end of mapcar
              ) ;_ end of lambda
               (mapcar 'strcase (mapcar 'car lst))
             )
             '<
           ) ;_ end of vl-sort-i
         ) ;_ end of mapcar
  ) ;_ end of setq
 
 
  (setq LST-AS
         (apply
           'append
           (mapcar
             '(lambda (X Y)
                (mapcar
                  '(lambda (Z)
                     (cons Z Y)
                   ) ;_ end of lambda
                  X
                ) ;_ end of mapcar
              ) ;_ end of lambda
             (list (list "Лист -" "Лист-" "Фл")
                   (list "Лист чечевица" "Лист ромб")
                   (list "-")
                   (list "Полоса")
                   (list "Уголок" "\\U+E720")
                   (list "\\U+E72E")
                   (list "Тр")
                   (list "Двутавр" "\\U+E729")
                   (list "Швеллер" "\\U+E725")
                   (list "%%c" "\\U+E712")
             ) ;_ end of list
             (list "ГОСТ 19903-74"
                   "ГОСТ 8568-77"
                   (list "ГОСТ 19903-74" "ГОСТ 103-76")
                   "ГОСТ 103-76"
                   (list "ГОСТ 8509-93" "ГОСТ 8510-86")
                   "ГОСТ 30245-03"
                   "ГОСТ 10704-91"
                   "ГОСТ 8239-89"
                   "ГОСТ 8240-97"
                   "ГОСТ 5781-82"
             ) ;_ end of list
           ) ;_ end of mapcar
         ) ;_ end of apply
  ) ;_ end of setq LST-AS
 
  (setq lst
         (mapcar
           '(lambda (EL-LST / EL-AS)
              (setq EL-AS
                     (car
                       (vl-remove-if-not
                         '(lambda (STR)
                            (wcmatch (cadr EL-LST) (strcat (car STR) "*"))
                          ) ;_ end of lambda
                         LST-AS
                       ) ;_ end of vl-remove-if-not
                     ) ;_ end of car
              ) ;_ end of setq
              (cons
                (car EL-LST)
                (cons
                  (cond
                    ((equal (car EL-AS) "-")
                     (if (equal (caddr EL-LST) "-")
                       (cadr EL-AS)
                       (caddr EL-AS)
                     ) ;_ end of if
                    )
                    ((member (car EL-AS) '("Уголок" "\\U+E720"))
                     (if
                       ((lambda (STR)
                          (equal
                            (vl-string-position (ascii "x") STR)
                            (vl-string-position (ascii "x") STR nil t)
                          ) ;_ end of equal
                        ) ;_ end of lambda
                         (vl-string-translate "х" "x" (cadr EL-LST))
                       )
                        (cadr EL-AS)
                        (caddr EL-AS)
                     ) ;_ end of if
                    )
                    (t (cdr EL-AS))
                  ) ;_ end of cond
                  (cdr EL-LST)
                ) ;_ end of cons
              ) ;_ end of cons
            ) ;_ end of lambda
           lst
         ) ;_ end of mapcar
  ) ;_ end of setq
 
;;;  ((lambda (/ b1 a1 a2 a3)
;;;     (mapcar
;;;       '(lambda (B A / b1 a1 a2 a3)
;;;          ((lambda (dxf)
;;;             (entmod
;;;               (subst (cons 1 A)
;;;                      (assoc 1 dxf)
;;;                      dxf
;;;               ) ;_ end of subst
;;;             ) ;_ end of entmod
;;;           ) ;_ end of lambda
;;;            (entget B)
;;;          )
;;;        ) ;_ end of lambda
;;;       (setq b1
;;;              ((lambda (/ sset)
;;;                 (princ "\nВыберите шаблон спецификации: ")
;;;                 (if (setq sset (ssget '((0 . "*TEXT"))))
;;;                   (vl-sort
;;;                     (vl-sort
;;;                       (vl-remove-if
;;;                         (function listp)
;;;                         (mapcar (function cadr)
;;;                                 (ssnamex sset)
;;;                         ) ;_ end of mapcar
;;;                       ) ;_ end of vl-remove-if
;;;                       '(lambda (a b)
;;;                          (> (caddr (assoc '10 (entget a)))
;;;                             (caddr (assoc '10 (entget b)))
;;;                          ) ;_ on Y
;;;                        ) ;_ end of lambda
;;;                     ) ;_ end of vl-sort
;;;                     '(lambda (a b)
;;;                        (and
;;;                          (equal (caddr (assoc '10 (entget a)))
;;;                                 (caddr (assoc '10 (entget b)))
;;;                                 1.
;;;                          ) ;_ end of equal
;;;                          (< (cadr (assoc '10 (entget a)))
;;;                             (cadr (assoc '10 (entget b)))
;;;                          ) ;_ end of <
;;;                        ) ;_ end of and
;;;                      ) ;_ end of lambda
;;;                   ) ;_ end of vl-sort
;;;                 ) ;_ end of if
;;;               ) ;_ end of lambda
;;;              )
;;;       ) ;_ end of setq
;;;       (progn
;;;         (setq a1 (apply 'append lst)
;;;               a1
;;;                  (append
;;;                    a1
;;;                    (if (not (minusp (setq a2 (- (length b1) (length a1)))))
;;;                      (append (repeat a2 (setq a3 (cons "XX" a3))))
;;;                    ) ;_ end of if
;;;                  ) ;_ end of append
;;;         ) ;_ end of setq
;;;       ) ;_ end of progn
;;;     ) ;_ end of mapcar
;;;   ) ;_ end of lambda
;;;  )
 
) ;_ end of defun ntt
 
Проверка
(setq lst '(("1" "%%c10 А500с, L=1550") ("1" " %%c10 А500с, шаг 150")))
(ntt lst) -> (("1" "ГОСТ 5781-82" "%%c10 А500с" "L=1550"))
Так что сделай так - выбери только эти две выноски
Код:
[Выделить все] 
 
(setq lst (mapcar '(lambda (x)
                     (list (vl-string-trim " " (car x))
                           (vl-string-trim " " (cadr x))
                     ) ;_ end of list
                   ) ;_ end of lambda
;;;                    lst
                  (_dwgru-get-spds-text-and-range) ; из #472 
          ) ;_ end of mapcar
) ;_ end of setq
Загрузи отдельно функцию CB-filtr, выполни (CB-filtr lst) и посмотри что получится.
CB вне форума  
 
Автор темы   Непрочитано 16.10.2008, 10:45
#62
Red Nova

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

Возвращяет
Код:
[Выделить все] 
(("1" "Ш10 A500c"))
Ш как всегда диаметр
__________________
Блог
Последний раз редактировалось Red Nova, 16.10.2008 в 10:51.
Red Nova вне форума  
 
Непрочитано 16.10.2008, 11:12
#63
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

Давай файл...
CB вне форума  
 
Автор темы   Непрочитано 16.10.2008, 11:20
#64
Red Nova

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

Вот файл.
Если выбрать только "правлиьную" выноску то предыдущим тестом вернет
Код:
[Выделить все] 
(("5" "Ш12 A500c, L=1000"))
Вложения
Тип файла: dwg
DWG 2004		 Спецификация2.dwg (56.9 Кб, 728 просмотров)
__________________
Блог
Red Nova вне форума  
 
Непрочитано 16.10.2008, 12:26
#65
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

Нда... Проверить не могу из-за отсутствия СПДС.
Зайди в лисп-редактор, вставь туда код (setq lst (mapcar ....) приведенный выше, выполни его оттуда же, скопируй полученный результат в буфер и выложи сюда. Ну не может возращаться значение "Ш12 A500c,... - должно либо "\\U+E71212 А500с, либо "%%c12 А500с...
CB вне форума  
 
Автор темы   Непрочитано 16.10.2008, 12:37
#66
Red Nova

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

Открыл Vlide, в новом файле вставил код, произвел load text in editor, в автокаде выбрал выноски, вернулся в Vlide. Что за результат (и где) я должен получить не понял.
__________________
Блог
Red Nova вне форума  
 
Автор темы   Непрочитано 16.10.2008, 12:40
#67
Red Nova

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

А если просто присвоить спивку lst то что выдает _dwgru-get-spds-text-and-range а дальше тестировать уже как обычный список?
_dwgru-get-spds-text-and-range выдает.
(("5" "Ш12 A500c, шаг 1000" 1) ("5" "Ш12 A500c, L=1000" 1))


Цитата:
"Ш12 A500c,... - должно либо "\\U+E71212 А500с, либо "%%c12 А500с...
Только что допетрил о чем ты. Дык выдает нормальный знак диаметра, который в автокаде (в ком строке) виден как квадрат, а когда я на форуме пытаюсь написать диаметр, то пишет Ш или , но это уже из за шрифтов форума. Если этот знак ввести в соответствующий шрифт (хоть в конечную спеку), то там все нормализуется
__________________
Блог
Последний раз редактировалось Red Nova, 16.10.2008 в 12:46.
Red Nova вне форума  
 
Непрочитано 16.10.2008, 13:20
#68
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

Цитата:
Что за результат (и где) я должен получить не понял.
В окне редактора - Visual LISP Console получить список, который возращает lst.
CB вне форума  
 
Автор темы   Непрочитано 16.10.2008, 13:35
#69
Red Nova

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

Списка там нет
Вот смотри сам
Вложения
Тип файла: rar Пример.rar (72.1 Кб, 91 просмотров)
__________________
Блог
Red Nova вне форума  
 
Непрочитано 16.10.2008, 14:18
#70
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

Понятно...
Подводишь курсор к началу кода, который нужно выполнить, делаешь двойной клик - он выделяется. Нажимаешь кнопку Load selection, смотришь результат выполнения в Visual LISP Console ...
Миниатюры
Нажмите на изображение для увеличения Название: Безимени-1.jpg Просмотров: 136 Размер: 126.0 Кб ID: 11156  
CB вне форума  
 
Автор темы   Непрочитано 16.10.2008, 14:31
#71
Red Nova

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

Аа, вот значит как надо.
Ну тогда и у меня результат идентичен с твоим
Код:
[Выделить все] 
(("5" "\U+E71212 A500c, шаг 1000") ("5" "\U+E71212 A500c, L=1000"))
__________________
Блог
Red Nova вне форума  
 
Непрочитано 16.10.2008, 17:34
#72
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

Тестируй:
Код:
[Выделить все] 
(defun c:ntt (/ CB-filtr lst LST-AS)    ;note to text
  (defun CB-filtr (lst)
    (setq
      lst
       (vl-remove-if
         '(lambda (x)
            (or
              (not (equal (length x) 2))
              (member "" x)
              (not
                (wcmatch
                  (vl-string-translate "Tp" "Тр" (cadr x))
;;;                  "*E72E*,Труба*,Тр.*,Лист*,Полоса*,*E720*,Уголок*,*E725*,Швеллер*,*E729*,Двутавр*,Фланец*,Фл.*,-*,%%c*,*E712*,#%%c*,# %%c*,##%%c*,## %%c*,#*E712*,# *E712*,##*E712*,## *E712*"
                  "\\U+E72E*,Труба*,Тр.*,Лист*,Полоса*,\\U+E720*,Уголок*,\\U+E725*,Швеллер*,\\U+E729*,Двутавр*,Фланец*,Фл.*,-*,%%c*,\\U+E712*,#%%c*,# %%c*,##%%c*,## %%c*,#\\U+E712*,# \\U+E712*,##\\U+E712*,## \\U+E712*"
                ) ;_ end of wcmatch
              ) ;_ end of not
              (not
                (or
                  (and
                    (wcmatch (car x) "@*")
                    (wcmatch (vl-string-right-trim "1234567890'\"" (car x))
                             "@"
                    ) ;_ end of wcmatch
                  ) ;_ end of and
                  (and (wcmatch (car x) "#*")
                       (wcmatch (vl-string-left-trim "1234567890" (car x))
                                ",@,@',@\",',\""
                       ) ;_ end of wcmatch
                  ) ;_ end of and
                ) ;_ end of or
              ) ;_ end of not
            ) ;_ end of or
          ) ;_ end of lambda
         lst
       ) ;_ end of vl-remove-if
    ) ;_ end of setq
    (setq lst
           ((lambda (lst / poz temp)
              (defun poz (str pat / p n)
                (while (setq n (vl-string-search pat str n))
                  (setq p (cons n p)
                        n (1+ n)
                  ) ;_ end of setq
                ) ;_ end of while
                p
              ) ;_ end of defun
              (while lst
                (setq
                  temp
                   (cons
                     ((lambda (lst-temp / n)
                        (list
                          (car lst-temp)
                          (vl-string-left-trim
                            "1234567890 "
                            (if (or
                                  (equal (length
                                           (setq n (poz (cadr lst-temp) ","))
                                         ) ;_ end of length
                                         2
                                  ) ;_ end of equal
                                  (not (wcmatch (cadr lst-temp) "*L=*"))
                                ) ;_ end of or
                              (substr (cadr lst-temp)
                                      1
                                      (if (wcmatch (cadr lst-temp) "*L=*")
                                        (car n)
                                        (car (reverse n))
                                      ) ;_ end of if
                              ) ;_ end of substr
                              (cadr lst-temp)
                            ) ;_ end of if
                          ) ;_ end of vl-string-left-trim
                        ) ;_ end of list
                      ) ;_ end of lambda
                       (car
                         (vl-sort
                           (vl-remove-if-not
                             '(lambda (x) (equal (caar lst) (car x)))
                             lst
                           ) ;_ end of vl-remove-if-not
                           '(lambda (str1 str2)
                              (>
                                (+ (length (poz (cadr str1) ","))
                                   (if (wcmatch (cadr str1) "*L=*")
                                     1
                                     0
                                   ) ;_ end of if
                                ) ;_ end of +
                                (+ (length (poz (cadr str2) ","))
                                   (if (wcmatch (cadr str2) "*L=*")
                                     1
                                     0
                                   ) ;_ end of if
                                ) ;_ end of +
                              ) ;_ end of >
                            ) ;_ end of lambda
                         ) ;_ end of vl-sort
                       ) ;_ end of car
                     )
                     temp
                   ) ;_ end of cons
                ) ;_ end of setq
                (setq lst
                       (vl-remove-if '(lambda (x) (equal (caar lst) (car x))) lst)
                ) ;_ end of setq
                (reverse temp)
              ) ;_ end of while
            ) ;_ end of lambda
             lst
           )
    ) ;_ end of setq
  ) ;_ end of defun
  (setq lst (mapcar '(lambda (x)
                       (list (vl-string-trim " " (car x))
                             (vl-string-trim " " (cadr x))
                       ) ;_ end of list
                     ) ;_ end of lambda
;;;                    lst
                    (_dwgru-get-spds-text-and-range) ; из #472 
            ) ;_ end of mapcar
  ) ;_ end of setq
  (setq lst (CB-filtr lst))
  (setq lst
         (mapcar
           '(lambda (x / p)
              (if (setq p (vl-string-position (ascii ",") (cadr x)))
                (list
                  (car x)
                  (substr (cadr x) 1 p)
                  (vl-string-left-trim " " (substr (cadr x) (+ 2 p)))
                ) ;_ end of list
                (if (wcmatch (cadr x) "-*,Лист*,Фл*")
                  (append x '("-"))
                  (append x '("L="))
                ) ;_ end of if
              ) ;_ end of if
            ) ;_ end of lambda
           lst
         ) ;_ end of mapcar
  ) ;_ end of setq
  (setq lst
         (mapcar
           '(lambda (x) (nth x lst))
           (vl-sort-i
             ((lambda (lst)
                (mapcar
                  '(lambda (str1 str2)
                     (if (wcmatch str2 "@*")
                       (strcat (substr str2 1 1) str1 (substr str2 2))
                       (strcat str1 str2)
                     ) ;_ end of if
                   ) ;_ end of lambda
                  (mapcar
                    '(lambda (x / str)
                       (setq str "0")
                       (repeat x
                         (setq str (strcat str "0"))
                       ) ;_ end of repeat
                       str
                     ) ;_ end of lambda
                    ((lambda (a)
                       (mapcar '(lambda (x) (- (apply 'max a) x)) a)
                     ) ;_ end of lambda
                      (mapcar
                        '(lambda (str)
                           (length
                             (vl-remove-if-not
                               '(lambda (x)
                                  (wcmatch x "#")
                                ) ;_ end of lambda
                               (mapcar 'chr (vl-string->list str))
                             ) ;_ end of vl-remove-if-not
                           ) ;_ end of length
                         ) ;_ end of lambda
                        lst
                      ) ;_ end of mapcar
                    )
                  ) ;_ end of mapcar
                  lst
                ) ;_ end of mapcar
              ) ;_ end of lambda
               (mapcar 'strcase (mapcar 'car lst))
             )
             '<
           ) ;_ end of vl-sort-i
         ) ;_ end of mapcar
  ) ;_ end of setq
  (setq LST-AS
         (apply
           'append
           (mapcar
             '(lambda (X Y)
                (mapcar
                  '(lambda (Z)
                     (cons Z Y)
                   ) ;_ end of lambda
                  X
                ) ;_ end of mapcar
              ) ;_ end of lambda
             (list (list "Лист -" "Лист-" "Фл")
                   (list "Лист чечевица" "Лист ромб")
                   (list "-")
                   (list "Полоса")
                   (list "Уголок" "\\U+E720")
                   (list "\\U+E72E")
                   (list "Тр")
                   (list "Двутавр" "\\U+E729")
                   (list "Швеллер" "\\U+E725")
                   (list "%%c" "\\U+E712")
             ) ;_ end of list
             (list "ГОСТ 19903-74"
                   "ГОСТ 8568-77"
                   (list "ГОСТ 19903-74" "ГОСТ 103-76")
                   "ГОСТ 103-76"
                   (list "ГОСТ 8509-93" "ГОСТ 8510-86")
                   "ГОСТ 30245-03"
                   "ГОСТ 10704-91"
                   "ГОСТ 8239-89"
                   "ГОСТ 8240-97"
                   "ГОСТ 5781-82"
             ) ;_ end of list
           ) ;_ end of mapcar
         ) ;_ end of apply
  ) ;_ end of setq LST-AS
  (setq lst
         (mapcar
           '(lambda (EL-LST / EL-AS)
              (setq EL-AS
                     (car
                       (vl-remove-if-not
                         '(lambda (STR)
                            (wcmatch (cadr EL-LST) (strcat (car STR) "*"))
                          ) ;_ end of lambda
                         LST-AS
                       ) ;_ end of vl-remove-if-not
                     ) ;_ end of car
              ) ;_ end of setq
              (cons
                (car EL-LST)
                (cons
                  (cond
                    ((equal (car EL-AS) "-")
                     (if (equal (caddr EL-LST) "-")
                       (cadr EL-AS)
                       (caddr EL-AS)
                     ) ;_ end of if
                    )
                    ((member (car EL-AS) '("Уголок" "\\U+E720"))
                     (if
                       ((lambda (STR)
                          (equal
                            (vl-string-position (ascii "x") STR)
                            (vl-string-position (ascii "x") STR nil t)
                          ) ;_ end of equal
                        ) ;_ end of lambda
                         (vl-string-translate "х" "x" (cadr EL-LST))
                       )
                        (cadr EL-AS)
                        (caddr EL-AS)
                     ) ;_ end of if
                    )
                    (t (cdr EL-AS))
                  ) ;_ end of cond
                  (cdr EL-LST)
                ) ;_ end of cons
              ) ;_ end of cons
            ) ;_ end of lambda
           lst
         ) ;_ end of mapcar
  ) ;_ end of setq
  ((lambda (/ b1 a1 a2 a3)
     (mapcar
       '(lambda (B A / b1 a1 a2 a3)
          ((lambda (dxf)
             (entmod
               (subst (cons 1 A)
                      (assoc 1 dxf)
                      dxf
               ) ;_ end of subst
             ) ;_ end of entmod
           ) ;_ end of lambda
            (entget B)
          )
        ) ;_ end of lambda
       (setq b1
              ((lambda (/ sset)
                 (princ "\nВыберите шаблон спецификации: ")
                 (if (setq sset (ssget '((0 . "*TEXT"))))
                   (vl-sort
                     (vl-sort
                       (vl-remove-if
                         (function listp)
                         (mapcar (function cadr)
                                 (ssnamex sset)
                         ) ;_ end of mapcar
                       ) ;_ end of vl-remove-if
                       '(lambda (a b)
                          (> (caddr (assoc '10 (entget a)))
                             (caddr (assoc '10 (entget b)))
                          ) ;_ on Y
                        ) ;_ end of lambda
                     ) ;_ end of vl-sort
                     '(lambda (a b)
                        (and
                          (equal (caddr (assoc '10 (entget a)))
                                 (caddr (assoc '10 (entget b)))
                                 1.
                          ) ;_ end of equal
                          (< (cadr (assoc '10 (entget a)))
                             (cadr (assoc '10 (entget b)))
                          ) ;_ end of <
                        ) ;_ end of and
                      ) ;_ end of lambda
                   ) ;_ end of vl-sort
                 ) ;_ end of if
               ) ;_ end of lambda
              )
       ) ;_ end of setq
       (progn
         (setq a1 (apply 'append lst)
               a1
                  (append
                    a1
                    (if (not (minusp (setq a2 (- (length b1) (length a1)))))
                      (append (repeat a2 (setq a3 (cons "XX" a3))))
                    ) ;_ end of if
                  ) ;_ end of append
         ) ;_ end of setq
       ) ;_ end of progn
     ) ;_ end of mapcar
   ) ;_ end of lambda
  )
) ;_ end of defun ntt
CB вне форума  
 
Автор темы   Непрочитано 16.10.2008, 17:40
#73
Red Nova

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

Спасибо, работает.
__________________
Блог
Red Nova вне форума  
 
Непрочитано 16.10.2008, 21:11
#74
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

Red Nova, а у меня нет почемуто
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Автор темы   Непрочитано 17.10.2008, 18:53
#75
Red Nova

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

Добавь в автозагрузку лисп по ссылке с #57
__________________
Блог
Red Nova вне форума  
 
Непрочитано 22.10.2008, 22:22
#76
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

Red Nova,

Command: (LOAD "C:/Documents and Settings/Admin/Рабочий стол/Копия Копия
summa.lsp") _DWGRU-GET-SPDS-TEXT-AND-RANGE

Command:
Command: (LOAD "C:/Documents and Settings/Admin/Рабочий стол/Копия summa.lsp")
C:NTT

Command: NTT

Select objects: Specify opposite corner: 1 found




Select objects:
; error: no function definition: _DWGRU-CONV-PICKSET-TO-LIST

Может выложишь автокадовский файл с спдсными выносками чтобы посмотреть что и как считает?
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Непрочитано 22.10.2008, 22:52
#77
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 36,746

dextron3, посмотри в библиотеке (ссылка в подписи)
__________________

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 23.10.2008, 07:50
#78
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

>dextron3
Файл здесь: #64
CB вне форума  
 
Непрочитано 23.10.2008, 10:28
#79
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

CB, я бы хотел увидеть видеоролик как все это работает,
Red Nova, не могли бы выложить, чтобы понять принципику, и увидеть результат автоматизации, будет более наглядно, даже без объяснений....

заранее благодарен...
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Непрочитано 23.10.2008, 10:52
#80
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

>dextron3
А чем не устраивает ролик в #52 ?
CB вне форума  
 
Непрочитано 23.10.2008, 21:46
#81
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

CB, не могу понять что я делаю не так?

Command:
NTT
Select objects: Specify opposite corner: 1 found

Select objects:
; error: no function definition: _DWGRU-CONV-PICKSET-TO-LIST
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Автор темы   Непрочитано 23.10.2008, 22:33
#82
Red Nova

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

В библиотеке есть.
__________________
Блог
Последний раз редактировалось Red Nova, 23.10.2008 в 22:46.
Red Nova вне форума  
 
Непрочитано 23.10.2008, 22:40
#83
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 36,746

Исходник (_dwgru-conv-pickset-to-list)
__________________

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 24.10.2008, 06:16
#84
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

Кулик Алексей aka kpblc, спасибо, почему нельзя в один лисп все загнать?



Red Nova, буду тестировать, но я работаю с отдельными текстами, а не м текстами,

СВ, хотел спросить я обычно вместо диаметра иногда букву Ф (Федя) пишу, это в лиспе предусмотрено?

буду усиленно тестировать...
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Непрочитано 24.10.2008, 08:51
#85
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 36,746

Цитата:
почему нельзя в один лисп все загнать?
А смысл? Функция преобразования набора примитивов в список используется не только в этой задаче.
__________________

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 24.10.2008, 17:57
#86
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

Red Nova, а выноски для болтов гаек, и остальных профилей как выглядят?
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Автор темы   Непрочитано 25.10.2008, 11:11
#87
Red Nova

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

dextron3, Таких нема. Я обычно их отдельной спецификацией делаю, и без нумерации.
__________________
Блог
Red Nova вне форума  
 
Непрочитано 25.10.2008, 19:31
#88
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

Мои замечания по работе программы:

1. Не узнает двутавры Б1, Б2 по госту ГОСТ 26020-83 и СТО АСЧМ 20-93
2. Подскажи где можно редактировавть распозновательные функции, чтобы я мог сам забить недостающие элементы. (согласно пункту 1), хотелось бы видеть эту часть кода. (есть ли возможность не только по префиксу но и по суффиксу выполнять детектирование)
3. Можно ли установить параметр КОЛ-ВО, после длины, в нижней части выноски, это бы вообще полностью автоматизировало процесс проектирования.

Идея мне понравилась буду тестировать по полной, я ведь заядлый пользователь СПДС
__________________
инженер проектировшик с опттом программа авто гад образование высшие
Последний раз редактировалось dextron3, 25.10.2008 в 19:44.
dextron3 вне форума  
 
Непрочитано 25.10.2008, 19:43
#89
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

4. Госты гнуты профилей квадратных и прямоугольных почемуто не различает...
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Автор темы   Непрочитано 25.10.2008, 23:49
#90
Red Nova

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

dextron3,
Добавить двутавры Б1, Б2 по госту ГОСТ 26020-83 или по СТО АСЧМ 20-93 (а оставить в любом случае нужно только один из них) можно, и по логике не очень сложно, но одно дело логика, а другое программирование, и нам с тобой этого не одолеть. Без помощи СВ не обойтись.
А логика такая.
Вот в этом месте
Код:
[Выделить все] 
           (list (list "Лист -" "Лист-" "Фл")
                 (list "Лист чечевица" "Лист ромб")
                 (list "-")
                 (list "Полоса")
                 (list "Уголок" "\\U+E720")
                 (list "\\U+E72E")
                 (list "Тр")
                 (list "Двутавр" "\\U+E729")
                 (list "Швеллер" "\\U+E725")
                 (list "%%c" "\\U+E712")
           ) ;_ end of list
           (list "ГОСТ 19903-74"
                 "ГОСТ 8568-77"
                 (list "ГОСТ 19903-74" "ГОСТ 103-76")
                 "ГОСТ 103-76"
                 (list "ГОСТ 8509-93" "ГОСТ 8510-86")
                 "ГОСТ 30245-03"
                 "ГОСТ 10704-91"
                 "ГОСТ 8239-89"
                 "ГОСТ 8240-97"
                 "ГОСТ 5781-82"
           ) ;_ end of list
Производится назначение ГОСТ-ов разным профилям. Проблема в том, что сейчас, если профиль начинается на "Двутавр" или "\\U+E729" то он автоматически причисляется к "ГОСТ 8239-89". Чтобы распознавался ГОСТ 26020-83, нужно усложнить условие для этого профиля.
Профиль для этого ГОСТа имеет свое специфическое обозначение. Пишется к примеру "Двутавр 20Б1"
Причем
1. Вместо буквы "Б" могут быть и буквы "К" и "Ш"
2. Вместо "Двутавр" может быть знак двутавра шрифта СПДС "\\U+E729"
3. Номера двутавров бывают не только двузначными, но и трехзначными (к примеру 100Ш1).
Следовательно чтобы различить ГОСТ 26020-83 и ГОСТ 8239-89 нужно проверить что написано после "Двутавр". Если после этого идут две или цифры, и после этого сразу (без пробела) буквы "Б", "К" или "Ш", то это ГОСТ 26020-83 иначе это ГОСТ 8239-89.

P.S. Если по каким то причинам нужен именно СТО АСЧМ 20-93, то поскольку там принцип написания тот же, то нужно будет просто вместо ГОСТ 26020-83 написать СТО АСЧМ 20-93.

P.P.S.
Цитата:
хотел спросить я обычно вместо диаметра иногда букву Ф (Федя) пишу, это в лиспе предусмотрено?
От плохих привычек надо отвыкать...
__________________
Блог
Red Nova вне форума  
 
Непрочитано 26.10.2008, 18:26
#91
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

Red Nova, будем ждать VVA и СВ, а почему не сформировал ТЗ сразу с часто используемыми профилями?

можно было конечно делать \\U+E729Б1 а потом размер указывать, что ты на это скажешь, или ГОСТЫ так не разрешают?

Объясни принцип действия кода, какми образом определяются равнополочные и разнополочные уголки, хотябы
__________________
инженер проектировшик с опттом программа авто гад образование высшие
Последний раз редактировалось dextron3, 26.10.2008 в 19:51.
dextron3 вне форума  
 
Непрочитано 26.10.2008, 20:43
#92
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,799
<phrase 1= Отправить сообщение для VVA с помощью Skype™

Red Nova, В общем мыслишь в правильном направлении.
Цитата:
Проблема в том, что сейчас, если профиль начинается на "Двутавр" или "\\U+E729" то он автоматически причисляется к "ГОСТ 8239-89"
Шаблон для двутавров СТО АЧСМ нужно разместить в списке выше шаблона для двутавра
Примерно так (выделил красным)
Код:
[Выделить все] 
(defun c:ntt (/ CB-filtr lst LST-AS)    ;note to text
  (defun CB-filtr (lst)
    (setq
      lst
       (vl-remove-if
         '(lambda (x)
            (or
              (not (equal (length x) 2))
              (member "" x)
              (not
                (wcmatch
                  (vl-string-translate "Tp" "Тр" (cadr x))
;;;                  "*E72E*,Труба*,Тр.*,Лист*,Полоса*,*E720*,Уголок*,*E725*,Швеллер*,*E729*,Двутавр*,Фланец*,Фл.*,-*,%%c*,*E712*,#%%c*,# %%c*,##%%c*,## %%c*,#*E712*,# *E712*,##*E712*,## *E712*"
                  "\\U+E72E*,Труба*,Тр.*,Лист*,Полоса*,\\U+E720*,Уголок*,\\U+E725*,Швеллер*,\\U+E729*,Двутавр*,Фланец*,Фл.*,-*,%%c*,\\U+E712*,#%%c*,# %%c*,##%%c*,## %%c*,#\\U+E712*,# \\U+E712*,##\\U+E712*,## \\U+E712*"
                ) ;_ end of wcmatch
              ) ;_ end of not
              (not
                (or
                  (and
                    (wcmatch (car x) "@*")
                    (wcmatch (vl-string-right-trim "1234567890'\"" (car x))
                             "@"
                    ) ;_ end of wcmatch
                  ) ;_ end of and
                  (and (wcmatch (car x) "#*")
                       (wcmatch (vl-string-left-trim "1234567890" (car x))
                                ",@,@',@\",',\""
                       ) ;_ end of wcmatch
                  ) ;_ end of and
                ) ;_ end of or
              ) ;_ end of not
            ) ;_ end of or
          ) ;_ end of lambda
         lst
       ) ;_ end of vl-remove-if
    ) ;_ end of setq
    (setq lst
           ((lambda (lst / poz temp)
              (defun poz (str pat / p n)
                (while (setq n (vl-string-search pat str n))
                  (setq p (cons n p)
                        n (1+ n)
                  ) ;_ end of setq
                ) ;_ end of while
                p
              ) ;_ end of defun
              (while lst
                (setq
                  temp
                   (cons
                     ((lambda (lst-temp / n)
                        (list
                          (car lst-temp)
                          (vl-string-left-trim
                            "1234567890 "
                            (if (or
                                  (equal (length
                                           (setq n (poz (cadr lst-temp) ","))
                                         ) ;_ end of length
                                         2
                                  ) ;_ end of equal
                                  (not (wcmatch (cadr lst-temp) "*L=*"))
                                ) ;_ end of or
                              (substr (cadr lst-temp)
                                      1
                                      (if (wcmatch (cadr lst-temp) "*L=*")
                                        (car n)
                                        (car (reverse n))
                                      ) ;_ end of if
                              ) ;_ end of substr
                              (cadr lst-temp)
                            ) ;_ end of if
                          ) ;_ end of vl-string-left-trim
                        ) ;_ end of list
                      ) ;_ end of lambda
                       (car
                         (vl-sort
                           (vl-remove-if-not
                             '(lambda (x) (equal (caar lst) (car x)))
                             lst
                           ) ;_ end of vl-remove-if-not
                           '(lambda (str1 str2)
                              (>
                                (+ (length (poz (cadr str1) ","))
                                   (if (wcmatch (cadr str1) "*L=*")
                                     1
                                     0
                                   ) ;_ end of if
                                ) ;_ end of +
                                (+ (length (poz (cadr str2) ","))
                                   (if (wcmatch (cadr str2) "*L=*")
                                     1
                                     0
                                   ) ;_ end of if
                                ) ;_ end of +
                              ) ;_ end of >
                            ) ;_ end of lambda
                         ) ;_ end of vl-sort
                       ) ;_ end of car
                     )
                     temp
                   ) ;_ end of cons
                ) ;_ end of setq
                (setq lst
                       (vl-remove-if '(lambda (x) (equal (caar lst) (car x))) lst)
                ) ;_ end of setq
                (reverse temp)
              ) ;_ end of while
            ) ;_ end of lambda
             lst
           )
    ) ;_ end of setq
  ) ;_ end of defun
;;;(setq lst '(("22" "Двутавр 20Б1" "-")("1" "-10х100x100" "-") ("2" "Швеллер 12" "L=1000") ("8" "Полоса -4х50" 
;;;"L=1000") ("14" "Уголок 75х5" "L=")))  
  (setq lst (mapcar '(lambda (x)
                       (list (vl-string-trim " " (car x))
                             (vl-string-trim " " (cadr x))
                       ) ;_ end of list
                     ) ;_ end of lambda
;;;                    lst
		    
                    (_dwgru-get-spds-text-and-range) ; из #472 
            ) ;_ end of mapcar
  ) ;_ end of setq
  (setq lst (CB-filtr lst))
  (setq lst
         (mapcar
           '(lambda (x / p)
              (if (setq p (vl-string-position (ascii ",") (cadr x)))
                (list
                  (car x)
                  (substr (cadr x) 1 p)
                  (vl-string-left-trim " " (substr (cadr x) (+ 2 p)))
                ) ;_ end of list
                (if (wcmatch (cadr x) "-*,Лист*,Фл*")
                  (append x '("-"))
                  (append x '("L="))
                ) ;_ end of if
              ) ;_ end of if
            ) ;_ end of lambda
           lst
         ) ;_ end of mapcar
  ) ;_ end of setq
  (setq lst
         (mapcar
           '(lambda (x) (nth x lst))
           (vl-sort-i
             ((lambda (lst)
                (mapcar
                  '(lambda (str1 str2)
                     (if (wcmatch str2 "@*")
                       (strcat (substr str2 1 1) str1 (substr str2 2))
                       (strcat str1 str2)
                     ) ;_ end of if
                   ) ;_ end of lambda
                  (mapcar
                    '(lambda (x / str)
                       (setq str "0")
                       (repeat x
                         (setq str (strcat str "0"))
                       ) ;_ end of repeat
                       str
                     ) ;_ end of lambda
                    ((lambda (a)
                       (mapcar '(lambda (x) (- (apply 'max a) x)) a)
                     ) ;_ end of lambda
                      (mapcar
                        '(lambda (str)
                           (length
                             (vl-remove-if-not
                               '(lambda (x)
                                  (wcmatch x "#")
                                ) ;_ end of lambda
                               (mapcar 'chr (vl-string->list str))
                             ) ;_ end of vl-remove-if-not
                           ) ;_ end of length
                         ) ;_ end of lambda
                        lst
                      ) ;_ end of mapcar
                    )
                  ) ;_ end of mapcar
                  lst
                ) ;_ end of mapcar
              ) ;_ end of lambda
               (mapcar 'strcase (mapcar 'car lst))
             )
             '<
           ) ;_ end of vl-sort-i
         ) ;_ end of mapcar
  ) ;_ end of setq
  (setq LST-AS
         (apply
           'append
           (mapcar
             '(lambda (X Y)
                (mapcar
                  '(lambda (Z)
                     (cons Z Y)
                   ) ;_ end of lambda
                  X
                ) ;_ end of mapcar
              ) ;_ end of lambda
             (list (list "Лист -" "Лист-" "Фл")
                   (list "Лист чечевица" "Лист ромб")
                   (list "-")
                   (list "Полоса")
                   (list "Уголок" "\\U+E720")
                   (list "\\U+E72E")
                   (list "Тр")
		   (list "Двутавр ##Б" "Двутавр ##К" "Двутавр ##Ш") ;_ Двузначный номер Двутавра
		   (list "Двутавр ###Б" "Двутавр ###К" "Двутавр ###Ш") ;_ Трехзначный номер Двутавра
                   (list "Двутавр" "\\U+E729")
                   (list "Швеллер" "\\U+E725")
                   (list "%%c" "\\U+E712")
             ) ;_ end of list
             (list "ГОСТ 19903-74"
                   "ГОСТ 8568-77"
                   (list "ГОСТ 19903-74" "ГОСТ 103-76")
                   "ГОСТ 103-76"
                   (list "ГОСТ 8509-93" "ГОСТ 8510-86")
                   "ГОСТ 30245-03"
                   "ГОСТ 10704-91"
		   "СТО АСЧМ 20-93" ;_ГОСТ _Для двузначного номера
		   "СТО АСЧМ 20-93" ;_ГОСТ _Для трехзначного номера
                   "ГОСТ 8239-89" ;;Двутавр
                   "ГОСТ 8240-97"
                   "ГОСТ 5781-82"
             ) ;_ end of list
           ) ;_ end of mapcar
         ) ;_ end of apply
  ) ;_ end of setq LST-AS
  (setq lst
         (mapcar
           '(lambda (EL-LST / EL-AS)
              (setq EL-AS
                     (car
                       (vl-remove-if-not
                         '(lambda (STR)
                            (wcmatch (cadr EL-LST) (strcat (car STR) "*"))
                          ) ;_ end of lambda
                         LST-AS
                       ) ;_ end of vl-remove-if-not
                     ) ;_ end of car
              ) ;_ end of setq
              (cons
                (car EL-LST)
                (cons
                  (cond
                    ((equal (car EL-AS) "-")
                     (if (equal (caddr EL-LST) "-")
                       (cadr EL-AS)
                       (caddr EL-AS)
                     ) ;_ end of if
                    )
                    ((member (car EL-AS) '("Уголок" "\\U+E720"))
                     (if
                       ((lambda (STR)
                          (equal
                            (vl-string-position (ascii "x") STR)
                            (vl-string-position (ascii "x") STR nil t)
                          ) ;_ end of equal
                        ) ;_ end of lambda
                         (vl-string-translate "х" "x" (cadr EL-LST))
                       )
                        (cadr EL-AS)
                        (caddr EL-AS)
                     ) ;_ end of if
                    )
                    (t (cdr EL-AS))
                  ) ;_ end of cond
                  (cdr EL-LST)
                ) ;_ end of cons
              ) ;_ end of cons
            ) ;_ end of lambda
           lst
         ) ;_ end of mapcar
  ) ;_ end of setq
  ((lambda (/ b1 a1 a2 a3)
     (mapcar
       '(lambda (B A / b1 a1 a2 a3)
          ((lambda (dxf)
             (entmod
               (subst (cons 1 A)
                      (assoc 1 dxf)
                      dxf
               ) ;_ end of subst
             ) ;_ end of entmod
           ) ;_ end of lambda
            (entget B)
          )
        ) ;_ end of lambda
       (setq b1
              ((lambda (/ sset)
                 (princ "\nВыберите шаблон спецификации: ")
                 (if (setq sset (ssget '((0 . "*TEXT"))))
                   (vl-sort
                     (vl-sort
                       (vl-remove-if
                         (function listp)
                         (mapcar (function cadr)
                                 (ssnamex sset)
                         ) ;_ end of mapcar
                       ) ;_ end of vl-remove-if
                       '(lambda (a b)
                          (> (caddr (assoc '10 (entget a)))
                             (caddr (assoc '10 (entget b)))
                          ) ;_ on Y
                        ) ;_ end of lambda
                     ) ;_ end of vl-sort
                     '(lambda (a b)
                        (and
                          (equal (caddr (assoc '10 (entget a)))
                                 (caddr (assoc '10 (entget b)))
                                 1.
                          ) ;_ end of equal
                          (< (cadr (assoc '10 (entget a)))
                             (cadr (assoc '10 (entget b)))
                          ) ;_ end of <
                        ) ;_ end of and
                      ) ;_ end of lambda
                   ) ;_ end of vl-sort
                 ) ;_ end of if
               ) ;_ end of lambda
              )
       ) ;_ end of setq
       (progn
         (setq a1 (apply 'append lst)
               a1
                  (append
                    a1
                    (if (not (minusp (setq a2 (- (length b1) (length a1)))))
                      (append (repeat a2 (setq a3 (cons "XX" a3))))
                    ) ;_ end of if
                  ) ;_ end of append
         ) ;_ end of setq
       ) ;_ end of progn
     ) ;_ end of mapcar
   ) ;_ end of lambda
  )
) ;_ end of defun ntt
Должно работать
__________________
Как использовать код на Лиспе читаем здесь
VVA на форуме  
 
Автор темы   Непрочитано 26.10.2008, 21:33
#93
Red Nova

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

VVA,
Да, то что можно новый код просто строкой раньше написать я не догодался. Вот мой вариант, на основе твоего, я еще добавил cимвол двутавра СПДС и учел вероятность отсутствия пробела. Получилось на все случаи.
Код:
[Выделить все] 
(defun c:ntt (/ CB-filtr lst LST-AS)    ;note to text
  (defun CB-filtr (lst)
    (setq
      lst
       (vl-remove-if
         '(lambda (x)
            (or
              (not (equal (length x) 2))
              (member "" x)
              (not
                (wcmatch
                  (vl-string-translate "Tp" "Тр" (cadr x))
;;;                  "*E72E*,Труба*,Тр.*,Лист*,Полоса*,*E720*,Уголок*,*E725*,Швеллер*,*E729*,Двутавр*,Фланец*,Фл.*,-*,%%c*,*E712*,#%%c*,# %%c*,##%%c*,## %%c*,#*E712*,# *E712*,##*E712*,## *E712*"
                  "\\U+E72E*,Труба*,Тр.*,Лист*,Полоса*,\\U+E720*,Уголок*,\\U+E725*,Швеллер*,\\U+E729*,Двутавр*,Фланец*,Фл.*,-*,%%c*,\\U+E712*,#%%c*,# %%c*,##%%c*,## %%c*,#\\U+E712*,# \\U+E712*,##\\U+E712*,## \\U+E712*"
                ) ;_ end of wcmatch
              ) ;_ end of not
              (not
                (or
                  (and
                    (wcmatch (car x) "@*")
                    (wcmatch (vl-string-right-trim "1234567890'\"" (car x))
                             "@"
                    ) ;_ end of wcmatch
                  ) ;_ end of and
                  (and (wcmatch (car x) "#*")
                       (wcmatch (vl-string-left-trim "1234567890" (car x))
                                ",@,@',@\",',\""
                       ) ;_ end of wcmatch
                  ) ;_ end of and
                ) ;_ end of or
              ) ;_ end of not
            ) ;_ end of or
          ) ;_ end of lambda
         lst
       ) ;_ end of vl-remove-if
    ) ;_ end of setq
    (setq lst
           ((lambda (lst / poz temp)
              (defun poz (str pat / p n)
                (while (setq n (vl-string-search pat str n))
                  (setq p (cons n p)
                        n (1+ n)
                  ) ;_ end of setq
                ) ;_ end of while
                p
              ) ;_ end of defun
              (while lst
                (setq
                  temp
                   (cons
                     ((lambda (lst-temp / n)
                        (list
                          (car lst-temp)
                          (vl-string-left-trim
                            "1234567890 "
                            (if (or
                                  (equal (length
                                           (setq n (poz (cadr lst-temp) ","))
                                         ) ;_ end of length
                                         2
                                  ) ;_ end of equal
                                  (not (wcmatch (cadr lst-temp) "*L=*"))
                                ) ;_ end of or
                              (substr (cadr lst-temp)
                                      1
                                      (if (wcmatch (cadr lst-temp) "*L=*")
                                        (car n)
                                        (car (reverse n))
                                      ) ;_ end of if
                              ) ;_ end of substr
                              (cadr lst-temp)
                            ) ;_ end of if
                          ) ;_ end of vl-string-left-trim
                        ) ;_ end of list
                      ) ;_ end of lambda
                       (car
                         (vl-sort
                           (vl-remove-if-not
                             '(lambda (x) (equal (caar lst) (car x)))
                             lst
                           ) ;_ end of vl-remove-if-not
                           '(lambda (str1 str2)
                              (>
                                (+ (length (poz (cadr str1) ","))
                                   (if (wcmatch (cadr str1) "*L=*")
                                     1
                                     0
                                   ) ;_ end of if
                                ) ;_ end of +
                                (+ (length (poz (cadr str2) ","))
                                   (if (wcmatch (cadr str2) "*L=*")
                                     1
                                     0
                                   ) ;_ end of if
                                ) ;_ end of +
                              ) ;_ end of >
                            ) ;_ end of lambda
                         ) ;_ end of vl-sort
                       ) ;_ end of car
                     )
                     temp
                   ) ;_ end of cons
                ) ;_ end of setq
                (setq lst
                       (vl-remove-if '(lambda (x) (equal (caar lst) (car x))) lst)
                ) ;_ end of setq
                (reverse temp)
              ) ;_ end of while
            ) ;_ end of lambda
             lst
           )
    ) ;_ end of setq
  ) ;_ end of defun
;;;(setq lst '(("22" "Двутавр 20Б1" "-")("1" "-10х100x100" "-") ("2" "Швеллер 12" "L=1000") ("8" "Полоса -4х50" 
;;;"L=1000") ("14" "Уголок 75х5" "L=")))  
  (setq lst (mapcar '(lambda (x)
                       (list (vl-string-trim " " (car x))
                             (vl-string-trim " " (cadr x))
                       ) ;_ end of list
                     ) ;_ end of lambda
;;;                    lst
		    
                    (_dwgru-get-spds-text-and-range) ; из #472 
            ) ;_ end of mapcar
  ) ;_ end of setq
  (setq lst (CB-filtr lst))
  (setq lst
         (mapcar
           '(lambda (x / p)
              (if (setq p (vl-string-position (ascii ",") (cadr x)))
                (list
                  (car x)
                  (substr (cadr x) 1 p)
                  (vl-string-left-trim " " (substr (cadr x) (+ 2 p)))
                ) ;_ end of list
                (if (wcmatch (cadr x) "-*,Лист*,Фл*")
                  (append x '("-"))
                  (append x '("L="))
                ) ;_ end of if
              ) ;_ end of if
            ) ;_ end of lambda
           lst
         ) ;_ end of mapcar
  ) ;_ end of setq
  (setq lst
         (mapcar
           '(lambda (x) (nth x lst))
           (vl-sort-i
             ((lambda (lst)
                (mapcar
                  '(lambda (str1 str2)
                     (if (wcmatch str2 "@*")
                       (strcat (substr str2 1 1) str1 (substr str2 2))
                       (strcat str1 str2)
                     ) ;_ end of if
                   ) ;_ end of lambda
                  (mapcar
                    '(lambda (x / str)
                       (setq str "0")
                       (repeat x
                         (setq str (strcat str "0"))
                       ) ;_ end of repeat
                       str
                     ) ;_ end of lambda
                    ((lambda (a)
                       (mapcar '(lambda (x) (- (apply 'max a) x)) a)
                     ) ;_ end of lambda
                      (mapcar
                        '(lambda (str)
                           (length
                             (vl-remove-if-not
                               '(lambda (x)
                                  (wcmatch x "#")
                                ) ;_ end of lambda
                               (mapcar 'chr (vl-string->list str))
                             ) ;_ end of vl-remove-if-not
                           ) ;_ end of length
                         ) ;_ end of lambda
                        lst
                      ) ;_ end of mapcar
                    )
                  ) ;_ end of mapcar
                  lst
                ) ;_ end of mapcar
              ) ;_ end of lambda
               (mapcar 'strcase (mapcar 'car lst))
             )
             '<
           ) ;_ end of vl-sort-i
         ) ;_ end of mapcar
  ) ;_ end of setq
  (setq LST-AS
         (apply
           'append
           (mapcar
             '(lambda (X Y)
                (mapcar
                  '(lambda (Z)
                     (cons Z Y)
                   ) ;_ end of lambda
                  X
                ) ;_ end of mapcar
              ) ;_ end of lambda
             (list (list "Лист -" "Лист-" "Фл")
                   (list "Лист чечевица" "Лист ромб")
                   (list "-")
                   (list "Полоса")
                   (list "Уголок" "\\U+E720")
                   (list "\\U+E72E")
                   (list "Тр")
		   (list "Двутавр ##Б" "Двутавр ##К" "Двутавр ##Ш" "\\U+E729 ##Б" "\\U+E729 ##К" "\\U+E729 ##Ш" "Двутавр##Б" "Двутавр##К" "Двутавр##Ш" "\\U+E729##Б" "\\U+E729##К" "\\U+E729##Ш") ;_ Двузначный номер Двутавра
		   (list "Двутавр ###Б" "Двутавр ###К" "Двутавр ###Ш" "\\U+E729 ###Б" "\\U+E729 ###К" "\\U+E729 ###Ш" "Двутавр###Б" "Двутавр###К" "Двутавр###Ш" "\\U+E729###Б" "\\U+E729###К" "\\U+E729###Ш") ;_ Трехзначный номер Двутавра
                   (list "Двутавр" "\\U+E729")
                   (list "Швеллер" "\\U+E725")
                   (list "%%c" "\\U+E712")
             ) ;_ end of list
             (list "ГОСТ 19903-74"
                   "ГОСТ 8568-77"
                   (list "ГОСТ 19903-74" "ГОСТ 103-76")
                   "ГОСТ 103-76"
                   (list "ГОСТ 8509-93" "ГОСТ 8510-86")
                   "ГОСТ 30245-03"
                   "ГОСТ 10704-91"
		   "СТО АСЧМ 20-93" ;_ГОСТ _Для двузначного номера
		   "СТО АСЧМ 20-93" ;_ГОСТ _Для трехзначного номера
                   "ГОСТ 8239-89" ;;Двутавр
                   "ГОСТ 8240-97"
                   "ГОСТ 5781-82"
             ) ;_ end of list
           ) ;_ end of mapcar
         ) ;_ end of apply
  ) ;_ end of setq LST-AS
  (setq lst
         (mapcar
           '(lambda (EL-LST / EL-AS)
              (setq EL-AS
                     (car
                       (vl-remove-if-not
                         '(lambda (STR)
                            (wcmatch (cadr EL-LST) (strcat (car STR) "*"))
                          ) ;_ end of lambda
                         LST-AS
                       ) ;_ end of vl-remove-if-not
                     ) ;_ end of car
              ) ;_ end of setq
              (cons
                (car EL-LST)
                (cons
                  (cond
                    ((equal (car EL-AS) "-")
                     (if (equal (caddr EL-LST) "-")
                       (cadr EL-AS)
                       (caddr EL-AS)
                     ) ;_ end of if
                    )
                    ((member (car EL-AS) '("Уголок" "\\U+E720"))
                     (if
                       ((lambda (STR)
                          (equal
                            (vl-string-position (ascii "x") STR)
                            (vl-string-position (ascii "x") STR nil t)
                          ) ;_ end of equal
                        ) ;_ end of lambda
                         (vl-string-translate "х" "x" (cadr EL-LST))
                       )
                        (cadr EL-AS)
                        (caddr EL-AS)
                     ) ;_ end of if
                    )
                    (t (cdr EL-AS))
                  ) ;_ end of cond
                  (cdr EL-LST)
                ) ;_ end of cons
              ) ;_ end of cons
            ) ;_ end of lambda
           lst
         ) ;_ end of mapcar
  ) ;_ end of setq
  ((lambda (/ b1 a1 a2 a3)
     (mapcar
       '(lambda (B A / b1 a1 a2 a3)
          ((lambda (dxf)
             (entmod
               (subst (cons 1 A)
                      (assoc 1 dxf)
                      dxf
               ) ;_ end of subst
             ) ;_ end of entmod
           ) ;_ end of lambda
            (entget B)
          )
        ) ;_ end of lambda
       (setq b1
              ((lambda (/ sset)
                 (princ "\nВыберите шаблон спецификации: ")
                 (if (setq sset (ssget '((0 . "*TEXT"))))
                   (vl-sort
                     (vl-sort
                       (vl-remove-if
                         (function listp)
                         (mapcar (function cadr)
                                 (ssnamex sset)
                         ) ;_ end of mapcar
                       ) ;_ end of vl-remove-if
                       '(lambda (a b)
                          (> (caddr (assoc '10 (entget a)))
                             (caddr (assoc '10 (entget b)))
                          ) ;_ on Y
                        ) ;_ end of lambda
                     ) ;_ end of vl-sort
                     '(lambda (a b)
                        (and
                          (equal (caddr (assoc '10 (entget a)))
                                 (caddr (assoc '10 (entget b)))
                                 1.
                          ) ;_ end of equal
                          (< (cadr (assoc '10 (entget a)))
                             (cadr (assoc '10 (entget b)))
                          ) ;_ end of <
                        ) ;_ end of and
                      ) ;_ end of lambda
                   ) ;_ end of vl-sort
                 ) ;_ end of if
               ) ;_ end of lambda
              )
       ) ;_ end of setq
       (progn
         (setq a1 (apply 'append lst)
               a1
                  (append
                    a1
                    (if (not (minusp (setq a2 (- (length b1) (length a1)))))
                      (append (repeat a2 (setq a3 (cons "XX" a3))))
                    ) ;_ end of if
                  ) ;_ end of append
         ) ;_ end of setq
       ) ;_ end of progn
     ) ;_ end of mapcar
   ) ;_ end of lambda
  )
) ;_ end of defun ntt
__________________
Блог
Red Nova вне форума  
 
Автор темы   Непрочитано 26.10.2008, 21:37
#94
Red Nova

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

dextron3,
Цитата:
а почему не сформировал ТЗ сразу с часто используемыми профилями?
А у тебя какие есть соображения на этот счет?
Цитата:
можно было конечно делать \\U+E729Б1 а потом размер указывать, что ты на это скажешь, или ГОСТЫ так не разрешают?
Эту часть сообщения я вообще не понял
Цитата:
Объясни принцип действия кода, какми образом определяются равнополочные и равнополочные уголки, хотябы
Условно принято что равнополочные уголки записываются коротко, к примеру
Уголок 75х5, а не Уголок 75х75х5
Таким образом получается зацепка для отличия от неравнополочных. В одном случае только один х а во втором – два
__________________
Блог
Red Nova вне форума  
 
Непрочитано 26.10.2008, 21:41
#95
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

у меня чтото последнее время не попорядку лисп записывать стал в спецификацию задом наперед тобишь,
не могу выявить в чем причина...?
Миниатюры
Нажмите на изображение для увеличения Название: 1212.JPG Просмотров: 92 Размер: 14.2 Кб ID: 11522  
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Автор темы   Непрочитано 27.10.2008, 11:37
#96
Red Nova

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

А у меня нормально...
__________________
Блог
Red Nova вне форума  
 
Непрочитано 27.10.2008, 12:36
#97
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

Вот видеоролик совсем все не так....
Вложения
Тип файла: rar Untitled.rar (563.3 Кб, 93 просмотров)
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Непрочитано 27.10.2008, 13:16
#98
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

У тебя одинаковые позиции...
CB вне форума  
 
Автор темы   Непрочитано 27.10.2008, 13:45
#99
Red Nova

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

CB, Выложи dwg
__________________
Блог
Red Nova вне форума  
 
Непрочитано 27.10.2008, 14:06
#100
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

Какое еще dwg? Я посмотрел ролик и увидел...
CB вне форума  
 
Автор темы   Непрочитано 27.10.2008, 14:22
#101
Red Nova

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

Дык то что у него позиции совподают не должно ведь влиять на очередность
__________________
Блог
Red Nova вне форума  
 
Непрочитано 27.10.2008, 14:51
#102
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

А это что?
Цитата:
А. Необходимо удалить дублирующие элементы.
Видно, что некоторые элементы дублируются абсолютно идентично.
("1" "-10х100x200") ("1" "-10х100x200)
А у некоторых одинаков только номер позиции
("2" "Швеллер 12, L=1000, шаг 1000") ("2" "Швеллер 12, L=1000") ("2" "Швеллер 12")
("5" "8 20 А500c, L=1000") ("5" "8 20 А500c")
Для правильной фильтрации дублирующих элементов Необходимо произвести сравнение первых и вторых элементов подсписка.
Если оба элемента идентичны, то оставляем только один подсписок.
Если идентичны только номера позиций, а содержание разное, то надо оставить на первом этапе более длинный подсписок.
И еще...
Сильно не проверял, но по моему вместо:
Код:
[Выделить все] 
........................................
(list "Двутавр ##Б" "Двутавр ##К" "Двутавр ##Ш" "\\U+E729 ##Б" "\\U+E729 ##К" "\\U+E729 ##Ш" "Двутавр##Б" "Двутавр##К" "Двутавр##Ш" "\\U+E729##Б" "\\U+E729##К" "\\U+E729##Ш") ;_ Двузначный номер Двутавра
(list "Двутавр ###Б" "Двутавр ###К" "Двутавр ###Ш" "\\U+E729 ###Б" "\\U+E729 ###К" "\\U+E729 ###Ш" "Двутавр###Б" "Двутавр###К" "Двутавр###Ш" "\\U+E729###Б" "\\U+E729###К" "\\U+E729###Ш") ;_ Трехзначный номер Двутавра
(list "Двутавр" \\U+E729)
.............................................................................
"СТО АСЧМ 20-93" ;_ГОСТ _Для двузначного номера
"СТО АСЧМ 20-93" ;_ГОСТ _Для трехзначного номера
"ГОСТ 8239-89" ;;Двутавр
.....................................
Можно попроще...
Код:
[Выделить все] 
.................................
(list "Двутавр*#*#[БКШ]" "\\U+E729*#*#[БКШ]")
(list "Двутавр" \\U+E729)
..........................................
"СТО АСЧМ 20-93" 
"ГОСТ 8239-89" ;;Двутавр
CB вне форума  
 
Автор темы   Непрочитано 27.10.2008, 14:59
#103
Red Nova

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

CB,
Цитата:
А это что?
Цитата:А. Необходимо удалить дублирующие элементы.
Видно, что некоторые элементы дублируются абсолютно идентично.
("1" "-10х100x200") ("1" "-10х100x200)
А у некоторых одинаков только номер позиции
("2" "Швеллер 12, L=1000, шаг 1000") ("2" "Швеллер 12, L=1000") ("2" "Швеллер 12")
("5" "8 20 А500c, L=1000") ("5" "8 20 А500c")
Для правильной фильтрации дублирующих элементов Необходимо произвести сравнение первых и вторых элементов подсписка.
Если оба элемента идентичны, то оставляем только один подсписок.
Если идентичны только номера позиций, а содержание разное, то надо оставить на первом этапе более длинный подсписок.
Все верно. Есть такое. Но причем тут поочередность окончательного списка?
Цитата:
Можно попроще...
Код:
.................................
(list "Двутавр*#*#[БКШ]" "\\U+E729*#*#[БКШ]")
(list "Двутавр" \\U+E729)
..........................................
"СТО АСЧМ 20-93"
"ГОСТ 8239-89" ;;Двутавр
Мда. Опять я делаю лоботомию через задний проход
__________________
Блог
Red Nova вне форума  
 
Непрочитано 27.10.2008, 15:09
#104
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

Вот вам файл ДВЖ, не работает даже для одной позиции не говоря уже о списке...
Вложения
Тип файла: rar Образец.rar (226.1 Кб, 90 просмотров)
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Автор темы   Непрочитано 27.10.2008, 16:05
#105
Red Nova

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

Все ясно. У тебя тексты по координате У не сошлись.
__________________
Блог
Red Nova вне форума  
 
Непрочитано 27.10.2008, 16:17
#106
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

Red Nova, ты невидел еще как тетки чертят, там понятие координаты даже неудобно применять, как можно исправить этот баг?

Код:
[Выделить все] 
(list "\\U+E729##Б1" "\\U+E729##Б2" "\\U+E729##К1" "\\U+E729##К2" "\\U+E729##К3" "\\U+E729##К4" "\\U+E729##К5" "\\U+E729##Ш1" "\\U+E729##Ш2" "\\U+E729##Ш3") ;_ Двузначный номер Двутавра
		   (list "\\U+E729###Б1" "\\U+E729###Б2" "\\U+E729###К1" "\\U+E729###К2" "\\U+E729###К3" "\\U+E729###К4" "\\U+E729###К5" "\\U+E729###Ш1" "\\U+E729###Ш2" "\\U+E729###Ш3") ;_ Трехзначный номер Двутавра
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Автор темы   Непрочитано 27.10.2008, 16:28
#107
Red Nova

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

dextron3, Это не баг. Прочти #45, все можно настроить.
__________________
Блог
Red Nova вне форума  
 
Непрочитано 27.10.2008, 17:06
#108
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

Red Nova, я еще не изучил язык, поясни где можно настроить, чтобы перепад считываемых текстов был не больше высоты самих текстов, как +Y так и -Y буду ждать совета...
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Автор темы   Непрочитано 27.10.2008, 17:12
#109
Red Nova

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

dextron3, Не ленись. Пойди на #45, там СВ как раз объяснил то что ты от меня хочешь. А язых тут не причем.
__________________
Блог
Red Nova вне форума  
 
Непрочитано 27.10.2008, 17:36
#110
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

Red Nova, спасибо я сообразил, мучают вопросы:

1. Будет ли лисп развиваться дальше или уже работать над ним самомстоятельно?
2. Будем ли его унифицировать?
__________________
инженер проектировшик с опттом программа авто гад образование высшие
Последний раз редактировалось dextron3, 27.10.2008 в 17:44.
dextron3 вне форума  
 
Автор темы   Непрочитано 27.10.2008, 17:47
#111
Red Nova

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

Лично у меня пока идей на развитие нет. Если есть предложения - выкладывай, подумаем все вместе.
__________________
Блог
Red Nova вне форума  
 
Непрочитано 27.10.2008, 18:00
#112
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

Red Nova,
для арматуры неплох параметр количество:

1. Ф25, L=800, 25шт.
и запись в ячейку количество, можно для этого проработать отдельный лисп, так как тут прийдется на 1 текст больше выделять,

вспомни когда ты ДЖ или плиту рисуешь, а заказчик говорит что ему детальное армирование надобно, а у тебя времени нет блох ловить, вот тут бы и пригодилась данная автоматизация....


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

2. PS Если дейстивтельно нужно то скажи я впринцепе могу и без этого обходится....

3. Я люблю профили значками изображать, да вот спдсный шрифт не на всех компах изображается корректно, что тут можно было бы сдеать?


4. Где можно в лиспе заменить диаметр на букву Ф (Федя)
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Автор темы   Непрочитано 27.10.2008, 20:25
#113
Red Nova

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

1. У меня честно говоря такого не бывало, количество никогда в выноске не писал. По части разработки отдельного лиспа - это не ко мне. Я в программировании такой же чурбан как и ты.
2. Не понял что мне "действительно нужно".
3. Не знаю в чем проблемма с шрифтом СПДС, но лучше решить ее, чем извращятся с лиспом.
4. Это возможно, но у меня не получилось.

СВ После работы лиспа в ком строку выбрасывается куча ненужной информации. Как от этого избавиться?
Код:
[Выделить все] 
Select objects:
el") (8 . "0") (100 . "AcDbMText") (10 43768.6 -18792.4 0.0) (40 . 62.5) (41 . 
547.212) (46 . 175.0) (71 . 4) (72 . 1) (1 . "XX") (7 . "GOST 2.304") (210 0.0 
0.0 1.0) (11 1.0 0.0 0.0) (42 . 100.0) (43 . 62.5) (50 . 0.0) (73 . 1) (44 . 
1.0)) ((-1 . <Entity name: 7ef15df8>) (0 . "MTEXT") (330 . <Entity name: 
7ef11cc0>) (5 . "29017") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . 
"0") (100 . "AcDbMText") (10 41690.8 -18968.2 0.0) (40 . 62.5) (41 . 250.0) (46 
. 173.307) (71 . 5) (72 . 1) (1 . "XX") (7 . "GOST 2.304") (210 0.0 0.0 1.0) 
(11 1.0 0.0 0.0) (42 . 100.0) (43 . 62.5) (50 . 0.0) (73 . 1) (44 . 1.0)) ((-1 
. <Entity name: 7ef15808>) (0 . "MTEXT") (330 . <Entity name: 7ef11cc0>) (5 . 
"28F09") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0") (100 . 
"AcDbMText") (10 42315.8 -18967.4 0.0) (40 . 62.5) (41 . 1000.0) (46 . 175.0) 
(71 . 5) (72 . 1) (1 . "XX") (7 . "GOST 2.304") (210 0.0 0.0 1.0) (11 1.0 0.0 
0.0) (42 . 100.0) (43 . 62.5) (50 . 0.0) (73 . 1) (44 . 1.0)) ((-1 . <Entity 
name: 7ef15820>) (0 . "MTEXT") (330 . <Entity name: 7ef11cc0>) (5 . "28F0C") 
(100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0") (100 . "AcDbMText") (10 
42917.7 -18967.4 0.0) (40 . 62.5) (41 . 850.0) (46 . 175.0) (71 . 4) (72 . 1) 
(1 . "XX") (7 . "GOST 2.304") (210 0.0 0.0 1.0) (11 1.0 0.0 0.0) (42 . 100.0) 
(43 . 62.5) (50 . 0.0) (73 . 1) (44 . 1.0)) ((-1 . <Entity name: 7ef15818>) (0 
. "MTEXT") (330 . <Entity name: 7ef11cc0>) (5 . "28F0B") (100 . "AcDbEntity") 
(67 . 0) (410 . "Model") (8 . "0") (100 . "AcDbMText") (10 43768.6 -18967.4 
0.0) (40 . 62.5) (41 . 547.212) (46 . 175.0) (71 . 4) (72 . 1) (1 . "XX") (7 . 
"GOST 2.304") (210 0.0 0.0 1.0) (11 1.0 0.0 0.0) (42 . 100.0) (43 . 62.5) (50 . 
0.0) (73 . 1) (44 . 1.0)))tity name: 7ef158b8>) (0 . "MTEXT") (330 . <Entity 
name: 7ef11cc0>) (5 . "28F1F") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 
. "0") (100 . "AcDbMText") (10 42315.8 -18617.4 0.0) (40 . 62.5) (41 . 1000.0) 
(46 . 175.0) (71 . 5) (72 . 1) (1 . "XX") (7 . "GOST 2.304") (210 0.0 0.0 1.0) 
(11 1.0 0.0 0.0) (42 . 100.0) (43 . 62.5) (50 . 0.0) (73 . 1) (44 . 1.0)) ((-1 
. <Entity name: 7ef158d0>) (0 . "MTEXT") (330 . <Entity name: 7ef11cc0>) (5 . 
"28F22") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0") (100 . 
"AcDbMText") (10 42917.7 -18617.4 0.0) (40 . 62.5) (41 . 850.0) (46 . 175.0) 
(71 . 4) (72 . 1) (1 . "XX") (7 . "GOST 2.304") (210 0.0 0.0 1.0) (11 1.0 0.0 
0.0) (42 . 100.0) (43 . 62.5) (50 . 0.0) (73 . 1) (44 . 1.0)) ((-1 . <Entity 
name: 7ef158c8>) (0 . "MTEXT") (330 . <Entity name: 7ef11cc0>) (5 . "28F21") 
(100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0") (100 . "AcDbMText") (10 
43768.6 -18617.4 0.0) (40 . 62.5) (41 . 547.212) (46 . 175.0) (71 . 4) (72 . 1) 
(1 . "XX") (7 . "GOST 2.304") (210 0.0 0.0 1.0) (11 1.0 0.0 0.0) (42 . 100.0) 
(43 . 62.5) (50 . 0.0) (73 . 1) (44 . 1.0)) ((-1 . <Entity name: 7ef15de8>) (0 
. "MTEXT") (330 . <Entity name: 7ef11cc0>) (5 . "29015") (100 . "AcDbEntity") 
(67 . 0) (410 . "Model") (8 . "0") (100 . "AcDbMText") (10 41690.8 -18793.2 
0.0) (40 . 62.5) (41 . 250.0) (46 . 173.307) (71 . 5) (72 . 1) (1 . "XX") (7 . 
"GOST 2.304") (210 0.0 0.0 1.0) (11 1.0 0.0 0.0) (42 . 100.0) (43 . 62.5) (50 . 
0.0) (73 . 1) (44 . 1.0)) ((-1 . <Entity name: 7ef15860>) (0 . "MTEXT") (330 . 
<Entity name: 7ef11cc0>) (5 . "28F14") (100 . "AcDbEntity") (67 . 0) (410 . 
"Model") (8 . "0") (100 . "AcDbMText") (10 42315.8 -18792.4 0.0) (40 . 62.5) 
(41 . 1000.0) (46 . 175.0) (71 . 5) (72 . 1) (1 . "XX") (7 . "GOST 2.304") (210 
0.0 0.0 1.0) (11 1.0 0.0 0.0) (42 . 100.0) (43 . 62.5) (50 . 0.0) (73 . 1) (44 
. 1.0)) ((-1 . <Entity name: 7ef15850>) (0 . "MTEXT") (330 . <Entity name: 
7ef11cc0>) (5 . "28F12") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . 
"0") (100 . "AcDbMText") (10 42917.7 -18792.4 0.0) (40 . 62.5) (41 . 850.0) (46 
. 175.0) (71 . 4) (72 . 1) (1 . "XX") (7 . "GOST 2.304") (210 0.0 0.0 1.0) (11 
1.0 0.0 0.0) (42 . 100.0) (43 . 62.5) (50 . 0.0) (73 . 1) (44 . 1.0)) ((-1 . 
<Entity name: 7ef15878>) (0 . "MTEXT") (330 . <Entity name: 7ef11cc0>) (5 . 
"28F17") (100 . "AcDbEntity") (67 . 0) (410 . "Mod
__________________
Блог
Red Nova вне форума  
 
Непрочитано 28.10.2008, 16:52
#114
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

Хотел добавить свое, а у меня чтото не работает, куда еще код прописать или я что то делаю не так?
Миниатюры
Нажмите на изображение для увеличения Название: Snap1.jpg Просмотров: 100 Размер: 64.9 Кб ID: 11589  Нажмите на изображение для увеличения Название: Snap2.jpg Просмотров: 100 Размер: 40.8 Кб ID: 11590  
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Автор темы   Непрочитано 28.10.2008, 22:35
#115
Red Nova

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

dextron3, Нужно добавить в двух местах. Смотри красным.
Код:
[Выделить все] 
(defun c:ntt (/ CB-filtr lst LST-AS)    ;note to text
  (defun CB-filtr (lst)
    (setq
      lst
       (vl-remove-if
         '(lambda (x)
            (or
              (not (equal (length x) 2))
              (member "" x)
              (not
                (wcmatch
                  (vl-string-translate "Tp" "Тр" (cadr x))
                  "Болт*,\\U+E72E*,Труба*,Тр.*,Лист*,Полоса*,\\U+E720*,Уголок*,\\U+E725*,Швеллер*,\\U+E729*,Двутавр*,Фланец*,Фл.*,-*,%%c*,\\U+E712*,#%%c*,# %%c*,##%%c*,## %%c*,#\\U+E712*,# \\U+E712*,##\\U+E712*,## \\U+E712*"
                ) ;_ end of wcmatch
              ) ;_ end of not
              (not
                (or
                  (and
                    (wcmatch (car x) "@*")
                    (wcmatch (vl-string-right-trim "1234567890'\"" (car x))
                             "@"
                    ) ;_ end of wcmatch
                  ) ;_ end of and
                  (and (wcmatch (car x) "#*")
                       (wcmatch (vl-string-left-trim "1234567890" (car x))
                                ",@,@',@\",',\""
                       ) ;_ end of wcmatch
                  ) ;_ end of and
                ) ;_ end of or
              ) ;_ end of not
            ) ;_ end of or
          ) ;_ end of lambda
         lst
       ) ;_ end of vl-remove-if
    ) ;_ end of setq
    (setq lst
           ((lambda (lst / poz temp)
              (defun poz (str pat / p n)
                (while (setq n (vl-string-search pat str n))
                  (setq p (cons n p)
                        n (1+ n)
                  ) ;_ end of setq
                ) ;_ end of while
                p
              ) ;_ end of defun
              (while lst
                (setq
                  temp
                   (cons
                     ((lambda (lst-temp / n)
                        (list
                          (car lst-temp)
                          (vl-string-left-trim
                            "1234567890 "
                            (if (or
                                  (equal (length
                                           (setq n (poz (cadr lst-temp) ","))
                                         ) ;_ end of length
                                         2
                                  ) ;_ end of equal
                                  (not (wcmatch (cadr lst-temp) "*L=*"))
                                ) ;_ end of or
                              (substr (cadr lst-temp)
                                      1
                                      (if (wcmatch (cadr lst-temp) "*L=*")
                                        (car n)
                                        (car (reverse n))
                                      ) ;_ end of if
                              ) ;_ end of substr
                              (cadr lst-temp)
                            ) ;_ end of if
                          ) ;_ end of vl-string-left-trim
                        ) ;_ end of list
                      ) ;_ end of lambda
                       (car
                         (vl-sort
                           (vl-remove-if-not
                             '(lambda (x) (equal (caar lst) (car x)))
                             lst
                           ) ;_ end of vl-remove-if-not
                           '(lambda (str1 str2)
                              (>
                                (+ (length (poz (cadr str1) ","))
                                   (if (wcmatch (cadr str1) "*L=*")
                                     1
                                     0
                                   ) ;_ end of if
                                ) ;_ end of +
                                (+ (length (poz (cadr str2) ","))
                                   (if (wcmatch (cadr str2) "*L=*")
                                     1
                                     0
                                   ) ;_ end of if
                                ) ;_ end of +
                              ) ;_ end of >
                            ) ;_ end of lambda
                         ) ;_ end of vl-sort
                       ) ;_ end of car
                     )
                     temp
                   ) ;_ end of cons
                ) ;_ end of setq
                (setq lst
                       (vl-remove-if '(lambda (x) (equal (caar lst) (car x))) lst)
                ) ;_ end of setq
                (reverse temp)
              ) ;_ end of while
            ) ;_ end of lambda
             lst
           )
    ) ;_ end of setq
  ) ;_ end of defun
;;;(setq lst '(("22" "Двутавр 20Б1" "-")("1" "-10х100x100" "-") ("2" "Швеллер 12" "L=1000") ("8" "Полоса -4х50" 
;;;"L=1000") ("14" "Уголок 75х5" "L=")))  
  (setq lst (mapcar '(lambda (x)
                       (list (vl-string-trim " " (car x))
                             (vl-string-trim " " (cadr x))
                       ) ;_ end of list
                     ) ;_ end of lambda
;;;                    lst
		    
                    (_dwgru-get-spds-text-and-range) ; из #472 
            ) ;_ end of mapcar
  ) ;_ end of setq
  (setq lst (CB-filtr lst))
  (setq lst
         (mapcar
           '(lambda (x / p)
              (if (setq p (vl-string-position (ascii ",") (cadr x)))
                (list
                  (car x)
                  (substr (cadr x) 1 p)
                  (vl-string-left-trim " " (substr (cadr x) (+ 2 p)))
                ) ;_ end of list
                (if (wcmatch (cadr x) "-*,Лист*,Фл*")
                  (append x '("-"))
                  (append x '("L="))
                ) ;_ end of if
              ) ;_ end of if
            ) ;_ end of lambda
           lst
         ) ;_ end of mapcar
  ) ;_ end of setq
  (setq lst
         (mapcar
           '(lambda (x) (nth x lst))
           (vl-sort-i
             ((lambda (lst)
                (mapcar
                  '(lambda (str1 str2)
                     (if (wcmatch str2 "@*")
                       (strcat (substr str2 1 1) str1 (substr str2 2))
                       (strcat str1 str2)
                     ) ;_ end of if
                   ) ;_ end of lambda
                  (mapcar
                    '(lambda (x / str)
                       (setq str "0")
                       (repeat x
                         (setq str (strcat str "0"))
                       ) ;_ end of repeat
                       str
                     ) ;_ end of lambda
                    ((lambda (a)
                       (mapcar '(lambda (x) (- (apply 'max a) x)) a)
                     ) ;_ end of lambda
                      (mapcar
                        '(lambda (str)
                           (length
                             (vl-remove-if-not
                               '(lambda (x)
                                  (wcmatch x "#")
                                ) ;_ end of lambda
                               (mapcar 'chr (vl-string->list str))
                             ) ;_ end of vl-remove-if-not
                           ) ;_ end of length
                         ) ;_ end of lambda
                        lst
                      ) ;_ end of mapcar
                    )
                  ) ;_ end of mapcar
                  lst
                ) ;_ end of mapcar
              ) ;_ end of lambda
               (mapcar 'strcase (mapcar 'car lst))
             )
             '<
           ) ;_ end of vl-sort-i
         ) ;_ end of mapcar
  ) ;_ end of setq
  (setq LST-AS
         (apply
           'append
           (mapcar
             '(lambda (X Y)
                (mapcar
                  '(lambda (Z)
                     (cons Z Y)
                   ) ;_ end of lambda
                  X
                ) ;_ end of mapcar
              ) ;_ end of lambda
             (list (list "Лист -" "Лист-" "Фл")
                   (list "Лист чечевица" "Лист ромб")
                   (list "-")
                   (list "Полоса")
                   (list "Уголок" "\\U+E720")
                   (list "\\U+E72E")
                   (list "Тр")
		   (list "Двутавр*#*#[БКШ]" "\\U+E729*#*#[БКШ]")
                   (list "Двутавр" "\\U+E729")
                   (list "Швеллер" "\\U+E725")
                   (list "%%c" "\\U+E712")
                   (list "Болт")
             ) ;_ end of list
             (list "ГОСТ 19903-74"
                   "ГОСТ 8568-77"
                   (list "ГОСТ 19903-74" "ГОСТ 103-76")
                   "ГОСТ 103-76"
                   (list "ГОСТ 8509-93" "ГОСТ 8510-86")
                   "ГОСТ 30245-03"
                   "ГОСТ 10704-91"
		   "СТО АСЧМ 20-93" 
                   "ГОСТ 8239-89"
                   "ГОСТ 8240-97"
                   "ГОСТ 5781-82"
                   "ГОСТ 7798-703"
             ) ;_ end of list
           ) ;_ end of mapcar
         ) ;_ end of apply
  ) ;_ end of setq LST-AS
  (setq lst
         (mapcar
           '(lambda (EL-LST / EL-AS)
              (setq EL-AS
                     (car
                       (vl-remove-if-not
                         '(lambda (STR)
                            (wcmatch (cadr EL-LST) (strcat (car STR) "*"))
                          ) ;_ end of lambda
                         LST-AS
                       ) ;_ end of vl-remove-if-not
                     ) ;_ end of car
              ) ;_ end of setq
              (cons
                (car EL-LST)
                (cons
                  (cond
                    ((equal (car EL-AS) "-")
                     (if (equal (caddr EL-LST) "-")
                       (cadr EL-AS)
                       (caddr EL-AS)
                     ) ;_ end of if
                    )
                    ((member (car EL-AS) '("Уголок" "\\U+E720"))
                     (if
                       ((lambda (STR)
                          (equal
                            (vl-string-position (ascii "x") STR)
                            (vl-string-position (ascii "x") STR nil t)
                          ) ;_ end of equal
                        ) ;_ end of lambda
                         (vl-string-translate "х" "x" (cadr EL-LST))
                       )
                        (cadr EL-AS)
                        (caddr EL-AS)
                     ) ;_ end of if
                    )
                    (t (cdr EL-AS))
                  ) ;_ end of cond
                  (cdr EL-LST)
                ) ;_ end of cons
              ) ;_ end of cons
            ) ;_ end of lambda
           lst
         ) ;_ end of mapcar
  ) ;_ end of setq
  ((lambda (/ b1 a1 a2 a3)
     (mapcar
       '(lambda (B A / b1 a1 a2 a3)
          ((lambda (dxf)
             (entmod
               (subst (cons 1 A)
                      (assoc 1 dxf)
                      dxf
               ) ;_ end of subst
             ) ;_ end of entmod
           ) ;_ end of lambda
            (entget B)
          )
        ) ;_ end of lambda
       (setq b1
              ((lambda (/ sset)
                 (princ "\nВыберите шаблон спецификации: ")
                 (if (setq sset (ssget '((0 . "*TEXT"))))
                   (vl-sort
                     (vl-sort
                       (vl-remove-if
                         (function listp)
                         (mapcar (function cadr)
                                 (ssnamex sset)
                         ) ;_ end of mapcar
                       ) ;_ end of vl-remove-if
                       '(lambda (a b)
                          (> (caddr (assoc '10 (entget a)))
                             (caddr (assoc '10 (entget b)))
                          ) ;_ on Y
                        ) ;_ end of lambda
                     ) ;_ end of vl-sort
                     '(lambda (a b)
                        (and
                          (equal (caddr (assoc '10 (entget a)))
                                 (caddr (assoc '10 (entget b)))
                                 1.
                          ) ;_ end of equal
                          (< (cadr (assoc '10 (entget a)))
                             (cadr (assoc '10 (entget b)))
                          ) ;_ end of <
                        ) ;_ end of and
                      ) ;_ end of lambda
                   ) ;_ end of vl-sort
                 ) ;_ end of if
               ) ;_ end of lambda
              )
       ) ;_ end of setq
       (progn
         (setq a1 (apply 'append lst)
               a1
                  (append
                    a1
                    (if (not (minusp (setq a2 (- (length b1) (length a1)))))
                      (append (repeat a2 (setq a3 (cons "XX" a3))))
                    ) ;_ end of if
                  ) ;_ end of append
         ) ;_ end of setq
       ) ;_ end of progn
     ) ;_ end of mapcar
   ) ;_ end of lambda
  )
) ;_ end of defun ntt
__________________
Блог
Red Nova вне форума  
 
Автор темы   Непрочитано 28.10.2008, 22:38
#116
Red Nova

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

dextron3, Если будешь добавлять ГОСТы, то не забудь и тут выложить.
__________________
Блог
Red Nova вне форума  
 
Непрочитано 28.10.2008, 22:55
#117
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

Red Nova, а куда подевались мои решеточки?
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Непрочитано 28.10.2008, 22:58
#118
DEM

YngIngKllr
 
Регистрация: 29.03.2005
СПб
Сообщений: 12,783

Если честно все как то через одно место делается.
Может все таки лучше сделать текстовый файл или *.dat и в нем сдеать соответствующую фильтрацию.
__________________
Шаг 12й......
Мои публикации
DEM вне форума  
 
Непрочитано 29.10.2008, 00:31
#119
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

>DEM
Цитата:
Если честно все как то через одно место делается
Я это уже давно заметил - не программа, а сплошное латание дыр. Но все же пусть ребята потренируются, может когда-нибудь и сформируется нормальное ТЗ, вот тогда можно будет переписать прогу заново...
>Red Nova
Цитата:
После работы лиспа в ком строку выбрасывается куча ненужной информации. Как от этого избавиться?
Вставь в конце программы (princ)
Код:
[Выделить все] 
 
   ) ;_ end of lambda
  )
(princ)
) ;_ end of defun ntt
CB вне форума  
 
Непрочитано 29.10.2008, 06:47
#120
ShaggyDoc

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

Цитата:
Я это уже давно заметил - не программа, а сплошное латание дыр
Так это этюды на тему скрещивания ужа и ежа. Практического значения ноль, null или nil. Очередное строительство моста вдоль реки. Хотя для учебных целей есть полезные куски кода.
ShaggyDoc вне форума  
 
Непрочитано 29.10.2008, 07:07
#121
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

CB, этот лисп очень хороший! я сомтрю тут не всефорумчане учавствуют в разговоре, но все следят за изменениями и в курсе дела, могу показать мое ТЗ, если конечно я вовремя...
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Автор темы   Непрочитано 29.10.2008, 09:56
#122
Red Nova

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

dextron3,
Цитата:
а куда подевались мои решеточки?
Какие решетки?
DEM,
Цитата:
все как то через одно место делается.
Может и так. Я не против того чтобы программа приняла более достойный вид. Так что, если хочешь, давай будем формулировать новое ТЗ, ты первый. СВ вроде не против все переделать.
ShaggyDoc,
Цитата:
Практического значения ноль, null или nil
Не согласен. Нужно учесть что ТЗ я сформулировал учитывая нужды нашего КБ. Конечно же это не для всех универсально. Но тут без помощи других участников форума не справиться. У нас программа уже используется, и все довольны. Так что практического значения уже не ноль.
__________________
Блог
Red Nova вне форума  
 
Непрочитано 29.10.2008, 10:05
#123
Рyslan


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

а где сам лисп? никак не могу его найти среди ваших постов
Рyslan вне форума  
 
Непрочитано 29.10.2008, 10:11
#124
DEM

YngIngKllr
 
Регистрация: 29.03.2005
СПб
Сообщений: 12,783

Red Nova
Занимаюсь своей программкой думаю о структуре и связи данных.
Правда часть моих пожеланий Яков Коренев пообещал в следующем релизе СПДС-ки учесть.
Связь данных можно осуществить и с помощь данного лиспа, только проблема в том что обозначения позиций на чертеже, Я делаю нумерацией, а не как в вашем случае описывая деталь грубо говоря.
__________________
Шаг 12й......
Мои публикации
DEM вне форума  
 
Непрочитано 29.10.2008, 11:23
#125
ShaggyDoc

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

Цитата:
практического значения уже не ноль
Я же писал "...null или nil". А null и nil это не ноль.
ShaggyDoc вне форума  
 
Непрочитано 29.10.2008, 12:04
#126
Рyslan


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

так где лисп то? дайте посмотреть то
Рyslan вне форума  
 
Автор темы   Непрочитано 29.10.2008, 13:21
#127
Red Nova

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

Рyslan, #115 + Это и Это
ShaggyDoc, Издеваемся... ну как не Ай Ай Ай.
DEM, А что конкретнее планируют ввести разработчики СПДС в следующем релизе?
__________________
Блог
Red Nova вне форума  
 
Непрочитано 29.10.2008, 14:40
#128
ShaggyDoc

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

Цитата:
ShaggyDoc, Издеваемся... ну как не Ай Ай Ай.
Ага. Пытаетесь решить задачу, чтобы в спецификацию попадали правильные данные. И придумали, что их надо из выносок копировать. А в выноски может попадать черт-те что, особенно если dextron3 возьмется. И пытаетесь программно перебирать все варианты, на которые способна "обезьяна с гранатой". Их будет бесконечное количество.

А надо делать, чтобы вообще ввести можно было только правильные данные.
Последний раз редактировалось ShaggyDoc, 29.10.2008 в 20:34. Причина: Убрал неправильное "ожирнение"
ShaggyDoc вне форума  
 
Непрочитано 29.10.2008, 15:14
#129
Рyslan


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

Red Nova
А одного этого нет? Выложи готовый вариант, которым сам пользуешься и описание что делает лисп, если не трудно
Рyslan вне форума  
 
Автор темы   Непрочитано 29.10.2008, 15:24
#130
Red Nova

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

ShaggyDoc, Похоже вы не очень внимательно просмотрели лисп. Там присутствует многократная фильтрация лишней информации. Как раз чтобы "черт-те что" туда не попадало. Честно говоря не понимаю вашего недоумения. Этот лисп лично для меня (и не только) очень удобен. И я не претендую на то чтобы программа стала эталонной.
__________________
Блог
Red Nova вне форума  
 
Автор темы   Непрочитано 29.10.2008, 15:34
#131
Red Nova

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

Рyslan, Я дал 3 ссылки. Сохрани коды как отдельные lsp файлы и загрузи. Описание работы на #52
__________________
Блог
Red Nova вне форума  
 
Непрочитано 29.10.2008, 19:13
#132
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

Red Nova, на счет болта L= не желательно бы,

хотябы прочерк вместо длины ставило, как в пластинах...
Миниатюры
Нажмите на изображение для увеличения Название: Snap1.jpg Просмотров: 102 Размер: 11.1 Кб ID: 11651  
__________________
инженер проектировшик с опттом программа авто гад образование высшие
Последний раз редактировалось dextron3, 29.10.2008 в 19:24.
dextron3 вне форума  
 
Непрочитано 29.10.2008, 19:54
#133
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

Red Nova,

Принимай обновлениия:

Код:
[Выделить все] 
"Анк.Болт*,ПВ1*,Сетка*,Чечев.*,Ромб.*,Шайба*,Гайка*,Болт*,\\U+E72E*,Труба*,Тр.*,Лист*,Полоса*,\\U+E720*,Уголок*,\\U+E725*,Швеллер*,\\U+E729*,Двутавр*,Фланец*,Фл.*,-*,%%c*,\\U+E712*,#%%c*,# %%c*,##%%c*,## %%c*,#\\U+E712*,# \\U+E712*,##\\U+E712*,## \\U+E712*"

Код:
[Выделить все] 
(list (list "Лист -" "Лист-" "Фл")
                   (list "Лист чечевица" "Лист ромб")
                   (list "-")
                   (list "Полоса")
                   (list "Уголок" "\\U+E720")
                   (list "\\U+E72E")
                   (list "Тр")
		   (list "Двутавр*#*#[БКШ]" "\\U+E729*#*#[БКШ]")
		   (list "Двутавр*#*#[М]" "\\U+E729*#*#[М]")
                   (list "Двутавр" "\\U+E729")
                   (list "Швеллер" "\\U+E725")
                   (list "%%c" "\\U+E712")
                   (list "Анк.Болт")
                   (list "Болт")
                   (list "Гайка")
                   (list "Шайба")
                   (list "Ромб.")
                   (list "Чечев.")
                   (list "Сетка")
                   (list "ПВ1")

             ) ;_ end of list
             (list "ГОСТ 19903-74"
                   "ГОСТ 8568-77"
                   (list "ГОСТ 19903-74" "ГОСТ 103-76")
                   "ГОСТ 103-76"
                   (list "ГОСТ 8509-93" "ГОСТ 8510-86")
                   "ГОСТ 30245-03"
                   "ГОСТ 10704-91"
		   "СТО АСЧМ 20-93"
                   "ГОСТ 19425-74" 
                   "ГОСТ 8239-89"
                   "ГОСТ 8240-97"
                   "ГОСТ 5781-82"
                   "ГОСТ 28778-90"
                   "ГОСТ 7798-703"
                   "ГОСТ 5915-70"
                   "ГОСТ 11371-78"
                   "ГОСТ 8568-77"
                   "ГОСТ 8568-77"
                   "ГОСТ 5336-80"
                   "ТУ 36.26.11-5-89"


             ) ;_ end of list
Не работает только Анк.Болт, жду объяснения
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Непрочитано 29.10.2008, 21:35
#134
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

А возможно просто сделать такой лисп + к нему текстовый файл

тоесть СПДС ная выноска, делиться на три как бы составляющих

1. Позиция
2. Надпись
3. Длина, любое наименование, разделение происходит при помощи ЗАПЯТОЙ,

в текстовом файле запись к примеру

Ф______ГОСТ такойто
Швеллер_______ГОСТ такойто

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

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

Буду ждать помощи Red Nova, СВ и VVA

заранее балгодарен
Миниатюры
Нажмите на изображение для увеличения Название: Snap2.jpg Просмотров: 106 Размер: 35.2 Кб ID: 11661  
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Непрочитано 29.10.2008, 22:38
#135
DEM

YngIngKllr
 
Регистрация: 29.03.2005
СПб
Сообщений: 12,783

dextron3
Че дурью маятся зачем повторять то что дано уже в спецификации.
Можно же просто использовать маркеры, там сделать не видимые свойства, и будет у тебя просто позиция на чертеже.
Короче ща времени нету, чуть позже поставлю 5-ку СПДС и разберу все по полочкам.
__________________
Шаг 12й......
Мои публикации
DEM вне форума  
 
Автор темы   Непрочитано 30.10.2008, 11:27
#136
Red Nova

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

DEM, Уже 5-я вышла? Может действительно там все уже по спецификациям тип-топ. Надо посмотреть...
__________________
Блог
Red Nova вне форума  
 
Непрочитано 31.10.2008, 22:48
#137
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

Red Nova, вроде почти подогнал под себя не могу внедрить свое условие:

Код:
[Выделить все] 
(if (wcmatch (cadr x) "\U+E722\U+E722\U+E722*")
                  (append x '("(м.кв.)"))
                  (append x '("L="))
                ) ;_ end of if
писалось только (м.кв.), а L= игнорировалось а не дублировалось

как это сделать?
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Автор темы   Непрочитано 31.10.2008, 23:00
#138
Red Nova

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

Хм. Нашел кого спрашивать
__________________
Блог
Red Nova вне форума  
 
Непрочитано 31.10.2008, 23:03
#139
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

Я все понял!!!!!!!!!

Код:
[Выделить все] 
(if (wcmatch (cadr x) "-*,Лист*,Фл*,Болт*,Гайка*,Шайба*")
                  (append x '("-"))
                  (append x '("(м.кв.)"))


Red Nova, я сделал такое условие если нет буквы L в выноске и это соответсвенно не -*,Лист*,Фл*,Болт*,Гайка*,Шайба*, то тогда будет проставляться (м.кв.), но проблема что хочется теперь п.м. вставить
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Непрочитано 31.10.2008, 23:09
#140
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

но приходится теперь в соновной спеке м.п. выражать так:
Миниатюры
Нажмите на изображение для увеличения Название: Snap3.jpg Просмотров: 98 Размер: 47.6 Кб ID: 11771  
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Непрочитано 31.10.2008, 23:28
#141
dextron3

Фотограф
 
Регистрация: 01.01.2007
Алматы
Сообщений: 5,042

Код:
[Выделить все] 
(setq lst
         (mapcar
           '(lambda (x / p)
              (if (setq p (vl-string-position (ascii ",") (cadr x)))
                (list
                  (car x)
                  (substr (cadr x) 1 p)
                  (vl-string-left-trim " " (substr (cadr x) (+ 2 p)))
                ) ;_ end of list
                (if (wcmatch (cadr x) "-*,Лист*,Фл*,Болт*,Гайка*,Шайба*")
                  (append x '("-"))
                (if (wcmatch (cadr x) "Сетка*")
                  (append x '("м.кв."))
                ) ;_ end of if
                  (append x '("(м.п.)"))
                ) ;_ end of if
              ) ;_ end of if
            ) ;_ end of lambda
           lst
         ) ;_ end of mapcar
  ) ;_ end of setq
не могу найти здесь ошибку...
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Автор темы   Непрочитано 24.11.2008, 20:19
#142
Red Nova

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

СВ
Удачно закончил настройку лиспа расчета спецификаций spec5d от VVA для армянского языка. Теперь пытаясь настроить ntt под армянский, и должен признать что успехи нулевые. Если в spec5d проблема возникла только с одним видом профиля, то в ntt не заработал ни один профиль с армянским наименованием. Вот мой вариант c попыткой добавить армянские наименования трубы, фланца и проф-листов. В чем я ошибаюсь?
Код:
[Выделить все] 
(defun c:ntt (/ CB-filtr lst LST-AS)    ;note to text
  (defun CB-filtr (lst)
    (setq
      lst
       (vl-remove-if
         '(lambda (x)
            (or
              (not (equal (length x) 2))
              (member "" x)
              (not
                (wcmatch
                  (vl-string-translate "Tp" "Тр" (cadr x))
                  "Болт*,\\U+E72E*,Труба*,Тр.*,Лист*,Полоса*,\\U+E720*,Уголок*,\\U+E725*,Швеллер*,\\U+E729*,Двутавр*,Фланец*,Фл.*,-*,%%c*,\\U+E712*,#%%c*,# %%c*,##%%c*,## %%c*,#\\U+E712*,# \\U+E712*,##\\U+E712*,## \\U+E712*, \\U+0547\\U+0580\\U+057В\\U+0561\\U+0576*, \\U053d\\U0578\U0572*, \\U0578\\U057d\\U057a\\U0561\\U0571\\U0587*"
                ) ;_ end of wcmatch
              ) ;_ end of not
              (not
                (or
                  (and
                    (wcmatch (car x) "@*")
                    (wcmatch (vl-string-right-trim "1234567890'\"" (car x))
                             "@"
                    ) ;_ end of wcmatch
                  ) ;_ end of and
                  (and (wcmatch (car x) "#*")
                       (wcmatch (vl-string-left-trim "1234567890" (car x))
                                ",@,@',@\",',\""
                       ) ;_ end of wcmatch
                  ) ;_ end of and
                ) ;_ end of or
              ) ;_ end of not
            ) ;_ end of or
          ) ;_ end of lambda
         lst
       ) ;_ end of vl-remove-if
    ) ;_ end of setq
    (setq lst
           ((lambda (lst / poz temp)
              (defun poz (str pat / p n)
                (while (setq n (vl-string-search pat str n))
                  (setq p (cons n p)
                        n (1+ n)
                  ) ;_ end of setq
                ) ;_ end of while
                p
              ) ;_ end of defun
              (while lst
                (setq
                  temp
                   (cons
                     ((lambda (lst-temp / n)
                        (list
                          (car lst-temp)
                          (vl-string-left-trim
                            "1234567890 "
                            (if (or
                                  (equal (length
                                           (setq n (poz (cadr lst-temp) ","))
                                         ) ;_ end of length
                                         2
                                  ) ;_ end of equal
                                  (not (wcmatch (cadr lst-temp) "*L=*"))
                                ) ;_ end of or
                              (substr (cadr lst-temp)
                                      1
                                      (if (wcmatch (cadr lst-temp) "*L=*")
                                        (car n)
                                        (car (reverse n))
                                      ) ;_ end of if
                              ) ;_ end of substr
                              (cadr lst-temp)
                            ) ;_ end of if
                          ) ;_ end of vl-string-left-trim
                        ) ;_ end of list
                      ) ;_ end of lambda
                       (car
                         (vl-sort
                           (vl-remove-if-not
                             '(lambda (x) (equal (caar lst) (car x)))
                             lst
                           ) ;_ end of vl-remove-if-not
                           '(lambda (str1 str2)
                              (>
                                (+ (length (poz (cadr str1) ","))
                                   (if (wcmatch (cadr str1) "*L=*")
                                     1
                                     0
                                   ) ;_ end of if
                                ) ;_ end of +
                                (+ (length (poz (cadr str2) ","))
                                   (if (wcmatch (cadr str2) "*L=*")
                                     1
                                     0
                                   ) ;_ end of if
                                ) ;_ end of +
                              ) ;_ end of >
                            ) ;_ end of lambda
                         ) ;_ end of vl-sort
                       ) ;_ end of car
                     )
                     temp
                   ) ;_ end of cons
                ) ;_ end of setq
                (setq lst
                       (vl-remove-if '(lambda (x) (equal (caar lst) (car x))) lst)
                ) ;_ end of setq
                (reverse temp)
              ) ;_ end of while
            ) ;_ end of lambda
             lst
           )
    ) ;_ end of setq
  ) ;_ end of defun

  (setq lst (mapcar '(lambda (x)
                       (list (vl-string-trim " " (car x))
                             (vl-string-trim " " (cadr x))
                       ) ;_ end of list
                     ) ;_ end of lambda
;;;                    lst
		    
                    (_dwgru-get-spds-text-and-range) ; из #472 
            ) ;_ end of mapcar
  ) ;_ end of setq
  (setq lst (CB-filtr lst))
  (setq lst
         (mapcar
           '(lambda (x / p)
              (if (setq p (vl-string-position (ascii ",") (cadr x)))
                (list
                  (car x)
                  (substr (cadr x) 1 p)
                  (vl-string-left-trim " " (substr (cadr x) (+ 2 p)))
                ) ;_ end of list
                (if (wcmatch (cadr x) "-*,Лист*,Фл*")
                  (append x '("-"))
                  (append x '("L="))
                ) ;_ end of if
              ) ;_ end of if
            ) ;_ end of lambda
           lst
         ) ;_ end of mapcar
  ) ;_ end of setq
  (setq lst
         (mapcar
           '(lambda (x) (nth x lst))
           (vl-sort-i
             ((lambda (lst)
                (mapcar
                  '(lambda (str1 str2)
                     (if (wcmatch str2 "@*")
                       (strcat (substr str2 1 1) str1 (substr str2 2))
                       (strcat str1 str2)
                     ) ;_ end of if
                   ) ;_ end of lambda
                  (mapcar
                    '(lambda (x / str)
                       (setq str "0")
                       (repeat x
                         (setq str (strcat str "0"))
                       ) ;_ end of repeat
                       str
                     ) ;_ end of lambda
                    ((lambda (a)
                       (mapcar '(lambda (x) (- (apply 'max a) x)) a)
                     ) ;_ end of lambda
                      (mapcar
                        '(lambda (str)
                           (length
                             (vl-remove-if-not
                               '(lambda (x)
                                  (wcmatch x "#")
                                ) ;_ end of lambda
                               (mapcar 'chr (vl-string->list str))
                             ) ;_ end of vl-remove-if-not
                           ) ;_ end of length
                         ) ;_ end of lambda
                        lst
                      ) ;_ end of mapcar
                    )
                  ) ;_ end of mapcar
                  lst
                ) ;_ end of mapcar
              ) ;_ end of lambda
               (mapcar 'strcase (mapcar 'car lst))
             )
             '<
           ) ;_ end of vl-sort-i
         ) ;_ end of mapcar
  ) ;_ end of setq
  (setq LST-AS
         (apply
           'append
           (mapcar
             '(lambda (X Y)
                (mapcar
                  '(lambda (Z)
                     (cons Z Y)
                   ) ;_ end of lambda
                  X
                ) ;_ end of mapcar
              ) ;_ end of lambda
             (list (list "Лист -" "Лист-" "Фл" "\\U+0547\\U+0580\\U+057В\\U+0561\\U+0576")
                   (list "Лист чечевица" "Лист ромб" "\\U0539\\U056b\\U0569\\U0565\\U0572 \\U0578\\U057d\\U057a\\U0561\\U0571\\U0587" "\\U0539\\U056b\\U0569\\U0565\\U0572 \\U0577\\U0565\\U0572\\U0561\\U0576\\U056f\\U0575\\U0578\\U0582\\U0576")
                   (list "-")
                   (list "Полоса")
                   (list "Уголок" "\\U+E720")
                   (list "\\U+E72E")
                   (list "Тр" "\\U053d\\U0578\\U0572." "\\U053d\\U0578\\U0572\\U0578\\U057e\\U0561\\U056f")
		   (list "Двутавр*#*#[БКШ]" "\\U+E729*#*#[БКШ]")
                   (list "Двутавр" "\\U+E729")
                   (list "Швеллер" "\\U+E725")
                   (list "%%c" "\\U+E712")
                   (list "Болт")
             ) ;_ end of list
             (list "ГОСТ 19903-74"
                   "ГОСТ 8568-77"
                   (list "ГОСТ 19903-74" "ГОСТ 103-76")
                   "ГОСТ 103-76"
                   (list "ГОСТ 8509-93" "ГОСТ 8510-86")
                   "ГОСТ 30245-03"
                   "ГОСТ 10704-91"
		   "СТО АСЧМ 20-93" 
                   "ГОСТ 8239-89"
                   "ГОСТ 8240-97"
                   "ГОСТ 5781-82"
                   "ГОСТ 7798-703"
             ) ;_ end of list
           ) ;_ end of mapcar
         ) ;_ end of apply
  ) ;_ end of setq LST-AS
  (setq lst
         (mapcar
           '(lambda (EL-LST / EL-AS)
              (setq EL-AS
                     (car
                       (vl-remove-if-not
                         '(lambda (STR)
                            (wcmatch (cadr EL-LST) (strcat (car STR) "*"))
                          ) ;_ end of lambda
                         LST-AS
                       ) ;_ end of vl-remove-if-not
                     ) ;_ end of car
              ) ;_ end of setq
              (cons
                (car EL-LST)
                (cons
                  (cond
                    ((equal (car EL-AS) "-")
                     (if (equal (caddr EL-LST) "-")
                       (cadr EL-AS)
                       (caddr EL-AS)
                     ) ;_ end of if
                    )
                    ((member (car EL-AS) '("Уголок" "\\U+E720"))
                     (if
                       ((lambda (STR)
                          (equal
                            (vl-string-position (ascii "x") STR)
                            (vl-string-position (ascii "x") STR nil t)
                          ) ;_ end of equal
                        ) ;_ end of lambda
                         (vl-string-translate "х" "x" (cadr EL-LST))
                       )
                        (cadr EL-AS)
                        (caddr EL-AS)
                     ) ;_ end of if
                    )
                    (t (cdr EL-AS))
                  ) ;_ end of cond
                  (cdr EL-LST)
                ) ;_ end of cons
              ) ;_ end of cons
            ) ;_ end of lambda
           lst
         ) ;_ end of mapcar
  ) ;_ end of setq
  ((lambda (/ b1 a1 a2 a3)
     (mapcar
       '(lambda (B A / b1 a1 a2 a3)
          ((lambda (dxf)
             (entmod
               (subst (cons 1 A)
                      (assoc 1 dxf)
                      dxf
               ) ;_ end of subst
             ) ;_ end of entmod
           ) ;_ end of lambda
            (entget B)
          )
        ) ;_ end of lambda
       (setq b1
              ((lambda (/ sset)
                 (princ "\nВыберите шаблон спецификации: ")
                 (if (setq sset (ssget '((0 . "*TEXT"))))
                   (vl-sort
                     (vl-sort
                       (vl-remove-if
                         (function listp)
                         (mapcar (function cadr)
                                 (ssnamex sset)
                         ) ;_ end of mapcar
                       ) ;_ end of vl-remove-if
                       '(lambda (a b)
                          (> (caddr (assoc '10 (entget a)))
                             (caddr (assoc '10 (entget b)))
                          ) ;_ on Y
                        ) ;_ end of lambda
                     ) ;_ end of vl-sort
                     '(lambda (a b)
                        (and
                          (equal (caddr (assoc '10 (entget a)))
                                 (caddr (assoc '10 (entget b)))
                                 1.
                          ) ;_ end of equal
                          (< (cadr (assoc '10 (entget a)))
                             (cadr (assoc '10 (entget b)))
                          ) ;_ end of <
                        ) ;_ end of and
                      ) ;_ end of lambda
                   ) ;_ end of vl-sort
                 ) ;_ end of if
               ) ;_ end of lambda
              )
       ) ;_ end of setq
       (progn
         (setq a1 (apply 'append lst)
               a1
                  (append
                    a1
                    (if (not (minusp (setq a2 (- (length b1) (length a1)))))
                      (append (repeat a2 (setq a3 (cons "XX" a3))))
                    ) ;_ end of if
                  ) ;_ end of append
         ) ;_ end of setq
       ) ;_ end of progn
     ) ;_ end of mapcar
   ) ;_ end of lambda
  )
) ;_ end of defun ntt
__________________
Блог
Red Nova вне форума  
 
Непрочитано 25.11.2008, 12:17
#143
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

>Red Nova
Ну это и естественно
Цитата:
что успехи нулевые.
т.к. все, что здесь я говорил про функцию wcmatch осталось без внимания...
Возьмем фрагмент кода
Код:
[Выделить все] 
(wcmatch
  (vl-string-translate "Tp" "Тр" (cadr x))
  ".....,##\\U+E712*,## \\U+E712*, \\U+0547\\U+0580\\U+057В\\U+0561\\U+0576*, \\U053d\\U0578\U0572*, \\U0578\\U057d\\U057a\\U0561\\U0571\\U0587*"
) ;_ end of wcmatch
и посмотрим синий шаблон:
1. Пробел после запятой указывает, что и в слове этот пробел должен быть перед ним - а он есть?
2. Совершенно непонятно с UNICODE, а именно
здесь у тебя "\U0547\U0580\U057b\U0561\U0576", здесь - "\U+0547\U+0580\U+057B\U+0561\U+0576" (т.е. в верхнем регистре, да еще появились +).
Так что тут уж ты определись, как должно быть на самом деле (в моем понимании должнен быть такой шаблон - ....,\\U+0547\\U+0580\\U+057b\\U+0561\\U+0576*,....
хотя это ты должен сам проверить... (выполни п.2 и п.5 (см.ниже) и результат сюда)
Ну и еще совет - не пытайся сделать все шаблоны сразу, добейся, чтобы сработал сначала один, потом по образу делай другие.
Вот примерный перечень твоих действий:
1. Открываем в VLIDE лисп с функцией ntt и лисп с функций _dwgru-get-spds-text-and-range
2. Загружаем _dwgru-get-spds-text-and-range (двойной клик перед функцией и Load selection в VLIDE)
3. Вносим шаблон в код, указанный выше
4. Загружаем функцию CB-filtr (так же как в п.2).
5. Находим в ntt код
Код:
[Выделить все] 
 
(setq lst (mapcar '(lambda (x)
                       (list (vl-string-trim " " (car x))
                             (vl-string-trim " " (cadr x))
                       ) ;_ end of list
                     ) ;_ end of lambda
;;;                    lst
 
                    (_dwgru-get-spds-text-and-range) ; из #472 
            ) ;_ end of mapcar
  ) ;_ end of setq
выполняем его так же, как и в п.2 и смотрим результат в VLIDE (указываем в чертеже только те объекты, которые нам нужны для проверки)
6. Находим в ntt код
Код:
[Выделить все] 
(setq lst (CB-filtr lst))
выполняем его так же, как и в п.2 и смотрим результат в VLIDE
7. После любых изменений в шаблоне, обязательно выполняем п.4
8. Только когда получаем нужный результат в п.6 - вставляем шаблон в LST-AS.

Ну и еще, для всех кому интересно - правило переноса длинного шаблона на следующую строку в функции wcmatch:
Код:
[Выделить все] 
(wcmatch "Уголок 20x25"
  "Болт*,\\U+E72E*,Труба*,Тр.*,Лист*,Полоса*,\\U+E720*,Уголок*,
  ,Швеллер*,\\U+E729*,Двутавр*,Фланец*,Фл.*,
  ,-*,%%c*,\\U+E712*,#%%c*,# %%c*,##%%c*,## %%c*,#\\U+E712*"
) ;_ end of wcmatch
T 
_$
т.е. перед шаблоном, который переносится на следующую должна быть запятая...
CB вне форума  
 
Автор темы   Непрочитано 25.11.2008, 15:30
#144
Red Nova

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

CB,
Цитата:
т.к. все, что здесь я говорил про функцию wcmatch осталось без внимания...
Ну без внимания не осталось, но что память у меня на такие вещи оставляет желать лучшего – это да.
Цитата:
2. Совершенно непонятно с UNICODE, а именно
здесь у тебя "\U0547\U0580\U057b\U0561\U0576", здесь - "\U+0547\U+0580\U+057B\U+0561\U+0576" (т.е. в верхнем регистре, да еще появились +).
Так что тут уж ты определись
Честно говоря уже и не помню откуда пошли разные варианты записи (делал в разные дни и наверное пользовался разными источниками), но факт что все они срабатывают в spec5d. Хотя конечно же лучше привести к единому виду.

Пытаюсь сделать все в той очередности что ты говоришь.
В Vlide скопировал такие коды
Код:
[Выделить все] 
;|
* ?-??? str-str-lst
* ????????? ?-??? ?????????? ?? ?????? ??????, ???????????
* ????? ???? ???????? ??? ??????? ????????
* ?????????? ?????? ?????
* ????????? [Type]:
  str - ?????? ??? ??????? [STRING]
  pat - ??????????? [STRING]
*  ?????? ???????
  (setq str "??;???????;????????" pat ";")
  (setq str "?? — ??????? — ????????" pat " — ")
  (str-str-lst str pat)
* ?????? ????????? http://www.autocad.ru/cgi-bin/f1/board.cgi?t=25113OT
|;
(defun str-str-lst (str pat / i)
  (cond ((= str "") nil)
        ((setq i (vl-string-search pat str))
         (cons (substr str 1 i)
               (str-str-lst (substr str (+ (strlen pat) 1 i)) pat)
         ) ;_  cons
        )
        (t (list str))
  ) ;_  cond
) ;_  defun
(defun SortStringWithNumberAsNumber (ListOfString IgnoreCase / NorStrs count)
;;;Function Normalize (add 0 befor number) number in string
;;; Count normalize symbols set in variable count
;;; CAB added count as an argument
  (defun NormalizeNumberInString (str count / ch i pat ret buf)
    (setq i   0
          pat '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9")
          ret ""
    ) ;_ end of setq
    (while (/= (setq ch (substr str (setq i (1+ i)) 1)) "")
      (if (vl-position ch pat)
        (progn
          (setq buf ch) ;_ end of setq
          (while
            (vl-position (setq ch (substr str (setq i (1+ i)) 1)) pat)
             (setq buf (strcat buf ch))
          ) ;_ end of while
          (while (< (strlen buf) count) (setq buf (strcat "0" buf)))
          (setq ret (strcat ret buf))
        ) ;_ end of progn
      ) ;_ end of if
      (setq ret (strcat ret ch))
    ) ;_ end of while
    ret
  ) ;_ end of defun
  ;;-------------------------------------------------
  ;;  function to Count the longest number in string 
  ;;  CAB added to get the correct COUNT
  (defun getcount (lst / count pat)
    (setq count 0)
    (setq pat '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
    (mapcar
      '(lambda (str / i maxlen ch)
         (setq i 0 maxlen 0)
         (while (/= (setq ch (substr str (setq i (1+ i)) 1)) "")
           (if (vl-position ch pat) ; number
             (setq maxlen (1+ maxlen))
             (setq count  (max count maxlen) maxlen 0)
           )
         )
	 (setq count  (max count maxlen)) ;_<<< ADD 21.06.2007 by 
       )
      Lst
    )
    count
  )
  ;;===============================================
  (setq count   (GetCount ListOfString)
        NorStrs (mapcar '(lambda (x) (NormalizeNumberInString x count))
                        ListOfString)
  )
  (and IgnoreCase (setq NorStrs (mapcar 'strcase NorStrs)))
  (mapcar '(lambda (x) (nth x ListOfString)) (vl-sort-i NorStrs '<))
)
(defun mip_MTEXT_Unformat ( Mtext / text Str )
  (setq MM Mtext)
  (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
		   (zerop (strlen Text))
		   (= " " (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)
(defun mydcl-i (zagl info-list / fl ret dcl_id)
    (vl-load-com)
    (if (null zagl)
        (setq zagl "?????")
    ) ;_ end of if
    (setq fl (vl-filename-mktemp "mip" nil ".dcl"))
    (setq ret (open fl "w"))
    (mapcar '(lambda (x) (write-line x ret))
            (list "mip_msg : dialog { "
                  (strcat "label=\"" zagl "\";")
                  " :list_box {"
                  "alignment=top ;"
                  "width=51 ;"
                  (if (> (length info-list) 26)
                      "height= 26 ;"
                      (strcat "height= " (itoa (+ 3 (length info-list))) ";")
                  ) ;_ end of if
                  "is_tab_stop = false ;"
                  "key = \"info\";}"
                  "ok_cancel;}"
            ) ;_ end of list
    ) ;_ end of mapcar
    (setq ret (close ret))
    (if (setq dcl_id (load_dialog fl))
        (if (new_dialog "mip_msg" dcl_id)
            (progn
                (start_list "info")
                (mapcar 'add_list info-list)
                (end_list)
                (set_tile "info" "0")
                (setq ret 0)
                (action_tile "info" "(setq ret (atoi $value))")
                (action_tile "cancel" "(progn(setq ret nil)(done_dialog 0))")
                (action_tile "accept" "(done_dialog 1)")
                (start_dialog)
            ) ;_ end of progn
        ) ;_ end of if
    ) ;_ end of if
    (unload_dialog dcl_id)
    (vl-file-delete fl)
    ret
) ;_ end of defun
;;; ************************************************************************
;;; * ?????????? DWGruLispLib Copyright ©2007  DWGru Programmers Group
;;; *
;;; * _dwgru-conv-ent-to-ename
;;; *
;;; * 26/12/2007 ?????? 0002. ????? ???????????, ????????? ? ??????????: VVA
;;; * 03/12/2007 ?????? 0001. 
;;; ************************************************************************

(defun _dwgru-conv-ent-to-ename (ent / ret)
;;;    ????????? ?????????????? ??????????? ????????? ? ename-???????
;;;    ????????? ??????:
;;;	ent	?????????????? ?????????. ????? ????:
;;;		 ename
;;;		 vla-object
;;;		 ?????? (?????????????? ??? ????? ?????????)
;;;		 ??????, ?????????? ?? (entsel)
;;;		 ??????, ?????????? ?? (entget)
;;;    ??????? ??????:
  ;|
(setq
  entity (vla-addline
        (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
        (vlax-3d-point (setq pt (getpoint)))
        (vlax-3d-point (getpoint pt))
        ) ;_ end of vla-addline
  ) ;_ end of setq
(_dwgru-conv-ent-to-ename entity)	; <Entity name: 7ef5cf68>
|;
  (cond
    ((= (type ent) 'vla-object) (vlax-vla-object->ename ent))
    ((= (type ent) 'ename) ent)
    ((= (type ent) 'str) (handent ent))
;;;((= (type ent) 'str) (handent str))
;;; VVA 26/12/2007 : start
    ((and (= (type ent) 'list)
          (= (type (setq ret (car ent))) 'ename)
          ) ;_ end of and
     ret
     )
    ((= (type ent) 'list) (cdr (assoc -1 ent)))
    (t nil)
;;; VVA 26/12/2007 : end
    ) ;_ end of cond
  ) ;_ end of defun


;;; ************************************************************************
;;; * ?????????? DWGruLispLib Copyright ©2007  DWGru Programmers Group
;;; *
;;; * dwgru-string-replace
;;; *
;;; * 03/12/2007 ?????? 0001.  ?????? ????   (ShaggyDoc)
;;; ************************************************************************

(defun dwgru-string-replace (string old_substr new_substr / pos)
;;;    ??????? ?????? ????????? ????????? (old_substr) ? ???????? ?????? (string) ?? ????? (new_substr).
;;;    ????????????????
;;;    ????????? ??????:
;;;	string		???????? ??????
;;;	ols_substr	?????? ?????????
;;;	new_substr	????? ?????????  
    ;;; ???????:
    ;;;   ?????? (String)

;;;* ?????? ??????:
;;;* (dwgru-string-replace "???????? ??????" "?????? ?????????" "????? ?????????")
;;;* ????????? ??? ????????? ???? 'STR ???????? ?????????? ??????? ???? ???????? ? ??????.
;;;* ?????????? ?????? ? ??????? ???? ????????? ?????? ????????? ? ???????? ?????? ?? ?????.
;;;* ????????????? ? ???????? ????????. ???????? ???????????? ?????????? ?? ??????????.
;;;* ??????:
;|  
 (dwgru-string-replace "????? ???? ?????? ? ????????. ????" "??" "??") ;_?????????   "????? ???? ?????? ? ????????. ????"
 (dwgru-string-replace "1  2       3" "  " " ") ;_?????????  "1 2 3"
|;
    (while (setq pos (vl-string-search old_substr string))
        (setq string
                 (strcat
                     (substr string 1 pos)
                     new_substr
                     (dwgru-string-replace
                         (substr string (+ (strlen old_substr) pos 1))
                         old_substr
                         new_substr
                     ) ;_ end of ru-string-replace
                 ) ;_ end of strcat
        ) ;_ end of setq
    ) ;_ end of while
    string
) ;_ end of defun


;;; ************************************************************************
;;; * ?????????? DWGruLispLib Copyright ©2007  DWGru Programmers Group
;;; *
;;; * _dwgru-conv-ent-to-vla
;;; *
;;; * 27.12.2007 ???????? VVA
;;; * 03/12/2007 ?????? 0001. 
;;; ************************************************************************
    (defun _dwgru-conv-ent-to-vla (ent / ret)
;;;*    ????????? ?????????????? ??????????? ????????? ? vlax-???????
;;;*    ????????? ??????:
;;;*    ????????? ??????:
;;;*   ent ????????, ??????? ???? ????????????? ? ????????. ?????
;;;*   ????:
;;;*                       -    ?????? ????????? (ename),
;;;*                       -    vla-?????????? (vla-object),
;;;*                       -    ?????? (?????????????? ??? ????? ?????????),
;;;*                       -    ?????? entget,
;;;*                       -    ?????? entsel.
;;;*   ???? ?? ??????????? ?? ?????? ?? ????????? ?????,
;;;*   ???????????? nil
;;;  
;;;* ?????????? ??????? ??????????
;;;                 _dwgru-conv-ent-to-ename

  ;|
(setq entity (entmakex (list (cons 0 "POINT") (cons 10 (getpoint)))))
(_dwgru-conv-ent-to-vla entity) ; #<VLA-OBJECT IAcadPoint 064ad294>
(_dwgru-conv-ent-to-vla (entget(entlast)))
(_dwgru-conv-ent-to-vla (cdr(assoc 5 (entget(entlast)))))
(_dwgru-conv-ent-to-vla (entsel))
(_dwgru-conv-ent-to-vla (vlax-ename->vla-object (entlast)))
|;
  (cond
    ((= (type ent) 'vla-object) ent)
;;; ((= (type ent) 'ename) (vlax-ename->vla-object ent)) ;;;Rem VVA
;;; 27.12.2007
    ((setq ret (_dwgru-conv-ent-to-ename ent)) (vlax-ename->vla-object ret))
;;;Add VVA 27.12.2007

    ;| ;;; Rem VVA 27.12.2007 ??????
;;; ???????????? ???????:
;;;((= (type ent) 'str) (vlax-ename->vla-object (handent ent)))
;; ??????????? Alaspher ?? 28.11.2007. ??????.
   ((= (type ent) 'str)
    (if (setq ent (handent ent))
      (vlax-ename->vla-object ent)
    ) ;_ end of if
   )
;; ??????????? Alaspher ?? 28.11.2007. ?????
;;; Rem VVA 27 12.2007 ?????|;
    (t nil)
    ) ;_ end of cond
  ) ;_ end of defun


;;; ************************************************************************
;;; * ?????????? DWGruLispLib Copyright ©2007  DWGru Programmers Group
;;; *
;;; * _dwgru-conv-pickset-to-list
;;; *
;;; * 03/12/2007 ?????? 0001. 
;;; ************************************************************************

(defun _dwgru-conv-pickset-to-list (value / lst item)
 ;;; ??????????:
    ;;; ??????????????? ????? (pickset) ? ??????? ?????? ???? ?????????? (ename)
    ;;; ?????????????? ???????. ???????? ???????????? ????? ?? ????????????

    ;;; ?????????: 
    ;;; value - ????? (pickset) ??? nil ???? ?????? ?????
    ;;; ???????:
    ;;;   - ?????? ?????????? (Ename)
;;;; ??????
  ;|
(setq point (vla-addpoint (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3d-point '(0 0 0))))
(_dwgru-conv-pickset-to-list (ssget "_L")) ;_(<??? ???????: 7ef85e00>)
(_dwgru-conv-pickset-to-list (ssadd)) ;_nil
  |;
       (repeat (setq item (sslength value)) ;_ end setq
         (setq lst (cons (ssname value (setq item (1- item))) lst))
         ) ;_ end repeat
lst
)

; ?-??? mip-put-hyperlink
; ?????????? nil.
; Arguments [Type]:
;   Ename = Object [ENAME]
;  URLDescription = ?????? [STR]
; ???? ?????? "", ?? ?????? ?????????
(defun mip-put-hyperlink (ENAME URLDescription)
  (if (eq (type ENAME) 'ENAME)
    (setq ENAME (vlax-ename->vla-object ENAME))
  ) ;_ end of if
  (vlax-for hyp (vla-get-hyperlinks ENAME) (vla-delete hyp))
  (if (/= URLDescription "")
  (vla-add (vla-get-hyperlinks ENAME)
           "about:blank"
           URLDescription
  ) ;_ end of vla-add
    )
) ;_ end of DEFUN		 

(defun mip-conv-to-str (dat)
  (cond ((= (type dat) 'INT)(setq dat (itoa dat)))
         ((= (type dat) 'REAL)(setq dat (rtos dat 2 12)))
        ((null dat)(setq dat ""))
        (t (setq dat (vl-princ-to-string dat)))))



;;;=====================================================================================




;;;http://dwg.ru/f/showthread.php?t=16987
;;;http://dwg.ru/f/showthread.php?t=16987&page=3
;;;?? ????? ????? ??????? ??????????? ??????????? TOKR. ????????? ??????, ???????.
;;;?????? ??????? ????????? ?? ??????????, ?????????, ????? ??????? ????????, ????? ??? ???? ??????????????.
;;;???? ? ?????? ???? ????, ?? ??? ??????????? ??? ??????????? ?????????. ? ??????? ??????????? ?????????? ?????? ? ?????? (???????????? ??),
;;;?? ???? ?? ?????????????. ??? ??????????? ????? ????? ? ???? ??????
;;;(text-round item okr t) ? ???????? ?? (text-round item okr nil)

;|
  ??????????:  ???????????? ??????,???????, ???????? ????????? ??? ??????.
               ??????? ??????? ????????????
  ???????????: ??????????? ? ???????????? ????? ??? ???????. 
               ????? ??????????? ?????? atof ????? ???? "22.3????" 
               ????? ?????? ??? ????? 22.3
 
               ??? ?????? ?????????? ????? ??????????? ? ???????????? 
               ? ????????? ?????????? num.
|;
;;;what - ???????? + ??? *
;;;newtext - t - ????? ?????, nil - ??????? ?????
;;; num - ?????????? ?????? ????? ???????, nil - ?????????? LUPREC
(defun operate_text ( what newtext num / res selset ins_pt txt_height blk obj ed *error*)
  (defun *error* (msg)
    (setvar "NOMUTT" 0)  ;_ ??????????????? NOMUTT
    (princ msg)
    )
 (vl-load-com)(if (eq what '*)(setq res 1.)(setq res 0.))
  (if (null num)(setq num (getvar "LUPREC")))
(princ "\n(?????????? ?? ")(princ num)(princ ") ")  
 (princ "???????? ?????? ??? ???????: ")
  (setvar "NOMUTT" 1)  ;_ ????????? NOMUTT
  (setq selset (ssget '((0 . "TEXT,MTEXT,*DIMENSION"))))
  (setvar "NOMUTT" 0)  ;_ ??????????????? NOMUTT
 (if  selset
    (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset)))
     (setq obj (vlax-ename->vla-object ent)
           ed (entget ent)
           ) 
     (if (and (wcmatch (cdr(assoc 0 ed)) "*DIMENSION")
              (or
                (member '(100 . "AcDbAlignedDimension") ed)  ;_???????????? ??? ????????
                (member '(100 . "AcDbDiametricDimension") ed);_???????
                (member '(100 . "AcDbRadialDimension") ed)   ;_??????
                (member '(100 . "AcDbArcDimension") ed)      ;_???????
                )
              )
       (progn
         (setq blk
             (vla-item (vla-get-blocks
                         (vla-get-activedocument (vlax-get-acad-object))
                       ) ;_ end of vla-get-Blocks
                       (cdr (assoc 2 ed))
             ) ;_ end of vla-item
      ) ;_ end of setq
      (vlax-for item blk
        (if (= (vla-get-objectname item) "AcDbMText")
          (setq obj item)
          )
         )
       )
       )
     (if (vlax-property-available-p obj 'Textstring)
       (progn
	 (setq txt_height (vla-get-Height obj))
     (setq str (str-str-lst (vla-get-textstring obj) "\\P")
     str (mapcar '(lambda(x)(mip_mtext_unformat x)) str)
      str (mapcar '(lambda(x)(vl-string-translate "," "." (vl-string-trim  "%UuoOcC \t"   x))) str)
      str (mapcar '(lambda(x)(vl-string-trim  "%UuoOcC \t"   x)) str)
     res ((eval what) res (apply what (mapcar 'atof str))))
     )
       )
      ) ;_ end of foreach 
    ) ;_ end of if 
  (princ "\n?????????= ")(princ res)(princ " ? ???????????= ")(princ (rtos res 2 num))
  
  (if (not (equal res 0. 1e-3))
    (if newtext
    (progn 
      (if (= (cdr (assoc 40 (tblsearch "STYLE" (getvar "TEXTSTYLE")))) 0.0) ;_ end of =
        (progn ;; ??????? ?????? ??????
	 (if (> (setq blk (_get_sumT_TH)) 1e-6)(setq txt_height blk))
   ;;;(if (not (setq txt_height (getreal "\n??????? ?????? ?????? <2.5> : ")))(setq txt_height 2.5)) 
          (vl-cmdf "_.TEXT" "0,0" txt_height 0 (_sumT_prep_Number(rtos res 2 num)))) ;_ end of progn
        (progn ;; ?????????????? ??????
          (vl-cmdf "_.TEXT" "0,0" 0 txt (_sumT_prep_Number(rtos res 2 num)))) ;_ end of progn
         )
      (command "_.copybase" "0,0" (entlast) "" "_.erase" (entlast) "" "_.pasteclip" pause) 
      ) ;_ end of progn
     (progn
       (TTC_Paste (_sumT_prep_Number(rtos res 2 num)) nil)
       )
    ) ;_ end of if
    )
   (princ) 
  )
;;;SUMm Text -> New text
(defun c:sumTN ( )
  (setq *sumT_Okr* (_get_sumT_Okr))
  (operate_text '+ t *sumT_Okr*)
   (princ) 
  )
;;;SUMm Text Exist
(defun c:sumTE ( )
  (setq *sumT_Okr* (_get_sumT_Okr))
  (operate_text '+ nil *sumT_Okr*)
   (princ) 
  )
(defun c:mulTN ( )
  (setq *sumT_Okr* (_get_sumT_Okr))
  (operate_text '* t *sumT_Okr*)
   (princ) 
  )
;;;SUMm Text Exist
(defun c:mulTE ( )
  (setq *sumT_Okr* (_get_sumT_Okr))
  (operate_text '* nil *sumT_Okr*)
   (princ) 
  )

(defun TTC_Paste(pasteStr keepText / nslLst vlaObj)
(if (setq nslLst(nentsel "\n?????, ???????, ??????? ??? ?????? ??? ??????? <?????> >>"))
(progn (cond
((and (= 4(length nslLst))
 (= "DIMENSION"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object (cdr(assoc -1(entget(car(last nslLst)))))))
(setq oldStat (vla-get-Measurement vlaObj))
(if keepText
 (if (= (vla-get-TextOverride vlaObj) "")
 (setq pasteStr (strcat pasteStr (rtos oldStat (vla-get-UnitsFormat vlaObj) (vla-get-PrimaryUnitsPrecision vlaObj))))
 (setq pasteStr (strcat pasteStr (vla-get-TextOverride vlaObj)))))
(if (vl-catch-all-error-p(vl-catch-all-apply 'vla-put-TextOverride(list vlaObj pasteStr)))
 (princ "\n Can't paste. Object may be on locked layer. "))); end condition #1
((and (= 4(length nslLst))
(= "ACAD_TABLE"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. ")(entupd (car(last nslLst))))); end condition # 2
((and (= 4(length nslLst))
 (= "INSERT"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(princ "\nCan't paste to block's DText or MText. ")); end condition #3
((and (= 2(length nslLst))
(member(cdr(assoc 0(entget(car nslLst)))) '("TEXT" "MTEXT" "ATTRIB" "ATTDEF"))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. "))); end condition #4
(T (princ "\nCan't paste. Invalid object. ")); end condition #5
); end cond
T); end progn
nil); end if
);_TTC_PASTE



;?????????? T ???? ? ??????? ???? ????
;;; obj — VLA-??????
(defun isFieldAvailable ( obj  / fc )
  (and
    (vlax-method-applicable-p obj 'FieldCode) ;_???? ????? FieldCode
    (setq fc (vlax-invoke obj 'FieldCode))
    (vl-string-search "%<\\Ac" fc)
    (vl-string-search ">%" fc)
   )
)
;;;?? ????? ????? ??????? ??????????? ??????????? TOKR. ????????? ??????, ???????.
;;;?????? ??????? ????????? ?? ??????????, ?????????, ????? ??????? ????????, ????? ??? ???? ??????????????.
;;;???? ? ?????? ???? ????, ?? ??? ??????????? ??? ??????????? ?????????. ? ??????? ??????????? ?????????? ?????? ? ?????? (???????????? ??),
;;;?? ???? ?? ?????????????. ??? ??????????? ????? ????? ? ???? ??????
;;;(text-round item okr t) ? ???????? ?? (text-round item okr nil)

(defun C:TOKR ( / *error* ss item entity ent okr l0 dimz)
  (defun *error* (msg)(princ msg)(setvar "DIMZIN" dimz)(princ))
  (setq dimz (getvar "DIMZIN"))
  (setq okr (_get_sumT_Okr))
  (princ "\n?????????? ?????? ?????????? <")
  (princ okr)(princ " >:")
  (initget 4)
  (if (null (setq okr (getint)))(setq okr *sumT_Okr*))
(initget "Yes No ?? ??? _Yes No Yes No")
(setq l0 (getkword "\n????????? ?????????? ?????????? ???? [??/???] <??>: "))
(if (= l0 "No")(setvar "DIMZIN" 0)(setvar "DIMZIN" 8))
(and
  okr
  (princ " ???????? ??????")
  (setq ss (ssget "_:L" '((0 . "*TEXT"))))
  (foreach item (_dwgru-conv-pickset-to-list ss)
    (text-round item okr t)
    )
  )
  (setvar "DIMZIN" dimz)
  (setq ss nil)
  (princ)
  )
(defun combine (inlist is-greater is-equal / sorted current result)
  (setq sorted (sort inlist is-greater))
  (setq current (list (car sorted)))
  (foreach item (cdr sorted)
    (if (apply is-equal (list item (car current)))
      (setq current (cons item current))
      (progn
        (setq result (cons current result))
        (setq current (list item))
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of foreach
  (cons current result)
) ;_ end of defun

;; can be used for list of most kinds of atoms:

(defun atomic-combine (lst)(combine lst '> 'eq)) ;_ end of defun
(defun sort (lst predicate)
  (mapcar '(lambda (x) (nth x lst)) (vl-sort-i lst predicate))
) ;_ end of defun


;;; ?????????? ??????
;;; text - ename or vla ??????
;;; num - ???-?? ?????? ??????????
;;; IgnoreField - t - ??????????? ????
;;;             nil - ??? (?????????? ?????? ? ??????)
(defun text-round ( text num IgnoreField )
  (if (and
	(setq text (_dwgru-conv-ent-to-vla  text))
	(vlax-property-available-p text 'Textstring)
	(or IgnoreField
	    (apply 'and (list (null IgnoreField)
			      (null (isFieldAvailable text)
				    )
			      )
		   )
	    )
	)
    (progn
     (setq str (str-str-lst (vla-get-textstring text) "\\P")
     str (mapcar '(lambda(x)(mip_mtext_unformat x)) str)
      str (mapcar '(lambda(x)(vl-string-translate "," "." (vl-string-trim  "%UuoOcC \t"   x))) str)
      str (mapcar '(lambda(x)(vl-string-trim  "%UuoOcC \t"   x)) str)
      str (mapcar '(lambda(x)(rtos x 2 num))(mapcar 'atof str))
      str (mapcar '_sumT_prep_Number str)
      str (if (> (length str) 1)
	    (vl-string-right-trim "\\P" (apply 'strcat (mapcar '(lambda(x)(strcat x "\\P")) str)))
	    (car str)
	    )
	   )
      (vla-put-TextString text str)
     )
    )
  text
)
;;;MULtiplication of the Text by Columns
;;;???????????? ?????? ?????????
(defun C:mulTC ( / nab pt1 pt2 i col mass SUM h itog t1 t2 okr)
(vl-load-com)
(setq okr (_get_sumT_Okr))
(princ "\n(?????????? ?? ")(princ okr)(princ ") ")  
(initget 1)
(setq pt1  (getpoint "??????? ?????? ??????? ??????????. ?????? ?????: "))
(initget 1)  
(setq pt2  (getcorner pt1 "\n?????? ?????: "))
(setq nab (ssget "_C" pt1 pt2 '((0 . "*TEXT"))))  
(if nab
  (progn
  (setq col (mapcar ' vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex nab))))
	col (vl-sort col '(lambda(x y)
	       (> (cadr (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint x))))
	       (cadr (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint y))))))))
  ));_if
(princ "\n(?????????? ?? ")(princ okr)(princ ") ")  
(initget 1)
(setq pt1  (getpoint "??????? ?????? ??????? ?????. ?????? ?????: "))
(initget 1)  
(setq pt2  (getcorner pt1 "\n?????? ?????: "))
(setq nab nil nab (ssget "_C" pt1 pt2 '((0 . "*TEXT"))))  
(if nab
(setq mass (mapcar ' vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex nab))))
	mass (vl-sort mass '(lambda(x y)
	       (> (cadr (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint x))))
	       (cadr (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint y))))))))
  );_if
(princ "\n(?????????? ?? ")(princ okr)(princ ") ")  
(initget 1)
(setq pt1  (getpoint "??????? ?????? ??????? ????. ?????? ?????: "))
(initget 1)  
(setq pt2  (getcorner pt1 "\n?????? ?????: "))
(setq nab nil nab (ssget "_C" pt1 pt2 '((0 . "*TEXT"))))  
(if nab
(setq itog (mapcar ' vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex nab))))
	itog (vl-sort itog '(lambda(x y)
	       (> (cadr (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint x))))
	       (cadr (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint y))))))))
  );_if
(if (and col mass itog
	 (= (length col)(length mass)(length itog))
	 )
    (progn
      (setq i 0 SUM 0)
      (princ "\n??????????\t?????\t????")
      (foreach item col
	(setq t1 (vla-get-TextString item))
	(setq t1 (vl-string-translate "," "." (vl-string-trim  "%UuoOcC \t"   t1)))
        (setq t1 (mip_mtext_unformat t1))
	(setq t1 (atof t1))
	(setq t2 (vla-get-TextString (nth i mass)))
	(setq t2 (vl-string-translate "," "." (vl-string-trim  "%UuoOcC \t"   t2)))
        (setq t2 (mip_mtext_unformat t2))
	(setq t2 (atof t2))
	
	(terpri)
	(princ t1)(princ " * ")
	(princ t2)(princ " = ")
	(setq SUM (* t1 t2))
	(princ sum)
	(setq pt1 (nth i itog))
	(if (vlax-write-enabled-p pt1)
	  (vla-put-TextString pt1 (_sumT_prep_Number(rtos sum 2 okr))))
	(setq i (1+ i))
	)
      )
      (alert "?? ????????? ???-?? ?????? ? ????????!")
  )
(princ)
);_defun
;;;MULtiplication of the Text by Columns
;;;???????????? ?????? ?????????
(defun C:mulTCv2 ( / nab pt1 pt2 i col mass SUM h itog t1 t2 okr fuzz)
(vl-load-com)
(setq okr (_get_sumT_Okr))
(princ "\n(?????????? ?? ")(princ okr)(princ ") ")
(initget 1)
(setq pt1  (getpoint "??????? ?????? ??????? ??????????, ????? ? ???? ?????? ?????: "))
(initget 1)  
(setq pt2  (getcorner pt1 "\n?????? ?????: "))
(setq nab (ssget "_C" pt1 pt2 '((0 . "*TEXT"))))
(setq pt2 (_dwgru-conv-pickset-to-list nab))
(setq pt1 (mapcar '(lambda(x)(cdr(assoc 40 (entget x)))) pt2))
(setq fuzz (/ (apply '+ pt1)(length pt1)))
(setq nab
                 (combine pt2
                          '(lambda (x y / a b)
			     (setq a (cdr(assoc 10 (entget x))))
			     (setq b (cdr(assoc 10 (entget y))))
			     (or (< (cadr a)(cadr b)) ;_ on Y
				 (equal (cadr a)
					(cadr b)
					  fuzz
					  )
				 ) ;_ end of or
                           ) ;_ end of lambda
                          '(lambda (x y / a b)
			     (setq a (cdr(assoc 10 (entget x))))
			     (setq b (cdr(assoc 10 (entget y))))
                             (equal (cadr a)
					(cadr b)
					  fuzz
					  )
                             ;(< (car a)(car b)) ;_ end of <
                           ) ;_ end of lambda
                 ) ;_ end of combine
          ) ;_ end of setq
  (setq nab (mapcar '(lambda(x)(vl-sort x '(lambda(a b)(< (cadr(assoc 10 (entget a)))(cadr(assoc 10 (entget b))))))) nab))
;;(mapcar '(lambda(y)(mapcar '(lambda(x)(cdr(assoc 1 (entget x)))) y)) nab)
  
  
(setq col (vl-remove-if 'null (mapcar 'car nab)))
(setq mass (vl-remove-if 'null (mapcar 'cadr nab)))
(setq itog (vl-remove-if 'null (mapcar 'caddr nab)))
(if (and col mass itog
	 (= (length col)(length mass)(length itog))
	 )
    (progn
      (setq i 0 SUM 0)
      (princ "\n??????????\t?????\t????")
      (foreach item col
	(setq t1 (vla-get-TextString (_dwgru-conv-ent-to-vla item)))
	(setq t1 (vl-string-translate "," "." (vl-string-trim  "%UuoOcC \t"   t1)))
        (setq t1 (mip_mtext_unformat t1))
	(setq t1 (atof t1))
	(setq t2 (vla-get-TextString (_dwgru-conv-ent-to-vla(nth i mass))))
	(setq t2 (vl-string-translate "," "." (vl-string-trim  "%UuoOcC \t"   t2)))
        (setq t2 (mip_mtext_unformat t2))
	(setq t2 (atof t2))
	
	(terpri)
	(princ t1)(princ " * ")
	(princ t2)(princ " = ")
	(setq SUM (* t1 t2))
	(princ sum)
	(if (and
	      	(setq pt1 (nth i itog))
		(setq pt1 (_dwgru-conv-ent-to-vla pt1))
		(vlax-write-enabled-p pt1)
		)
	  (vla-put-TextString pt1 (_sumT_prep_Number(rtos sum 2 okr))))
	(setq i (1+ i))
	)
      )
      (alert "?? ????????? ???-?? ?????? ? ????????!")
  )
(princ)
);_defun



;;;GSUM - ????????? ????????????
;;;????????? ???????- ?????
;;;????? ??????? ??????? ?????????? ? ?????
(defun C:GSUM ( / nab pt1 pt2 i col mass SUM h itog t1 t2 okr fuzz)
(vl-load-com)
(setq okr (_get_sumT_Okr))
(princ "\n(?????????? ?? ")(princ okr)(princ ") ")
(initget 1)
(setq pt1  (getpoint "??????? ?????? ??????? ?????????? ? ????? ?????? ?????: "))
(initget 1)  
(setq pt2  (getcorner pt1 "\n?????? ?????: "))
(setq nab (ssget "_C" pt1 pt2 '((0 . "*TEXT"))))
(setq pt2 (_dwgru-conv-pickset-to-list nab))
(setq pt1 (mapcar '(lambda(x)(cdr(assoc 40 (entget x)))) pt2))
(setq fuzz (/ (apply '+ pt1)(length pt1)))
(setq nab
                 (combine pt2
                          '(lambda (x y / a b)
			     (setq a (cdr(assoc 10 (entget x))))
			     (setq b (cdr(assoc 10 (entget y))))
			     (or (< (cadr a)(cadr b)) ;_ on Y
				 (equal (cadr a)
					(cadr b)
					  fuzz
					  )
				 ) ;_ end of or
                           ) ;_ end of lambda
                          '(lambda (x y / a b)
			     (setq a (cdr(assoc 10 (entget x))))
			     (setq b (cdr(assoc 10 (entget y))))
                             (equal (cadr a)
					(cadr b)
					  fuzz
					  )
                             ;(< (car a)(car b)) ;_ end of <
                           ) ;_ end of lambda
                 ) ;_ end of combine
          ) ;_ end of setq
  (setq nab (mapcar '(lambda(x)(vl-sort x '(lambda(a b)(< (cadr(assoc 10 (entget a)))(cadr(assoc 10 (entget b))))))) nab))
;;(mapcar '(lambda(y)(mapcar '(lambda(x)(cdr(assoc 1 (entget x)))) y)) nab)
(mapcar '(lambda(x)(length x)) nab)
(setq mass nil col nil itog nil)
  
(setq col (mapcar '(lambda(x)
           (setq x (reverse x)
               mass (cons (car x) mass)
                 x (reverse (cdr x))
                 )
           )
          
        nab)
      )
(setq mass (reverse mass))
(if (and (apply '= (mapcar 'length nab))
         col mass
	 (= (length col)(length mass))
        )
    (progn

(setq itog(mapcar '(lambda(col1 mas)
           (setq t2 (vla-get-TextString (_dwgru-conv-ent-to-vla mas)))
           (setq t2 (vl-string-translate "," "." (vl-string-trim  "%UuoOcC \t"   t2)))
           (setq t2 (mip_mtext_unformat t2))
           (setq t2 (atof t2))
           (mapcar '(lambda(y)
                      (setq t1 (vla-get-TextString (_dwgru-conv-ent-to-vla y)))
                      (setq t1 (vl-string-translate "," "." (vl-string-trim  "%UuoOcC \t"   t1)))
                      (setq t1 (mip_mtext_unformat t1))
                      (setq t1 (atof t1))
                      (setq t1 (* t1 t2))
                      )
                   col1
                   )
           )
        col
        mass
     )
      )
(setq itog
       (mapcar '(lambda(x)(apply '+ x))
               (apply 'mapcar (cons 'list itog))
               )
      )
(if (> (length nab) 1)
  (progn
    (setq pt1 (reverse (mapcar '(lambda(x)(cdr(assoc 10 (entget x)))) (mapcar 'car nab))))
    (setq pt2 (abs(- (abs(cadr(cadr pt1)))(abs(cadr(car pt1))))))
    (setq t2 (list 0 (- 0. pt2) 0))
    )
  (progn
    (setq pt1 (cdr (assoc 40 (entget(caar nab)))))
    (setq t2 (list 0 (- 0. (* 2.0 pt1) 0)))
    )
  )
    (setq i '-1 SUM (1- (length (last nab))))
    (foreach txt (last nab)
        (setq i (1+ i))
        (setq t1 (entget txt))
        (setq pt1 (mapcar '+ (cdr(assoc 10 t1)) t2))
        (setq pt2 (mapcar '+ (cdr(assoc 11 t1)) t2))
        (setq t1 (subst (cons 10 pt1)
                        (assoc 10 t1)
                        t1)
              )
      (setq t1 (subst (cons 11 pt2)
                        (assoc 11 t1)
                        t1)
              )
      (if (< i SUM)
        (progn
          (setq t1 (subst (cons 1 (_sumT_prep_Number(rtos (nth i itog) 2 okr)))
                          (assoc 1 t1)
                          t1
                          )
                )
          (entmakex t1)
          )
        )
      
      )
    

  
  )
  (alert "?? ????????? ???-?? ?????? ? ????????!")
  )
(princ)
);_defun`


;;;????????? ?????????? ??????? ?????
(defun mark_parser (str / i buf)
 ;;;??????? ????????????? ? ?????????????, ???????, ????? ????????? 
 (setq str (vl-string-trim  "%UuoO \t" str))
 ;;;?????????, ???????????? ?? UNICOD ??????? (???? \U+EXXXX)
 (if (= (substr str 1 3) "\\U+")
   (setq buf (substr str 1 7) str (substr str 8))
   (setq buf "")
   )
 (while (setq i (VL-STRING-SEARCH "\\U+" str))
   (setq str(dwgru-string-replace str (substr str (1+ i) 7) ""))
   )
   
 (setq str (vl-string-trim  "%UuoO \t" str))
  ;;;??????? ? ??????? ?????? ???????-????????
  ;;; ???? ??? ??? ???????
  ;;;?????? ????????? ? ???????? ???????
 (mapcar '(lambda(txt)
            (setq str(dwgru-string-replace str txt ""))
            )
         '("%%U" "%%O" "%%C" "\\U+E712")
         )
            
 (setq i 0 )
   (while (not(vl-position (substr str (setq i (1+ i)) 1)
            '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "")
            )
              )
     )
  (if (> i 0)(setq i (1- i)))
  (list
    (strcat buf (strcase(vl-string-trim  "%UuoO \t"  (substr str 1 i))))
    (strcase(vl-string-trim  "%UuoO \t" (if (zerop i) str (substr str (1+ i)))))
    )
  )
(defun find-prokat-ves ( tip marka obz wcm / ret MPROF)
;;;tip -??? ???????????
;;; ??? - ??? ???????
;;; "?" - ????????
;;; "?" - ??????
;;; "?" - ????????
;;; "?" - ???????
;;; "?" - ????????
;;;marka - ????? ???????
;;;obz - ??????????? ??? Nil - ?????
;;; wcm - ??????? ?????? 
;;;                     0 - assoc
;;;                     1 - wcmatch -  ?????? ????a
;;;                     2 - wcmatch  - ?????? ?????? ? ???? 
;;;???? ????? ?????????? ? ?????, ?? ???? ?? assoc ????? ?? wcmatch
  (setq ret (vl-remove-if '(lambda(xy)(null (car xy)))
  (mapcar '(lambda(y / pat pat1 sym rr)
             (setq pat (mip-conv-to-str(nth 2 y)))
             (setq pat1 (str-str-lst pat "&"))
             (setq pat (mip-conv-to-str(car pat1)))
             (setq pat1 (mip-conv-to-str(cadr pat1)))
             (if (= (setq sym(substr pat1 1 1)) "~")
               (setq pat1 (substr pat1 2))
               (setq sym "")
               )
             (setq pat (vl-string-translate ";" ","  pat))
             (setq pat1 (vl-string-translate ";" ","  pat1))
             (setq pat (str-str-lst pat ","))
             (setq pat1 (str-str-lst pat1 ","))
             (if (null pat1)(setq pat1 ""))
             (setq pat (apply 'strcat (mapcar '(lambda(z)(strcat "*" (vl-string-trim " *" z) "*,"))pat)))
             (if (= pat1 "") (setq pat1 "*" sym "")
                    (setq pat1 (apply 'strcat (mapcar '(lambda(z)(strcat sym "*" (vl-string-trim " *" z) "*,"))pat1)))
                    )
             (if (and
                 (or (null obz) (wcmatch obz pat))
                 (wcmatch obz pat1)
                 )
               (if (listp (car(last y)))
                 (cond
                   ((= wcm 1);_?????? ????a
                    (setq MPROF (vl-remove-if-not '(lambda(z1)
                                      (wcmatch (car z1)(strcat "*" marka "*"))
                                      )(last y))
                          rr (cadar MPROF)
                          MPROF (caar MPROF)
                          )
                    )
                   ((= wcm 2);_?????? ?????? ? ????
                     (setq MPROF (vl-remove-if-not '(lambda(z1)
                                      (wcmatch marka(strcat "*" (car z1)  "*"))
                                      )(last y))
                                rr (cadar MPROF)
                           MPROF (caar MPROF)
                           )

                    )
                   (t ;_assoc
                     (setq MPROF (assoc marka (last y))
                               rr  (cadr MPROF)
                           MPROF (car MPROF)
                           )
                           )
                   )
                 
                 (if (zerop (car(last y)))
                   (setq rr 0)
                   (setq rr nil)
                   )
                 )
               (setq rr nil)
               )
             (list rr MPROF)
             )
          (if tip (vl-remove-if-not '(lambda(x)(= tip (car x))) *PROKAT_VES_BASE*)
                   *PROKAT_VES_BASE*)
          )
    )
        )
  (setq *MPROF* (cadar ret))
  (mapcar 'car ret)
)

(defun find-sortament-GOST ( tip obz / ret)
  (setq obz(mip-conv-to-str obz))
  (setq tip(mip-conv-to-str tip))
  (setq *PROKAT_KLASS* "")
;;;tip -??? ???????????
;;; ??? - ??? ???????
;;; "?" - ????????
;;; "?" - ??????
;;; "?" - ????????
;;; "?" - ???????
;;; "?" - ????????
;;; nil - ?????
;;;marka - ????? ???????
;;;obz - ???????????
;;;??????? ??????? ????? ??? ""  


  (mip-conv-to-str
  (car
  (setq ret (vl-remove-if 'null
  (mapcar '(lambda(y / pat pat1)
             (setq pat (mip-conv-to-str(nth 2 y)))
             (setq pat1 (str-str-lst pat "&"))
             (setq pat (mip-conv-to-str(car pat1)))
             (setq pat (vl-string-translate ";" ","  pat))
             (setq pat (str-str-lst pat ","))
             (setq pat (apply 'strcat (mapcar '(lambda(z)(strcat "*" (vl-string-trim " *" z) "*,"))pat)))
             (if (wcmatch obz pat)
               (progn
               (setq *PROKAT_KLASS* (nth 3 y))
               (car (str-str-lst (setq pat (mip-conv-to-str(nth 2 y))) ";"))
               )
               nil
               )
             )
           (if (= tip "") *PROKAT_VES_BASE*
           (vl-remove-if-not '(lambda(x)(= tip (car x))) *PROKAT_VES_BASE*))
                   
          )
    )
        )
  )
  )
)
;;;?-??? ?????????? ???? ? ????? ??????
;;;Err - integer
(defun _get_Err_color_string ( Err / ErrColor ErrString )
  (cond
    ((= Err 1)
     (setq ErrColor acRed ErrString "?? ??????? ? ????")
     )
    ((= Err 2)
     (setq ErrColor acBlue ErrString " ?????? 1 ? ????, ???? 1-? ?????????") 
     )
    ((= Err 4)
     (setq ErrColor acBlue ErrString " ???? ? ???? ???. ???????? ?? ???????")
     )
    ((= Err 8)
     (setq ErrColor acRed ErrString " ??????? ?? ???????")
     )
  (t (setq ErrColor acByLayer ErrString ""))
    )
  (list ErrColor ErrString)
  )

;;; ?-??? ?????????? ??? ???????
;;; obz - ??????????? (?????????? ? ?????????????)
;;; ?????????? ???_??????? ??? nil
(defun _get_Prokat_TIP ( obz )
  (if (null *PROKAT_VES_BASE*)(_read-prokat-base))
    (setq ret (vl-remove-if 'null
  (mapcar '(lambda(y / pat pat1)
             (setq pat (mip-conv-to-str(nth 2 y)))
             (setq pat1 (str-str-lst pat "&"))
             (setq pat (mip-conv-to-str(car pat1)))
             (setq pat (vl-string-translate ";" ","  pat))
             (setq pat (str-str-lst pat ","))
             (setq pat (apply 'strcat (mapcar '(lambda(z)(strcat "*" (vl-string-trim " *" z) "*,"))pat)))
             (if (wcmatch obz pat)
               (list (car y))
               )
             )
          *PROKAT_VES_BASE*
          )
    )
        )
  (cond ((= (length ret) 1)(caar ret))
        ((null ret) nil)
        ((apply '= (apply 'append ret))(caar ret))
        (t nil)
        )
  )
;;;???? ?? ???????? ?????

(defun IzPM ( x )
  (or
    (wcmatch (setq x (strcase x)) "*?.?*")  ;_???????? ?????
    (wcmatch x "*?.?*")
    (wcmatch x "*? ?*")
    (wcmatch x "*? ?*")
    (wcmatch x "*??*")
    (wcmatch x "*??*")
    )
  )
(defun _sumT_Ves_okr ( ves)
  ;;;???? ??? ????? ?????? ?????? 100 ????? (0.1), ?? ????????? ?? 4 ??????
  (if (< ves 0.1)
       (rtos ves 2 4)
       (rtos ves 2 (_get_sumT_Okr))
    )
  )
;;;?-??? ?????????? ??? ???????
(defun _get_Prokat_ves ( obzn naim DLN count / what L ves_det_all ves_det_1 ErrCod *STAL* kF Diam Ts Sh Vs kFAll Mprof)
  ;;;?-??? ?????????? ??? ???????
  ;;; obzn - ?????? ??????????? String
  ;;; naim - ?????? ???????????? String
  ;;; DLN - real ????? Real ? ??
  ;;; count - ?????????? Real
  ;;; ?????????? ??????  ????? (???_??????_???????? ???_????? ???_??????)
  ;;;Errcod
  ;;; 0 -??? ??
  ;;; 1 - ??? ? ????
  ;;; 2 - ?????? 1 ? ???? ???? 1-? ?????????
  ;;; 4 - ???? ? ???? ???, ???????? ?? ???????
  ;;; 8 - ??????????
(if (null *PROKAT_VES_BASE*)(_read-prokat-base))  
(setq Errcod 0 what (mark_parser naim))
;;;?????????? ??? ??????? ?? ????
(if (setq L  (_get_Prokat_TIP obzn))
  (setq what (list L (cadr what)))
  (setq what (list (vl-string-trim  "%UuoO \t.," (dwgru-string-replace  (mip-conv-to-str(car (str-str-lst (car what) " "))) "%%?" ""))
               (cadr what)))
  )
(setq *STAL* 0.00000785) ;_????????? ?????
(setq kFAll 1) ;_?????????? ???????
;;; ??? - ??? ???????
;;; "?" - ????????
;;; "?" - ??????
;;; "?" - ????????
;;; "?" - ??????? ?????????? ??? ?????????????, ????????? ?? ????????
;;; "?" - ????????
;;; "????" - ?????? ????????, ????????? ?? ????????. ?? ???????? ? ???? ?????, ?.?. ????? ?????, ?????
;;; ?????????? ??? ???????
;;; "????????????" - ????? ???????, ????????? ?? ????????. ???????? ? ???? ?????, ?.?. ????? ?????, ?????
;;; ?????????? ??? ???????
;;;"?????" - ??????????????? ????. ????? ?????? ?? ??????? ?????????
(setq Mprof (cadr what))  
(cond
;;;======= ??????? + ????? ???? E ???????? ?? ??????? ?
  ((vl-position (car WHAT) '("?" "???????" "??????" "[" "\\U+E725" "\\U+E724" "\\U+E726" "\\U+?725" "\\U+?724" "\\U+?726")) ;_???????
   (if (vl-position (car WHAT) '("\\U+E724" "\\U+E726" "\\U+?724" "\\U+?726")) ;_??????? ????????
     (setq kFAll 2)
     )
   (setq L (vl-string-translate "X" "?" (car(str-str-lst (cadr what) " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ??????
                                                                             ;;;_ ???????? ?? ???????
   (setq L (vl-string-trim  "%UuoO \t.," L))
   (setq L(find-prokat-ves "?" L (if (= obzn "") naim obzn) 0))
   (if (and L (apply '= L))(setq L (list(car L)))) ;_???? ????????? ????????? ? ??? ???? ??????????
   (if (and L (numberp (car L))(zerop (car L)))(setq Errcod 0 L nil))
   (cond ((null L)(setq ves_det_1 0 ves_det_all 0 Errcod 1)) ;_??? ? ????
         ((> (length L) 1)(setq ves_det_1 (car L) Errcod 2)) ;_?????? ??????, ????? 1-?
         (t (setq ves_det_1 (car L)))
         )
   (setq *MPROF* (STRCAT "??????? " (MIP-CONV-TO-STR *MPROF*)))
   (setq ves_det_1   (* ves_det_1 DLN (if (< DLN 5) 1 0.001))
         ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
         ves_det_all (* count ves_det_1 kFAll))
   )
;;;??????? ???????? ???????? ?????? ? ??????????????? ??????? ??? ????????????? ???? 24045-94
((vl-position (car WHAT) '("?????")) ;_ __/--\__
 (setq kFAll 1)
   (setq L (vl-string-translate "X" "?" (car(str-str-lst (cadr what) " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ??????
                                                                             ;;;_ ???????? ?? ???????
   (setq L (vl-string-trim  "%UuoO \t.," L))
   (setq L(find-prokat-ves "?????" L (if (= obzn "") naim obzn) 1))
   (setq *MPROF* (STRCAT "???? ?????? " (MIP-CONV-TO-STR *MPROF*)))
   (if (and L (apply '= L))(setq L (list(car L)))) ;_???? ????????? ????????? ? ??? ???? ??????????
   (if (and L (numberp (car L))(zerop (car L)))(setq Errcod 0 L nil))
   (cond ((null L)(setq ves_det_1 0 ves_det_all 0 Errcod 1)) ;_??? ? ????
         ((> (length L) 1)(setq ves_det_1 (car L) Errcod 2)) ;_?????? ??????, ????? 1-?
         (t (setq ves_det_1 (car L)))
         )
   
   (setq ves_det_1   (* ves_det_1 DLN (if (< DLN 5) 1 0.001))
         ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
         ves_det_all (* count ves_det_1 kFAll))
   )
((vl-position (car WHAT) '("??")) ;_ ????? ??????????? ? ???????? ???????? ??????????? ???? 19425-74
 (setq kFAll 1)
   (setq L (vl-string-translate "X" "?" (car(str-str-lst (cadr what) " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ??????
                                                                             ;;;_ ???????? ?? ???????
   (setq L (vl-string-trim  "%UuoO \t.," L))
   (setq L(find-prokat-ves "??" L (if (= obzn "") naim obzn) 0))
   (setq *MPROF* (STRCAT "????? " (MIP-CONV-TO-STR *MPROF*)))
   (if (and L (apply '= L))(setq L (list(car L)))) ;_???? ????????? ????????? ? ??? ???? ??????????
   (if (and L (numberp (car L))(zerop (car L)))(setq Errcod 0 L nil))
   (cond ((null L)(setq ves_det_1 0 ves_det_all 0 Errcod 1)) ;_??? ? ????
         ((> (length L) 1)(setq ves_det_1 (car L) Errcod 2)) ;_?????? ??????, ????? 1-?
         (t (setq ves_det_1 (car L)))
         )
   
   (setq ves_det_1   (* ves_det_1 DLN (if (< DLN 5) 1 0.001))
         ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
         ves_det_all (* count ves_det_1 kFAll))
   )
((vl-position (car WHAT) '("????" "?????" "?????")) ;_ ????? ??????????? ? ???????? ???????? ??????????? ???? 19425-74
 (setq kFAll 1)
;;; (setq L (dwgru-string-replace (cadr what) " " ""))
;;;   (setq L (vl-string-translate "X" "?" (car(str-str-lst L " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ??????
;;;                                                                             ;;;_ ???????? ?? ???????
;;;   (setq L (vl-string-trim  "%UuoO \t.," L))
  (setq L(find-prokat-ves (car WHAT) obzn (if (= obzn "") naim obzn) 2))
  ;;;;??????? ??????? *[]
 (setq *MPROF* ((lambda(str pat)
                  (setq str (vl-string->list str))
                  (mapcar '(lambda(nom)
                             (setq str (vl-remove nom str))
                             )
                          (vl-string->list pat)
                          )
                  (VL-LIST->STRING str)
                  )
                 (MIP-CONV-TO-STR *MPROF*) "*[] "
                 )
       )
  (setq *MPROF* (STRCAT (car WHAT) " " *MPROF*))
   (if (and L (apply '= L))(setq L (list(car L)))) ;_???? ????????? ????????? ? ??? ???? ??????????
   (if (and L (numberp (car L))(zerop (car L)))(setq Errcod 0 L nil))
   (cond ((null L)(setq ves_det_1 0 ves_det_all 0 Errcod 1)) ;_??? ? ????
         ((> (length L) 1)(setq ves_det_1 (car L) Errcod 2)) ;_?????? ??????, ????? 1-?
         (t (setq ves_det_1 (car L)))
         )
   
   (setq ;_ ves_det_1   (* ves_det_1 DLN)
         ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
         ves_det_all (* count ves_det_1 kFAll))
   )
((vl-position (car WHAT) '("?????")) ;_ ????? ?????? ???? 5336-80
 (setq kFAll 1)
   (setq L (vl-string-translate "X" "?" (car(str-str-lst (cadr what) " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ??????
                                                                             ;;;_ ???????? ?? ???????
   (setq L (vl-string-trim  "%UuoO \t.," L))
  (setq L(find-prokat-ves (car WHAT) obzn (if (= obzn "") naim obzn) 2))
  (setq *MPROF* (STRCAT "????? ??????" " " (MIP-CONV-TO-STR *MPROF*)))
   (if (and L (apply '= L))(setq L (list(car L)))) ;_???? ????????? ????????? ? ??? ???? ??????????
   (if (and L (numberp (car L))(zerop (car L)))(setq Errcod 0 L nil))
   (cond ((null L)(setq ves_det_1 0 ves_det_all 0 Errcod 1)) ;_??? ? ????
         ((> (length L) 1)(setq ves_det_1 (car L) Errcod 2)) ;_?????? ??????, ????? 1-?
         (t (setq ves_det_1 (car L)))
         )
   
   (setq ves_det_1   (* ves_det_1 DLN (if (< DLN 5) 1 0.001))
         ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
         ves_det_all (* count ves_det_1 kFAll))
   )  
((vl-position (car WHAT) '("???????")) ;_????? ???????? ? ??????????? ? ?????????? ????????? ???? 8568-77
   (setq L (vl-string-translate "X" "?" (car(str-str-lst (cadr what) " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ??????
   (setq kFAll 1)                                                                           ;;;_ ???????? ?? ???????
   (setq L (vl-string-trim  "%UuoO \t.," L))
   (setq L (str-str-lst L "?"))
 ;;;???? ?? min ???????? - ???????
   (setq Vs (mapcar 'atof L))
   (setq Ts (apply 'min Vs))
   (setq Vs (vl-remove Ts Vs))
   (setq Vs (mapcar '(lambda(x)(* x 0.001)) Vs)) ;_????????? ? ?
   (setq Ts (rtos Ts 2 1))
   (setq Ts (dwgru-string-replace Ts ".0" ""))
   ;;;??????????? ??? ?????????? ????????
 
   (setq L (find-prokat-ves "???????" Ts (if (= obzn "") naim obzn) 0))
   (setq *MPROF* (STRCAT "???????? ???? " (if (wcmatch obzn "*?????*") "?????. " "???? ")(MIP-CONV-TO-STR *MPROF*)))
   (if (and L (apply '= L))(setq L (list(car L)))) ;_???? ????????? ????????? ? ??? ???? ??????????
   (if (and L (numberp (car L))(zerop (car L)))(setq Errcod 0 L nil))
   (cond ((null L)(setq ves_det_1 0 ves_det_all 0 Errcod 1)) ;_??? ? ????
         ((> (length L) 1)(setq ves_det_1 (car L) Errcod 2)) ;_?????? ??????, ????? 1-?
         (t (setq ves_det_1 (car L)))
         )
   
   (setq ves_det_1   (* (apply '* Vs) ves_det_1 DLN (if (< DLN 5) 1 0.001))
         ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
         ves_det_all (* count ves_det_1 kFAll))
   )
((vl-position (car WHAT) '("??????")) ;_????? ???????? ????????-???????? ?? 36.26.11-5-89
   (setq L (vl-string-translate "X" "?" (cadr what))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ??????
   (setq kFAll 1)                                                                           ;;;_ ???????? ?? ???????
   (setq L (vl-string-trim  "%UuoO \t.," L))
   (setq L (str-str-lst L "?"))
 ;;;???? ?? min ???????? - ???????
   (setq Ts (car L))
   (setq Vs (mapcar 'atof (cdr L)))
   (setq Vs (mapcar '(lambda(x)(* x 0.001)) Vs)) ;_????????? ? ?
   ;;;??????????? ??? ?????????? ????????

   ;;;??????????? ??? ?????????? ???????? ??? 
   (setq L (find-prokat-ves "???????" Ts (if (= obzn "") naim obzn) 0))
   (setq *MPROF* (STRCAT "???????? ???? " (if (wcmatch obzn "*\U0578\U057d\U057a\U0561\U0571\U0587*") "\U0578\U057d\U057a\U0561\U0571\U0587 " "\U0577\U0565\U0572\U0561\U0576\U056f \U0575\U0578\U0582\U0576 ")(MIP-CONV-TO-STR *MPROF*)))
   (if (and L (apply '= L))(setq L (list(car L)))) ;_???? ????????? ????????? ? ??? ???? ??????????
   (if (and L (numberp (car L))(zerop (car L)))(setq Errcod 0 L nil))
   (cond ((null L)(setq ves_det_1 0 ves_det_all 0 Errcod 1)) ;_??? ? ????
         ((> (length L) 1)(setq ves_det_1 (car L) Errcod 2)) ;_?????? ??????, ????? 1-?
         (t (setq ves_det_1 (car L)))
         )
   
   (setq ves_det_1   (* (apply '* Vs) ves_det_1 DLN (if (< DLN 5) 1 0.001))
         ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
         ves_det_all (* count ves_det_1 kFAll))
   )
((vl-position (car WHAT) '("??????")) ;_????? ???????? ????????-???????? ?? 36.26.11-5-89
   (setq L (vl-string-translate "X" "?" (cadr what))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ??????
   (setq kFAll 1)                                                                           ;;;_ ???????? ?? ???????
   (setq L (vl-string-trim  "%UuoO \t.," L))
   (setq L (str-str-lst L "?"))
 ;;;???? ?? min ???????? - ???????
   (setq Ts (car L))
   (setq Vs (mapcar 'atof (cdr L)))
   (setq Vs (mapcar '(lambda(x)(* x 0.001)) Vs)) ;_????????? ? ?
   ;;;??????????? ??? ?????????? ???????? ???
 
   (setq L (find-prokat-ves "??????" Ts (if (= obzn "") naim obzn) 0))
   (setq *MPROF* (STRCAT "???? ????????-???????? " (MIP-CONV-TO-STR *MPROF*)))
   (if (and L (apply '= L))(setq L (list(car L)))) ;_???? ????????? ????????? ? ??? ???? ??????????
   (if (and L (numberp (car L))(zerop (car L)))(setq Errcod 0 L nil))
   (cond ((null L)(setq ves_det_1 0 ves_det_all 0 Errcod 1)) ;_??? ? ????
         ((> (length L) 1)(setq ves_det_1 (car L) Errcod 2)) ;_?????? ??????, ????? 1-?
         (t (setq ves_det_1 (car L)))
         )
   
   (setq ves_det_1   (* (apply '* Vs) ves_det_1 DLN (if (< DLN 5) 1 0.001))
         ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
         ves_det_all (* count ves_det_1 kFAll))
   )  
((vl-position (car WHAT) '("??????"))
 (setq kFAll 1)
   (setq L (vl-string-translate "X" "?" (car(str-str-lst (cadr what) " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ??????
                                                                             ;;;_ ???????? ?? ???????
   (setq L (vl-string-trim  "%UuoO \t.," L))
   (setq L(find-prokat-ves "??????" L (if (= obzn "") naim obzn) 0))
   (setq *MPROF* (STRCAT "?????? " (MIP-CONV-TO-STR *MPROF*)))
   (if (and L (apply '= L))(setq L (list(car L)))) ;_???? ????????? ????????? ? ??? ???? ??????????
   (if (and L (numberp (car L))(zerop (car L)))(setq Errcod 0 L nil))
   (cond ((null L)(setq ves_det_1 0 ves_det_all 0 Errcod 1)) ;_??? ? ????
         ((> (length L) 1)(setq ves_det_1 (car L) Errcod 2)) ;_?????? ??????, ????? 1-?
         (t (setq ves_det_1 (car L)))
         )
   
   (setq ves_det_1   (* ves_det_1 DLN (if (< DLN 5) 1 0.001))
         ;;??? ?????? ????????? ???-?? ??????? ??? ??????????
         ;;ves_det_1   (if (_get_sumT_Ves1)(atof(rtos ves_det_1 2 (_get_sumT_Okr))) ves_det_1)
         ves_det_all (* count ves_det_1 kFAll))
   )  
;;;======= ??????? +
  ((vl-position (car WHAT) '("?" "???????" "\\U+E729" "\\U+E72A" "\\U+?729" "\\U+?72?")) ;_???????
   (if (vl-position (car WHAT) '("\U+E72A" "\U+?72?")) ;_??????? ???????
     (setq kFAll 2)
     )
   (setq L (vl-string-translate "X" "?" (car(str-str-lst (cadr what) " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ?????? ???????? ?? ???????
   (setq L (vl-string-trim  "%UuoO \t.," L))
   (setq L(find-prokat-ves "?" L (if (= obzn "") naim obzn) 0))
   (setq *MPROF* (STRCAT "??????? " (MIP-CONV-TO-STR *MPROF*)))
   (if (and L (apply '= L))(setq L (list(car L)))) ;_???? ????????? ????????? ? ??? ???? ??????????
   (if (and L (numberp (car L))(zerop (car L)))(setq Errcod 0 L nil))
   (cond ((null L)(setq ves_det_1 0 ves_det_all 0 Errcod 1)) ;_??? ? ????
         ((> (length L) 1)(setq ves_det_1 (car L) Errcod 2)) ;_?????? ??????, ????? 1-?
         (t (setq ves_det_1 (car L)))
         )
   (setq ves_det_1   (* ves_det_1 DLN (if (< DLN 5) 1 0.001))
         ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
         ves_det_all (* count ves_det_1 kFAll))
   )
;;;======= ????????            +
   ((vl-position (car WHAT) '("?" "C" "?" "\\U+E712" "\\U+?712")) ;_????????
     (setq Diam (atof (cadr what))) ;???????
     (setq L(find-prokat-ves "?" (itoa (fix Diam)) (if (= obzn "") naim obzn) 0))
    (setq *MPROF* (STRCAT "???????? d= " (rtos Diam 2 0)))
    (if (and L (apply '= L))(setq L (list(car L)))) ;_???? ????????? ????????? ? ??? ???? ??????????
    (if (and L (numberp (car L))(zerop (car L)))(setq Errcod 0 L nil))
(cond ((null L)
       (setq  Errcod 4 ves_det_1 nil)) ;_??? ? ???? ??????? ?? ???????
         ((> (length L) 1)(setq ves_det_1 (car L) Errcod 2)) ;_?????? ??????, ????? 1-?
         (t (setq ves_det_1 (car L)))
         )
     (if ves_det_1
       ;;;????? ??? ?? ????
       (if (IzPM obzn)
       (setq ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
             ves_det_all (* count ves_det_1 DLN (if (< DLN 5) 1 0.001)))  
       (setq ves_det_1 (* ves_det_1 DLN (if (< DLN 5) 1 0.001))
             ves_det_1   (if (_get_sumT_Ves1)(atof(rtos ves_det_1 2 (_get_sumT_Okr))) ves_det_1)
             ves_det_all (* count ves_det_1))
         )
       ;;;??? ???????? ?????????? ??? ?? ???????? ?? 0.5 ???????? ? ???????? ???????? ?? ????? ? ?? *STAL*
       (if (IzPM obzn)
       (setq Errcod 4 ves_det_1 (* pi 0.25 Diam Diam 1000 *STAL*)
             ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
             ves_det_all (* count ves_det_1 DLN))
         (setq Errcod 4 ves_det_1 (* pi 0.25 Diam Diam DLN *STAL*)
             ves_det_1   (if (_get_sumT_Ves1)(atof(rtos ves_det_1 2 (_get_sumT_Okr))) ves_det_1)
             ves_det_all (* count ves_det_1))
         )
         )
     )
;;;======= ????? ???????? (???? ??? ??????) +
   ((vl-position (car WHAT) '("-" "????" "??????" )) ;_????? ????????
     (setq L (vl-string-translate "X" "?" (car(str-str-lst (cadr what) " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ?????? ???????? ?? ???????
     (setq L (str-str-lst L "?"))
    (setq *MPROF* (STRCAT (if (= (car WHAT) "??????") "?????? " "???? ")
                          (dwgru-string-replace (rtos (apply 'min (mapcar 'atof L)) 2 1) ".0" "")
                          ))
     (if (= (length L) 3)(setq DLN 1))
     (setq ves_det_1 (* (apply '* (mapcar 'atof L)) DLN *STAL*)
           ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
                    ves_det_all (* count ves_det_1))
     )
;;;======= ????? ???????? ??? ????????? ??????? ?
    ((vl-position (car WHAT) '("??" "FL" "??????" "\\U+0547\\U+0580\\U+057B\\U+0561\\U+0576")) ;_????? ????????
    (setq L (vl-string-translate "X" "?" (car(str-str-lst (cadr what) " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ?????? ???????? ?? ???????
    (setq L (str-str-lst L "?"))
                      ;;;??? ????? ??? ??????? ?????????? ??? ?? ???????? ?? 0.5 ???????? ? ???????? ???????? ?? ????? ? ?? *STAL*
                      ;;;??????? - ??????? ?????, ????? - ???????
                     (setq L     (mapcar 'atof L))
                     (setq Diam  (apply 'max L) ;_ ???????
                           sH (apply 'min L) ;_ ??????
                           )
    (setq *MPROF* (STRCAT "???? " (dwgru-string-replace (rtos Sh 2 0) ".0" "")))
                      (setq ves_det_1 (* pi 0.25 Diam Diam sH *STAL*)
                            ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
                            ves_det_all (* count ves_det_1))
                    )
;;;======= ????? ??????? +
   ((vl-position (vl-string-trim  "%UuoO??Cc \t" (car WHAT)) '("????????????" "??" "TR" "TP" "T?" "?P" "?????" "\U053d\U0578\U0572." "\U053d\U0578\U0572\U0578\U057e\U0561\U056f")) ;_????? ???????
    (setq L (vl-string-translate "X" "?" (car(str-str-lst (cadr what) " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ?????? ???????? ?? ???????
    (setq L (str-str-lst L "?"))
    ;;;??? ????? ??? ???? ?????????? ??? ?? ???????? ?? 0.5 ???????? ? ???????? ???????? ?? ????? ? ?? *STAL*
    ;;;??????? - ??????? ?????, ????? - ???????
                     (setq L (mapcar 'atof L))
                     (setq Diam (apply 'max L) ;_ ???????
                           Ts (apply 'min L) ;_ ??????? ??????
                           Diam (* 0.5 Diam)    ;_??????? ??????
                           sH (- Diam Ts)    ;_?????????? ??????
                           )
(setq *MPROF* (strcat "????? ??????? " (rtos (* 2 Diam) 2 0) "?" (rtos Ts 2 0)))                    
                      (setq ves_det_1 (*  (- (* Diam Diam)(* sH sH)) DLN pi *STAL*)
                            ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
                            ves_det_all (* count ves_det_1))
                    )
;;;======= ????? ?????????????? ?????????? ? ?????????????n ?
   ((vl-position (vl-string-trim  "%UuoO??Cc \t" (car WHAT)) '("?" "\\U+E72E" "\\U+?72?")) ;_????? ?????????????? ?????????? ? ?????????????
    (setq Vs (vl-string-translate "X" "?" (car(str-str-lst (cadr what) " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ?????? ???????? ?? ???????
    (setq Ts (find-prokat-ves "?" Vs (if (= obzn "") naim obzn) 0))
    (if (and Ts (apply '= Ts))(setq Ts (list(car Ts)))) ;_???? ????????? ????????? ? ??? ???? ??????????
    (setq ves_det_1 (car Ts))
    (if (and Ts (numberp (car Ts))(zerop (car Ts)))(setq Errcod 0 ves_det_1 nil))
    (If ves_det_1
      (progn
        (setq *MPROF* (strcat "??????? ?????? " (MIP-CONV-TO-STR *MPROF*))
              ves_det_1 (*  ves_det_1 DLN (if (< DLN 5) 1 0.001))
              ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
              ves_det_all (* count ves_det_1)
              Errcod 0)
        )
      (progn
        (if (and Ts (numberp (car Ts))(zerop (car Ts)))(setq Errcod 0)(setq Errcod 4)) ;_??? ? ???? ??????? ?? ???????
        (setq L (str-str-lst Vs "?"))
        (setq L (mapcar 'atof L))
        (if (= (length L) 2)
          ;;;????? ??????????
          (setq Sh (apply 'max L) ;_ ??????
                Vs Sh             ;_??????
                Ts (apply 'min L) ;_ ??????? ??????
                *MPROF* "????? "
                )
          (setq Ts (apply 'min L) ;_ ??????? ??????
                Sh (apply 'max (vl-remove Ts L)) ;_ ??????
                Vs (apply 'min (vl-remove Ts L)) ;_ ??????
                *MPROF* "????? "
                )
          )
        (setq *MPROF* (strcat *MPROF* (rtos Vs 2 0) "?" (rtos Sh 2 0) "?" (rtos Ts 2 0)))
        (setq Diam (- Sh Ts Ts)  ;_ ?????? ??????????
              kF (- Vs Ts Ts)  ;_?????? ??????????
              )
        (setq ves_det_1 (*  (- (* Sh Vs)(* Diam kF)) DLN *STAL*)
              ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
              ves_det_all (* count ves_det_1))
        )
      )
    )
;;;======= ??????
   ((vl-position (vl-string-trim  "%UuoO??Cc \t" (car WHAT))
      '("?" "??????" "\\U+E720" "\\U+E721" "\\U+E722" "\\U+E723" "\\U+?720" "\\U+?721" "\\U+?722" "\\U+?723"  "L")) ;_?????? ??????? UNICOD ?? ?????? CS_Gost2304
    (if (vl-position (car WHAT) '("\\U+E721" "\\U+E722" "\\U+E723" "\\U+?721" "\\U+?722" "\\U+?723")) ;_??????? ??????
     (setq kFAll 2)
     )
    (setq L (vl-string-translate "X" "?" (car(str-str-lst (cadr what) " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ?????? ???????? ?? ???????
    (setq L (str-str-lst L "?"))
    (setq L (mapcar 'atof L))
    (if (= (length L) 2)
      ;;;?????? ?????????????
      (setq Sh (apply 'max L) ;_ ??????
            Vs Sh             ;_??????
            Ts (apply 'min L) ;_ ??????? ??????
            )
      (setq Ts (apply 'min L) ;_ ??????? ??????
            Sh (apply 'max (vl-remove Ts L)) ;_ ??????
            Vs (apply 'min (vl-remove Ts L)) ;_ ??????
            )
      )
    (setq Diam (max Vs Sh)
          Sh (min Vs Sh)
          Vs Diam
          )
    (setq L(find-prokat-ves "?"
             (strcat
               (dwgru-string-replace (rtos Vs 2 1) ".0" "")
               "?"
               (dwgru-string-replace (rtos Sh 2 1) ".0" "")
               "?"
               (dwgru-string-replace (rtos Ts 2 1) ".0" "")
               )
              (if (= obzn "") naim obzn) 0))
    (setq *MPROF* (STRCAT "?????? " (MIP-CONV-TO-STR *MPROF*)))
    (if (and L (apply '= L))(setq L (list(car L)))) ;_???? ????????? ????????? ? ??? ???? ??????????
    (if (and L (numberp (car L))(zerop (car L)))(setq Errcod 0 L nil))
    (cond ((null L)(setq ves_det_1 0 ves_det_all 0 Errcod 1)) ;_??? ? ????
         ((> (length L) 1)(setq ves_det_1 (car L) Errcod 2)) ;_?????? ??????, ????? 1-?
         (t (setq ves_det_1 (car L)))
         )
    (setq ves_det_1   (* ves_det_1 DLN (if (< DLN 5) 1 0.001))
          ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
          ves_det_all (* count ves_det_1 kFAll))
    )
  (t ;;;??????????
   (setq ves_det_1 0  ves_det_all 0 Errcod 8 *MPROF* "")
   )
  );_cond
  ;(princ "\nMPROF=")(princ *MPROF*)(princ " ");(princ what)
  (list ves_det_1 ves_det_all kFAll Errcod *MPROF*)
)
(defun C:SPECW ()(specWood)(princ))
(defun C:SPEC5 ()(speckg "5")(princ))
(defun C:SPEC5D ()(speckg "5D")(princ))
(defun C:SPEC4 ()(speckg "4")(princ))
(defun C:SPEC4D ()(speckg "4D")(princ))
(defun C:SPEC3 ()(speckg "3")(princ))
(defun C:SPEC3D ()(speckg "3D")(princ))
(defun C:SPECKG ( / ret)
  (setq ret (mydcl-i "??????? ??????? ????????????. ?????????? ?????????"
                     '(
                       "5 -  ??????????? ???????????? ???-?? ?????_?? ?????_?????"         ;_ 0
                       "5D - ??????????? ???????????? ????? ???-?? ?????_?? ?????_?????"   ;_ 1
                       "4 -  ??????????? ???????????? ???-?? ?????_??"                     ;_ 2
                       "4D - ??????????? ???????????? ????? ???-?? ?????_??"               ;_ 3
                       "3 -  ??????????? ???????????? ???-??"                              ;_ 4
                       "3D - ??????????? ???????????? ????? ???-??"                        ;_ 5
                       )
                     )
        )
                       
                       
  (speckg (nth ret '("5" "5D" "4" "4D" "3" "3D")))
  (princ)
  )

(defun IsAllCharNumeric  ( str / translit)(vl-load-com)  
;;;  http://www.autocad.ru/cgi-bin/f1/board.cgi?t=28488Sx
;;;  ???????????? ???????? ????? ? translit.ru
;;;  ?? ??????? 
;;;  name - ???????? ?????? 
;;;  ???????????? ???????????????
  (apply 'and
  (mapcar '(lambda(x)
             (vl-position x '("1" "2" "3" "4" "5" "6" "7" "8" "9" "0" "."))
             )
          (mapcar 'chr (vl-string->list (vl-string-trim  "%UuoO \t" str)))
          )
         )
)

;;;???????????? ?? ??? ???? 20-93        ??????? 25?2, l=3000       5          100
;;; tip - ??? ???????????? (???-?? ????????? ????????)
(defun SpecKG ( tip / nab pt1 pt2 i SUM okr fuzz marka dlina col ves1 vesall ind pt_ves1 pt_ves_all pat minCol *error* ved itog arm)
  (defun *ERROR*(msg)
    (princ msg)(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))(princ)); end of *ERROR*
  
(vl-load-com)
(vla-StartUndoMark  (vla-get-activedocument (vlax-get-acad-object)))
(if (and ACET-GEOM-TEXTBOX (or *PROKAT_VES_BASE* (_read-prokat-base)))
(progn  
(setq okr (_get_sumT_Okr) ved nil)
(princ "\n(?????????? ?? ")(princ okr)(princ ") ")
(cond ((= tip "5")(setq minCol 4 ind 2) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 5 ??? 4 ???????? (??? ???? ???-?? ?????_?? ?????_????). ?????? ?????: ")
       )
      ((= tip "5D")(setq minCol 5 ind 3) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 6 ??? 5 ???????? (??? ???? ????? ???-?? ?????_?? ?????_????). ?????? ?????: ")
       )
      ((= tip "4")(setq minCol 3 ind 2) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 4 ??? 3 ???????? (??? ???? ???-?? ?????_??). ?????? ?????: ")
       )
      ((= tip "4D")(setq minCol 4 ind 3) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 5 ??? 4 ???????? (??? ???? ????? ???-?? ?????_??). ?????? ?????: ")
       )
      ((= tip "3D")(setq minCol 3 ind 3) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 4 ??? 3 ???????? (??? ???? ????? ???-??). ?????? ?????: ")
       )
      (t (setq tip "3")(setq minCol 2 ind 2) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 3 ??? 2 ???????? (??????????? ???????????? ????????????). ?????? ?????: ")
       )
      )
  ;(princ "??????? ?????? ??????? ?????, ?????,???-??,???1, ??? ????")
(initget 1)
(setq pt1  (getpoint))
(initget 1)  
(setq pt2  (getcorner pt1 "\n?????? ?????: "))
(setq nab (ssget "_C" pt1 pt2 '((0 . "*TEXT"))))
(setq pt2 (_dwgru-conv-pickset-to-list nab))
(setq pt1 (mapcar '(lambda(x)(cdr(assoc 40 (entget x)))) pt2))
(setq fuzz (/ (apply '+ pt1)(length pt1)))
(setq nab
                 (combine pt2
                          '(lambda (x y / a b)
			     (setq a (cdr(assoc 10 (entget x))))
			     (setq b (cdr(assoc 10 (entget y))))
			     (or (< (cadr a)(cadr b)) ;_ on Y
				 (equal (cadr a)
					(cadr b)
					  fuzz
					  )
				 ) ;_ end of or
                           ) ;_ end of lambda
                          '(lambda (x y / a b)
			     (setq a (cdr(assoc 10 (entget x))))
			     (setq b (cdr(assoc 10 (entget y))))
                             (equal (cadr a)
					(cadr b)
					  fuzz
					  )
                             ;(< (car a)(car b)) ;_ end of <
                           ) ;_ end of lambda
                 ) ;_ end of combine
          ) ;_ end of setq
  (setq nab (mapcar '(lambda(x)(vl-sort x '(lambda(a b)(< (cadr(assoc 10 (entget a)))(cadr(assoc 10 (entget b))))))) nab))
 (if (= tip "5D")
   (progn
     (setq nab (mapcar '(lambda(x / ost str)
           (setq ost (reverse x)
                 ost (list (cadr ost)(car ost)))
           (setq x (cddr (reverse x)))
           (setq x (mapcar '(lambda(y)(mip_mtext_unformat
                               (vl-string-translate "," "."
                                 (vl-string-trim  "%UuoO \t" (cdr(assoc 1 (entget y))))))) x))
            (setq x (_prepare_base x))
           (if (= (length x) 1) ;_??? ????????????
             (setq x (list "-" "-" (car x) ""))
             )
           (if (= (length x) 2) ;_????????? ??? ???????. ?????
             (progn
               (if (not(wcmatch (last x) "*????*,*??*,*???*,*???*,*???*,*??*")) ;_???????? ??????? ???????????
                 (setq x (append x '("")))
                 ;;;????? ????????? ????? ? ??????????
                 (setq x (append
                           (list "-"
                                 (if (setq str(cadr(str-str-lst (car x) "=")))
                                   str
                                   "-"
                                   )
                                 )
                           x))
                 )
               )
             )
           (cond ((= (length x) 3) ;_???????? ???? ???????. ?????
                  (if (or (wcmatch (last x) "*????*,*??*,*???*,*???*,*???*,*??*") ;_????? ???????????. ????????? ????
                          (= (last x) "")
                          )
                    (cond ((not(IsAllCharNumeric (car x))) ;_??? ??????????
                         (setq x (cons "" x))
                         )
                        ((not(cadr (str-str-lst (cadr x) "=")));_?? ?????
                         (setq x (append(list (car x) "")(cdr x)))
                         )
                        (t
                         (setq x (append(list (car x) (cadr x))(cdr x)))
                         )
                          )
                    (setq x (append x '("")));_????????? ???????????
                    )
                  )
                  (t nil)
                 );_cond
                 (append (reverse x) ost)
                          );_lambda
                       nab
                  )
           )
     )
   (setq nab (mapcar '(lambda(x)(if (= (length x) minCol)(cons nil x) x)) nab))
   );_if = tip "5D"
  (setq pt1 (apply 'min (mapcar 'length nab)))
  (setq nab (vl-remove-if-not '(lambda(x)(= (length x) pt1)) nab))
;;(mapcar '(lambda(y)(mapcar '(lambda(x)(cdr(assoc 1 (entget x)))) y)) nab)
(setq obz  (mapcar '(lambda(x)(nth 0 x)) nab)
      marka (mapcar '(lambda(x)(nth 1 x)) nab)
      col  (mapcar '(lambda(x)(nth ind x)) nab)
      ind  (if (= ind 3) 2 1) ;_?????? ???????? ??????????? ????? 2 ??? ???? D 1 - ???????
      dlina (mapcar '(lambda(x)(nth ind x)) nab)
   )
  
(if 
      
      (and  obz marka col dlina
	 (= (length obz)
            (length marka)
            (length col)
            (length dlina)
            )
          (= (1+ minCol) pt1)  
          (apply 'and marka)
          (apply 'and col)
          (apply 'and dlina)  
	 )
    (progn
      
      
      ;;;???????? ??????? ?????????, ?????? ???????, ?????????, ?????????????, ?????????????,
      ;;;??????? ??????? ??????. ?.?. %% ???? ?????????, ?? ?? ????????, ????????? ??? %%c ???????? ?????? ?
      ;;;????? ?????????? C ?????????? ?? ??????? ?
      (setq
        table (mapcar '(lambda (a1 a2 a3 a4)
                         (list
                           (mip_mtext_unformat
                             (vl-string-translate
                               ","
                               "."
                               (vl-string-trim
                                 "%UuoO \t"
                                 (cond ((= (type a1) 'ENAME)
                                        (cdr (assoc 1 (entget a1)))
                                       )
                                       ((= (type a1) 'STR) a1)
                                       (t "")
                                 ) ;_ end of cond
                               ) ;_ end of vl-string-trim
                             ) ;_ end of vl-string-translate
                           ) ;_ end of mip_mtext_unformat
                           (if a2
                             (mip_mtext_unformat
                               (vl-string-translate
                                 ","
                                 "."
                                 (vl-string-trim
                                   "%UuoO \t"
                                   (cond ((= (type a2) 'ENAME)
                                          (cdr (assoc 1 (entget a2)))
                                         )
                                         ((= (type a2) 'STR) a2)
                                         (t "")
                                   ) ;_ end of cond
                                 ) ;_ end of vl-string-trim
                               ) ;_ end of vl-string-translate
                             ) ;_ end of mip_mtext_unformat
                             "1"
                           ) ;_ end of if
                           (mip_mtext_unformat
                             (vl-string-translate
                               ","
                               "."
                               (vl-string-trim
                                 "%UuoO \t"
                                 (cond ((= (type a3) 'ENAME)
                                        (cdr (assoc 1 (entget a3)))
                                       )
                                       ((= (type a3) 'STR) a3)
                                       (t "")
                                 ) ;_ end of cond
                               ) ;_ end of vl-string-trim
                             ) ;_ end of vl-string-translate
                           ) ;_ end of mip_mtext_unformat
                           (if a4
                             (mip_mtext_unformat
                               (vl-string-translate
                                 ","
                                 "."
                                 (vl-string-trim
                                   "%UuoO \t"
                                   (cond ((= (type a4) 'ENAME)
                                          (cdr (assoc 1 (entget a4)))
                                         )
                                         ((= (type a4) 'STR) a4)
                                         (t "")
                                   ) ;_ end of cond
                                 ) ;_ end of vl-string-trim
                               ) ;_ end of vl-string-translate
                             ) ;_ end of mip_mtext_unformat
                             "1"
                           ) ;_ end of if
                         ) ;_ end of list
                       ) ;_ end of lambda
                      obz
                      marka
                      col
                      dlina
              ) ;_ end of mapcar

      ) ;_ end of setq
 ;;???????? ?? ???? ??????? ????
 ;;; - X ????????? ?? ? ???????
 ;;; - , ?? .
 ;;; - 2 ??????? ?? 1 ??????
 ;;; -   ?????????? ??????? ????? ?? ???????
 ;;; - ????????? ??? ? ??????? ???????
   (setq table (_prepare_base table))
      ;;?????????????? ??????? ?????. ????? ??????????? ? ????? (????????????) ??? L=
      ;;???? ????? L=? ???? ??????? ? ( ? ?.?. ?? ?.?. ??), ?? ????? ????????? ? ??????, ????? - ??
      ;;???? ??? =, ?? ????????? 1 ???? (1000 ??)
      (setq dlina
             (mapcar '(lambda(x / lst ret)
                 (setq x (nth 3 x)) ;???? ?????
                 (if (IsAllCharNumeric x)(setq ret (atof x))
                   (progn
                     (setq lst (str-str-lst x "="))
                     ;(setq x (cadr lst))
                     (setq x (mip-conv-to-str (cadr lst)))
                     (if (= x "") (setq ret 1000.) ;_?????? ?? ??????? ????????? 1 ?
                       (setq ret (atof x)))
                     )
                   )
                   (if (equal ret 0.0 1e-6)(setq ret 1))
                   (setq ret (abs ret))     
                     (cond
                       ((wcmatch x "*??*") nil) ;_?????????? ???????????
                       ((or
                          (wcmatch x "*?.??*")  ;_?????????? ?????????? ?????
                          (wcmatch x "*??.?*")
                          (wcmatch x "*? ??*")
                          (wcmatch x "*?? ?*")
                          )
                        nil)
                       ((or
                          (IzPM x)
                          (wcmatch x "*# ?*") ;_ ????????????? ?? ?????, ?????? ? ?
                          )
                        (setq ret (* ret 1000.))
                        )
                        (t nil)
                        )
                        ret
                        )
              table
              )
            )
      ;;?????????????? ??????? ??????????
      ;;???? ?????????? 0, ?? ??????? 1
      (setq col
             (mapcar '(lambda(x / lst)
                 (setq x (nth 2 x)) ;???? ?????
                 (if (zerop (setq x (atof x)))
                   1
                   x
                   )
                 )
              table
              )
             )
(cond 
      ((member tip '("4" "4D"))
       (setq pt_ves1 (mapcar 'last nab)
             pt_ves_all nil)
       )
      ((member tip '("5" "5D"))
       (setq Ind (mapcar 'reverse nab)
             pt_ves_all (mapcar 'car Ind)
             pt_ves1 (mapcar 'cadr Ind))
       )
      (t
       
;;;       (initget 1)
;;;       (setq pt1  (getpoint "\n??????? ?????? ?????? \"????? ??\". ?????? ?????: "))
;;;       (initget 1)
;;;       (setq pt2  (getcorner pt1 "\n??????? ?????? ?????? \"????? ??\". ?????? ?????: "))
;;;       (setq pt_ves1 (mapcar '(lambda (x y)(* 0.5 (+ x y))) pt1 pt2))
;;;       (setq pt_ves1 (trans pt_ves1 1 0))
;;;       (if (setq pt1  (getpoint "\n??????? ?????? ?????? \"????? ????\". ?????? ????? <???????????>: "))
;;;           (progn
;;;             (initget 1)
;;;             (setq pt2  (getcorner pt1 "\n??????? ?????? ?????? \"????? ????\". ?????? ?????: "))
;;;             (setq pt_ves_all (mapcar '(lambda (x y)(* 0.5 (+ x y))) pt1 pt2))
;;;             (setq pt_ves_all (trans pt_ves_all 1 0))
;;;             )
;;;         (setq pt_ves_all nil)
;;;         )
       (initget 1)
       (setq pt_ves1  (getpoint "\n??????? ???????? ??????? \"????? ??\": "))
       (setq pt_ves1 (trans pt_ves1 1 0))
       (if (setq pt_ves_all  (getpoint "\n??????? ???????? ??????? \"????? ????\" <???????????>: "))
         (setq pt_ves_all (trans pt_ves_all 1 0))
         )
      
       (setq pt1 (entget(car marka)))
;;;?? ??????? ????? 1-? ??????? ???? ????? (????????????)
       (setq pat (list
             '(0 . "TEXT")
             (assoc 410 pt1) ;_????????????
             (assoc 8 pt1)   ;_????
             '(100 . "AcDbText")
             (assoc 10 pt1)
             (assoc 40 pt1) ;_??????
             (assoc 1 pt1)  ;_????????
             (assoc 50 pt1)  ;_???????
             '(41 . 1.0)
             (if (= (cdr(assoc 0 pt1)) "TEXT")
             (assoc 51 pt1)  ;_???? ???????
             (cons 51 (cdr(assoc 50(tblsearch "STYLE" (cdr(assoc 7 pt1))))))
               )
             (assoc 7 pt1)  ;_?????
             '(71 . 0)
             '(72 . 1) ;_????????????? ?? ??????
             (cons 11 (cdr(assoc 10 pt1))) ;_????? ????????????
             (assoc 210 pt1)  ;_???? ???????
             '(100 . "AcDbText")
             '(73 . 2);_??????????? ?? ??????
             )
       )
       )
      
      )
       (setq Ind '-1 ved nil itog nil)

 (mapcar '(lambda(line / obzn naim dln count ret pt10 ed tmp Err)
            (setq Ind (1+ Ind))
            
            ;(setq line (nth Ind table))
            (setq obzn (apply 'strcat(mapcar '(lambda(x)(strcat x "|")) line))
                  naim (cadr line)
                  dln (nth Ind dlina)
                  count (nth Ind col)
                  )
            
            (setq ret (_get_Prokat_ves obzn naim dln count))
            (setq ved (cons 
                            (list obzn
                                  *MPROF*
                                  (MIP-CONV-TO-STR(find-sortament-GOST "" obzn))
                                  (cadr ret)
                                  *PROKAT_KLASS*
                                  )
                            ved
                            )
                  )
            (setq Err (_get_Err_color_string (nth 3 ret)))

 (if (and (= (type (nth Ind pt_ves1)) 'ENAME)
          (setq tmp (_dwgru-conv-ent-to-vla (nth Ind pt_ves1)))
          (vlax-write-enabled-p tmp)
          )
   (progn
     (vla-put-TextString tmp
       (if (zerop (car ret)) "-"
           (_sumT_prep_Number(_sumT_Ves_okr (car ret))))
       )
     )
   (progn
     (setq pt1 (ACET-GEOM-TEXTBOX (entget(nth ind marka)) 1e-3))
     (setq pt2 (mapcar '(lambda (x y)(* 0.5 (+ x y)))
                       (mapcar '(lambda(x)(apply 'min x))(apply 'mapcar (cons 'list pt1)))
                       (mapcar '(lambda(x)(apply 'max x))(apply 'mapcar (cons 'list pt1)))
                       )
           )
     (setq pt10 (list (car pt_ves1)
                      (cadr pt2)
                      (caddr pt_ves1)
                      )
           )
     (setq ed (subst (cons 10 pt10)(assoc 10 pat) pat))
     (setq ed (subst (cons 11 pt10)(assoc 11 ed) ed))
     (setq ed (subst (cons 1
                           (if (zerop (car ret)) "-"
                             (_sumT_prep_Number(_sumT_Ves_okr (car ret))))
                           )
                     (assoc 1 ed) ed))
     (setq ed (entmakex ed))
     (setq tmp (_dwgru-conv-ent-to-vla ed))
     )
   )
(if (and tmp (vlax-write-enabled-p tmp))
  (progn
    (setq ves1 tmp)
    (vla-put-color tmp  (car Err))
    (mip-put-hyperlink tmp (cadr Err))
    )
  )
(setq tmp nil)            
(cond
  ((and pt_ves_all (= (type (nth Ind pt_ves_all)) 'ENAME)  ;_????? ?????
          (setq tmp (_dwgru-conv-ent-to-vla (nth Ind pt_ves_all)))
          (vlax-write-enabled-p tmp)
          )
     (vla-put-TextString tmp  (if (zerop (cadr ret)) "-" (_sumT_prep_Number(_sumT_Ves_okr (cadr ret)))))
   (mip-put-hyperlink tmp "")
   (vla-put-color tmp  (car Err))
   )
  ((and pt_ves_all (listp pt_ves_all) (apply 'and(mapcar 'numberp pt_ves_all)))
   (setq pt10 (list (car pt_ves_all)
                    (cadr pt2)
                    (caddr pt_ves_all)
                    )
         )
                (setq ed (subst (cons 10 pt10)(assoc 10 pat) pat))
                (setq ed (subst (cons 11 pt10)(assoc 11 ed) ed))
                (setq ed (subst (cons 1
                                  (if (zerop (cadr ret)) "-"
                                    (_sumT_prep_Number(_sumT_Ves_okr (cadr ret))))
                                  )
                                  (assoc 1 ed) ed))
                (setq ed (entmakex ed))
                (setq tmp (_dwgru-conv-ent-to-vla ed))
                (vla-put-color tmp  (car Err))
   )
  (t  (setq tmp ves1);_????? ? ???1
   )
  );_cond
(if (and tmp
         (vlax-write-enabled-p tmp)
         )
     (progn
       (if (= (cadr Err) "")
         
         (mip-put-hyperlink tmp (strcat (_sumT_Ves_okr (cadr ret))
                                                    "="
                                                    (_sumT_Ves_okr (car ret))
                                                    " * "
                                                    (rtos count 2 1)
                                                    (if (= (nth 2 ret) 1)
                                                      ""
                                                      (strcat " * " (itoa (nth 2 ret)))
                                                      )
                                                  )
                        )
                  )
                )
              )            
   )
         table
         )
      (setq arm  (last(assoc "?????????????" *PROKAT_VES_BASE*))) ;_?????? ????????

      (mapcar '(lambda(line / pt1 pt2 nab diam gost klass ed tmp ret obzn)
               (setq obzn (car line) line (cdr line))
(setq klass (mip-conv-to-str
                              (car
                              (vl-remove-if 'null
                              (mapcar '(lambda(x)
                                   (if (wcmatch obzn (strcat "*" x "*"))
                                       ;(vl-string-search x obzn)
                                     x
                                     nil
                                     )
                                   )
                                arm
                                )
                                )
                              )
                              )
                            
                  )
            (if (= klass "")(setq klass (strcat "?????? " (mip-conv-to-str(nth 3 line))))
              (setq klass (strcat "???????? " klass)))
            (setq diam (car line))
            (setq GOST (cadr line)) 
            (setq ret (cdr line))
            (if (setq tmp (assoc klass itog))
              (progn
                (setq ed (cdr tmp))
                (if (setq pt1 (assoc GOST ed))
                  (progn
                    (setq pt2 (cdr pt1))
                    (if (setq nab(assoc diam pt2))
                      (setq pt2
                             (subst (list (car nab)(+ (cadr nab)(cadr ret)))
                             (assoc diam pt2)
                             pt2)
                            )
                      
                      (setq pt2 (cons (list diam (cadr ret)) pt2))
                      )
                      (setq ed (subst (cons GOST pt2)
                                       (assoc GOST ed)
                                       ed
                                       )
                            )
                                       
                    )
                  (progn
                   (setq ed (cons (list GOST (list diam (cadr ret))) ed))
                    )
                  )
                (setq itog (subst (cons klass ed)
                                      (assoc klass itog)
                                      itog
                                      )
                          )
                
                )
              (setq itog (cons
                           (list klass (list GOST (list diam (cadr ret))))
                           itog)
                    );_setq
                 
                 )
                 )
              ved
              
      )
      (setq ved nil)
    (setq itog  
    (mapcar '(lambda (kl)
               (cons (car kl)
                     (mapcar '(lambda(GST / sort_list) ;!!23456
                                (setq sort_list (SortstringWithNumberasNumber (mapcar 'car (cdr GST)) nil))
                                (cons (car GST)
                                      (vl-sort (cdr GST)
                                               '(lambda (a1 a2)
                                                  (< (VL-POSITION (car a1) sort_list)
                                                     (VL-POSITION (car a2) sort_list)
                                                     )
                                                  )
                                               )
                                      )
                               )
                             (cdr KL)
                             )
                     )
               )
            itog)
          )
;;;      (setq iii itog)
;;;      (setq itog iii)
      (princ "\n============= ???? ?????? ==============\n")
      (foreach klass itog
        (princ "\n????? : ")(princ (car klass))
      (mapcar '(lambda(line)
                 (terpri)
                 (princ (car line))
                 (foreach xx (cdr line)
                   (princ "\n     ")
                   (princ (car xx))
                   (princ "  -  ")
                   (princ (cadr xx))
                   (princ " ??.")
                   )
                 (princ "\n-------------------------------------------------")
                 )
              (cdr klass)
              )
        )
      )
      (alert "?? ????????? ???-?? ?????? ? ????????!")
  )
)
 (if (null ACET-GEOM-TEXTBOX )(alert "?????????? ????????? Express Tools!"))
  )
  
(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))  
(princ)
)

;;;???????????? ??????
;;; ??????? B H L ???-?? ????? ??, ????? ?????
(defun SpecWood ( / nab pt1 pt2 i SUM okr fuzz marka dlina col ves1 vesall ind pt_ves1 pt_ves_all pat minCol *error* ved itog tip)
  (defun *ERROR*(msg)
    (princ msg)(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))(princ)); end of *ERROR*
  
(vl-load-com)
(vla-StartUndoMark  (vla-get-activedocument (vlax-get-acad-object)))
(if (and ACET-GEOM-TEXTBOX (or *PROKAT_VES_BASE* (_read-prokat-base)))
(progn
(setq tip "5D")  
(setq okr (_get_sumT_Okr) ved nil)
(princ "\n(?????????? ?? ")(princ okr)(princ ") ")
(cond ((= tip "5")(setq minCol 4 ind 2) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 5 ??? 4 ???????? (??? ???? ???-?? ?????_?? ?????_????). ?????? ?????: ")
       )
      ((= tip "5D")(setq minCol 6 ind 3) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 6 ???????? (B H L ???-?? ?????_?? ?????_????). ?????? ?????: ")
       )
      ((= tip "4")(setq minCol 3 ind 2) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 4 ??? 3 ???????? (??? ???? ???-?? ?????_??). ?????? ?????: ")
       )
      ((= tip "4D")(setq minCol 4 ind 3) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 5 ??? 4 ???????? (??? ???? ????? ???-?? ?????_??). ?????? ?????: ")
       )
      ((= tip "3D")(setq minCol 3 ind 3) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 4 ??? 3 ???????? (??? ???? ????? ???-??). ?????? ?????: ")
       )
      (t (setq tip "3")(setq minCol 2 ind 2) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 3 ??? 2 ???????? (??????????? ???????????? ????????????). ?????? ?????: ")
       )
      )
  ;(princ "??????? ?????? ??????? ?????, ?????,???-??,???1, ??? ????")
(initget 1)
(setq pt1  (getpoint))
(initget 1)  
(setq pt2  (getcorner pt1 "\n?????? ?????: "))
(setq nab (ssget "_C" pt1 pt2 '((0 . "*TEXT"))))
(setq pt2 (_dwgru-conv-pickset-to-list nab))
(setq pt1 (mapcar '(lambda(x)(cdr(assoc 40 (entget x)))) pt2))
(setq fuzz (/ (apply '+ pt1)(length pt1)))
(setq nab
                 (combine pt2
                          '(lambda (x y / a b)
			     (setq a (cdr(assoc 10 (entget x))))
			     (setq b (cdr(assoc 10 (entget y))))
			     (or (< (cadr a)(cadr b)) ;_ on Y
				 (equal (cadr a)
					(cadr b)
					  fuzz
					  )
				 ) ;_ end of or
                           ) ;_ end of lambda
                          '(lambda (x y / a b)
			     (setq a (cdr(assoc 10 (entget x))))
			     (setq b (cdr(assoc 10 (entget y))))
                             (equal (cadr a)
					(cadr b)
					  fuzz
					  )
                             ;(< (car a)(car b)) ;_ end of <
                           ) ;_ end of lambda
                 ) ;_ end of combine
          ) ;_ end of setq
  (setq nab (mapcar '(lambda(x)(vl-sort x '(lambda(a b)(< (cadr(assoc 10 (entget a)))(cadr(assoc 10 (entget b))))))) nab))
  ;(setq nab (mapcar '(lambda(x)(if (= (length x) minCol)(cons nil x) x)) nab))
  (setq pt1 (apply 'max (mapcar 'length nab)))
  ;(setq nab (vl-remove-if-not '(lambda(x)(= (length x) pt1)) nab))
;;(mapcar '(lambda(y)(mapcar '(lambda(x)(cdr(assoc 1 (entget x)))) y)) nab)
(setq obz  (mapcar '(lambda(x)(nth 0 x)) nab)
      marka (mapcar '(lambda(x)(nth 1 x)) nab)
      dlina  (mapcar '(lambda(x)(nth 2 x)) nab)
      col  (mapcar '(lambda(x)(nth 3 x)) nab)
   )
  
(if 
      
      (and  obz marka col dlina
	 (= (length obz)
            (length marka)
            (length col)
            (length dlina)
            )
            (= pt1 6)
          
	 )
    (progn
      
      ;;;???????? ??????? ?????????, ?????? ???????, ?????????, ?????????????, ?????????????,
      ;;;??????? ??????? ??????. ?.?. %% ???? ?????????, ?? ?? ????????, ????????? ??? %%c ???????? ?????? ?
      ;;;????? ?????????? C ?????????? ?? ??????? ?
      (setq table (mapcar '(lambda(a1 a2 a3 a4)
                             (list
                               (mip_mtext_unformat
                               (vl-string-translate "," "."
                                 (vl-string-trim  "%UuoO \t" (if a1 (cdr(assoc 1 (entget a1))) ""))))
                               (if a2
                               (mip_mtext_unformat
                               (vl-string-translate "," "."
                                 (vl-string-trim  "%UuoO \t" (cdr(assoc 1 (entget a2))))))
                                 "1"
                                 )
                               (mip_mtext_unformat
                               (vl-string-translate "," "."
                                 (vl-string-trim  "%UuoO \t" (cdr(assoc 1 (entget a3))))))
                             (if a4
                               (mip_mtext_unformat
                               (vl-string-translate "," "."
                                 (vl-string-trim  "%UuoO \t" (cdr(assoc 1 (entget a4))))))
                                 "1"
                                 )
                               )
                          )
                          obz marka col dlina
                          )
            
            )
 ;;???????? ?? ???? ??????? ????
 ;;; - X ????????? ?? ? ???????
 ;;; - , ?? .
 ;;; - 2 ??????? ?? 1 ??????
 ;;; -   ?????????? ??????? ????? ?? ???????
 ;;; - ????????? ??? ? ??????? ???????
   (setq table (_prepare_base table))
      ;;?????????????? ??????? ?????. ????? ??????????? ? ????? (????????????) ??? L=
      ;;???? ????? L=? ???? ??????? ? ( ? ?.?. ?? ?.?. ??), ?? ????? ????????? ? ??????, ????? - ??
      ;;???? ??? =, ?? ????????? 1 ???? (1000 ??)
      (setq dlina
             (mapcar '(lambda(x / lst ret)
                 (setq x (nth 3 x)) ;???? ?????
                 (if (IsAllCharNumeric x)(setq ret (atof x))
                   (progn
                     (setq lst (str-str-lst x "="))
                     ;(setq x (cadr lst))
                     (setq x (mip-conv-to-str (cadr lst)))
                     (if (= x "") (setq ret 1000.) ;_?????? ?? ??????? ????????? 1 ?
                       (setq ret (atof x)))
                     )
                   )
                   (if (equal ret 0.0 1e-6)(setq ret 1))
                   (setq ret (abs ret))     
                     (cond
                       ((wcmatch x "*??*") nil) ;_?????????? ???????????
                       ((or
                          (wcmatch x "*?.??*")  ;_?????????? ?????????? ?????
                          (wcmatch x "*??.?*")
                          (wcmatch x "*? ??*")
                          (wcmatch x "*?? ?*")
                          )
                        nil)
                       ((or
                          (IzPM x)
                          (wcmatch x "*# ?*") ;_ ????????????? ?? ?????, ?????? ? ?
                          )
                        (setq ret (* ret 1000.))
                        )
                        (t nil)
                        )
                        ret
                        )
              table
              )
            )
      ;;?????????????? ??????? ??????????
      ;;???? ?????????? 0, ?? ??????? 1
      (setq col
             (mapcar '(lambda(x / lst)
                 (setq x (nth 2 x)) ;???? ?????
                 (if (zerop (setq x (atof x)))
                   1
                   x
                   )
                 )
              table
              )
             )
(cond 
      ((member tip '("4" "4D"))
       (setq pt_ves1 (mapcar 'last nab)
             pt_ves_all nil)
       )
      ((member tip '("5" "5D"))
       (setq Ind (mapcar 'reverse nab)
             pt_ves_all (mapcar 'car Ind)
             pt_ves1 (mapcar 'cadr Ind))
       )
      (t
       
;;;       (initget 1)
;;;       (setq pt1  (getpoint "\n??????? ?????? ?????? \"????? ??\". ?????? ?????: "))
;;;       (initget 1)
;;;       (setq pt2  (getcorner pt1 "\n??????? ?????? ?????? \"????? ??\". ?????? ?????: "))
;;;       (setq pt_ves1 (mapcar '(lambda (x y)(* 0.5 (+ x y))) pt1 pt2))
;;;       (setq pt_ves1 (trans pt_ves1 1 0))
;;;       (if (setq pt1  (getpoint "\n??????? ?????? ?????? \"????? ????\". ?????? ????? <???????????>: "))
;;;           (progn
;;;             (initget 1)
;;;             (setq pt2  (getcorner pt1 "\n??????? ?????? ?????? \"????? ????\". ?????? ?????: "))
;;;             (setq pt_ves_all (mapcar '(lambda (x y)(* 0.5 (+ x y))) pt1 pt2))
;;;             (setq pt_ves_all (trans pt_ves_all 1 0))
;;;             )
;;;         (setq pt_ves_all nil)
;;;         )
       (initget 1)
       (setq pt_ves1  (getpoint "\n??????? ???????? ??????? \"????? ??\": "))
       (setq pt_ves1 (trans pt_ves1 1 0))
       (if (setq pt_ves_all  (getpoint "\n??????? ???????? ??????? \"????? ????\" <???????????>: "))
         (setq pt_ves_all (trans pt_ves_all 1 0))
         )
      
       (setq pt1 (entget(car marka)))
;;;?? ??????? ????? 1-? ??????? ???? ????? (????????????)
       (setq pat (list
             '(0 . "TEXT")
             (assoc 410 pt1) ;_????????????
             (assoc 8 pt1)   ;_????
             '(100 . "AcDbText")
             (assoc 10 pt1)
             (assoc 40 pt1) ;_??????
             (assoc 1 pt1)  ;_????????
             (assoc 50 pt1)  ;_???????
             '(41 . 1.0)
             (if (= (cdr(assoc 0 pt1)) "TEXT")
             (assoc 51 pt1)  ;_???? ???????
             (cons 51 (cdr(assoc 50(tblsearch "STYLE" (cdr(assoc 7 pt1))))))
               )
             (assoc 7 pt1)  ;_?????
             '(71 . 0)
             '(72 . 1) ;_????????????? ?? ??????
             (cons 11 (cdr(assoc 10 pt1))) ;_????? ????????????
             (assoc 210 pt1)  ;_???? ???????
             '(100 . "AcDbText")
             '(73 . 2);_??????????? ?? ??????
             )
       )
       )
      
      )
       (setq Ind '-1)
 (mapcar '(lambda(line / obzn naim dln count ret pt10 ed tmp Err V1 V_all)
            (setq Ind (1+ Ind))
            
            ;(setq line (nth Ind table))
            (setq obzn (atof (nth 0 line))
                  naim (atof (nth 1 line))
                  dln (nth Ind dlina)
                  count (nth Ind col)
                  V1 (* obzn naim dln 1e-9))
            (setq 
                  V1 (if (_get_sumT_Ves1)(atof(rtos V1 2 (_get_sumT_Okr))) V1)
                  V_all (* V1 count)
                  )
            
            (setq ret (list V1 V_all))
                        


 (if (and (= (type (nth Ind pt_ves1)) 'ENAME)
          (setq tmp (_dwgru-conv-ent-to-vla (nth Ind pt_ves1)))
          (vlax-write-enabled-p tmp)
          )
   (progn
     (vla-put-TextString tmp
       (if (zerop (car ret)) "-"
           (_sumT_prep_Number(rtos (car ret) 2 okr)))
       )
     )
    )
(if (and pt_ves_all (= (type (nth Ind pt_ves_all)) 'ENAME)  ;_????? ?????
          (setq tmp (_dwgru-conv-ent-to-vla (nth Ind pt_ves_all)))
          (vlax-write-enabled-p tmp)
          )
  (progn
    (vla-put-TextString tmp  (if (zerop (cadr ret)) "-" (_sumT_prep_Number(rtos (cadr ret) 2 okr))))
    )
  )
   )
         table
         )
      
      )
      (alert "?? ????????? ???-?? ?????? ? ????????!")
  )
)
 (if (null ACET-GEOM-TEXTBOX )(alert "?????????? ????????? Express Tools!"))
  )
  
(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))  
(princ)
)

;|

(defun SpecDiam ( / nab pt1 pt2 i SUM okr fuzz marka dlina col ves1 vesall ind pt_ves1 pt_ves_all pat minCol *error* arm itog)
  (defun *ERROR*(msg)
    (princ msg)(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))(princ)); end of *ERROR*
(vl-load-com)  
(setq arm  (last(assoc "?????????????" *PROKAT_VES_BASE*))) ;_?????? ????????
(vla-StartUndoMark  (vla-get-activedocument (vlax-get-acad-object)))
(if (and ACET-GEOM-TEXTBOX (or *PROKAT_VES_BASE* (_read-prokat-base)))
(progn  
(setq okr (_get_sumT_Okr))
(princ "\n(?????????? ?? ")(princ okr)(princ ") ")
(setq tip "3")
(cond ((= tip "5")(setq minCol 4 ind 2) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 5 ??? 4 ???????? (??? ???? ???-?? ?????_?? ?????_????). ?????? ?????: ")
       )
      ((= tip "5D")(setq minCol 5 ind 3) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 6 ??? 5 ???????? (??? ???? ????? ???-?? ?????_?? ?????_????). ?????? ?????: ")
       )
      ((= tip "4")(setq minCol 3 ind 2) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 4 ??? 3 ???????? (??? ???? ???-?? ?????_??). ?????? ?????: ")
       )
      ((= tip "4D")(setq minCol 4 ind 3) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 5 ??? 4 ???????? (??? ???? ????? ???-?? ?????_??). ?????? ?????: ")
       )
      ((= tip "3D")(setq minCol 3 ind 3) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 4 ??? 3 ???????? (??? ???? ????? ???-??). ?????? ?????: ")
       )
      (t (setq tip "3")(setq minCol 2 ind 2) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 3 ??? 2 ???????? (??????????? ???????????? ????????????). ?????? ?????: ")
       )
      )
  ;(princ "??????? ?????? ??????? ?????, ?????,???-??,???1, ??? ????")
(initget 1)
(setq pt1  (getpoint))
(initget 1)  
(setq pt2  (getcorner pt1 "\n?????? ?????: "))
(setq nab (ssget "_C" pt1 pt2 '((0 . "*TEXT"))))
(setq pt2 (_dwgru-conv-pickset-to-list nab))
(setq pt1 (mapcar '(lambda(x)(cdr(assoc 40 (entget x)))) pt2))
(setq fuzz (/ (apply '+ pt1)(length pt1)))
(setq nab
                 (combine pt2
                          '(lambda (x y / a b)
			     (setq a (cdr(assoc 10 (entget x))))
			     (setq b (cdr(assoc 10 (entget y))))
			     (or (< (cadr a)(cadr b)) ;_ on Y
				 (equal (cadr a)
					(cadr b)
					  fuzz
					  )
				 ) ;_ end of or
                           ) ;_ end of lambda
                          '(lambda (x y / a b)
			     (setq a (cdr(assoc 10 (entget x))))
			     (setq b (cdr(assoc 10 (entget y))))
                             (equal (cadr a)
					(cadr b)
					  fuzz
					  )
                             ;(< (car a)(car b)) ;_ end of <
                           ) ;_ end of lambda
                 ) ;_ end of combine
          ) ;_ end of setq
  (setq nab (mapcar '(lambda(x)(vl-sort x '(lambda(a b)(< (cadr(assoc 10 (entget a)))(cadr(assoc 10 (entget b))))))) nab))
  (setq nab (mapcar '(lambda(x)(if (= (length x) minCol)(cons nil x) x)) nab))
  (setq pt1 (apply 'max (mapcar 'length nab)))
  (setq nab (vl-remove-if-not '(lambda(x)(= (length x) pt1)) nab))
;;(mapcar '(lambda(y)(mapcar '(lambda(x)(cdr(assoc 1 (entget x)))) y)) nab)
(setq obz  (mapcar '(lambda(x)(nth 0 x)) nab)
      marka (mapcar '(lambda(x)(nth 1 x)) nab)
      col  (mapcar '(lambda(x)(nth ind x)) nab)
      ind  (if (= ind 3) 2 1) ;_?????? ???????? ??????????? ????? 2 ??? ???? D 1 - ???????
      dlina (mapcar '(lambda(x)(nth ind x)) nab)
   )
  
(if 
      ;;;4 ????????
      (and  obz marka col dlina
	 (= (length obz)
            (length marka)
            (length col)
            (length dlina)
            )
          (= (1+ minCol) pt1)  
          (apply 'and marka)
          (apply 'and col)
          (apply 'and dlina)  
	 )
    (progn
      
      ;;;???????? ??????? ?????????, ?????? ???????, ?????????, ?????????????, ?????????????,
      ;;;??????? ??????? ??????. ?.?. %% ???? ?????????, ?? ?? ????????, ????????? ??? %%c ???????? ?????? ?
      ;;;????? ?????????? C ?????????? ?? ??????? ?
      (setq table (mapcar '(lambda(a1 a2 a3 a4)
                             (list
                               (mip_mtext_unformat
                               (vl-string-translate "," "."
                                 (vl-string-trim  "%UuoO \t" (if a1 (cdr(assoc 1 (entget a1))) ""))))
                               (if a2
                               (mip_mtext_unformat
                               (vl-string-translate "," "."
                                 (vl-string-trim  "%UuoO \t" (cdr(assoc 1 (entget a2))))))
                                 "1"
                                 )
                               (mip_mtext_unformat
                               (vl-string-translate "," "."
                                 (vl-string-trim  "%UuoO \t" (cdr(assoc 1 (entget a3))))))
                             (if a4
                               (mip_mtext_unformat
                               (vl-string-translate "," "."
                                 (vl-string-trim  "%UuoO \t" (cdr(assoc 1 (entget a4))))))
                                 "1"
                                 )
                               )
                          )
                          obz marka col dlina
                          )
            
            )
 ;;???????? ?? ???? ??????? ????
 ;;; - X ????????? ?? ? ???????
 ;;; - , ?? .
 ;;; - 2 ??????? ?? 1 ??????
 ;;; -   ?????????? ??????? ????? ?? ???????
 ;;; - ????????? ??? ? ??????? ???????
   (setq table (_prepare_base table))
      ;;?????????????? ??????? ?????. ????? ??????????? ? ????? (????????????) ??? L=
      ;;???? ????? L=? ???? ??????? ? ( ? ?.?. ?? ?.?. ??), ?? ????? ????????? ? ??????, ????? - ??
      ;;???? ??? =, ?? ????????? 1 ???? (1000 ??)
      (setq dlina
             (mapcar '(lambda(x / lst ret)
                 (setq x (nth 3 x)) ;???? ?????
                 (if (IsAllCharNumeric x)(setq ret (atof x))
                   (progn
                     (setq lst (str-str-lst x "="))
                     (setq x (cadr lst))
                     (if (null x) (setq ret 1000.)
                       (if (and
                             (not (wcmatch x "*??*"))
                             (wcmatch x "*?*")
                             )
                         (setq ret (* (atof x) 1000.))
                         (setq ret (atof x))
                         )
                       )
                     )
                   )
                        ret
                        )
              table
              )
            )
      ;;?????????????? ??????? ??????????
      ;;???? ?????????? 0, ?? ??????? 1
      (setq col
             (mapcar '(lambda(x / lst)
                 (setq x (nth 2 x)) ;???? ?????
                 (if (zerop (setq x (atof x)))
                   1
                   x
                   )
                 )
              table
              )
             )
(setq table (mapcar '(lambda(x)(list (car x)(cadr x))) table))      
(setq table (vl-remove-if-not '(lambda(x)
              (= (_GET_PROKAT_TIP (apply 'strcat(mapcar '(lambda(x)(strcat x "|")) x))) "?")
                                 )
              table)
      )
  (setq Ind '-1 itog nil)
 (mapcar '(lambda(line / obzn naim dln count ret pt10 ed tmp Err diam GOST)
            (setq Ind (1+ Ind))
            
            ;(setq line (nth Ind table))
            (setq obzn (apply 'strcat(mapcar '(lambda(x)(strcat x "|")) line))
                  naim (cadr line)
                  dln (nth Ind dlina)
                  count (nth Ind col)
                  )
            
            (setq ret (_get_Prokat_ves obzn  naim dln count))
            (setq diam (atoi(mip-conv-to-str(cadr(mark_parser naim)))))
            (setq GOST (find-sortament-GOST "?" obzn)) 
            (setq klass (mip-conv-to-str
                              (car
                              (vl-remove-if 'null
                              (mapcar '(lambda(x)
                                   (if (wcmatch obzn (strcat "*" x "*"))
                                     x
                                     nil
                                     )
                                   )
                                arm
                                )
                                )
                              )
                              )
                            
                  )
            (if (setq tmp (assoc klass itog))
              (progn
                (setq ed (cdr tmp))
                (if (setq pt1 (assoc GOST ed))
                  (progn
                    (setq pt2 (cdr pt1))
                    (if (setq nab(assoc diam pt2))
                      (setq pt2
                             (subst (list (car nab)(+ (cadr nab)(cadr ret)))
                             (assoc diam pt2)
                             pt2)
                            )
                      
                      (setq pt2 (cons (list diam (cadr ret)) pt2))
                      )
                      (setq ed (subst (cons GOST pt2)
                                       (assoc GOST ed)
                                       ed
                                       )
                            )
                                       
                    )
                  (progn
                   (setq ed (cons (list GOST (list diam (cadr ret))) ed))
                    )
                  )
                (setq itog (subst (cons klass ed)
                                      (assoc klass itog)
                                      itog
                                      )
                          )
                
                )
              (setq itog (cons
                           (list klass (list GOST (list diam (cadr ret))))
                           itog)
                    );_setq
              )



   )
         table
         )
      )
      (alert "?? ????????? ???-?? ?????? ? ????????!")
  )
)
 (if (null ACET-GEOM-TEXTBOX )(alert "?????????? ????????? Express Tools!"))
  )
(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))  
(princ itog)(princ)
)

|;

;|
(defun SpecGOST ( tip / nab pt1 pt2 i SUM okr fuzz marka dlina col ves1 vesall ind pt_ves1 pt_ves_all pat minCol *error*)
  (defun *ERROR*(msg)
    (princ msg)(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))(princ)); end of *ERROR*
  
(vl-load-com)
(vla-StartUndoMark  (vla-get-activedocument (vlax-get-acad-object)))
(if (and ACET-GEOM-TEXTBOX (or *PROKAT_VES_BASE* (_read-prokat-base)))
(progn  
(setq okr (_get_sumT_Okr))

(princ "\n(?????????? ?? ")(princ okr)(princ ") ")
(princ " ??????? ?????? ??????? ????????????. ???????????(????????????) - ?????_????). ?????? ?????: ")
(initget 1)
(setq pt1  (getpoint))
(initget 1)  
(setq pt2  (getcorner pt1 "\n?????? ?????: "))
(setq nab (ssget "_C" pt1 pt2 '((0 . "*TEXT"))))
(setq pt2 (_dwgru-conv-pickset-to-list nab))
(setq pt1 (mapcar '(lambda(x)(cdr(assoc 40 (entget x)))) pt2))
(setq fuzz (/ (apply '+ pt1)(length pt1)))
(setq nab
                 (combine pt2
                          '(lambda (x y / a b)
			     (setq a (cdr(assoc 10 (entget x))))
			     (setq b (cdr(assoc 10 (entget y))))
			     (or (< (cadr a)(cadr b)) ;_ on Y
				 (equal (cadr a)
					(cadr b)
					  fuzz
					  )
				 ) ;_ end of or
                           ) ;_ end of lambda
                          '(lambda (x y / a b)
			     (setq a (cdr(assoc 10 (entget x))))
			     (setq b (cdr(assoc 10 (entget y))))
                             (equal (cadr a)
					(cadr b)
					  fuzz
					  )
                             ;(< (car a)(car b)) ;_ end of <
                           ) ;_ end of lambda
                 ) ;_ end of combine
          ) ;_ end of setq
  (setq nab (mapcar '(lambda(x)(vl-sort x '(lambda(a b)(< (cadr(assoc 10 (entget a)))(cadr(assoc 10 (entget b))))))) nab))
  ;(setq nab (mapcar '(lambda(x)(if (= (length x) minCol)(cons nil x) x)) nab))
  ;(setq pt1 (apply 'max (mapcar 'length nab)))
  ;(setq nab (vl-remove-if-not '(lambda(x)(= (length x) pt1)) nab))
;;(mapcar '(lambda(y)(mapcar '(lambda(x)(cdr(assoc 1 (entget x)))) y)) nab)
;;;(setq obz  (mapcar '(lambda(x)(nth 0 x)) nab)
;;;      marka (mapcar '(lambda(x)(nth 1 x)) nab)
;;;      col  (mapcar '(lambda(x)(nth ind x)) nab)
;;;      ind  (if (= ind 3) 2 1) ;_?????? ???????? ??????????? ????? 2 ??? ???? D 1 - ???????
;;;      dlina (mapcar '(lambda(x)(nth ind x)) nab)
;;;   )
  
(if nab
    (progn
      ;;;???????? ??????? ?????????, ?????? ???????, ?????????, ?????????????, ?????????????,
      ;;;??????? ??????? ??????. ?.?. %% ???? ?????????, ?? ?? ????????, ????????? ??? %%c ???????? ?????? ?
      ;;;????? ?????????? C ?????????? ?? ??????? ?
      (setq table (mapcar '(lambda(a1 / ll)
                             (setq ll (mapcar '(lambda(x)
                                                 (mip_mtext_unformat
                               (vl-string-translate "," "."
                                 (vl-string-trim  "%UuoO \t" (if x (cdr(assoc 1 (entget x))) ""))))
                                                 )
                                              a1
                                              )
                                   
                                   )
                             (list
                             (apply 'strcat(mapcar '(lambda(x)(strcat x "|")) ll))
                             (nth 1 ll)
                             (atof (last ll))
                             )
                          )
                          nab
                          )
            
            )
      
 ;;???????? ?? ???? ??????? ????
 ;;; - X ????????? ?? ? ???????
 ;;; - , ?? .
 ;;; - 2 ??????? ?? 1 ??????
 ;;; -   ?????????? ??????? ????? ?? ???????
 ;;; - ????????? ??? ? ??????? ???????
   (setq table (_prepare_base table))
    (setq Ind '-1 itog nil)
 (mapcar '(lambda(line / obzn naim dln count ret pt10 ed tmp Err tip GOST)
            (setq Ind (1+ Ind))
            
            ;(setq line (nth Ind table))
            (setq obzn (car line)
                  naim (cadr line)
                  )
            (setq tip (_get_Prokat_TIP obzn))
            (setq GOST (find-sortament-GOST tip obzn))
            (setq ret (_get_Prokat_ves obzn naim 1000 1))
           
            
            
            (setq klass (mip-conv-to-str
                              (car
                              (vl-remove-if 'null
                              (mapcar '(lambda(x)
                                   (if (wcmatch obzn (strcat "*" x "*"))
                                     x
                                     nil
                                     )
                                   )
                                arm
                                )
                                )
                              )
                              )
                            
                  )
            (if (setq tmp (assoc klass itog))
              (progn
                (setq ed (cdr tmp))
                (if (setq pt1 (assoc GOST ed))
                  (progn
                    (setq pt2 (cdr pt1))
                    (if (setq nab(assoc diam pt2))
                      (setq pt2
                             (subst (list (car nab)(+ (cadr nab)(cadr ret)))
                             (assoc diam pt2)
                             pt2)
                            )
                      
                      (setq pt2 (cons (list diam (cadr ret)) pt2))
                      )
                      (setq ed (subst (cons GOST pt2)
                                       (assoc GOST ed)
                                       ed
                                       )
                            )
                                       
                    )
                  (progn
                   (setq ed (cons (list GOST (list diam (cadr ret))) ed))
                    )
                  )
                (setq itog (subst (cons klass ed)
                                      (assoc klass itog)
                                      itog
                                      )
                          )
                
                )
              (setq itog (cons
                           (list klass (list GOST (list diam (cadr ret))))
                           itog)
                    )
              )



   )
         table
         )
 
 
      );_progn if nab
      (alert "?? ????????? ???-?? ?????? ? ????????!")
  )
)
 (if (null ACET-GEOM-TEXTBOX )(alert "?????????? ????????? Express Tools!"))
  )
(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))  
(princ)
)
|;


;;??????? ???????? ? ??????? ???? X ????????? ?? ? ??????? , ?? . 2 ??????? ?? 1 ??????
;;?????????? ??????? ????? ?? ???????
(defun _prepare_base ( lin / ch en->rus)
(setq en->rus '(("A" "?" )("B" "?")("E" "?")("T" "?")
                ("Y" "?")("O" "?")("P" "?")("H" "?")
                ("K" "?")("X" "?")("C" "?")("M" "?"))
      )
  (cond
     ((null lin) nil)
     ((listp lin) (mapcar '_prepare_base lin))
     ((= (type lin) 'STR)
      (setq ch (strcase(vl-string-translate ",xX??" ".????"
                                 (vl-string-trim  "%UuoO \t" lin))))
      ;;; ???????? ? ?????? ??? ??????? ??????? ?? ?????????
       (setq ch (dwgru-string-replace ch (strcat (chr 32) (chr 32))(chr 32)))
      ;;; ???????? ??? ????? ?? ????
      (setq ch (dwgru-string-replace ch ".." "."))
      ;;;???????? ?????????? ????? ?? ??????? (???????)
      (setq ch (apply 'strcat
                      (mapcar '(lambda (x / sym)
                                 (if (setq sym (assoc x en->rus))
                                   (cadr sym)
                                   x
                                   ) ;_ ????? if
                                 ) ;_ ????? lambda
                              (mapcar 'chr (vl-string->list ch))
                              ) ;_ ????? mapcar
                      ) ;_ ????? apply
            )
      )
     (t lin)
   )   
  )

;;;?????? ????
(defun _read-prokat-base ( / fil fl)
  (setq fil "prokat.ves" *PROKAT_VES_BASE* nil)
  (if (setq fl (findfile fil))
    (progn
      (setq fil (open fl "r"))
      (while (setq str (read-line fil))
        
        (setq str (vl-string-trim  "%UuoO??Cc \t" str))
        (cond ((vl-position (substr str 1 1) '(";" "")) nil)
              (t
               (setq *PROKAT_VES_BASE*  (cons (read str) *PROKAT_VES_BASE* ))
               )
        )
        )
      (close fil)
      (setq *PROKAT_VES_BASE* (mapcar '_prepare_base *PROKAT_VES_BASE*))
      )
    (alert (strcat "?????????? ????? ???? ????\n" fil))
    )
  )
(defun _get_sumT_Okr ( / okr )
  (or (setq okr *sumT_Okr*)
      (setq okr (getcfg "AppData/sumT/sumT_Okr"))
      (setq okr (getvar "LUPREC"))
      )
(if (= (type okr) 'STR)(setq okr (atoi okr)))
(setq *sumT_Okr* (if (numberp okr)(fix okr) 2))
  )
(defun _get_sumT_Ves1 ( / okr )
  (or (setq okr *sumT_Ves1*)
      (if (setq okr (getcfg "AppData/sumT/sumT_Ves1"))
        (setq okr (atoi okr))
        (setq okr 1)
        )
      )
  (= okr 1)
  )

(defun _get_sumT_TH ( / okr )
  (or (setq okr *sumT_TH*)
      (setq okr (getcfg "AppData/sumT/sumT_TH"))
      (setq okr (getvar "TEXTSIZE"))
      
      )
  (cond
    ((= okr "")(setq okr (getvar "TEXTSIZE")))
    ((= (type okr) 'STR)(setq okr (atof okr)))
    ((numberp okr) okr)
    (t (setq okr (getvar "TEXTSIZE")))
    )
  (cond ((zerop okr)(setq okr (getvar "TEXTSIZE")))
	((minusp okr)(setq okr '-1))
	(t nil)
	)
  (setq *sumT_TH*  okr)
  )
(defun _sumT_prep_Number ( str )
  (vl-string-translate "." (_get_sumT_sDecimal)(mip-conv-to-str str))
  )
;;;(vl-registry-read "HKEY_CURRENT_USER\\Control Panel\\International" "sDecimal")
(defun _get_sumT_sDecimal ( / okr )
  (or (setq okr *sumT_sDecimal*)
      (setq okr (getcfg "AppData/sumT/sumT_sDecimal"))
      (setq okr (vl-registry-read "HKEY_CURRENT_USER\\Control Panel\\International" "sDecimal"))
      )
  (if (= okr "")(setq okr (vl-registry-read "HKEY_CURRENT_USER\\Control Panel\\International" "sDecimal")))
  (if (not (member okr '("." ",")))(setq okr ","))
  (setq *sumT_sDecimal*  okr)
  )


(defun C:sumTSet ( / okr )
  (if (or (null (setq okr (getcfg "AppData/sumT/sumT_Okr")))
	  (= okr "")
	  )
    (setcfg "AppData/sumT/sumT_Okr" "2")
    ;(setq *sumT_Okr* (atoi okr))
    )
  (or *sumT_Okr*
  (setq *sumT_Okr* (atoi(getcfg "AppData/sumT/sumT_Okr")))
      )
  (setq okr *sumT_Okr*)
  (princ "\n?????????? ?????? ?????????? <")
  (princ okr)(princ " >:")
  (initget 4)
  (if (setq okr (getint))
    (setcfg "AppData/sumT/sumT_Okr" (itoa (setq *sumT_Okr* okr)))
    (setq okr *sumT_Okr*)
    )
;;=======================================
  (if (or (null (setq okr (getcfg "AppData/sumT/sumT_Ves1")))
	  (= okr "")
	  )
    (setcfg "AppData/sumT/sumT_Ves1" "1")
    ;(setq *sumT_Okr* (atoi okr))
    )
  (or *sumT_Ves1*
  (setq *sumT_Ves1* (atoi(getcfg "AppData/sumT/sumT_Ves1")))
      )
  (setq okr *sumT_Ves1*)
  (princ "\n????????? ??? ??????? ????? ????? ????? ??????? ?? ????????????? ?????? ??????????? [??/???]<")
  (princ (if (= okr 1) "??" "???"))(princ ">:")
  (initget "?? ??? Yes No _Yes No Yes No")
  (setq okr (getkword))
  (cond ((= okr "Yes")(setq okr 1))
        ((= okr "No")(setq okr 0))
        (t (setq okr *sumT_Ves1*))
        )
    (setcfg "AppData/sumT/sumT_Ves1" (itoa (setq *sumT_Ves1* okr)))
;;=======================================
  
    (if (or (null (setq okr (getcfg "AppData/sumT/sumT_TH")))
	  (= okr "")
	  )
    (setcfg "AppData/sumT/sumT_TH" "2")
    ;(setq *sumT_Okr* (atoi okr))
    )
  (or *sumT_TH*
  (setq *sumT_TH* (atoi(getcfg "AppData/sumT/sumT_TH")))
      )
  (setq okr *sumT_TH*)
  (cond ((zerop okr)(setq okr (strcat "???????-" (rtos (getvar "TEXTSIZE") 2 2))))
	((minusp okr)(setq okr "??? ? ?????????"))
	(t nil)
	)
  (princ "\n?????? ????? ??????? ??? [???????/??? ? ?????????] <")
  (princ okr)(princ " >:")
  (initget "? ? C S _C S C S")
  (setq okr (getint))
  (cond ((= okr "C")(setq okr "0"))
	((= okr "S")(setq okr "-1"))
	((numberp okr)(setq okr (rtos okr 2 4)))
	(t (setq okr "2"))
	)
  (setcfg "AppData/sumT/sumT_TH" okr)
  (setq *sumT_TH* (atof okr))
(setq okr (getcfg "AppData/sumT/sumT_sDecimal"))  
(initget "Point Comma System ????? ??????? ????????? _Point Comma System Point Comma System")
(princ "\n??????????? ????? ? ??????? ????? [?????/???????/?????????] <")
(princ (cond ((= okr ".") "?????")
             ((= okr ",") "???????")
             (t "?????????")
             )
       )
  (princ ">: ")
  (setq okr (getkword))
(cond
  ((= okr "Point")(setq okr "."))
  ((= okr "Comma")(setq okr ","))
  (t (setq okr ""))
  )
(setcfg "AppData/sumT/sumT_sDecimal" okr)
 (_get_sumT_sDecimal) 
  
  (princ)
  )
;;;(defun C:HYPD ( / sset hyptxt)(vl-load-com)  
;;;(setq hyptxt "")
;;;(princ "\n???????? ??????? ??? ???????? ???????????")  
;;;(if (setq sset (ssget "_:L"))
;;; (foreach item (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex sset)))) 
;;;   (mip-put-hyperlink item hyptxt)))(princ))
(princ "\n????????????: http:////dwg.ru//f//showthread.php?t=16987 ??????(????) #449")
(princ "\n???????? ? ????????? ??????")
(princ "\nSumTN - ???????????? ?????? ? ????? ?????")
(princ "\nSumTE - ???????????? ?????? ? ???????????? ?????")
(princ "\nMulTN - ????????? ?????? ? ????? ?????")
(princ "\nMulTE - ????????? ?????? ? ???????????? ?????")
(princ "\nTOKR  - ?????????? ??????")
(princ "\nMulTC - ???????????? ??????? ?????????")
(princ "\nMulTCv2 - ???????????? ??????? ????????? ??????? 2")
(princ "\nsumTSet - ????????? ?????????? ? ?????? ????? ???????")
(princ "\nGSUM - ??????? ????????? ????????????")
(princ "\nSPECKG - ??????? ???????????? (SPEC3 SPEC3D SPEC4 SPEC4D SPEC5 SPEC5D")
(princ "\nSPECW - ??????? ???????????? ?????????? ??????? (SPEC Wood")
(princ "\n_-HYPERLINK - ???????? ??????????? (????? _Remove)")


(princ)


;| ???????? ??????  ? ?????????? ?????
(defun rec-pat (str / rec-pat)
  (defun rec-pat (temp str pat n /)
    (cond ((= str "") (list temp))
   ((if (minusp n)
      (not (member (substr str 1 1) pat))
      (member (substr str 1 1) pat)
    ) ;_ end of if
    (if (/= temp "")
      (cons temp (rec-pat "" str pat (- n)))
      (rec-pat "" str pat (- n))
    ) ;_ end of if
   )
   (t
    (rec-pat (strcat temp (substr str 1 1))
      (substr str 2)
      pat
      n
    ) ;_ end of trim_gap
   )
    ) ;_ end of cond
  ) ;_ end of defun
  (rec-pat ""
    str
    '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9" ".")
    1
  ) ;_ end of rec-pat
) ;_ end of defun
|;

(defun _dwgru-get-spds-text-and-range (/ selset lst)
                                      ;|
*    ?????????? ?????? ????? ?????????? ???????. ? ????? ???????? ??????? ???????,
* ??????????? ???????, ?????? ? ???????????.
*    ????????? ??????:
	???
*    ??????? ??????:
(_dwgru-get-spds-text)
	;
|;
  (if
    (and
      (= (type (setq selset (vl-catch-all-apply
                              (function (lambda () (ssget)))
                              ) ;_ end of vl-catch-all-apply
                     ) ;_ end of setq
               ) ;_ end of type
         'pickset
         ) ;_ end of =
      (setq selset
             (vl-remove-if-not
               (function
                 (lambda (x)
                   (member (cdr (assoc 0 x))
                           '("spdsNotePosition"
                             ;"spdsNoteKnot"
                             "spdsNoteComb"
                             "spdsNoteChain"
                             )
                           ) ;_ end of member
                   ) ;_ end of lambda
                 ) ;_ end of function
               (mapcar
                 (function (lambda (a)
                             (vl-remove-if-not
                               '(lambda (b) (member (car b) '(0 300 301 90)))
                               (entget a)
                               ) ;_ end of vl-remove-if-not
                             ) ;_ end of lambda
                           ) ;_ end of function
                 (_dwgru-conv-pickset-to-list selset)
                 ) ;_ end of mapcar
               ) ;_ end of vl-remove-if-not
            ) ;_ end of setq
      ) ;_ end of and
     (setq
       lst
        (mapcar
          (function
            (lambda (item)
              (cond
                ((= (cdr (assoc 0 item)) "spdsNoteKnot")
                 (append (mapcar
                           (function cdr)
                           (vl-remove-if-not
                             (function
                               (lambda (x)
                                 (= (car x) 300)
                                 ) ;_ end of lambda
                               ) ;_ end of function
                             (reverse
                               (member '(301 . "???????????? ??????")
                                       (reverse (member '(301 . "????? ????") item))
                                       ) ;_ end of member
                               ) ;_ end of reverse
                             ) ;_ end of vl-remove-if-not
                           ) ;_ end of mapcar
                         (list 1)
                         ) ;_ end of append
                 )
                ((= (cdr (assoc 0 item)) "spdsNotePosition")
                 (append (mapcar
                           (function cdr)
                           (vl-remove-if-not
                             (function
                               (lambda (x)
                                 (= (car x) 300)
                                 ) ;_ end of lambda
                               ) ;_ end of function
                             (member '(301 . "?????? ??????") item)
                             ) ;_ end of vl-remove-if-not
                           ) ;_ end of mapcar
                         (list 1)
                         ) ;_ end of append
                 )
                ((member (cdr (assoc 0 item))
                         '("spdsNoteComb" "spdsNoteChain")
                         ) ;_ end of member
                 (append
                   (mapcar
                     (function cdr)
                     (vl-remove-if-not
                       (function
                         (lambda (x)
                           (= (car x) 300)
                           ) ;_ end of lambda
                         ) ;_ end of function
                       (reverse
                         (member '(301 . "???????????? ??????")
                                 (reverse (member '(301 . "?????? ??????") item))
                                 ) ;_ end of member
                         ) ;_ end of reverse
                       ) ;_ end of vl-remove-if-not
                     ) ;_ end of mapcar
                   (list (cdr (assoc 90 (reverse item))))
                   ) ;_ end of cons
                 )
                ) ;_ end of cond
              ) ;_ end of lambda
            ) ;_ end of function
          selset
          ) ;_ end of mapcar
       ) ;_ end of setq
     ) ;_ end of if
  lst
  ) ;_ end of defun


(defun CB-filtr (lst)
    (setq
      lst
       (vl-remove-if
         '(lambda (x)
            (or
              (not (equal (length x) 2))
              (member "" x)
              (not
                (wcmatch
                  (vl-string-translate "Tp" "??" (cadr x))
                  "????*,\\U+E72E*,?????*,??.*,????*,??????*,\\U+E720*,??????*,\\U+E725*,???????*,\\U+E729*,???????*,??????*,??.*,-*,%%c*,\\U+E712*,#%%c*,# %%c*,##%%c*,## %%c*,#\\U+E712*,# \\U+E712*,##\\U+E712*,## \\U+E712*,\\U+0547\\U+0580\\U+057?\\U+0561\\U+0576*,\\U+053d\\U+0578\\U+0572*,\\U+0578\\U+057d\\U+057a\\U+0561\\U+0571\\U+0587*"
                ) ;_ end of wcmatch
              ) ;_ end of not
              (not
                (or
                  (and
                    (wcmatch (car x) "@*")
                    (wcmatch (vl-string-right-trim "1234567890'\"" (car x))
                             "@"
                    ) ;_ end of wcmatch
                  ) ;_ end of and
                  (and (wcmatch (car x) "#*")
                       (wcmatch (vl-string-left-trim "1234567890" (car x))
                                ",@,@',@\",',\""
                       ) ;_ end of wcmatch
                  ) ;_ end of and
                ) ;_ end of or
              ) ;_ end of not
            ) ;_ end of or
          ) ;_ end of lambda
         lst
       ) ;_ end of vl-remove-if
    ) ;_ end of setq
    (setq lst
           ((lambda (lst / poz temp)
              (defun poz (str pat / p n)
                (while (setq n (vl-string-search pat str n))
                  (setq p (cons n p)
                        n (1+ n)
                  ) ;_ end of setq
                ) ;_ end of while
                p
              ) ;_ end of defun
              (while lst
                (setq
                  temp
                   (cons
                     ((lambda (lst-temp / n)
                        (list
                          (car lst-temp)
                          (vl-string-left-trim
                            "1234567890 "
                            (if (or
                                  (equal (length
                                           (setq n (poz (cadr lst-temp) ","))
                                         ) ;_ end of length
                                         2
                                  ) ;_ end of equal
                                  (not (wcmatch (cadr lst-temp) "*L=*"))
                                ) ;_ end of or
                              (substr (cadr lst-temp)
                                      1
                                      (if (wcmatch (cadr lst-temp) "*L=*")
                                        (car n)
                                        (car (reverse n))
                                      ) ;_ end of if
                              ) ;_ end of substr
                              (cadr lst-temp)
                            ) ;_ end of if
                          ) ;_ end of vl-string-left-trim
                        ) ;_ end of list
                      ) ;_ end of lambda
                       (car
                         (vl-sort
                           (vl-remove-if-not
                             '(lambda (x) (equal (caar lst) (car x)))
                             lst
                           ) ;_ end of vl-remove-if-not
                           '(lambda (str1 str2)
                              (>
                                (+ (length (poz (cadr str1) ","))
                                   (if (wcmatch (cadr str1) "*L=*")
                                     1
                                     0
                                   ) ;_ end of if
                                ) ;_ end of +
                                (+ (length (poz (cadr str2) ","))
                                   (if (wcmatch (cadr str2) "*L=*")
                                     1
                                     0
                                   ) ;_ end of if
                                ) ;_ end of +
                              ) ;_ end of >
                            ) ;_ end of lambda
                         ) ;_ end of vl-sort
                       ) ;_ end of car
                     )
                     temp
                   ) ;_ end of cons
                ) ;_ end of setq
                (setq lst
                       (vl-remove-if '(lambda (x) (equal (caar lst) (car x))) lst)
                ) ;_ end of setq
                (reverse temp)
              ) ;_ end of while
            ) ;_ end of lambda
             lst
           )
    ) ;_ end of setq
  ) ;_ end of defun


(setq lst (mapcar '(lambda (x)
                       (list (vl-string-trim " " (car x))
                             (vl-string-trim " " (cadr x))
                       ) ;_ end of list
                     ) ;_ end of lambda
;;;                    lst
 
                    (_dwgru-get-spds-text-and-range) ; из #472 
            ) ;_ end of mapcar
  ) ;_ end of setq
Дошел то этого места
Цитата:
5. Находим в ntt код
Код:

(setq lst (mapcar '(lambda (x)
(list (vl-string-trim " " (car x))
(vl-string-trim " " (cadr x))
) ;_ end of list
) ;_ end of lambda
;;; lst

(_dwgru-get-spds-text-and-range) ; из #472
) ;_ end of mapcar
) ;_ end of setq
выполняем его так же, как и в п.2 и смотрим результат в VLIDE (указываем в чертеже только те объекты, которые нам нужны для проверки)
После этого в AutoCAD-е предлагается что-то выбрать. Что именно нужно выбрать. Я думал что выноску, но при выборе не только армянской но и русской выноски у меня возвращается такой ответ
Цитата:
; error: bad argument type: (or stringp symbolp): 1
_$
__________________
Блог
Последний раз редактировалось Red Nova, 25.11.2008 в 15:35.
Red Nova вне форума  
 
Непрочитано 25.11.2008, 16:50
#145
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

>Red Nova

Я же тебе сказал ОТКРЫТЬ в VLIDE лисп, а не скопировать его из файла (посмотри что у тебя делается в лиспе - одни вопросы) , т.е. заходишь в VLIDE, нажимаешь кнопку Open file, находишь lsp-файл в котором у тебя находится функция _dwgru-get-spds-text-and-range, загружаем ее (см.п.2). Точно также открываем файл с функцией ntt.
Далее выполняешь п.5, выбираешь армянскую выноску и скриншот результата сюда - для того чтобы определиться с правильностью выбора шаблона для армянской выноски.
CB вне форума  
 
Автор темы   Непрочитано 25.11.2008, 18:56
#146
Red Nova

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

CB,
Вот что вернуло
Код:
[Выделить все] 
(("5" "\U+0539\U+056B\U+0569\U+0565\U+0572 \U+0577\U+0565\U+0572\U+0561\U+0576\U+056F\U+0575\U+0578\U+0582\U+0576 -10x100x1000") ("4" "\U+0539\U+056B\U+0569\U+0565\U+0572 \U+0578\U+057D\U+057A\U+0561\U+0571\U+0587 -10x100x1000") ("3" "\U+053D\U+0578\U+0572\U+0578\U+057E\U+0561\U+056F \U+E71250x3") ("2" "\U+053D\U+0578\U+0572. \U+E71250x3") ("1" "\U+0547\U+0580\U+057B\U+0561\U+0576 \U+E712500x10"))
То есть употребляятся следуящие армянские слова
Цитата:
\U+0539\U+056B\U+0569\U+0565\U+0572*,\U+053D\U+0578\U+0572*,\U+0547\U+0580\U+057B\U+0561\U+0576*
Правлю код ntt
Код:
[Выделить все] 
(defun c:ntt (/ CB-filtr lst LST-AS)    ;note to text
  (defun CB-filtr (lst)
    (setq
      lst
       (vl-remove-if
         '(lambda (x)
            (or
              (not (equal (length x) 2))
              (member "" x)
              (not
                (wcmatch
                  (vl-string-translate "Tp" "Тр" (cadr x))
                  "Болт*,\\U+E72E*,Труба*,Тр.*,Лист*,Полоса*,\\U+E720*,Уголок*,\\U+E725*,Швеллер*,\\U+E729*,Двутавр*,Фланец*,Фл.*,-*,%%c*,\\U+E712*,#%%c*,# %%c*,##%%c*,## %%c*,#\\U+E712*,# \\U+E712*,##\\U+E712*,## \\U+E712*,\U+0539\U+056B\U+0569\U+0565\U+0572*,\U+053D\U+0578\U+0572*,\U+0547\U+0580\U+057B\U+0561\U+0576*"
                ) ;_ end of wcmatch
              ) ;_ end of not
              (not
                (or
                  (and
                    (wcmatch (car x) "@*")
                    (wcmatch (vl-string-right-trim "1234567890'\"" (car x))
                             "@"
                    ) ;_ end of wcmatch
                  ) ;_ end of and
                  (and (wcmatch (car x) "#*")
                       (wcmatch (vl-string-left-trim "1234567890" (car x))
                                ",@,@',@\",',\""
                       ) ;_ end of wcmatch
                  ) ;_ end of and
                ) ;_ end of or
              ) ;_ end of not
            ) ;_ end of or
          ) ;_ end of lambda
         lst
       ) ;_ end of vl-remove-if
    ) ;_ end of setq
    (setq lst
           ((lambda (lst / poz temp)
              (defun poz (str pat / p n)
                (while (setq n (vl-string-search pat str n))
                  (setq p (cons n p)
                        n (1+ n)
                  ) ;_ end of setq
                ) ;_ end of while
                p
              ) ;_ end of defun
              (while lst
                (setq
                  temp
                   (cons
                     ((lambda (lst-temp / n)
                        (list
                          (car lst-temp)
                          (vl-string-left-trim
                            "1234567890 "
                            (if (or
                                  (equal (length
                                           (setq n (poz (cadr lst-temp) ","))
                                         ) ;_ end of length
                                         2
                                  ) ;_ end of equal
                                  (not (wcmatch (cadr lst-temp) "*L=*"))
                                ) ;_ end of or
                              (substr (cadr lst-temp)
                                      1
                                      (if (wcmatch (cadr lst-temp) "*L=*")
                                        (car n)
                                        (car (reverse n))
                                      ) ;_ end of if
                              ) ;_ end of substr
                              (cadr lst-temp)
                            ) ;_ end of if
                          ) ;_ end of vl-string-left-trim
                        ) ;_ end of list
                      ) ;_ end of lambda
                       (car
                         (vl-sort
                           (vl-remove-if-not
                             '(lambda (x) (equal (caar lst) (car x)))
                             lst
                           ) ;_ end of vl-remove-if-not
                           '(lambda (str1 str2)
                              (>
                                (+ (length (poz (cadr str1) ","))
                                   (if (wcmatch (cadr str1) "*L=*")
                                     1
                                     0
                                   ) ;_ end of if
                                ) ;_ end of +
                                (+ (length (poz (cadr str2) ","))
                                   (if (wcmatch (cadr str2) "*L=*")
                                     1
                                     0
                                   ) ;_ end of if
                                ) ;_ end of +
                              ) ;_ end of >
                            ) ;_ end of lambda
                         ) ;_ end of vl-sort
                       ) ;_ end of car
                     )
                     temp
                   ) ;_ end of cons
                ) ;_ end of setq
                (setq lst
                       (vl-remove-if '(lambda (x) (equal (caar lst) (car x))) lst)
                ) ;_ end of setq
                (reverse temp)
              ) ;_ end of while
            ) ;_ end of lambda
             lst
           )
    ) ;_ end of setq
  ) ;_ end of defun

  (setq lst (mapcar '(lambda (x)
                       (list (vl-string-trim " " (car x))
                             (vl-string-trim " " (cadr x))
                       ) ;_ end of list
                     ) ;_ end of lambda
;;;                    lst
		    
                    (_dwgru-get-spds-text-and-range) ; из #472 
            ) ;_ end of mapcar
  ) ;_ end of setq
  (setq lst (CB-filtr lst))
  (setq lst
         (mapcar
           '(lambda (x / p)
              (if (setq p (vl-string-position (ascii ",") (cadr x)))
                (list
                  (car x)
                  (substr (cadr x) 1 p)
                  (vl-string-left-trim " " (substr (cadr x) (+ 2 p)))
                ) ;_ end of list
                (if (wcmatch (cadr x) "-*,Лист*,Фл*")
                  (append x '("-"))
                  (append x '("L="))
                ) ;_ end of if
              ) ;_ end of if
            ) ;_ end of lambda
           lst
         ) ;_ end of mapcar
  ) ;_ end of setq
  (setq lst
         (mapcar
           '(lambda (x) (nth x lst))
           (vl-sort-i
             ((lambda (lst)
                (mapcar
                  '(lambda (str1 str2)
                     (if (wcmatch str2 "@*")
                       (strcat (substr str2 1 1) str1 (substr str2 2))
                       (strcat str1 str2)
                     ) ;_ end of if
                   ) ;_ end of lambda
                  (mapcar
                    '(lambda (x / str)
                       (setq str "0")
                       (repeat x
                         (setq str (strcat str "0"))
                       ) ;_ end of repeat
                       str
                     ) ;_ end of lambda
                    ((lambda (a)
                       (mapcar '(lambda (x) (- (apply 'max a) x)) a)
                     ) ;_ end of lambda
                      (mapcar
                        '(lambda (str)
                           (length
                             (vl-remove-if-not
                               '(lambda (x)
                                  (wcmatch x "#")
                                ) ;_ end of lambda
                               (mapcar 'chr (vl-string->list str))
                             ) ;_ end of vl-remove-if-not
                           ) ;_ end of length
                         ) ;_ end of lambda
                        lst
                      ) ;_ end of mapcar
                    )
                  ) ;_ end of mapcar
                  lst
                ) ;_ end of mapcar
              ) ;_ end of lambda
               (mapcar 'strcase (mapcar 'car lst))
             )
             '<
           ) ;_ end of vl-sort-i
         ) ;_ end of mapcar
  ) ;_ end of setq
  (setq LST-AS
         (apply
           'append
           (mapcar
             '(lambda (X Y)
                (mapcar
                  '(lambda (Z)
                     (cons Z Y)
                   ) ;_ end of lambda
                  X
                ) ;_ end of mapcar
              ) ;_ end of lambda
             (list (list "Лист -" "Лист-" "Фл" "\U+0547\U+0580\U+057B\U+0561\U+0576")
                   (list "Лист чечевица" "Лист ромб" "\U+0539\U+056B\U+0569\U+0565\U+0572 \U+0577\U+0565\U+0572\U+0561\U+0576\U+056F\U+0575\U+0578\U+0582\U+0576" "\U+0539\U+056B\U+0569\U+0565\U+0572 \U+0578\U+057D\U+057A\U+0561\U+0571\U+0587")
                   (list "-")
                   (list "Полоса")
                   (list "Уголок" "\\U+E720")
                   (list "\\U+E72E")
                   (list "Тр" "\U+053D\U+0578\U+0572." "\U+053D\U+0578\U+0572\U+0578\U+057E\U+0561\U+056F")
		   (list "Двутавр*#*#[БКШ]" "\\U+E729*#*#[БКШ]")
                   (list "Двутавр" "\\U+E729")
                   (list "Швеллер" "\\U+E725")
                   (list "%%c" "\\U+E712")
                   (list "Болт")
             ) ;_ end of list
             (list "ГОСТ 19903-74"
                   "ГОСТ 8568-77"
                   (list "ГОСТ 19903-74" "ГОСТ 103-76")
                   "ГОСТ 103-76"
                   (list "ГОСТ 8509-93" "ГОСТ 8510-86")
                   "ГОСТ 30245-03"
                   "ГОСТ 10704-91"
		   "СТО АСЧМ 20-93" 
                   "ГОСТ 8239-89"
                   "ГОСТ 8240-97"
                   "ГОСТ 5781-82"
                   "ГОСТ 7798-703"
             ) ;_ end of list
           ) ;_ end of mapcar
         ) ;_ end of apply
  ) ;_ end of setq LST-AS
  (setq lst
         (mapcar
           '(lambda (EL-LST / EL-AS)
              (setq EL-AS
                     (car
                       (vl-remove-if-not
                         '(lambda (STR)
                            (wcmatch (cadr EL-LST) (strcat (car STR) "*"))
                          ) ;_ end of lambda
                         LST-AS
                       ) ;_ end of vl-remove-if-not
                     ) ;_ end of car
              ) ;_ end of setq
              (cons
                (car EL-LST)
                (cons
                  (cond
                    ((equal (car EL-AS) "-")
                     (if (equal (caddr EL-LST) "-")
                       (cadr EL-AS)
                       (caddr EL-AS)
                     ) ;_ end of if
                    )
                    ((member (car EL-AS) '("Уголок" "\\U+E720"))
                     (if
                       ((lambda (STR)
                          (equal
                            (vl-string-position (ascii "x") STR)
                            (vl-string-position (ascii "x") STR nil t)
                          ) ;_ end of equal
                        ) ;_ end of lambda
                         (vl-string-translate "х" "x" (cadr EL-LST))
                       )
                        (cadr EL-AS)
                        (caddr EL-AS)
                     ) ;_ end of if
                    )
                    (t (cdr EL-AS))
                  ) ;_ end of cond
                  (cdr EL-LST)
                ) ;_ end of cons
              ) ;_ end of cons
            ) ;_ end of lambda
           lst
         ) ;_ end of mapcar
  ) ;_ end of setq
  ((lambda (/ b1 a1 a2 a3)
     (mapcar
       '(lambda (B A / b1 a1 a2 a3)
          ((lambda (dxf)
             (entmod
               (subst (cons 1 A)
                      (assoc 1 dxf)
                      dxf
               ) ;_ end of subst
             ) ;_ end of entmod
           ) ;_ end of lambda
            (entget B)
          )
        ) ;_ end of lambda
       (setq b1
              ((lambda (/ sset)
                 (princ "\nВыберите шаблон спецификации: ")
                 (if (setq sset (ssget '((0 . "*TEXT"))))
                   (vl-sort
                     (vl-sort
                       (vl-remove-if
                         (function listp)
                         (mapcar (function cadr)
                                 (ssnamex sset)
                         ) ;_ end of mapcar
                       ) ;_ end of vl-remove-if
                       '(lambda (a b)
                          (> (caddr (assoc '10 (entget a)))
                             (caddr (assoc '10 (entget b)))
                          ) ;_ on Y
                        ) ;_ end of lambda
                     ) ;_ end of vl-sort
                     '(lambda (a b)
                        (and
                          (equal (caddr (assoc '10 (entget a)))
                                 (caddr (assoc '10 (entget b)))
                                 1.
                          ) ;_ end of equal
                          (< (cadr (assoc '10 (entget a)))
                             (cadr (assoc '10 (entget b)))
                          ) ;_ end of <
                        ) ;_ end of and
                      ) ;_ end of lambda
                   ) ;_ end of vl-sort
                 ) ;_ end of if
               ) ;_ end of lambda
              )
       ) ;_ end of setq
       (progn
         (setq a1 (apply 'append lst)
               a1
                  (append
                    a1
                    (if (not (minusp (setq a2 (- (length b1) (length a1)))))
                      (append (repeat a2 (setq a3 (cons "XX" a3))))
                    ) ;_ end of if
                  ) ;_ end of append
         ) ;_ end of setq
       ) ;_ end of progn
     ) ;_ end of mapcar
   ) ;_ end of lambda
  )
(princ)
) ;_ end of defun ntt
Пробую
Код:
[Выделить все] 
Command: _ntt
Select objects: Specify opposite corner: 5 found

Select objects:

Выберите шаблон спецификации:
Select objects: Specify opposite corner: 20 found

Select objects:
; error: bad DXF group: (1)

Command:
__________________
Блог
Red Nova вне форума  
 
Непрочитано 25.11.2008, 21:21
#147
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

>Red Nova
Ты немного поспешил выполнять весь лисп...
Загрузить нужно не ntt, CB-filtr точно также как ты загружал до этого dwgru-get-spds-text-and-range (см.п.2).
Код:
[Выделить все] 
(defun c:ntt (/ CB-filtr lst LST-AS)    ;note to text
  (defun CB-filtr (lst)
  (setq
    lst
.........
После загрузки выполни - (setq lst (CB-filtr lst)) (естественно это делаешь только после выполнения #145 , чтобы у нас была определена переменная lst). Если результат будет nil, то значит шаблон сделан не правильно и не прошел через фильтр. Сделай это обязательно.
Но я думаю, что в шаблоне просто нужно ставить двойной cлэш -
Код:
[Выделить все] 
.....,##\\U+E712*,## \\U+E712*,\\U+0539\\U+056B\\U+0569\\U+0565\\U+0572*,\\U+053D\\U+0578\\U+0572*,\\U+0547\\U+0580\\U+057B\\U+0561\\U+0576*"
Только после того, как CB-filtr даст нужный результат делай изменения дальше - по п.8
Последний раз редактировалось CB, 25.11.2008 в 21:31.
CB вне форума  
 
Автор темы   Непрочитано 26.11.2008, 10:51
#148
Red Nova

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

Цитата:
После загрузки выполни - (setq lst (CB-filtr lst)) (естественно это делаешь только после выполнения #145 , чтобы у нас была определена переменная lst). Если результат будет nil, то значит шаблон сделан не правильно и не прошел через фильтр.
Выполняю, через фильтр проходит, но в окончательном коде не работает.
__________________
Блог
Red Nova вне форума  
 
Непрочитано 26.11.2008, 13:43
#149
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

Там где выделено красным добавь армянские символы, относящиеся к листу и фланцу...
Код:
[Выделить все] 
(defun C:ntt (/ CB-filtr lst LST-AS)    ;note to text
  (defun CB-filtr (lst)
    (setq
      lst
       (vl-remove-if
         '(lambda (x)
            (or
              (not (equal (length x) 2))
              (member "" x)
              (not
                (wcmatch
                  (vl-string-translate "Tp" "Тр" (cadr x))
                  "Болт*,\\U+E72E*,Труба*,Тр.*,Лист*,Полоса*,\\U+E720*,Уголок*,\\U+E725*,Швеллер*,\\U+E729*,Двутавр*,Фланец*,Фл.*,-*,%%c*,\\U+E712*,#%%c*,# %%c*,##%%c*,## %%c*,#\\U+E712*,# \\U+E712*,##\\U+E712*,## \\U+E712*,\\U+0539\\U+056B\\U+0569\\U+0565\\U+0572*,\\U+053D\\U+0578\\U+0572*,\\U+0547\\U+0580\\U+057B\\U+0561\\U+0576*"
                ) ;_ end of wcmatch
              ) ;_ end of not
              (not
                (or
                  (and
                    (wcmatch (car x) "@*")
                    (wcmatch (vl-string-right-trim "1234567890'\"" (car x))
                             "@"
                    ) ;_ end of wcmatch
                  ) ;_ end of and
                  (and (wcmatch (car x) "#*")
                       (wcmatch (vl-string-left-trim "1234567890" (car x))
                                ",@,@',@\",',\""
                       ) ;_ end of wcmatch
                  ) ;_ end of and
                ) ;_ end of or
              ) ;_ end of not
            ) ;_ end of or
          ) ;_ end of lambda
         lst
       ) ;_ end of vl-remove-if
    ) ;_ end of setq
    (setq lst
           ((lambda (lst / poz temp)
              (defun poz (str pat / p n)
                (while (setq n (vl-string-search pat str n))
                  (setq p (cons n p)
                        n (1+ n)
                  ) ;_ end of setq
                ) ;_ end of while
                p
              ) ;_ end of defun
              (while lst
                (setq
                  temp
                   (cons
                     ((lambda (lst-temp / n)
                        (list
                          (car lst-temp)
                          (vl-string-left-trim
                            "1234567890 "
                            (if (or
                                  (equal (length
                                           (setq n (poz (cadr lst-temp) ","))
                                         ) ;_ end of length
                                         2
                                  ) ;_ end of equal
                                  (not (wcmatch (cadr lst-temp) "*L=*"))
                                ) ;_ end of or
                              (substr (cadr lst-temp)
                                      1
                                      (if (wcmatch (cadr lst-temp) "*L=*")
                                        (car n)
                                        (car (reverse n))
                                      ) ;_ end of if
                              ) ;_ end of substr
                              (cadr lst-temp)
                            ) ;_ end of if
                          ) ;_ end of vl-string-left-trim
                        ) ;_ end of list
                      ) ;_ end of lambda
                       (car
                         (vl-sort
                           (vl-remove-if-not
                             '(lambda (x) (equal (caar lst) (car x)))
                             lst
                           ) ;_ end of vl-remove-if-not
                           '(lambda (str1 str2)
                              (>
                                (+ (length (poz (cadr str1) ","))
                                   (if (wcmatch (cadr str1) "*L=*")
                                     1
                                     0
                                   ) ;_ end of if
                                ) ;_ end of +
                                (+ (length (poz (cadr str2) ","))
                                   (if (wcmatch (cadr str2) "*L=*")
                                     1
                                     0
                                   ) ;_ end of if
                                ) ;_ end of +
                              ) ;_ end of >
                            ) ;_ end of lambda
                         ) ;_ end of vl-sort
                       ) ;_ end of car
                     )
                     temp
                   ) ;_ end of cons
                ) ;_ end of setq
                (setq lst
                       (vl-remove-if '(lambda (x) (equal (caar lst) (car x))) lst)
                ) ;_ end of setq
                (reverse temp)
              ) ;_ end of while
            ) ;_ end of lambda
             lst
           )
    ) ;_ end of setq
  ) ;_ end of defun
  (setq lst (mapcar '(lambda (x)
                       (list (vl-string-trim " " (car x))
                             (vl-string-trim " " (cadr x))
                       ) ;_ end of list
                     ) ;_ end of lambda
;;;                    lst
                    (_dwgru-get-spds-text-and-range) ; из #472 
            ) ;_ end of mapcar
  ) ;_ end of setq
  (setq lst (CB-filtr lst))
  (setq lst
         (mapcar
           '(lambda (x / p)
              (if (setq p (vl-string-position (ascii ",") (cadr x)))
                (list
                  (car x)
                  (substr (cadr x) 1 p)
                  (vl-string-left-trim " " (substr (cadr x) (+ 2 p)))
                ) ;_ end of list
                (if (wcmatch (cadr x) "-*,Лист*,Фл*,")
                  (append x '("-"))
                  (append x '("L="))
                ) ;_ end of if
              ) ;_ end of if
            ) ;_ end of lambda
           lst
         ) ;_ end of mapcar
  ) ;_ end of setq
  (setq lst
         (mapcar
           '(lambda (x) (nth x lst))
           (vl-sort-i
             ((lambda (lst)
                (mapcar
                  '(lambda (str1 str2)
                     (if (wcmatch str2 "@*")
                       (strcat (substr str2 1 1) str1 (substr str2 2))
                       (strcat str1 str2)
                     ) ;_ end of if
                   ) ;_ end of lambda
                  (mapcar
                    '(lambda (x / str)
                       (setq str "0")
                       (repeat x
                         (setq str (strcat str "0"))
                       ) ;_ end of repeat
                       str
                     ) ;_ end of lambda
                    ((lambda (a)
                       (mapcar '(lambda (x) (- (apply 'max a) x)) a)
                     ) ;_ end of lambda
                      (mapcar
                        '(lambda (str)
                           (length
                             (vl-remove-if-not
                               '(lambda (x)
                                  (wcmatch x "#")
                                ) ;_ end of lambda
                               (mapcar 'chr (vl-string->list str))
                             ) ;_ end of vl-remove-if-not
                           ) ;_ end of length
                         ) ;_ end of lambda
                        lst
                      ) ;_ end of mapcar
                    )
                  ) ;_ end of mapcar
                  lst
                ) ;_ end of mapcar
              ) ;_ end of lambda
               (mapcar 'strcase (mapcar 'car lst))
             )
             '<
           ) ;_ end of vl-sort-i
         ) ;_ end of mapcar
  ) ;_ end of setq
  (setq LST-AS
         (apply
           'append
           (mapcar
             '(lambda (X Y)
                (mapcar
                  '(lambda (Z)
                     (cons Z Y)
                   ) ;_ end of lambda
                  X
                ) ;_ end of mapcar
              ) ;_ end of lambda
             (list (list "Лист -" "Лист-" "Фл" "\\U+0547\\U+0580\\U+057B\\U+0561\\U+0576")
                   (list "Лист чечевица" "Лист ромб" "\\U+0539\\U+056B\\U+0569\\U+0565\\U+0572 \\U+0577\\U+0565\\U+0572\\U+0561\\U+0576\\U+056F\\U+0575\\U+0578\\U+0582\\U+0576" "\\U+0539\\U+056B\\U+0569\\U+0565\\U+0572 \\U+0578\\U+057D\\U+057A\\U+0561\\U+0571\\U+0587")
                   (list "-")
                   (list "Полоса")
                   (list "Уголок" "\\U+E720")
                   (list "\\U+E72E")
                   (list "Тр" "\\U+053D\\U+0578\\U+0572." "\\U+053D\\U+0578\\U+0572\\U+0578\\U+057E\\U+0561\\U+056F")
     (list "Двутавр*#*#[БКШ]" "\\U+E729*#*#[БКШ]")
                   (list "Двутавр" "\\U+E729")
                   (list "Швеллер" "\\U+E725")
                   (list "%%c" "\\U+E712")
                   (list "Болт")
             ) ;_ end of list
             (list "ГОСТ 19903-74"
                   "ГОСТ 8568-77"
                   (list "ГОСТ 19903-74" "ГОСТ 103-76")
                   "ГОСТ 103-76"
                   (list "ГОСТ 8509-93" "ГОСТ 8510-86")
                   "ГОСТ 30245-03"
                   "ГОСТ 10704-91"
     "СТО АСЧМ 20-93" 
                   "ГОСТ 8239-89"
                   "ГОСТ 8240-97"
                   "ГОСТ 5781-82"
                   "ГОСТ 7798-703"
             ) ;_ end of list
           ) ;_ end of mapcar
         ) ;_ end of apply
  ) ;_ end of setq LST-AS
  (setq lst
         (mapcar
           '(lambda (EL-LST / EL-AS)
              (setq EL-AS
                     (car
                       (vl-remove-if-not
                         '(lambda (STR)
                            (wcmatch (cadr EL-LST) (strcat (car STR) "*"))
                          ) ;_ end of lambda
                         LST-AS
                       ) ;_ end of vl-remove-if-not
                     ) ;_ end of car
              ) ;_ end of setq
              (cons
                (car EL-LST)
                (cons
                  (cond
                    ((equal (car EL-AS) "-")
                     (if (equal (caddr EL-LST) "-")
                       (cadr EL-AS)
                       (caddr EL-AS)
                     ) ;_ end of if
                    )
                    ((member (car EL-AS) '("Уголок" "\\U+E720"))
                     (if
                       ((lambda (STR)
                          (equal
                            (vl-string-position (ascii "x") STR)
                            (vl-string-position (ascii "x") STR nil t)
                          ) ;_ end of equal
                        ) ;_ end of lambda
                         (vl-string-translate "х" "x" (cadr EL-LST))
                       )
                        (cadr EL-AS)
                        (caddr EL-AS)
                     ) ;_ end of if
                    )
                    (t (cdr EL-AS))
                  ) ;_ end of cond
                  (cdr EL-LST)
                ) ;_ end of cons
              ) ;_ end of cons
            ) ;_ end of lambda
           lst
         ) ;_ end of mapcar
  ) ;_ end of setq
  ((lambda (/ b1 a1 a2 a3)
     (mapcar
       '(lambda (B A / b1 a1 a2 a3)
          ((lambda (dxf)
             (entmod
               (subst (cons 1 A)
                      (assoc 1 dxf)
                      dxf
               ) ;_ end of subst
             ) ;_ end of entmod
           ) ;_ end of lambda
            (entget B)
          )
        ) ;_ end of lambda
       (setq b1
              ((lambda (/ sset)
                 (princ "\nВыберите шаблон спецификации: ")
                 (if (setq sset (ssget '((0 . "*TEXT"))))
                   (vl-sort
                     (vl-sort
                       (vl-remove-if
                         (function listp)
                         (mapcar (function cadr)
                                 (ssnamex sset)
                         ) ;_ end of mapcar
                       ) ;_ end of vl-remove-if
                       '(lambda (a b)
                          (> (caddr (assoc '10 (entget a)))
                             (caddr (assoc '10 (entget b)))
                          ) ;_ on Y
                        ) ;_ end of lambda
                     ) ;_ end of vl-sort
                     '(lambda (a b)
                        (and
                          (equal (caddr (assoc '10 (entget a)))
                                 (caddr (assoc '10 (entget b)))
                                 1.
                          ) ;_ end of equal
                          (< (cadr (assoc '10 (entget a)))
                             (cadr (assoc '10 (entget b)))
                          ) ;_ end of <
                        ) ;_ end of and
                      ) ;_ end of lambda
                   ) ;_ end of vl-sort
                 ) ;_ end of if
               ) ;_ end of lambda
              )
       ) ;_ end of setq
       (progn
         (setq a1 (apply 'append lst)
               a1
                  (append
                    a1
                    (if (not (minusp (setq a2 (- (length b1) (length a1)))))
                      (append (repeat a2 (setq a3 (cons "XX" a3))))
                    ) ;_ end of if
                  ) ;_ end of append
         ) ;_ end of setq
       ) ;_ end of progn
     ) ;_ end of mapcar
   ) ;_ end of lambda
  )
(princ)
) ;_ end of defun ntt
CB вне форума  
 
Непрочитано 26.11.2008, 14:36
#150
ShaggyDoc

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

А не смущает, что условия поиска чрезвычайно ненадежны в принципе?

Символы шрифта с кодами E720, E725 и т.п. обозначающие "уголок", "швеллер" и т.д. привязаны к частному шрифту. Видимо, CS_GOST или его собратьям.
В этих шрифтах на такие позиции нарисовали уголки и прочий прокат. Но это же совсем не соответствует стандартам Unicode.

Там для каждых групп символов (английский, армянский, кириллица, математика, пунктуация и т.п.) отводятся определенные диапазоны адресов. 0E00—0E7F относятся к "тайскому письму". Обидятся тайцы-то.

Возьмут, и в армянский диапазон какие-нибудь свои "бамбуки" воткнут. Ладно, их обиду переживем. Но ведь в любом другом шрифте "уголки" и "швеллера" могут оказаться на другом месте. И код уголка может оказаться, например, где-нибудь в диапазоне 2300—23FF, там где и должны находиться "разнообразные технические символы".

Вечно будете программу переделывать. А можно сразу правильно.
ShaggyDoc вне форума  
 
Непрочитано 26.11.2008, 15:34
#151
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321

А как правильно?
CB вне форума  
 
Автор темы   Непрочитано 26.11.2008, 16:40
#152
Red Nova

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

CB, Заработало. Спасибо.

ShaggyDoc,
Для тех кто пользуется обычными шрифтами в лиспе есть возможность записи профилей по имени, например "Уголок 75x5"
__________________
Блог
Red Nova вне форума  
 
Непрочитано 26.11.2008, 20:07
#153
ShaggyDoc

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

В ТЗ верху страницы было множество "должны". Потом, по ходу разборок, появилось множество уточнений. И это всего лишь по поводу таких простейших описаний, как прокат. Типа Уголок 75х5. Теперь уже "есть возможность" появляется.

Но, даже здесь могут быть варианты. Кто-то сделает опечатку, кто-то напишет "х" русским символом, кто-то английским. Кто-то сделает несколько выносок, указывающих на одну и ту же конструкцию, а кто-то ни одной. Простейшее действие обрастает таким множеством формльных требований, что гораздо проще и надежнее будет выполнить спецификацию вручную.

А если вообще надо только позиции указывать? А если надписи будут в иных случаях, более длинные, с еще большим количеством вариантов для ошибок?

А как правильно? Да в разных вариантах, но не так. Я уже писал в #128.

Здесь надо разделить хранение данных, маркировку, подсчет количеств и оформление.

Данные надо хранить в базе данных. Она может быть и "настоящей", а может быть и простой. Даже такой - в виде файлов в подкаталогах. Каждый файлик - описание изделия, в простейшем виде строка. Но ведь для спецификаций нужно, как минимум, несколько параметров - наименование, обозначение (ГОСТ, ТУ), масса и т.п. А может быть и клиент-серверная.

При маркировке производится визуальный выбор из БД. Чего угодно. Сама маркировка может и выноской делаться. Здесь можно и наименование из БД взять (уже автоматически), а можно и позицию номером поставить. А можно и просто на изображение изделия ткнуть.

Секрет в том, что к этой видимой марке надо привязать невидимые для пользователя данные. В виде xdata, например. Но там всего лишь ссылка на базу данных (запись), а не сами данные.

В момент подсчета количеств анализируются не тексты надписей, а ссылки на БД. Там-то уже ошибок нет. А в момент оформления нужные надписи извлекаются из БД и вписываются в любое место в любой необходимой форме. На любом языке.

Вот такая программа становится пригодна для специфицирования чего угодно.
ShaggyDoc вне форума  
 
Непрочитано 26.11.2008, 22:38
#154
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 36,746

Все, что говорит ShaggyDoc, верно. Одно "но": объекты СПДС такому "насилию" вряд ли поддадутся. Лично мне, например, не удалось программно создать объекты выноски, модифицировать его, да еще и "погасить"* или заранее вбить в выноску нужные данные. Ведь заранее неизвестны ни точка вставки, ни радиус (а то и форма) "оконечника" стрелки, ни точ