mes: Add unfold.

* module/srfi/srfi-1.mes (unfold): New function.
This commit is contained in:
Jan Nieuwenhuizen 2018-05-20 13:04:20 +02:00
parent 479a5ef7f1
commit 1cd97f1172
No known key found for this signature in database
GPG Key ID: F3C1A0D9C1D65273
2 changed files with 19 additions and 3 deletions

View File

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
@ -52,8 +52,6 @@
(filter-map f (cdr h) (cdar t))))
(error 'unsupported (cons* "filter-map 3:" f h t))))))
;;; nyacc requirements
(define (fold proc init lst1 . rest)
(if (null? rest)
(let loop ((lst lst1) (result init))
@ -68,6 +66,20 @@
(proc (car lst) (loop (cdr lst)))))
'*FOLD-RIGHT-n-NOT-SUPPORTED))
(define (unfold p f g seed . rest)
(let ((tail-gen (if (null? rest) (const '())
(car rest))))
(define (reverse+tail lst seed)
(let loop ((lst lst)
(result (tail-gen seed)))
(if (null? lst) result
(loop (cdr lst)
(cons (car lst) result)))))
(let loop ((seed seed) (result '()))
(if (p seed) (reverse+tail result seed)
(loop (g seed)
(cons (f seed) result))))))
(define (remove pred lst) (filter (lambda (x) (not (pred x))) lst))
(define (reverse! lst . term)

View File

@ -40,6 +40,10 @@ exit $?
'(1 2 3)
(fold-right cons '() '(1 2 3)))
(pass-if-equal "unfold"
'(4 3 2 1 foo)
(unfold zero? identity 1- 4 (const '(foo))))
(pass-if-equal "remove"
'(1 3)
(remove even? '(1 2 3)))