[WhiteShark]

Есть ли красивая реализация у кого нибудь функции которая возвращает весь список только без элемента за номером N?

[Vov.Ka]

..

Сообщение от WhiteShark Подскажите в чем дело?

=

[gomer]

потому что #2!!!!!!!!! WhiteShark, включи уже мозг, мало того что у тебя же аргументы гуляют как по тверской, так еще и и сравниваешь атом со списком и циклишь по заведомо ложному условию! Nil тебе вместо якоря

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

Пошагово попробуй выполнить код.

[WhiteShark]

Так в том то и дело, что я трейсил код. И своими глазами видел, что почему то (3) не равно (3).
Спасибо, с "equal" вместо "=" работает как задумывалось
А аргументы загуляли по тверской когда красоту наводил и местами переставил

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

Код:

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

 
(defun WS-SSetToPolygon (sset / lst head tail)
  (if sset
    (progn
      (setq lst (WS-GetLinesEnds sset))
      (if (not (vl-remove-if (function (lambda (e) (vl-position e (cdr (member e lst))))) lst))
        (progn
          (setq head (list (car lst) (cadr lst)))
          (setq tail (cddr lst))
          (repeat (- (/ (length lst) 2) 1)
            (setq tail (WS-lshift (car (reverse head)) tail))
            (setq head (append head (list (car tail)) (list (cadr tail)) ))
            (setq tail (cddr tail))        
          )
          head
        )
      )
    )
  )
)

;------------------------------------------------------------------

(defun WS-GetLinesEnds (sset / k XYZ1 XYZ2 XYZlist)
  (cond (sset
  (setq k 0)
  (setq XYZlist nil)
  (repeat (sslength sset)
    (setq ent (ssname sset k))
    (setq k (1+ k))
    (if (= "LINE" (cdr (assoc 0 (entget ent))))
      (progn
        (setq XYZ1 (cdr (assoc 10 (entget ent))))
        (setq XYZ2 (cdr (assoc 11 (entget ent))))
        (setq XYZlist (append (list XYZ1 XYZ2) XYZlist))
      )
      nil
    )
  )
  XYZlist)
  (T nil)
  )
)

;----------------------------------------------------------------

(defun WS-lshift (elem lst /)
       (cond ((equal (car lst) elem) lst)
         (T (WS-lshift  elem (append (cdr lst) (list (car lst))) ))
       )
)

[Олег (jr.)]

Не работает если линии расположены не по одному направлению
Посмотри хороший пример от VVA:

Код:

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

;;* Author VVA
;;* Утилита объединения набора линий в полилинию*
;;* Должно выбирать все (сначала и с конца) найденные примитивы в цепочку)
;;------------------------------------------------
;;Алгоритм взят у ChainSelect Fatty
;;http://www.cadforyou.spb.ru/index.php?current_section=section_programs_page
;;Доработан до понимания ARC,PLINE,LINE
;;Для выполнения необходимо указать только точку
;; pt - Список точек для выбранных примитивов в МСК !!!
;; fuzz - точность
;;Возвращает список vla объектов
(defun ChainSelectFromAny1 ( pt obj fuzz / chain_list couple line_lst ln ss cycl line_list )
(vl-load-com)
(if (setq ss (ssget "_I")
          ss nil
          ss (ssget "_X" '((0 . "ARC,LINE,*POLYLINE")))
    ) ;_ end of setq
  (progn
    (setq line_lst  (mapcar 'vlax-ename->vla-object
                             (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
                     ) ;_ end of mapcar
          chain_list nil
          chain_list (list obj)
    ) ;_ end of setq
    (setq line_lst (vl-remove-if
                      '(lambda (x)
                         (eq "AcDb3dPolyline" (vla-get-objectname x))
                       ) ;_ end of lambda
                      line_lst
                    ) ;_ end of vl-remove-if
    ) ;_ end of setq
     (setq line_lst (vl-remove obj line_lst))
    (setq cycl 0 line_list line_lst)
    (foreach pt_Pattern pt
     (while
        (setq couple
               (vl-remove-if-not
                 (function (lambda (x)
                             ;; значение допуска 0.01 можно изменить по ситуации
                             ;; в зависимости от единиц черчения : 
                             (or (equal (vlax-curve-getStartPoint x)
                                        pt_Pattern
                                        fuzz      ;<--- допуск 
                                 ) ;_ end of equal
                                 (equal (vlax-curve-getEndPoint x)
                                        pt_Pattern
                                        fuzz     ;<--- допуск 
                                 ) ;_ end of equal
                             ) ;_ end of or
                           ) ;_ end of lambda
                 ) ;_ end of function
                 line_list
               ) ;_ end of vl-remove-if-not
        ) ;_ end of setq
       (grtext -1 (strcat "Обработка. Цикл - " (itoa (setq cycl (1+ cycl)))))
       (if couple
           (progn
             (setq chain_list (cons (car couple) chain_list))
             (setq ln (car chain_list))
             (setq line_list (vl-remove ln line_list))
             (setq pt_Pattern (if (equal pt_Pattern (vlax-curve-getStartPoint ln) 1e-6)
                                (vlax-curve-getEndPoint ln)
                                (vlax-curve-getStartPoint ln)
                                )
                   )
           ) ;_ end of progn
         ) ;_ end of if
      )
   )
  ) ;_ end of progn
) ;_ end of if
chain_list
)
;;;Ф-ция переводит градусы в радианы
;;;( pl:DTR a)
(defun pl:DTR (a)(* pi (/ a 180.0)))
;;;---------------------------------------------
;;;Ф-ция переводит радианы в градусы
;;;( R2D a)
(defun pl:RTD (a)(/ (* a 180.0) pi))
(defun mip_grdraw ( ptdraw ang color / pt1 pt2 )
  (setq pt1 (polar ptdraw (+ ang (pl:DTR 135)) (* 0.05 (getvar "VIEWSIZE"))))
  (setq pt2 (polar ptdraw (+ ang (pl:DTR 225)) (* 0.05 (getvar "VIEWSIZE"))))
  (grvecs (list color pt1 ptdraw ptdraw pt2))
  )
(defun _vxgrdraw ( ptdraw color / ang pt11 pt12 pt21 pt22 len )
  (setq len (* 0.03 (getvar "VIEWSIZE"))
       ang 0
       pt11 (polar ptdraw (+ ang (pl:DTR 225)) len)
       pt12 (polar ptdraw (+ ang (pl:DTR 45)) len)
       pt21 (polar ptdraw (+ ang (pl:DTR 315)) len)
       pt22 (polar ptdraw (+ ang (pl:DTR 135)) len))
  (grvecs (list color pt11 pt12 pt21 pt22))
  )
;;;------------------------------------------------------------------
;;;------------------------------------------------------------------
 
(defun C:ChainSelect ( / ss en fuzz obj pt pt1 len dst ptother what lst *error*)
 (vl-load-com)
 (defun *error* (msg)(princ msg)
   (vla-EndUndoMark(vla-get-ActiveDocument (vlax-get-acad-object)))(princ))
 (vla-StartUndoMark(vla-get-ActiveDocument (vlax-get-acad-object))) 
 (setvar "cmdecho" 0) 
 (if (and (setq en (entsel "\nВыбрать линию в цепи :"))
          (wcmatch (cdr(assoc 0 (entget (car en)))) "ARC,LINE,*POLYLINE,SPLINE")
          (setq obj (vlax-ename->vla-object (car en)))
          (cond ((=(vla-get-ObjectName obj) "AcDb3dPolyline")
                 (princ "\n3d Полилиния. ") nil)
                ((and (=(vla-get-ObjectName obj) "AcDbLine")
                      (not(equal (last(cdr(assoc 10 (entget(car en)))))
                             (last(cdr(assoc 11 (entget(car en)))))
                             1e-9
                             )
                          )
                      )
                 (princ "\nОтрезок. Разные координаты Z. ") nil)
                ((and (=(vla-get-ObjectName obj) "AcDb2dPolyline")
                     (member (vla-get-Type obj) '(1 2 3)))
                 (princ "\n2d сглаженная полилиния. ") nil)
                (t t)
                )
          )
 (progn
 (setq pt1 (trans (cadr en) 1 0))  
 (setq pt1 (vlax-curve-getclosestpointto obj pt1))
 (setq len (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj)))
 (setq dst (vlax-curve-getDistAtPoint obj pt1))
 (if (<= dst (- len dst))
   (setq pt (vlax-curve-getStartPoint obj) ptother (vlax-curve-getEndPoint obj))
   (setq pt (vlax-curve-getEndPoint obj) ptother (vlax-curve-getStartPoint obj))
   )
  (_vxgrdraw (trans pt 0 1) -1)
(mip_grdraw (trans pt1 0 1)
  (angle (trans pt1 0 1)(trans pt 0 1)) 1)
 (initget "Ближайшая Противоположная Обе Nearest Opposite Both _Nearest Opposite Both Nearest Opposite Both")
 (princ "\nСтроить цепочку от ближайшей точки [Ближайшая/Противоположная/Обе] <Обе>:")
 (setq what (getkword))
 (cond ((= what "Opposite")
        (setq pt (list ptother))
        (vl-cmdf "_.redrawall")
        (_vxgrdraw (trans ptother 0 1) -1)
        (mip_grdraw (trans pt1 0 1)
  (angle (trans pt1 0 1)(trans ptother 0 1)) 1)
        )
       ((= what "Nearest") (setq pt (list pt)))
       (t (setq pt (list pt ptother)))
       )
 
 (if (null *FUZZ*)(setq *FUZZ* 0.0))
 (princ "\nЗначение допуска < ")(princ *FUZZ*)(princ " >: ")
 (if (null (setq fuzz  (getdist)))
   (setq fuzz *FUZZ*))
 (setq *FUZZ* fuzz)
 (vl-cmdf "_.redrawall")
 (setq ss nil ss (ssadd (car en)))
       
 (setq lst (ChainSelectFromAny1 pt obj (+ fuzz 1e-6)))
 (foreach item lst
      (ssadd (vlax-vla-object->ename item) ss)
    )
 (sssetfirst nil ss)
  )
   (princ " Нужно указать LINE, POLYLINE, ARC или SPLINE")
   )
 (vla-EndUndoMark(vla-get-ActiveDocument(vlax-get-acad-object)))
  (princ)
  )
(princ "\nНаберите ChainSelect  в командной строке")
(princ)

;;(C:ChainSelect)

[Sleekka]

Значит WhiteShark как тебе что-то надо, помогите! научите! как тебя попросил в личке - хрен тебе! Давай досвиданья!

[WhiteShark]

Offtop: Sleekka, пардон муа, но в личке меня никто ни о чем не просил