blob: 09c844934631e7386c4986da9c82a5df953f02a1 (
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
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
|
;;; -*- mode: lisp; coding: utf-8 -*-
;;; Étoilisp/Mulklisp, a Common Lisp subset for the Étoilé runtime.
;;; Copyright (C) 2008 Matthias Andreas Benkard.
;;;
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(in-package #:common-lisp)
(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))))
|
