> 1 <

Автор Сообщение

Добрый_Утконос

Members


Статус

15 сообщений

Где: Latvia
Род занятий:
Возраст:

#4676   2011-09-24 03:04 GMT+3 часа(ов)      
Задание: реализовать функцию, которая получит список (с подсписками в том числе)и удалит второй по очереди элемент пары элементов с одинаковым значением, но разными знаками.
1. Например: FUNKCIJA '( 1 2 3 4 -3 2 -1 -1) выдаст (1 2 3 4 2 -1) ;<- таким образом было 2 пары. (3 и -3) и (1 и -1). Второй элемент пары удалили. При этом ещё одна '-1' не входит в пару – его не трогаем.
Всё это выполняется.

Желательный результат: Сделать то же, но вытаскивая пары даже из подсписков любой глубины.
2. Например: FUNKCIJA '( ((-1)) 2 (((((-2))))) 4 (-3 (1 4)) ) выдаст ( ((-1)) 2 4 (-3(4)) ) ;<- То есть будет искать такую пару и вытащит, при необходимости, сохранив информацию об уровне подсписка.

Сейчас программа, не реализует второе условие. Она просто открывает список и работает только с атомами. Соответственно при такой же команде FUNKCIJA '( ((-1)) 2 (((((-2))))) 4 (-3 (1 4)) ) выдаст ( -1 2 4 -3 4)

Сам исходник:
///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*
; Proverjaet, estj li element X v spiske L
(DEFUN MEM2 (X L) (
COND
((NULL L) NIL)
(T (OR (COND((ATOM(CAR L))(EQUAL X (CAR L)))
(T (MEM2 X (CAR L)))
)
(MEM2 X (CDR L))
)
)
))


;Raskrivaet vse skobki, 4tobi glavnaja "rabo4aja" funkcija ('SUBTEST') mogla rabotatj so spiskami
(DEFUN InOneLine (L)

(COND

((NULL L) NIL)

((ATOM L) (CONS L NIL))

(T

(APPEND

(InOneLine (CAR L))

(InOneLine (CDR L))

))))





;Sama funkcija

(DEFUN SUBTEST (SUB)
( COND
((NULL SUB) NIL) ;........................................ KONEC

;.................................1 uslovie:



( T ( COND
( (MEM2 (- (CAR SUB)) (CDR SUB)) ;.................................. Esli element nahoditsa v daljnejshej 4asti spiska




( COND
((NOT (NULL (CDR SUB))) ; Esli daljnejshaja 4astj spiska ne pustaja
; otshepljaem etot samij rasmatrivaemij element (potom prikleem ego) i prodolzhaem rekursiju,
;!udaliv v odnom ekzempljare takoj zhe element, no s otricateljnim znakom. Na obratnom puti ego ne pridetsa sobiratj, ibo ego uzhe ne budet.
(return-from subtest (CONS(CAR SUB)(SUBTEST (CDR (Delete (-(CAR SUB)) SUB :count 1))))) )

(T (return-from subtest NIL)) ; Esli daljnejshaja 4astj spiska pustaja

))

(T (return-from subtest (CONS (CAR SUB) (SUBTEST (CDR SUB))) )) ;.................................. Esli element ne nahoditsa v daljnejshej 4asti spiska
; otshepljaem etot samij rasmatrivaemij element (potom prikleem ego) i prodolzhaem rekursiju.

))




)
)


(defun FUNKCIJA(L) (
COND
((NULL L) NIL) ; vozvrashjem NIL, esli spisok pustoj
((ATOM L) L) ; vozvroshjaem sam element, esli on Atom

(T (subtest (InOneLine L) )) ; peredajem spisok funkcii InOneLine (kotoraja otkroet vse podspiski), a zatem primenjaem funkciju SUBTEST, 4tobi vipolnitj postavlennoe zadanie


))

///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*

ПС. понимаю, что задание не такой смехотворной сложности, чтобы кто-то на этом форуме за 5 секунд разобрался во всём и помог, чем сможет. Поэтому и добавил, что эта тема предназначена строго альтруистам. Если вы им не являетесь, просто пропустите эту тему.
Спасибо.

megamanx

Members


Статус

307 сообщений

Где: Russia
Род занятий:
Возраст:

#4677   2011-09-24 15:36 GMT+3 часа(ов)      
1. Список
(defun foo (L &optional (F nil))
(cond
((null L) nil)
((member (car L) F) (foo (cdr L) F))
(T (cons (car L) (foo (cdr L) (cons (- (car L)) F))))))

2. Список и подсписки. Здесь при наличии пустого списка он не удаляется, а копируется
(defun digg2(L)
(let ((F nil))
(labels ((ret (L)
(cond
((null L) nil)
((null (car L)) (cons '() (ret (cdr L)))) ;;;delete line to avoid copying of empty lists
((listp (car L))
(let ((ret-car-l (ret (car L))))
(if (null ret-car-l)
(ret (cdr L))
(cons ret-car-l (ret (cdr L))))))
(T (if (member (car L) F)
(ret (cdr L))
(progn
(setf F (cons (- (car L)) F))
(cons (car L) (ret (cdr L)))))))))
(ret L))))

3. Если запоминание идёт не по порядку (слева-направо), а по глубине
(defun digg(L &optional (F nil))
(cond
((null L) nil)
((listp (car L))
(if (null (digg (car L) F))
(digg (cdr L) F)
(cons (digg (car L) F) (digg (cdr L) F))))
(T (if (member (car L) F)
(digg (cdr L) F)
(cons (car L) (digg (cdr L) (cons (- (car L)) F)))))))

отредактировал(а) megamanx: 2011-09-24 16:36 GMT+3 часа(ов)
I wish I'd made you angry earlier

Добрый_Утконос

Members


Статус

15 сообщений

Где: Latvia
Род занятий:
Возраст:

#4678   2011-09-24 18:52 GMT+3 часа(ов)      
megamanx, спасибо. Вы во второй раз мне очень помогли.
Я немного отредактировал вашу digg2 функцию (чтобы она удаляла не все противоположного знака элементы, а только по одному соответствующему паре).

Например, у вас бы после digg2'(-2 2 2) вышло бы (-2), а у меня (-2 2), ибо пару образуют только первые два элемента. (это имелось ввиду так)

///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*

(defun digg2(L)

(let ((F nil))

(labels ((ret (L)

(cond

((null L) nil)

((listp (car L))

(if (null (ret (car L)))

(ret (cdr L))

(cons (ret (car L)) (ret (cdr L)))))

(T (if (member (car L) F)

(progn

( setq F(Delete (car L) F :count 1 ) );TUT MOJA 4ASTJ
(ret (cdr L))

)

(progn

(setf F (cons (- (car L)) F))

(cons (car L) (ret (cdr L)))))))))

(ret L))))

///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*///*

Ещё раз СПАСИБО!

megamanx

Members


Статус

307 сообщений

Где: Russia
Род занятий:
Возраст:

#4680   2011-09-24 21:13 GMT+3 часа(ов)      
Используй тогда лучше хэш
(defun digg2(L)
(let ((F (make-hash-table)))
(labels ((ret (L)
(cond
((null L) nil)
((null (car L)) (cons '() (ret (cdr L))))
((listp (car L))
(let ((ret-car-l (ret (car L))))
(if (null ret-car-l)
(ret (cdr L))
(cons ret-car-l (ret (cdr L))))))
(T (let ((x (gethash (-(car L)) F)))
(cond
((null x)
(progn
(setf (gethash (car L) F) 1)
(cons (car L) (ret (cdr L)))))
((eq x 1)
(progn
(incf (gethash (-(car L)) F))
(ret (cdr L))))
(T (cons (car L) (ret (cdr L))))))))))
(ret L))))
I wish I'd made you angry earlier
> 1 <


Онлайн :

0 пользователь(ей), 16 гость(ей) :




Реклама на сайте: