fixing corner cases in pair-fold, alist-delete and reduce-right

This commit is contained in:
Alex Shinn 2017-08-24 21:27:08 +09:00
parent 1c3f2bd6d5
commit 32bd7fbad6
2 changed files with 7 additions and 5 deletions

View file

@ -8,7 +8,7 @@
(define (alist-delete key ls . o) (define (alist-delete key ls . o)
(let ((eq (if (pair? o) (car o) equal?))) (let ((eq (if (pair? o) (car o) equal?)))
(remove (lambda (x) (eq (car x) key)) ls))) (remove (lambda (x) (eq key (car x))) ls)))
(define alist-delete! alist-delete) (define alist-delete! alist-delete)

View file

@ -42,7 +42,7 @@
(if (null? ls) identity (fold f (car ls) (cdr ls)))) (if (null? ls) identity (fold f (car ls) (cdr ls))))
(define (reduce-right f identity ls) (define (reduce-right f identity ls)
(if (null? ls) identity (fold-right f (car ls) (cdr ls)))) (if (null? ls) identity (fold-right f identity ls)))
(define (unfold p f g seed . o) (define (unfold p f g seed . o)
(let lp ((seed seed)) (let lp ((seed seed))
@ -77,14 +77,16 @@
(define map-in-order map) (define map-in-order map)
(define (pair-for-each f ls . lists) (define (pair-for-each f ls . lists)
(apply pair-fold (lambda (x _) (f x)) #f ls lists)) (if (pair? lists)
(apply pair-fold (lambda args (apply f (drop-right args 1))) #f ls lists)
(pair-fold (lambda (x _) (f x)) #f ls)))
(define (filter-map f ls . lists) (define (filter-map f ls . lists)
(if (null? lists) (if (null? lists)
(let lp ((ls ls) (res '())) (let lp ((ls ls) (res '()))
(if (pair? ls) (if (pair? ls)
(let ((x (f (car ls)))) (lp (cdr ls) (if x (cons x res) res))) (let ((x (f (car ls)))) (lp (cdr ls) (if x (cons x res) res)))
(reverse! res))) (reverse res)))
(filter (lambda (x) x) (apply map f ls lists)))) (filter (lambda (x) x) (apply map f ls lists))))
(define (take-up-to-reverse from to init) (define (take-up-to-reverse from to init)
@ -97,7 +99,7 @@
(let ((tail (find-tail pred ls))) (let ((tail (find-tail pred ls)))
(if tail (if tail
(lp (cdr tail) (take-up-to-reverse ls tail rev)) (lp (cdr tail) (take-up-to-reverse ls tail rev))
(if (pair? rev) (append-reverse! rev ls) ls))))) (if (pair? rev) (append-reverse rev ls) ls)))))
(define (filter pred ls) (remove (lambda (x) (not (pred x))) ls)) (define (filter pred ls) (remove (lambda (x) (not (pred x))) ls))