conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* Added fold-left and fold-right.

This commit is contained in:
Abdulaziz Ghuloum 2007-10-10 06:43:25 -04:00
parent 995944723d
commit b24ce124b2
5 changed files with 163 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

136
src/ikarus.lists.ss
View File

@ -3,7 +3,7 @@
(export $memq list? list cons* make-list append length list-ref reverse (export $memq list? list cons* make-list append length list-ref reverse
last-pair memq memp memv member find assq assp assv assoc last-pair memq memp memv member find assq assp assv assoc
remq remv remove remp filter map for-each andmap ormap list-tail remq remv remove remp filter map for-each andmap ormap list-tail
partition for-all exists) partition for-all exists fold-left fold-right)
(import (import
(ikarus system $fx) (ikarus system $fx)
(ikarus system $pairs) (ikarus system $pairs)
@ -11,7 +11,7 @@
last-pair length list-ref memq memp memv member find last-pair length list-ref memq memp memv member find
assq assp assv assoc remq remv remove remp filter assq assp assv assoc remq remv remove remp filter
map for-each andmap ormap list-tail partition map for-each andmap ormap list-tail partition
for-all exists)) for-all exists fold-left fold-right))
(define $memq (define $memq
(lambda (x ls) (lambda (x ls)
@ -934,5 +934,137 @@
(define-iterator for-all and) (define-iterator for-all and)
(define-iterator exists or) (define-iterator exists or)
(module (fold-left)
(define who 'fold-left)
(define (null*? ls)
(or (null? ls) (and (null? (car ls)) (null*? (cdr ls)))))
(define (err* ls*)
(if (null? ls*)
(error who "length mismatch")
(if (list? (car ls*))
(err* (cdr ls*))
(error who "~s is not a proper list" (car ls*)))))
(define (cars+cdrs ls ls*)
(cond
[(null? ls) (values '() '())]
[else
(let ([a (car ls)])
(if (pair? a)
(let-values ([(cars cdrs) (cars+cdrs (cdr ls) (cdr ls*))])
(values (cons (car a) cars) (cons (cdr a) cdrs)))
(if (list? (car ls*))
(error who "length mismatch")
(error who "~s is not a proper list" (car ls*)))))]))
(define (loop1 f nil h t ls)
(if (pair? h)
(let ([a (car h)] [h (cdr h)])
(if (pair? h)
(if (eq? h t)
(error who "~s is circular" ls)
(let ([b (car h)] [h (cdr h)] [t (cdr t)])
(loop1 f (f (f nil a) b) h t ls)))
(if (null? h)
(f nil a)
(error who "~s is not a proper list" ls))))
(if (null? h)
nil
(error who "~s is not a proper list" ls))))
(define (loopn f nil h h* t ls ls*)
(if (pair? h)
(let-values ([(a* h*) (cars+cdrs h* ls*)])
(let ([a (car h)] [h (cdr h)])
(if (pair? h)
(if (eq? h t)
(error who "~s is circular" ls)
(let-values ([(b* h*) (cars+cdrs h* ls*)])
(let ([b (car h)] [h (cdr h)] [t (cdr t)])
(loopn f
(apply f (apply f nil a a*) b b*)
h h* t ls ls*))))
(if (and (null? h) (null*? h*))
(apply f nil a a*)
(err* (cons ls ls*))))))
(if (and (null? h) (null*? h*))
nil
(err* (cons ls ls*)))))
(define fold-left
(case-lambda
[(f nil ls)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(loop1 f nil ls ls ls)]
[(f nil ls . ls*)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(loopn f nil ls ls* ls ls ls*)])))
(module (fold-right)
(define who 'fold-right)
(define (null*? ls)
(or (null? ls) (and (null? (car ls)) (null*? (cdr ls)))))
(define (err* ls*)
(if (null? ls*)
(error who "length mismatch")
(if (list? (car ls*))
(err* (cdr ls*))
(error who "~s is not a proper list" (car ls*)))))
(define (cars+cdrs ls ls*)
(cond
[(null? ls) (values '() '())]
[else
(let ([a (car ls)])
(if (pair? a)
(let-values ([(cars cdrs) (cars+cdrs (cdr ls) (cdr ls*))])
(values (cons (car a) cars) (cons (cdr a) cdrs)))
(if (list? (car ls*))
(error who "length mismatch")
(error who "~s is not a proper list" (car ls*)))))]))
(define (loop1 f nil h t ls)
(if (pair? h)
(let ([a (car h)] [h (cdr h)])
(if (pair? h)
(if (eq? h t)
(error who "~s is circular" ls)
(let ([b (car h)] [h (cdr h)] [t (cdr t)])
(f a (f b (loop1 f nil h t ls)))))
(if (null? h)
(f a nil)
(error who "~s is not a proper list" ls))))
(if (null? h)
nil
(error who "~s is not a proper list" ls))))
(define (loopn f nil h h* t ls ls*)
(if (pair? h)
(let-values ([(a* h*) (cars+cdrs h* ls*)])
(let ([a (car h)] [h (cdr h)])
(if (pair? h)
(if (eq? h t)
(error who "~s is circular" ls)
(let-values ([(b* h*) (cars+cdrs h* ls*)])
(let ([b (car h)] [h (cdr h)] [t (cdr t)])
(apply f a
(append a*
(list
(apply f
b (append b*
(list (loopn f nil h h* t ls ls*))))))))))
(if (and (null? h) (null*? h*))
(apply f a (append a* (list nil)))
(err* (cons ls ls*))))))
(if (and (null? h) (null*? h*))
nil
(err* (cons ls ls*)))))
(define fold-right
(case-lambda
[(f nil ls)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(loop1 f nil ls ls ls)]
[(f nil ls . ls*)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(loopn f nil ls ls* ls ls ls*)]
)))
) )

4
src/makefile.ss
View File

@ -933,8 +933,8 @@
[cons* i r ls] [cons* i r ls]
[filter i r ls] [filter i r ls]
[find i r ls] [find i r ls]
[fold-left r ls] [fold-left i r ls]
[fold-right r ls] [fold-right i r ls]
[for-all i r ls] [for-all i r ls]
[exists i r ls] [exists i r ls]
[member i r ls se] [member i r ls se]

26
src/tests/lists.ss
View File

@ -15,5 +15,29 @@
[values (equal? (for-all cons '(1 2 3) '(a b c)) '(3 . c))] [values (equal? (for-all cons '(1 2 3) '(a b c)) '(3 . c))]
[values (equal? (for-all (lambda (a b) (= a 1)) '(1 2 3) '(a b c)) #f)] [values (equal? (for-all (lambda (a b) (= a 1)) '(1 2 3) '(a b c)) #f)]
[values (equal? (for-all (lambda (a b) (= a 1)) '(1 2) '(a b c)) #f)] [values (equal? (for-all (lambda (a b) (= a 1)) '(1 2) '(a b c)) #f)]
[values (equal? (fold-left + 0 '(1 2 3 4 5)) 15)]
[values (equal? (fold-left (lambda (a b) (cons b a)) '() '(1 2 3 4 5))
'(5 4 3 2 1))]
[values (equal? (fold-left (lambda (count x)
(if (odd? x)
(+ count 1)
count))
0
'(3 1 4 1 5 9 2 6 5 3))
7)]
[values (equal? (fold-left cons '(q) '(a b c)) '((((q) . a) . b) . c))]
[values (equal? (fold-left + 0 '(1 2 3) '(4 5 6)) 21)]
[values (equal? (fold-right + 0 '(1 2 3 4 5)) 15)]
[values (equal? (fold-right cons '() '(1 2 3 4 5))
'(1 2 3 4 5))]
[values (equal? (fold-right (lambda (x l)
(if (odd? x)
(cons x l)
l))
'()
'(3 1 4 1 5 9 2 6 5 3))
'(3 1 1 5 9 5 3))]
[values (equal? (fold-right + 0 '(1 2 3) '(4 5 6)) 21)]
)) ))

4
src/todo-r6rs.ss
View File

@ -510,8 +510,8 @@
[cons* C ls] [cons* C ls]
[filter C ls] [filter C ls]
[find C ls] [find C ls]
[fold-left S ls] [fold-left C ls]
[fold-right S ls] [fold-right C ls]
[for-all C ls] [for-all C ls]
[exists C ls] [exists C ls]
[member C ls se] [member C ls se]