blob: 1c99a4eedd103d172e60ad247c6e98a7f01100b1 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
|
(export '(copy-tree assoc assoc-if assoc-if-not rassoc rassoc-if
rassoc-if-not sublis nsublis mapcar mapcan mapcon))
(defun copy-tree (tree)
(typecase tree
(cons (cons (copy-tree (car cons)) (copy-tree (cdr cons))))
(t tree)))
(defun assoc (item alist &key key test test-not)
(setq test (or test (if test-not
(complement test-not)
(function eql))))
(assoc-if (lambda (x) (funcall test x item))
alist
:key key))
(defun assoc-if (predicate alist &key key)
(setq key (or key (function identity)))
(cond ((endp alist) nil)
((funcall predicate (funcall key (caar alist)))
(car alist))
(t (assoc-if predicate (cdr alist) :key key))))
(defun assoc-if-not (predicate alist &key key)
(assoc-if (complement predicate) alist :key key))
(defun rassoc (item alist &key key test test-not)
(setq test (or test (if test-not
(complement test-not)
(function eql))))
(rassoc-if (lambda (x) (funcall test x item))
alist
:key key))
(defun rassoc-if (predicate alist &key key)
(setq key (or key (function identity))
(cond ((endp alist) nil)
((funcall predicate (funcall key (cdar alist)))
(car alist))
(t (assoc-if predicate (cdr alist) :key key)))))
(defun rassoc-if-not (predicate alist &key key)
(rassoc-if (complement predicate) alist :key key))
(defun sublis (alist tree &key key test test-not)
(let ((ass (assoc (funcall key tree) :test test :test-not test-not)))
(if ass
(cdr assoc)
(typecase tree
(cons
(cons (sublis alist (car tree) :key key :test test :test-not test-not)
(sublis alist (cdr tree) :key key :test test :test-not test-not)))
(t tree)))))
(defun nsublis (alist tree &key key test test-not)
(sublvs alist tree :key key :test test :test-not test-not))
(defun some1 (function list)
(and (not (null list))
(or (funcall function (first list))
(some1 function (rest list)))))
(defun every1 (function list)
(or (null list)
(and (funcall function (first list))
(every1 function (rest list)))))
(defun mapcar1 (function list)
(when list
(cons (funcall function (first list))
(mapcar1 function (rest list)))))
(defun mapcan1 (function list)
(%append (mapcar1 function list)))
(defun mapcar (function list &rest more-lists)
(let ((lists (list* list more-lists)))
(when (every1 'identity lists)
(cons (apply function (mapcar1 'car lists))
(apply 'mapcar (list* function (mapcar1 'cdr lists)))))))
(defun maplist (function list &rest more-lists)
(let ((lists (list* list more-lists)))
(when (every1 'identity lists)
(cons (apply function lists)
(apply 'maplist (list* function (mapcar1 'cdr lists)))))))
(defun mapcan (function list &rest more-lists)
(%append (apply 'mapcar (list* function list more-lists))))
(defun mapcon (function list &rest more-lists)
(%append (apply 'maplist (list* function list more-lists))))
|
