mes: Add unfold.
[mes.git] / module / srfi / srfi-1.scm
1 ;;; From Guile-1.8
2
3 ;;      Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
4 ;;
5 ;; This library is free software; you can redistribute it and/or
6 ;; modify it under the terms of the GNU Lesser General Public
7 ;; License as published by the Free Software Foundation; either
8 ;; version 2.1 of the License, or (at your option) any later version.
9 ;; 
10 ;; This library is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
13 ;; Lesser General Public License for more details.
14 ;; 
15 ;; You should have received a copy of the GNU Lesser General Public
16 ;; License along with this library; if not, write to the Free Software
17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
18
19 ;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
20 ;;; Date: 2001-06-06
21
22 ;;; Searching
23
24 ;; Internal helper procedure.  Map `f' over the single list `ls'.
25 ;;
26 (define map1 map)
27
28 (define (any pred ls . lists)
29   (if (null? lists)
30       (any1 pred ls)
31       (let lp ((lists (cons ls lists)))
32         (cond ((any1 null? lists)
33                #f)
34               ((any1 null? (map1 cdr lists))
35                (apply pred (map1 car lists)))
36               (else
37                (or (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
38
39 (define (any1 pred ls)
40   (let lp ((ls ls))
41     (cond ((null? ls)
42            #f)
43           ((null? (cdr ls))
44            (pred (car ls)))
45           (else
46            (or (pred (car ls)) (lp (cdr ls)))))))
47
48 (define (every pred ls . lists)
49   (if (null? lists)
50       (every1 pred ls)
51       (let lp ((lists (cons ls lists)))
52         (cond ((any1 null? lists)
53                #t)
54               ((any1 null? (map1 cdr lists))
55                (apply pred (map1 car lists)))
56               (else
57                (and (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
58
59 (define (every1 pred ls)
60   (let lp ((ls ls))
61     (cond ((null? ls)
62            #t)
63           ((null? (cdr ls))
64            (pred (car ls)))
65           (else
66            (and (pred (car ls)) (lp (cdr ls)))))))
67
68 (define (list-index pred clist1 . rest)
69   (if (null? rest)
70     (let lp ((l clist1) (i 0))
71       (if (null? l)
72         #f
73         (if (pred (car l))
74           i
75           (lp (cdr l) (+ i 1)))))
76     (let lp ((lists (cons clist1 rest)) (i 0))
77       (cond ((any1 null? lists)
78              #f)
79             ((apply pred (map car lists)) i)
80             (else
81              (lp (map cdr lists) (+ i 1)))))))
82
83 ;;; Set operations on lists
84
85 (define (lset-union = . rest)
86   (let ((acc '()))
87     (for-each (lambda (lst)
88                 (if (null? acc)
89                     (set! acc lst)
90                     (for-each (lambda (elem)
91                                 (if (not (member elem acc =))
92                                     (set! acc (cons elem acc))))
93                               lst)))
94               rest)
95     acc))
96
97 (define (lset-intersection = list1 . rest)
98   (let lp ((l list1) (acc '()))
99     (if (null? l)
100       (reverse! acc)
101       (if (every (lambda (ll) (member (car l) ll =)) rest)
102         (lp (cdr l) (cons (car l) acc))
103         (lp (cdr l) acc)))))
104
105 (define (lset-difference = list1 . rest)
106   (if (null? rest)
107     list1
108     (let lp ((l list1) (acc '()))
109       (if (null? l)
110         (reverse! acc)
111         (if (any (lambda (ll) (member (car l) ll =)) rest)
112           (lp (cdr l) acc)
113           (lp (cdr l) (cons (car l) acc)))))))