Задача 37.
; ----------------------------------------------- ;
; Попытайтесь восстановить условие данной задачи! ;
; ----------------------------------------------- ;
(DEFUN AAA (LAMBDA (Y LST)
(SETQ W (COPY LST LST Y))
(COPY1 W W)
))
; ---------------------------- ;
(DEFUN COPY (LAMBDA (LST LST1 Y)
; Построение списка, конгруэнтного списку LST и ;
; содержащего символы вида G*** вместо вхождений ;
; символов Y ;
(COND ( (NULL LST) NIL )
( (AND (ATOM LST) (EQ LST Y)) (GENSYM) )
( (AND (ATOM LST) (NOT (EQ LST Y))) LST )
( T (CONS (COPY (CAR LST) LST1 Y)
(COPY (CDR LST) LST1 Y)
)
)
)
))
; --------------------------- ;
(DEFUN COPY1 (LAMBDA (LST LST1)
; Построение списка, конгруэнтного списку LST и ;
; содержащего "глубины погружения" элементов в ;
; список LST вместо символов G*** ;
(COND ( (NULL LST) NIL )
( (AND (ATOM LST) (EQ (CAR (UNPACK LST)) G))
(POISK LST LST1) )
( (AND (ATOM LST) (NOT (EQ (CAR (UNPACK LST)) G)))
LST )
( T (CONS (COPY1 (CAR LST) LST1)
(COPY1 (CDR LST) LST1)) )
)
))
; ----------- ;
(SETQ GENSYM 0)
(DEFUN GENSYM (LAMBDA (NUM LST)
(SETQ NUM (- 4 (LENGTH GENSYM)))
(LOOP
( (ZEROP NUM) )
( PUSH 0 LST )
( SETQ NUM (- NUM 1)) )
(PROG1
(PACK (NCONC (CONS (QUOTE G) LST) (LIST GENSYM)))
(SETQ GENSYM (+ GENSYM 1))
)
))
; ------------------------ ;
(DEFUN POISK (LAMBDA (X LST)
; Нахождение "глубины погружения" X в список LST ;
(COND ( (MEMBER X LST) 1 )
( (MEMBER2 X (CAR LST))
(+ 1 (POISK X (CAR LST))) )
( T (POISK X (CDR LST)) )
)
))
; -------------------------- ;
(DEFUN MEMBER2 (LAMBDA (X LST)
; Предикат MEMBER2 устанавливает вхождение ;
; элемента X в многоуровневый список LST ;
(COND ( (NULL LST) NIL)
( T (OR (COND ( (ATOM (CAR LST))
(EQ X (CAR LST)) )
( T (MEMBER2 X (CAR LST)) )
)
(MEMBER2 X (CDR LST))) )
)
))
Текст этой библиотеки можно взять здесь.