mes: Add unfold.
[mes.git] / module / srfi / srfi-1.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; This file is part of Mes.
7 ;;;
8 ;;; 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 ;;; 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 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 ((lst lst1) (result init))
58         (if (null? lst) result
59             (loop (cdr lst) (proc (car lst) result))))
60       '*FOLD-n-NOT-SUPPORTED))
61
62 (define (fold-right proc init lst1 . rest)
63   (if (null? rest)
64       (let loop ((lst lst1))
65         (if (null? lst) init
66             (proc (car lst) (loop (cdr lst)))))
67       '*FOLD-RIGHT-n-NOT-SUPPORTED))
68
69 (define (unfold p f g seed . rest)
70   (let ((tail-gen (if (null? rest) (const '())
71                       (car rest))))
72     (define (reverse+tail lst seed)
73             (let loop ((lst lst)
74                        (result (tail-gen seed)))
75               (if (null? lst) result
76                   (loop (cdr lst)
77                         (cons (car lst) result)))))
78     (let loop ((seed seed) (result '()))
79       (if (p seed) (reverse+tail result seed)
80           (loop (g seed)
81                 (cons (f seed) result))))))
82
83 (define (remove pred lst) (filter (lambda (x) (not (pred x))) lst))
84
85 (define (reverse! lst . term)
86   (if (null? term) (core:reverse! lst term)
87       (core:reverse! lst (car term))))
88
89 (define (srfi-1:member x lst eq)
90   (if (null? lst) #f
91       (if (eq x (car lst)) lst
92           (srfi-1:member x (cdr lst) eq))))
93
94 (define mes:member member)
95
96 (define (member x lst . rest)
97   (if (null? rest) (mes:member x lst)
98       (srfi-1:member x lst (car rest))))
99
100 (define mes:iota iota)
101
102 (define (srfi-1:iota n start step)
103   (if (<= n 0) '()
104       (cons start (srfi-1:iota (- n 1) (+ start step) step))))
105
106 (define (iota n . rest)
107   (if (null? rest) (mes:iota n)
108       (let ((start (car rest))
109             (step (if (null? (cdr rest)) 1
110                       (cadr rest))))
111         (srfi-1:iota n start step))))
112
113 (define last (compose car last-pair))
114
115 (define (delete-duplicates lst . equal)
116   (let ((equal (and (pair? equal) (car equal))))
117     (let loop ((lst lst))
118       (if (null? lst) '()
119           (if (if equal (member (car lst) (cdr lst) equal)
120                   (member (car lst) (cdr lst)))
121               (loop (cdr lst))
122                 (cons (car lst) (loop (cdr lst))))))))
123
124 (include-from-path "srfi/srfi-1.scm")