LISP: функция Nth наоборот

LISP: функция Nth наоборот · 18.03.2013, 19:02

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

gomer · 18.03.2013, 19:19

А самому подумать?

WhiteShark · 18.03.2013, 19:25

Да я то сделал вот такую... но мне не нравится

Код:

 (defun invNth (lst N / k newlst)
  (setq k 0)
  (if lst
    (progn
      (while lst
	(if (/= k N)
	  (setq newlst (append newlst (car lst)))
	  )
	(setq k (1+ k))
	(setq lst (cdr lst))
      )
    newlst
    )
  )
)

gomer · 18.03.2013, 19:35

забыли list

Код:

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

 (setq newlst (append newlst (list (car lst))))

вообще рекурсивно это гораздо проще решается

WhiteShark · 18.03.2013, 19:43

Ну я вот и чувствую что можно лучше.. но не могу сложить в кучу. Не подскажите как рекурсивно?

gomer · 18.03.2013, 19:48

Код:

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

 (defun butnth (i lst)
  (if (zerop i)
    (cdr lst)
    (cons (car lst)
	  (butnth
	    (1- i)
	    (cdr lst)
	  )
    )
  )
)

Настоятельно рекомендую начать изучать рекурсию

ну и еще вопрос: нафига это надо?

WhiteShark · 18.03.2013, 22:31

Спрашивали? Отвечаем :-)

Стоит задача по списку вида ((x1 y1 z1) (x2 y2 z2) ... ... ), содержащему наборы координат концов линий, определить образуют ли они замкнутый контур.
Ну и вообще, в принципе, как же получать список без какого то элемента? (vl-remove-if не подходит из за того что элемент не уникальный)

VVA · 18.03.2013, 23:03

Looking for a faster version of delete_nth, insert_nth and switch_nth
Парочка функций из этой темы (там требутся регистрация)
http://forum.dwg.ru/showthread.php?p=676403#post676403
http://forum.dwg.ru/showthread.php?t=80369

gomer · 19.03.2013, 00:14

Цитата:

Сообщение от WhiteShark

Стоит задача по списку вида ((x1 y1 z1) (x2 y2 z2) ... ... )

Это список точек, а не отрезков

WhiteShark · 19.03.2013, 01:50

Уважаемый gomer, я именно так ((x1 y1 z1) (x2 y2 z2) ... ... ) написал, чтоб было понятно, что каждый отрезок задан координатой начала и конца, идущими подряд. Задача проверить контур на незамкнутость весьма проста: список не будет содержать по два раза одни и те же координаты или будет нечетное количество элементов. Я пытаюсь решить задачу сложнее: попытаться составить из такого списка замкнутый контур (то есть еще и упорядочить его). Для чего нужно попробовать выстроить из данного набора координат цепочку, где каждая конечная координата одного отрезка соседствует с такой же начальной координатой следующего (ну а голова равна хвосту). Если цепочка выстроится, то контур замкнутый.

VVA, как всегда спасибо!

Sleekka · 20.03.2013, 17:50

Цитата:

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

Красивая говоришь...
Может и не супер красивая, но зато быстрая.

Код:

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

 (defun remove-i (i lst)
      (setq i (1+ i))
      (vl-remove-if '(lambda (x) (zerop (setq i (1- i)))) lst)
    )

считается что первый список в листе - номер 0.

Олег (jr.) · 20.03.2013, 18:31

Рекурсивненько тоже можно

Код:

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

;;fixo () 2013 * all rights released
(defun remove-by-index	 (lst idx)
  (if (car lst)
    (cons (vl-remove-if
	    '(lambda (a) (= (vl-position a (car lst)) idx))
	    (car lst))
	  (remove-by-index (cdr lst) idx))))

WhiteShark · 20.03.2013, 22:51

Спасибо спасибо! С Nth уже понятно )
Намного более нетривиальная задачка - исходная (та, что в 10-ом посте). Если у кого мысли есть - скрывайте!

Если прям на пальцах то так: есть список

( (18 7 0) (23 59 0) (34 14 0) (18 7 0) (95 13 0) (34 14 0) (23 59 0) (95 13 0) )

надо получить из него

( (23 59 0) (95 13 0) (95 13 0) (34 14 0) (34 14 0) (18 7 0) (18 7 0) (23 59 0) )

Олег (jr.) · 21.03.2013, 01:17

Цитата:

Сообщение от WhiteShark

Если у кого мысли есть - скрывайте!

Поищи chain selection не помню где, склерозьм

gomer · 21.03.2013, 02:17

см. #2

CB · 21.03.2013, 13:00

Цитата:

Если прям на пальцах то так: есть список
( (18 7 0) (23 59 0) (34 14 0) (18 7 0) (95 13 0) (34 14 0) (23 59 0) (95 13 0) )
надо получить из него
( (23 59 0) (95 13 0) (95 13 0) (34 14 0) (34 14 0) (18 7 0) (18 7 0) (23 59 0) )

А почему не так?

Код:

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

 '( (23 59 0) (34 14 0) (34 14 0) (18 7 0) (18 7 0) (95 13 0) (95 13 0) (23 59 0)  ))
 '( (34 14 0) (18 7 0) (18 7 0) (95 13 0) (95 13 0) (23 59 0) (23 59 0) (34 14 0)))
 '( (18 7 0) (95 13 0) (95 13 0) (34 14 0) (34 14 0) (23 59 0) (23 59 0) (18 7 0) ))
 '( (18 7 0) (34 14 0) (34 14 0) (95 13 0) (95 13 0) (23 59 0) (23 59 0) (18 7 0) ))

WhiteShark · 21.03.2013, 14:07

Олег (jr.), спасибо, попробую найти!
gomer, спасибо, я уже почти придумал ) просто есть непреодолимая тяга сделать всё так же красиво как вы
CB, первый, третий и четвертый списки неправильные потому, что в исходном списке элементы (подсписки) 1и2, 3и4 и т.д. образуют неразрывные пары, т.к. описывают начало и конец одного отрезка

Sleekka · 21.03.2013, 17:32

WhiteShark, ничего не понятно какой тебе алгоритм нужен?

http://algolist.manual.ru/maths/geom...ull/graham.php
этот что-ли?

VVA · 21.03.2013, 18:22

Цитата:

Сообщение от Олег (jr.)

Поищи chain selection не помню где, склерозьм

Пробы пера были здесь
http://forum.dwg.ru/showthread.php?p=134515#post134515

WhiteShark · 22.03.2013, 00:47

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

Код:

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

 
(defun lshift (elem lst  /)
       (cond ((= (car lst) elem) lst)
               (T (lshift (append  (cdr lst) (list (car lst)) )  elem))
       )
)

(lshift 3 '(1 2 3 4)) возвращает как и задумывалось (3 4 1 2), но

(lshift '(3) '((1) (2) (3) (4))) делает stack overflow

Подскажите в чем дело?

Vov.Ka · 22.03.2013, 02:32

..

Цитата:

Сообщение от WhiteShark

Подскажите в чем дело?

=

gomer · 22.03.2013, 03:19

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

Кулик Алексей aka kpblc · 22.03.2013, 09:04

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

WhiteShark · 22.03.2013, 10:56

Так в том то и дело, что я трейсил код. И своими глазами видел, что почему то (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.) · 23.03.2013, 21:42

Не работает если линии расположены не по одному направлению
Посмотри хороший пример от 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 · 24.03.2013, 11:11

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

WhiteShark · 24.03.2013, 13:22

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

18.03.2013, 19:02		#1
LISP: функция Nth наоборот WhiteShark Регистрация: 30.03.2012 Сообщений: 101 Есть ли красивая реализация у кого нибудь функции которая возвращает весь список только без элемента за номером N?
Просмотров: 6311

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
AUTOCAD 2010 перестал переключаться в многооконный режим. Проблемы с переменными	Андрей Х.	AutoCAD	24	27.05.2015 10:17
Подправте старый лисп	evg76	LISP	10	25.10.2012 10:23
Двутавр	Born	AutoCAD	14	26.03.2009 16:45
3D Konstruktor для проектировщиков КМ.	Дима_	Готовые программы	17	10.07.2008 10:03
Помогите с автолиспом	MaloI	LISP	12	26.12.2006 08:05

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