diff --git a/module/srfi/srfi-1.mes b/module/srfi/srfi-1.mes index 58de5b08..c305302e 100644 --- a/module/srfi/srfi-1.mes +++ b/module/srfi/srfi-1.mes @@ -1,7 +1,7 @@ ;;; -*-scheme-*- ;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen +;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen ;;; ;;; 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) diff --git a/tests/srfi-1.test b/tests/srfi-1.test index 3778b7ec..c5fd1443 100755 --- a/tests/srfi-1.test +++ b/tests/srfi-1.test @@ -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)))