8a69b7bce403793e179c832da8fdb306bdd93ef7
[mes.git] / mes / module / srfi / srfi-1.mes
1 ;;; -*-scheme-*-
2
3 ;;; GNU Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; This file is part of GNU Mes.
7 ;;;
8 ;;; GNU Mes is free software; you can redistribute it and/or modify it
9 ;;; under the terms of the GNU General Public License as published by
10 ;;; the Free Software Foundation; either version 3 of the License, or (at
11 ;;; your option) any later version.
12 ;;;
13 ;;; GNU Mes is distributed in the hope that it will be useful, but
14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 ;;; GNU General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
20
21 ;;; Commentary:
22
23 ;;; srfi-1.mes is the minimal srfi-1 needed to run mescc.
24
25 ;;; Code:
26
27 (define (find pred lst)
28   (let loop ((lst lst))
29     (if (null? lst) #f
30         (if (pred (car lst)) (car lst)
31             (loop (cdr lst))))))
32
33 (define (filter pred lst)
34   (let loop ((lst lst))
35     (if (null? lst) '()
36         (if (pred (car lst))
37             (cons (car lst) (loop (cdr lst)))
38             (loop (cdr lst))))))
39
40 (define (append-map f lst . rest)
41   (apply append (apply map f (cons lst rest))))
42
43 (define (filter-map f h . t)
44   (if (null? h) '()
45       (if (null? t)
46           (let ((r (f (car h))))
47             (if r (cons r (filter-map f (cdr h)))
48                 (filter-map f (cdr h))))
49           (if (null? (cdr t))
50               (let ((r (f (car h) (caar t))))
51                 (if r (cons r (filter-map f (cdr h) (cdar t)))
52                     (filter-map f (cdr h) (cdar t))))
53               (error 'unsupported (cons* "filter-map 3:" f h t))))))
54
55 (define (fold proc init lst1 . rest)
56   (if (null? rest)
57       (let loop ((lst1 lst1) (result init))
58         (if (null? lst1) result
59             (loop (cdr lst1) (proc (car lst1) result))))
60       (if (null? (cdr rest))
61           (let loop ((lst1 lst1) (lst2 (car rest)) (result init))
62             (if (or (null? lst1)
63                     (null? lst2)) result
64                     (loop (cdr lst1) (cdr lst2) (proc (car lst1) (car lst2) result))))
65           (let loop ((lst1 lst1) (lst2 (car rest)) (lst3 (cadr rest)) (result init))
66             (if (or (null? lst1)
67                     (null? lst2)
68                     (null? lst3)) result
69                     (loop (cdr lst1) (cdr lst2) (cdr lst3) (proc (car lst1) (car lst2) (car lst3) result))))
70           (error "FOLD-4-NOT-SUPPORTED"))))
71
72 (define (fold-right proc init lst1 . rest)
73   (if (null? rest)
74       (let loop ((lst lst1))
75         (if (null? lst) init
76             (proc (car lst) (loop (cdr lst)))))
77       (if (null? (cdr rest))
78           (let loop ((lst1 lst1) (lst2 (car rest)))
79             (if (or (null? lst1)
80                     (null? lst2)) init
81                     (proc (car lst1) (car lst2) (loop (cdr lst1) (cdr lst2)))))
82           (let loop ((lst1 lst1) (lst2 (car rest)) (lst3 (cadr rest)))
83             (if (or (null? lst1)
84                     (null? lst2)
85                     (null? lst3)) init
86                     (proc (car lst1) (car lst2) (car lst3) (loop (cdr lst1) (cdr lst2) (cdr lst3)))))
87           (error "FOLD-RIGHT-4-NOT-SUPPORTED"))))
88
89 (define (unfold p f g seed . rest)
90   (let ((tail-gen (if (null? rest) (const '())
91                       (car rest))))
92     (define (reverse+tail lst seed)
93             (let loop ((lst lst)
94                        (result (tail-gen seed)))
95               (if (null? lst) result
96                   (loop (cdr lst)
97                         (cons (car lst) result)))))
98     (let loop ((seed seed) (result '()))
99       (if (p seed) (reverse+tail result seed)
100           (loop (g seed)
101                 (cons (f seed) result))))))
102
103 (define (remove pred lst) (filter (lambda (x) (not (pred x))) lst))
104
105 (define (reverse! lst . term)
106   (if (null? term) (core:reverse! lst term)
107       (core:reverse! lst (car term))))
108
109 (define (srfi-1:member x lst eq)
110   (if (null? lst) #f
111       (if (eq x (car lst)) lst
112           (srfi-1:member x (cdr lst) eq))))
113
114 (define mes:member member)
115
116 (define (member x lst . rest)
117   (if (null? rest) (mes:member x lst)
118       (srfi-1:member x lst (car rest))))
119
120 (define mes:iota iota)
121
122 (define (srfi-1:iota n start step)
123   (if (<= n 0) '()
124       (cons start (srfi-1:iota (- n 1) (+ start step) step))))
125
126 (define (iota n . rest)
127   (if (null? rest) (mes:iota n)
128       (let ((start (car rest))
129             (step (if (null? (cdr rest)) 1
130                       (cadr rest))))
131         (srfi-1:iota n start step))))
132
133 (define last (compose car last-pair))
134
135 (define (delete-duplicates lst . equal)
136   (let ((equal (and (pair? equal) (car equal))))
137     (let loop ((lst lst))
138       (if (null? lst) '()
139           (if (if equal (member (car lst) (cdr lst) equal)
140                   (member (car lst) (cdr lst)))
141               (loop (cdr lst))
142                 (cons (car lst) (loop (cdr lst))))))))
143
144 (include-from-path "srfi/srfi-1.scm")
145
146 (define (take-while pred lst)
147   (if (or (null? lst) (not (pred (car lst)))) '()
148           (cons (car lst) (take-while pred (cdr lst)))))