[Shaft]

Доброго времени суток уважаемые знатоки!

У меня такая ситуация:

- есть группа отрезков/полилиний различной длины, нарисованые стык в стык (что это за линии долго объяснять, да и вряд ли это нужно, для написания кода. Поэтому я этот пункт опущу) паралельно горизонту.

- есть изогнутая полилиния (см. чертеж)

Задача как бы наложить эти отрезки на полилинию (более подробно см. чертеж)

Ps Может кто-то сталкивался с подобной задачей?

[Anisimov]

Возможно, предложение не из той оперы, но очень похоже на ось пути и продольный профиль. (Alignment, Profile). Ось пути представляет собой плановое положение, продольный профиль - высотное. Когда одно с другим совмещается, получается 3D-модель.
Подобный функционал есть в Civil 3D.

[Shaft]

Спасибо за совет НО:
у меня блин просто физический пока нет времени даже на установку Civil'a пока что удалось только скачать демо-версию. А так как демка фукцианирует лишь ограниченное время, то и ставить я ее планирую только когда будет достаточно времени для ее всестороннего изучения, а пока увы!
Ps Если есть возможность, выполните пожалуйста выше описаные вами действия и выложите для ознакомления. Чтобы можно было в обычном автокаде открыть и посмотреть, действительно ли это то, что нужно!
Ps Заранее благодарю!

[Anisimov]

В обычном автокаде не откроется.
Civil оперирует своим объектами.

[Shaft]

Сообщение от Anisimov В обычном автокаде не откроется. Civil оперирует своим объектами.

А DWGTrueView сможет открыть?

Ps А можешь набросать краткий порядок действий в Civil'e (если это возможно) что надо нажать.
Или перечисли хотя бы названия команд, а я уже все остальное в справке прочту.

[Do$]

В качестве первого приближения к рабочей программе:

Код:

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

(defun c:test (/
           _dwgru-conv-pickset-to-list
           vector-collinear-and-direction-check
           line_lst
           beg_pt
           end_pt
           pline
           pline_beg_pt
           pline_end_pt
           prp_lst
           obj_pline
           beg_dst
           mat_sym
           prm_grn
           pnt_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
 
  (defun vector-collinear-and-direction-check (vect1 vect2 prec / lst)
    (setq
      lst
       (vl-remove-if
     'not
     (mapcar
       '(lambda (c1 c2)
          (if (not (and (equal c1 c2 prec) (equal c2 0.0 prec)))
        (/ c1 c2)
        (if (not (equal c1 c2 prec))
          1.0e+072
        ) ;_ end of if
          ) ;_ end of if
        ) ;_ end of lambda
       vect1
       vect2
     ) ;_ end of mapcar
       ) ;_ end of vl-remove-if
    ) ;_ end of setq
    (vl-every 'boundp
          (mapcar '(lambda (a b) (equal a b prec))
              (reverse (cdr (reverse lst)))
              (cdr lst)
          ) ;_ end of mapcar
    ) ;_ end of vl-every
  ) ;_ end of defun
 
  (vl-load-com)
  (if
    (and
      (listp
    (setq
      line_lst (vl-catch-all-apply
             '(lambda ()
            (prompt "\nВыберите разноцветные отрезки:")
            (_dwgru-conv-pickset-to-list
              (setq ss (ssget "_:L" '((0 . "LINE"))))
            ) ;_ end of dwgru-conv-pickset-to-list
              ) ;_ end of lambda
           ) ;_ end of vl-catch-all-apply
    ) ;_ end of setq
      ) ;_ end of listp
      (setq
    beg_pt (vl-catch-all-apply
         '(lambda ()
            (initget 1)
            (getpoint "\nУкажите начало разноцветной линии:")
          ) ;_ end of lambda
           ) ;_ end of vl-catch-all-apply
      ) ;_ end of setq
      (not (vl-catch-all-error-p beg_pt))
      (setq
    end_pt
     (vl-catch-all-apply
       '(lambda ()
          (initget 1)
          (getpoint beg_pt "\nУкажите конец разноцветной линии:")
        ) ;_ end of lambda
     ) ;_ end of vl-catch-all-apply
      ) ;_ end of setq
      (not (vl-catch-all-error-p end_pt))
      (setq
    pline (vl-catch-all-apply
        '(lambda ()
           (prompt "\nУкажите полилинию:")
           (car    (_dwgru-conv-pickset-to-list
              (setq    ss1 (ssget "_:L:S" '((0 . "LWPOLYLINE")))
              ) ;_ end of _dwgru-conv-pickset-to-list
            ) ;_ end of setq
           ) ;_ end of car
         ) ;_ end of lambda
          ) ;_ end of vl-catch-all-apply
      ) ;_ end of setq
      (not (vl-catch-all-error-p pline))
      (setq pline_beg_pt
         (vl-catch-all-apply
           '(lambda    ()
          (initget 1)
          (getpoint "\nУкажите начальную точку на полилинии:")
        ) ;_ end of lambda
         ) ;_ end of vl-catch-all-apply
      ) ;_ end of setq
      (not (vl-catch-all-error-p pline_beg_pt))
      (setq pline_end_pt
         (vl-catch-all-apply
           '(lambda    ()
          (initget 1)
          (getpoint
            pline_beg_pt
            "\nУкажите вторую точку на полилинии, определяющую направление в котором расположатся отрезки:"
          ) ;_ end of getpoint
        ) ;_ end of lambda
         ) ;_ end of vl-catch-all-apply
      ) ;_ end of setq
      (not (vl-catch-all-error-p pline_end_pt))
      (not
    (vl-catch-all-error-p
      (vl-catch-all-apply
        '(lambda (/ dir_vec)
           (setq dir_vec (mapcar '- end_pt beg_pt))
           (foreach    line (mapcar 'entget line_lst)
         (if (not
               (vector-collinear-and-direction-check
             dir_vec
             (mapcar '-
                 (cdr (assoc 11 line))
                 (cdr (assoc 10 line))
             ) ;_ end of mapcar
             1.0e-006
               ) ;_ end of vector-collinear-and-direction-check
             ) ;_ end of not
           (entmod (list (assoc -1 line)
                 (cons 10 (cdr (assoc 11 line)))
                 (cons 11 (cdr (assoc 10 line)))
               ) ;_ end of list
           ) ;_ end of entmod
         ) ;_ end of if
           ) ;_ end of foreach
           (setq line_lst      (vl-sort
                    line_lst
                    '(lambda (l1 l2)
                       (vector-collinear-and-direction-check
                     dir_vec
                     (apply
                       '(lambda (a b) (mapcar '- a b))
                       (mapcar '(lambda (l)
                              (cdr (assoc 10 (entget l)))
                            ) ;_ end of lambda
                           (list l2 l1)
                       ) ;_ end of mapcar
                     ) ;_ end of apply
                     1.0e-006
                       ) ;_ end of vector-collinear-and-direction-check
                     ) ;_ end of lambda
                  ) ;_ end of vl-sort
             prp_lst      (mapcar
                    '(lambda (el)
                       (list
                     (apply
                       'distance
                       (mapcar
                         '(lambda (c) (cdr (assoc c el)))
                         '(10 11)
                       ) ;_ end of mapcar
                     ) ;_ end of apply
                     (assoc 8 el)
                     (assoc 62 el)
                       ) ;_ end of list
                     ) ;_ end of lambda
                    (mapcar 'entget line_lst)
                  ) ;_ end of mapcar
             obj_pline      (vlax-ename->vla-object pline)
             beg_dst      (vlax-curve-getDistAtPoint
                    obj_pline
                    (trans pline_beg_pt 1 0)
                  ) ;_ end of vlax-curve-getDistAtPoint
             pline_beg_pt (trans pline_beg_pt 0 pline)
             mat_sym      (if
                    (apply
                      '>
                      (mapcar
                    '(lambda (pt)
                       (vlax-curve-getDistAtPoint
                         obj_pline
                         pt
                       ) ;_ end of vlax-curve-getDistAtPoint
                     ) ;_ end of lambda
                    (list pline_end_pt pline_beg_pt)
                      ) ;_ end of mapcar
                    ) ;_ end of apply
                     +
                     -
                  ) ;_ end of if
           ) ;_ end of setq
         ) ;_ end of lambda
      ) ;_ end of vl-catch-all-apply
    ) ;_ end of vl-catch-all-error-p
      ) ;_ end of not
    ) ;_ end of and
 
     (progn
       (vla-StartUndoMark
     (vla-get-ActiveDocument (vlax-get-acad-object))
       ) ;_ end of vla-StartUndoMark
       (foreach    prp prp_lst
     (setq end_dst (mat_sym beg_dst (car prp)))
     (setq pline_end_pt
        (trans (vlax-curve-getPointAtDist obj_pline end_dst)
               0
               pline
        ) ;_ end of trans
     ) ;_ end of setq
     (if
       (apply
         '=
         (setq prm_grn (mapcar '(lambda (pt)
                      (fix
                    (vlax-curve-getParamAtPoint
                      obj_pline
                      (trans pt pline 0)
                    ) ;_ end of vlax-curve-getParamAtPoint
                      ) ;_ end of fix
                    ) ;_ end of lambda
                   (list pline_beg_pt pline_end_pt)
               ) ;_ end of mapcar
         ) ;_ end of setq
       ) ;_ end of apply
        (setq pnt_lst (list pline_beg_pt pline_end_pt))
        ((lambda (/ tmp tmp_lst prm_lst)
           (setq tmp (mat_sym (car prm_grn) 1))
           (while (/= tmp (last prm_grn))
         (setq tmp_lst (cons tmp tmp_lst)
               tmp     (mat_sym tmp 1)
         ) ;_ end of setq
           ) ;_ end of while
           (setq prm_lst (if (eq mat_sym +)
                   (reverse
                 (cons (last prm_grn) tmp_lst)
                   ) ;_ end of reverse
                   (cons (car prm_grn) (reverse tmp_lst))
                 ) ;_ end of if
             pnt_lst (append
                   (list pline_beg_pt)
                   (mapcar
                 '(lambda (prm)
                    (trans (vlax-curve-getPointAtParam
                         obj_pline
                         prm
                       ) ;_ end of vlax-curve-getPointAtParam
                       0
                       pline
                    ) ;_ end of trans
                  ) ;_ end of lambda
                 prm_lst
                   ) ;_ end of mapcar
                   (list pline_end_pt)
                 ) ;_ end of append
           ) ;_ end of setq
         ) ;_ end of lambda
        )
     ) ;_ end of if
     (entmakex
       (append
         '((0 . "LWPOLYLINE")
           (100 . "AcDbEntity")
           (100 . "AcDbPolyline")
          )
         (vl-remove-if 'null (cdr prp))
         (list (cons 90 (length pnt_lst)) '(70 . 0))
         (mapcar '(lambda (pt) (cons 10 pt)) pnt_lst)
         (list (assoc 210 (entget pline)))
       ) ;_ end of append
     ) ;_ end of entmakex
     (setq pline_beg_pt (vl-symbol-value 'pline_end_pt)
           beg_dst        (vl-symbol-value 'end_dst)
     ) ;_ end of setq
       ) ;_ end of foreach
       (vla-EndUndoMark
     (vla-get-ActiveDocument (vlax-get-acad-object))
       ) ;_ end of vla-EndUndoMark
     ) ;_ end of progn
     (alert "Что-то делаете неправильно!")
  ) ;_ end of if
  (princ)
) ;_ end of defun

Проверял только на представленном чертеже.

[Shaft]

Сообщение от Do$ Проверял только на представленном чертеже.

Do$ - вы просто ГЕНИЙ!!!!
Ваш Lisp работает шикарно!!!!!!!!!!!!!
Ох если бы вы могли представить!!! Как сильно вы облегчили мою монотоную-ю-ю работу!

Я даже принялся за изучение Lispa (наивно полагая что смогу найти решение в ближайшее время )

Но увидев то количество кода, который написали ВЫ!!!!!! Я понял что решение мне бы удалось найти только в будущем году!!!!!!!!!! Не раньше!!!!
И то это в лучшем случае!

Но все же изучение Lispa я бросать даже не собираюсь! Напротив я хочу разобрать ваш код по "атомам" и разобраться что к чему.

Еще раз искренне Вас благодарю!!!!!!! И низкий поклон в знак глубочайшего уважения за ваш труд!!!!!!!!

[Sleekka]

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

[zamtmn]

Offtop: Sleekka
Видимо графа "род деятельности" у вас заполнена исключительно правильно. На то он и форум чтоб помогать, а не впаривать

[Shaft]

Сообщение от zamtmn На то он и форум чтоб помогать, а не впаривать

АБСОЛЮТНО С ВАМИ СОГЛАСЕН!!!

[Do$]

Offtop:

Сообщение от Sleekka offtop продолжают выкладывать ценный код забесплатно.

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

Сообщение от Sleekka Неужели нету никого у вас на работе, кому вы сможете помочь и выслушать - "ты гений".

Помогаю, благодарят (Коллеги, а начальству пофиг, с помощью программы сделана работа или без программы.). Но моя основная деятельность - это проектирование, за это мне и платят. А LISP - это полезное хобби.
Shaft, на здоровье, успехов! Offtop: С тебя 5 баксов

[Sleekka]

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

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

помогаю, благодарят (Коллеги, а начальству пофиг, с помощью программы сделана работа или без программы.). Но моя основная деятельность - это проектирование, за это мне и платят.

это печально, когда человек делает работу за которую ему не платят. Я сам этот путь прошел, но я к счастью бесплатно ничего не делал, чего и вам желаю - любое начальство можно убедить, а такого количества халявы как на dwg нинайдешь ни на каком программерском форуме. Я еще понимаю выкладывать, то что есть но делать это по просьбе кого-то, кто сам еще ни строчки не чирканул - ИМХО вредно для развития общества.

Сообщение от zamtmn На то он и форум чтоб помогать, а не впаривать АБСОЛЮТНО С ВАМИ СОГЛАСЕН!!!

А вы-то собственно кому сами-то помогли, чтобы иметь право соглашаться? может дадите ссылочку?

[Кулик Алексей aka kpblc]

Брек!

[Shaft]

Сообщение от Do$ С тебя 5 баксов

Не вопрос!!!!!!!
Говори куда перевести денежку!!!

А вы-то собственно кому сами-то помогли, чтобы иметь право соглашаться? может дадите ссылочку?

Пока ни кому (на этом форуме). Но регулярно читаю "Сообщения за день" Правда задаваемые вопросы пока находятся за пределами моих знаний и опыта .
Ps Я всего 1 год работаю инженером. Пришел сразу после учебы. И благодаря этому форуму и всем его участникам, я уже стал самым знающим (в своем отделе) по вопросам связанным с автокадом!!!

Если кому нужно, то вот решение любезно предоставленное пользователемDo$. За что ему огромное спасибо!!!