|
|
|
@ -23,8 +23,13 @@ |
|
|
|
|
(define (is-not value) (lambda (x) (not (equal? x value)))) |
|
|
|
|
(define (is-not-empty value) (not (null? value))) |
|
|
|
|
|
|
|
|
|
;=============== prepend ====================== |
|
|
|
|
(define (prepend first-value) (lambda (rest) (cons first-value rest))) |
|
|
|
|
|
|
|
|
|
(assert-eq "prepend test failed" |
|
|
|
|
'(1 2 3 4) |
|
|
|
|
((prepend 1) '(2 3 4))) |
|
|
|
|
|
|
|
|
|
;=============== combinators ====================== |
|
|
|
|
(define (Y f) (f (lambda (x) ((Y f) x)))) |
|
|
|
|
(define (Y2 f) (f (lambda (x y) ((Y2 f) x y)))) |
|
|
|
@ -39,17 +44,35 @@ |
|
|
|
|
(if (= a 0) 1 (if (= b 0) 1 (+ (f (- a 1) b) (f a (- b 1)))))))) |
|
|
|
|
3 4)) |
|
|
|
|
|
|
|
|
|
;=============== reduce-right ====================== |
|
|
|
|
(define (reduce-right initial reducer) (Y |
|
|
|
|
(lambda (f) (lambda (values) |
|
|
|
|
(if (null? values) initial (reducer (car values) (f (cdr values)))))))) |
|
|
|
|
|
|
|
|
|
(assert-eq "reduce-right test 1 failed" |
|
|
|
|
'(4 101 3 102 2 103 1 104 0) |
|
|
|
|
((reduce-right '(0) |
|
|
|
|
(lambda (current accumulator) (cons (+ 1 (car accumulator)) (cons current accumulator)))) |
|
|
|
|
'(101 102 103 104))) |
|
|
|
|
|
|
|
|
|
;=============== map ====================== |
|
|
|
|
(define (map mapper) (reduce-right '() |
|
|
|
|
(lambda (current accumulator) (cons (mapper current) accumulator)))) |
|
|
|
|
|
|
|
|
|
(assert-eq "map test 1 failed" |
|
|
|
|
'(1 4 9 16) |
|
|
|
|
((map (lambda (x) (* x x))) |
|
|
|
|
'(1 2 3 4))) |
|
|
|
|
|
|
|
|
|
;=============== map ====================== |
|
|
|
|
(define (concat left right) |
|
|
|
|
((reduce-right right (lambda (current accumulator) (cons current accumulator))) |
|
|
|
|
left)) |
|
|
|
|
|
|
|
|
|
(assert-eq "concat test 1 failed" |
|
|
|
|
'(1 2 3 4 5) |
|
|
|
|
(concat '(1 2) '(3 4 5))) |
|
|
|
|
|
|
|
|
|
;=============== flat ====================== |
|
|
|
|
(define flat (reduce-right '() concat)) |
|
|
|
|
|
|
|
|
@ -57,10 +80,16 @@ |
|
|
|
|
'(1 2 3 4 5 (6 7) 8) |
|
|
|
|
(flat '((1 2) () (3 4) (5 (6 7) 8)))) |
|
|
|
|
|
|
|
|
|
;=============== filter ====================== |
|
|
|
|
(define (filter predicate) (reduce-right '() |
|
|
|
|
(lambda (current accumulator) |
|
|
|
|
(if (predicate current) (cons current accumulator) accumulator)))) |
|
|
|
|
|
|
|
|
|
(assert-eq "filter test 1 failed" |
|
|
|
|
'(2 4 4 2) |
|
|
|
|
((filter (lambda (x) (= (modulo x 2) 0))) |
|
|
|
|
'(1 2 3 4 4 3 2 1))) |
|
|
|
|
|
|
|
|
|
;=============== first ====================== |
|
|
|
|
(define (first predicate) (reduce-right '() |
|
|
|
|
(lambda (current accumulator) |
|
|
|
@ -70,23 +99,98 @@ |
|
|
|
|
'(1 2 3) |
|
|
|
|
((first is-not-empty) '(() (1 2 3)))) |
|
|
|
|
|
|
|
|
|
;=============== coalesce ====================== |
|
|
|
|
(define (coalesce-not-empty default-lazy) (lambda (value) (if (null? value) (default-lazy) value))) |
|
|
|
|
|
|
|
|
|
(assert-eq "coalesce-not-empty test 1 failed" |
|
|
|
|
'(1) |
|
|
|
|
((coalesce-not-empty (lambda () '(1))) '())) |
|
|
|
|
|
|
|
|
|
(assert-eq "coalesce-not-empty test 2 failed" |
|
|
|
|
'(2) |
|
|
|
|
((coalesce-not-empty (lambda () '(1))) '(2))) |
|
|
|
|
|
|
|
|
|
(assert-eq "coalesce-not-empty test 3 failed (wrong result)" |
|
|
|
|
'(2) |
|
|
|
|
((coalesce-not-empty (lambda () (display-ln "coalesce-not-empty test 3 failed (called default-lazy)"))) |
|
|
|
|
'(2))) |
|
|
|
|
|
|
|
|
|
;=============== truthy-chaining ====================== |
|
|
|
|
(define (truthy-chaining f) (lambda (value) (if value (f value) #f))) |
|
|
|
|
|
|
|
|
|
(assert-eq "coalesce-not-empty test 1 failed" |
|
|
|
|
2 |
|
|
|
|
((truthy-chaining (lambda (x) (+ x 1))) 1)) |
|
|
|
|
|
|
|
|
|
(assert-eq "coalesce-not-empty test 2 failed" |
|
|
|
|
#f |
|
|
|
|
((truthy-chaining (lambda (x) (+ x 1))) #f)) |
|
|
|
|
|
|
|
|
|
;=============== compose-two ====================== |
|
|
|
|
(define (compose-two f g) (lambda (x) (f (g x)))) |
|
|
|
|
|
|
|
|
|
(assert-eq "compose-two test 1 failed" |
|
|
|
|
6 |
|
|
|
|
((compose-two |
|
|
|
|
(lambda (x) (* x 2)) |
|
|
|
|
(lambda (x) (+ x 2))) |
|
|
|
|
1)) |
|
|
|
|
|
|
|
|
|
;=============== compose ====================== |
|
|
|
|
(define compose (reduce-right id compose-two)) |
|
|
|
|
|
|
|
|
|
(assert-eq "compose test 1 failed" |
|
|
|
|
'(1 2 3 4) |
|
|
|
|
((compose (list |
|
|
|
|
(prepend 1) |
|
|
|
|
(prepend 2) |
|
|
|
|
(prepend 3))) |
|
|
|
|
'(4))) |
|
|
|
|
|
|
|
|
|
;=============== compose ====================== |
|
|
|
|
(define (combine combiner) |
|
|
|
|
(lambda (a b) (if (null? a) b (if (null? b) a (combiner a b))))) |
|
|
|
|
|
|
|
|
|
(assert-eq "combine test 1 failed" |
|
|
|
|
'(1 3) |
|
|
|
|
((combine (lambda (a b) (list (car a) (car b)))) |
|
|
|
|
'(1 2) |
|
|
|
|
'(3 4))) |
|
|
|
|
|
|
|
|
|
(assert-eq "combine test 1 failed" |
|
|
|
|
'(1 2) |
|
|
|
|
((combine (lambda (a b) (list (car a) (car b)))) |
|
|
|
|
'(1 2) |
|
|
|
|
'())) |
|
|
|
|
|
|
|
|
|
(assert-eq "combine test 1 failed" |
|
|
|
|
'(3 4) |
|
|
|
|
((combine (lambda (a b) (list (car a) (car b)))) |
|
|
|
|
'() |
|
|
|
|
'(3 4))) |
|
|
|
|
|
|
|
|
|
(assert-eq "combine test 1 failed" |
|
|
|
|
'() |
|
|
|
|
((combine (lambda (a b) (list (car a) (car b)))) |
|
|
|
|
'() |
|
|
|
|
'())) |
|
|
|
|
|
|
|
|
|
;=============== sum ====================== |
|
|
|
|
(define sum (reduce-right 0 +)) |
|
|
|
|
|
|
|
|
|
(assert-eq "sum test 1 failed" |
|
|
|
|
6 |
|
|
|
|
(sum '(1 2 3))) |
|
|
|
|
|
|
|
|
|
;=============== repeat ====================== |
|
|
|
|
(define (repeat value) (Y |
|
|
|
|
(lambda (f) (lambda (n) |
|
|
|
|
(if (= n 0) '() (cons value (f (- n 1)))))))) |
|
|
|
|
|
|
|
|
|
(assert-eq "repeat test 1 failed" |
|
|
|
|
'(1 1 1) |
|
|
|
|
((repeat 1) 3)) |
|
|
|
|
|
|
|
|
|
;=============== starts-with ====================== |
|
|
|
|
(define starts-with (Y2 |
|
|
|
|
(lambda (f) (lambda (prefix values) |
|
|
|
|