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

* Added partition

This commit is contained in:
Abdulaziz Ghuloum 2007-09-10 17:28:06 -04:00
parent dd968d389d
commit eeac68352a
4 changed files with 37 additions and 3 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.

37
src/ikarus.lists.ss
View File

@ -2,14 +2,15 @@
(library (ikarus lists) (library (ikarus lists)
(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)
(import (import
(ikarus system $fx) (ikarus system $fx)
(ikarus system $pairs) (ikarus system $pairs)
(except (ikarus) list? list cons* make-list append reverse (except (ikarus) list? list cons* make-list append reverse
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)) map for-each andmap ormap list-tail partition))
(define $memq (define $memq
(lambda (x ls) (lambda (x ls)
@ -814,5 +815,37 @@
[else (error who "improper list")])] [else (error who "improper list")])]
[_ (error who "vararg not supported yet")]))) [_ (error who "vararg not supported yet")])))
(define partition
(letrec ([race
(lambda (h t ls p)
(if (pair? h)
(let ([a0 ($car h)] [h ($cdr h)])
(if (pair? h)
(if (eq? h t)
(error 'partition "circular list ~s" ls)
(let ([a1 ($car h)])
(let-values ([(a* b*) (race ($cdr h) ($cdr t) ls p)])
(if (p a0)
(if (p a1)
(values (cons* a0 a1 a*) b*)
(values (cons a0 a*) (cons a1 b*)))
(if (p a1)
(values (cons a0 a*) (cons a1 b*))
(values a* (cons* a0 a1 b*)))))))
(if (null? h)
(if (p a0)
(values (list a0) '())
(values '() (list a0)))
(error 'parititon "~s is not a proper list" ls))))
(if (null? h)
(values '() '())
(error 'parition "~s is not a proper list" ls))))])
(lambda (p ls)
(unless (procedure? p)
(error 'partition "~s is not a procedure" p))
(race ls ls ls p))))
) )

1
src/makefile.ss
View File

@ -334,6 +334,7 @@
[remove i] [remove i]
[filter i] [filter i]
[find i] [find i]
[partition i]
[list-sort i] [list-sort i]
[vector-sort i] [vector-sort i]
[vector-sort! i] [vector-sort! i]

2
src/todo-r6rs.ss
View File

@ -514,7 +514,7 @@
[memp C ls] [memp C ls]
[memq C ls se] [memq C ls se]
[memv C ls se] [memv C ls se]
[partition S ls] [partition C ls]
[remq C ls] [remq C ls]
[remp C ls] [remp C ls]
[remv C ls] [remv C ls]