various srfi-1 fixes

This commit is contained in:
Alex Shinn 2012-01-22 11:38:49 +09:00
parent 29b461bb44
commit ad46061a5b
6 changed files with 26 additions and 24 deletions

View file

@ -16,7 +16,7 @@
(if (<= n 0) res (lp (- n 1) (cons default res))))))
(define (list-tabulate n proc)
(let lp ((n n) (res '()))
(let lp ((n (- n 1)) (res '()))
(if (< n 0) res (lp (- n 1) (cons (proc n) res)))))
(define (list-copy ls) (reverse! (reverse ls)))

View file

@ -1,5 +1,5 @@
;; deletion.scm -- list deletion utilities
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; Copyright (c) 2009-2012 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (delete x ls . o)
@ -18,8 +18,7 @@
(let ((eq (if (pair? o) (car o) equal?)))
(let lp ((ls ls) (res '()))
(if (pair? ls)
(lp (cdr ls) (if (member (car ls) res) res (cons (car ls) res)))
(lp (cdr ls) (if (member (car ls) res eq) res (cons (car ls) res)))
(reverse! res)))))
(define delete-duplicates! delete-duplicates)

View file

@ -1,5 +1,5 @@
;; fold.scm -- list fold/reduce utilities
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; Copyright (c) 2009-2012 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (fold kons knil ls . lists)
@ -17,7 +17,7 @@
(if (pair? ls) (kons (car ls) (lp (cdr ls))) knil))
(let lp ((lists (cons ls lists)))
(if (every pair? lists)
(apply kons (map-onto car lists (lp (map cdr lists))))
(apply kons (map-onto car lists (list (lp (map cdr lists)))))
knil))))
(define (pair-fold kons knil ls . lists)
@ -32,10 +32,10 @@
(define (pair-fold-right kons knil ls . lists)
(if (null? lists)
(let lp ((ls ls))
(if (pair? ls) (kons (car ls) (lp (cdr ls))) knil))
(if (pair? ls) (kons ls (lp (cdr ls))) knil))
(let lp ((lists (cons ls lists)))
(if (every pair? lists)
(apply kons (append lists (lp (map cdr lists))))
(apply kons (append lists (list (lp (map cdr lists)))))
knil))))
(define (reduce f identity ls)
@ -77,13 +77,13 @@
(define map-in-order map)
(define (pair-for-each f ls . lists)
(apply pair-fold (lambda (x _) (f x)) ls lists))
(apply pair-fold (lambda (x _) (f x)) #f ls lists))
(define (filter-map f ls . lists)
(if (null? lists)
(let lp ((ls ls) (res '()))
(if (pair? ls)
(let ((x (f (car ls)))) (lp (cdr ls) (if f (cons f res) res)))
(let ((x (f (car ls)))) (lp (cdr ls) (if x (cons x res) res)))
(reverse! res)))
(filter (lambda (x) x) (apply map f ls lists))))

View file

@ -1,5 +1,5 @@
;; lset.scm -- list set library
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; Copyright (c) 2009-2012 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (lset<= eq . sets)
@ -18,7 +18,7 @@
(and (apply lset<= eq sets) (apply lset<= eq (reverse sets))))
(define (lset-adjoin eq set . elts)
(lset-union2 eq elts set))
(lset-union2 eq set elts))
(define (lset-union2 eq a b)
(if (null? b)
@ -26,18 +26,19 @@
(lset-union2 eq (if (member (car b) a eq) a (cons (car b) a)) (cdr b))))
(define (lset-union eq . sets)
(reduce (lambda (a b) (lset-union2 eq a b)) '() sets))
(reduce (lambda (a b) (lset-union2 eq b a)) '() sets))
(define (lset-intersection eq . sets)
(reduce (lambda (a b) (filter (lambda (x) (member x b eq)) a)) '() sets))
(reduce (lambda (a b) (filter (lambda (x) (member x a eq)) b)) '() sets))
(define (lset-diff2 eq a b)
(remove (lambda (x) (member x a eq)) b))
(define (lset-difference eq . sets)
(reduce (lambda (a b) (remove (lambda (x) (member x b eq)) a)) '() sets))
(reduce (lambda (a b) (lset-diff2 eq a b)) '() sets))
(define (lset-xor eq . sets)
(reduce (lambda (a b)
(append (filter (lambda (x) (member x b eq)) a)
(filter (lambda (x) (member x a eq)) b)))
(reduce (lambda (a b) (append (lset-diff2 eq a b) (lset-diff2 eq b a)))
'()
sets))

View file

@ -1,5 +1,5 @@
;; misc.scm -- miscellaneous list utilities
;; Copyright (c) 2009-2011 Alex Shinn. All rights reserved.
;; Copyright (c) 2009-2012 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (map-onto proc ls init)
@ -17,7 +17,7 @@
'()
(let lp ((ls lists))
(cond ((not (pair? (cdr ls)))
lists)
(car lists))
(else
(set-cdr! (last-pair (car ls)) (cadr ls))
(lp (cdr ls)))))))
@ -51,4 +51,3 @@
(if (every pair? lists)
(lp (map cdr lists) (if (apply pred (map car lists)) (+ res 1) res))
res))))

View file

@ -18,7 +18,9 @@
(test '(0 1 2 3) (list-tabulate 4 values))
(test '(z q z q z q) (take (circular-list 'z 'q) 6))
(test '(0 1 2 3 4) (iota 5))
(test '(0 -0.1 -0.2 -0.3 -0.4) (iota 5 0 -0.1))
(test '(0 -0.1 -0.2 -0.3 -0.4)
(let ((res (iota 5 0 -0.1)))
(cons (inexact->exact (car res)) (cdr res))))
(test '#t (pair? '(a . b)))
(test '#t (pair? '(a b c)))
(test '#f (pair? '()))
@ -72,6 +74,7 @@
(test '(c 3 b 2 a 1) (fold cons* '() '(a b c) '(1 2 3 4 5)))
(test '(a 1 b 2 c 3) (fold-right cons* '() '(a b c) '(1 2 3 4 5)))
(test '((a b c) (b c) (c)) (pair-fold-right cons '() '(a b c)))
(test '((a b c) (1 2 3) (b c) (2 3) (c) (3)) (pair-fold-right cons* '() '(a b c) '(1 2 3)))
(test '(b e h) (map cadr '((a b) (d e) (g h))))
(test '(1 4 27 256 3125) (map (lambda (n) (expt n n)) '(1 2 3 4 5)))
(test '(5 7 9) (map + '(1 2 3) '(4 5 6)))
@ -94,7 +97,7 @@
(test '#t (any even? '(1 2 3)))
(test '#f (find even? '(1 7 3)))
(test '#f (any even? '(1 7 3)))
(test-error (find even? '(1 3 . x)))
;(test-error (find even? '(1 3 . x)))
(test-error (any even? '(1 3 . x)))
;(test 'error/undefined (find even? '(1 2 . x)))
;(test 'error/undefined (any even? '(1 2 . x))) ; success, error or other
@ -148,7 +151,7 @@
(test '(a b c) (lset-intersection eq? '(a b c)))
(test '(b c d) (lset-difference eq? '(a b c d e) '(a e i o u)))
(test '(a b c) (lset-difference eq? '(a b c)))
(test '(d c b i o u) (lset-xor eq? '(a b c d e) '(a e i o u)))
(test #t (lset= eq? '(d c b i o u) (lset-xor eq? '(a b c d e) '(a e i o u))))
(test '() (lset-xor eq?))
(test '(a b c d e) (lset-xor eq? '(a b c d e)))
(let ((f (lambda () (list 'not-a-constant-list)))