Функционалы.

Задание 21: Сформировать список, содержащий номера позиций элементов исходного списка, удовлетворяющих заданному условию. Запускать (PosP ...).

(defun RunPosP (F L N) (cond ((Null L) NIL) ((FunCall F (Car L)) (Cons N (RunPosP F (Cdr L) (+ N 1)))) (T (RunPosP F (Cdr L) (+ N 1))) ) )

(Defun PosP (F L) (Cond ((ListP L) (RunPosP F L 1)) (T "Non-list argument") ) )

(rds)

-----------------------------------------------------------------

Задание 22: Задан линейный числовой список. Сформировать список сумм подмножеств элементов исходного списка таким образом, что на первом месте должны стоять сумма всех элементов списка, на втором - сумма без первого, на третьем - сумма без первых двух и т. д. Запускать (SumList ...).

(Defun RunSumList (L) (MapList '(Lambda (L) (Apply + L)) L) )

(defun SumList (L) (cond ((ListP L) (RunSumList L)) (T (Print "Non-list Argument")) ) ) (rds)

-----------------------------------------------------------------

Задание 23: Удалить из исходного линейного списка все вхождения заданного элемента. Запускать (DelItem ...).

(Defun RunDelItem (L A) (MapCon '(Lambda (L2) (If (Eq (Car L2) A) Nil (List (Car L2)) ) ) L ) )

(defun DelItem (A L) (cond ((Not (Atom A)) "Non-Atom First Argument") ((Not (ListP L)) "Non-List Second Argument") (T (RunDelItem L A)) ) ) (Rds)

----------------------------------------------------------------

Задание 24:Оставить в исходном линейном списке не более одного вхождения каждого элемента. Запускать (TheOnly ...).

(Defun RunTheOnly (L) (MapCon '(Lambda (L2) (if (Member (Car L2) (Cdr L2)) Nil (List (Car L2)) ) ) L ) )

(defun TheOnly (L) (Cond ((ListP L) (RunTheOnly L)) (T "Non-list Argument") ) )

(rds)

-------------------------------------------------------------------

Задание 25: Даны два исходных списка одного размера. Сформировать из неравных друг другу элементов с одинаковыми порядковыми номерами точечные пары, объединив их в один результирующий список. Запускать (Sley ...).

(Defun RunSley (L1 L2) (MapCan '(Lambda (A1 A2) (IF (And (Atom A1) (Atom A1) (Not (= A1 A2))) (List (Cons A1 A2)) Nil ) ) L1 L2 ) )

(Defun Sley (L1 L2) (Cond ((Not (ListP L1)) "Non List First Argument!") ((Not (ListP L2)) "Non List Second Argument!") ((Not (= (Length L1) (Length L2))) "Different Length!!") (T (RunSley L1 L2)) ) )

Лаб 6

Ассоциативные списки и списки свойств.

Задание 26: Извлечь из ассоциативного списка элементы, ключи которых удовлетворяют заданным условиям. Запускать (Assel ...).

(defun ASSEL (F AL) (COND ((NULL AL) NIL) ((FUNCALL F (CAR (CAR AL))) (CONS (CDR (CAR AL)) (ASSEL F (CDR AL)))) (T (ASSEL F (CDR AL))) ) )

-----------------------------------------------------------------

Задание 27: Исходный список содержит имена объектов, списки свойств которых содержат некоторую информацию. Определить для каждого объекта количество пар <ключ-значение>. Запускать (Defit ...).

(DEFUN L2 (AL) (LENGTH (CDR AL)));

(defun DEFIT (L) (COND ((NULL L) NIL) (T (CONS (L2 (CAR L)) (DEFIT (CDR L)) )) ) ) ; (rds)

-----------------------------------------------------------------

Задание 28: Исходный список содержит имена объектов, списки свойств которых содержат некоторую информацию. Другой список содержит некоторое количество (>1) флагов. Сформировать список объектов, содержащих не менее двух флагов из заданного списка. Запускать (FgMain ...).

; Предикат определяющий содержится ли флаг в списке (DEFUN FLP (L F) (SETQ L (FLAGP L F)) (COND ((NULL L) 0) (T 1) ) )

(DEFUN FG1 (L1 L2) (SETQ C '0) (LOOP ((NULL L2) (COND ((> C 1) T) (T NIL))) (SETQ C (+ C (FLP L1 (CAR L2)))) (SETQ L2 (CDR L2)) ) )

(defun FGMAIN (L1 L2) (SETQ KC NIL) (LOOP ((NULL L1) KC) (IF (FG1 (CDR (CAR L1)) L2) (SETQ KC (APPEND KC (LIST (CAR L1)))) ) (SETQ L1 (CDR L1)) ) )

(SETQ L '(A B C V))

(flag A 'F) (flag A 'D) (flag B 'F) (flag B 'H) (flag B 'G) (flag C 'J) (flag C 'K) (flag C 'O)

(SETQ K '(F G H J))

(FGMAIN L K) ; (rds)

----------------------------------------------------------------

Задание 29: Пусть в списке свойств атома может быть специальное свойство с ключом ISA, значение которого является именем другого списка свойств, называемого списком-прототипом, из которого могут наследоваться дополнительные свойства. Написать функцию (Get-Isa <имя списка> <имя свойства>), которая в случае отсутствия искомого свойства в исходном списке выдаёт значение первого найденного такаго же свойства среди всех Isa-прототипов данного списка свойств. Запускать (GetIsa ...).

(SETQ L1 '((S0 . A1) (ISA . A1) (S1 . 1) (S2 . 1) )) (put A1 's4 '1) (put A1 's5 '7)

(DEFUN GET-ISA (L K) (COND ((GET L K) (GET L K)) (T (SETQ L3754 (GET L 'ISA)) (GET L3754 K) ) ) )

; (rds)

----------------------------------------------------------------

Задание 30: На складе имеется несколько видов продукции. Ассортимент каждого вида продукции представлен несколькими наименованиями. Задать инфомацию о имеющихся на складе товарах и их количестве с помощью списков свойств. Определить функции, позволяющие получать информацию о наличии некоторого товара на складе и корректирующие информацию о наличии при завозе и вывозе заданного количестве товара.

(SETQ SCLAD '(TEXTBOOKS PENS))

(put textboOKS 'OB '100) (put textboOKS 'TO '2500)

(put PENS 'ROL '1000) (put pens 'GEL '12000) (put pens 'PER '0)

(DEFUN ISINSCLAD (SCL S) (LOOP ((GET (CAR SCL) S) (GET (CAR SCL) S)) ((NULL SCL) 'NO THIS OBJECT IN OUR SCLAD) (SETQ SCL (CDR SCL)) ) )

(DEFUN GETFROMSCLAD (SCL S N) (LOOP ((GET (CAR SCL) S) (PUT (CAR SCL) S (- (GET (CAR SCL) S) N)) ) ((NULL SCL) 'NO THIS OBJECT IN OUR SCLAD) (SETQ SCL (CDR SCL)) ) )

(DEFUN PUTTOSCLAD (SCL S N) (LOOP ((GET (CAR SCL) S) (PUT (CAR SCL) S (+ (GET (CAR SCL) S) N)) ) ((NULL SCL) 'NO THIS OBJECT IN OUR SCLAD) (SETQ SCL (CDR SCL)) ) )

; (rds)