#lang scheme (require racket/trace) (define-namespace-anchor anch) (define ns (namespace-anchor->namespace anch)) ;;; Append two lists (define (append2 a b) (cond ((null? a) b) (else (cons (car a) (append2 (cdr a) b))) ) ) ;;; Append arbitrary list of lists (define (my-append . args) (display args) (newline) (cond ((null? args) args) (else (append2 (car args) (apply my-append (cdr args))) ) ) ) ;;; Implementation of apply (define (my-apply1 f args) (define (quote-all lst) (cond ((null? lst) '()) (else (cons `(quote ,(car lst)) (quote-all (cdr lst)) ) ) ) ) (display (quote-all args)) (newline) (eval (cons f (quote-all args))) ) (define (my-apply f . args) (display args) (newline) (define (append-last lst) (cond ((null? (cdr lst)) (car lst)) (else (cons (car lst) (append-last (cdr lst))) ) ) ) (display (append-last args)) (newline) (my-apply1 f (append-last args)) ) ;;; Implementation of compose (define (compose1 f g) (lambda args (f (apply g args)) ) ) ;;; Implementation of map (define (map1 f lst) (cond ((null? lst) '()) (else (cons (f (car lst)) (map1 f (cdr lst)) ) ) ) ) (define (my-map f . args) (cond ((null? (car args)) '()) (else (cons (apply f (map1 car args)) (apply my-map (cons f (map1 cdr args)) ) ) ) ) ) ;;; Reduce (define (reduce f lst) (cond ((null? (cdr lst)) (car lst)) (else (f (car lst) (reduce f (cdr lst)))) ) ) ;;; Implementation of foldr (define (my-foldr f a lst) (display (list a lst)) (newline) (cond ((null? lst) a) (else (f (car lst) (my-foldr f a (cdr lst)) ) ) ) ) ;;; Implementation of foldl (define (my-foldl f a lst) (display (list a lst)) (newline) (cond ((null? lst) a) (else (my-foldl f (f (car lst) a) (cdr lst)) ) ) ) (define (my-append22 a b) (my-foldr cons b a) ;(my-foldl (lambda (x y) (append y (list x))) a b) ) (define (my-append2 . args) (my-foldr my-append22 '() args) ) (define (my-map3 f lst) (my-foldr (lambda (x y) (cons (f x) y)) '() lst) ) (define (swapargs f) (lambda (x y) (f y x)) ) ;;; Every and some (define (every1 pred lst) (cond ((null? lst) #t) (else (and (pred (car lst)) (every1 pred (cdr lst))) ) ) ) (define (some1 pred lst) (not (every1 (lambda (x) (not (pred x))) lst)) ) ;;; Combined examples (define (sum-numbers lst) (foldr + 0 (filter number? lst)) ) (define (some2 pred lst) (my-foldl (trace-lambda (x y) (or y (pred x))) #f lst) ) (define (my-flatten lst) (if (not (list? lst)) (list lst) (apply append (map my-flatten lst)) ) ) (define (L2 lst) (sqrt (foldr + 0 (map (lambda (x) (* x x)) lst))) ) (define (my-filter pred lst) (foldr (lambda (x y) (if (pred x) (cons x y) y)) '() lst) ) ;;; Other examples (define (cartesian-product lst1 lst2) (apply append (map (lambda (x) (map (lambda (y) (list x y)) lst2)) lst1) ) ) (define (inner-join lst1 lst2) (map (lambda (x) (map cadr x)) (filter (lambda (x) (eqv? (caar x) (caadr x))) (cartesian-product lst1 lst2)) ) ) (define (aggregate pred f lst) (cond ((null? lst) '()) (else (let ((selected (filter (lambda (x) (pred x (car lst))) lst)) (rest (filter (lambda (x) (not (pred x (car lst)))) lst))) (cons (f selected) (aggregate pred f rest)) ) ) ) ) ;;; Tests (define (assert-equal x y) (let ((vx (eval x ns))) (if (equal? vx y) (display (list x "=" vx ", expected " y ", Ok")) (display (list x "=" vx ", expected " y ", Wrong")) ) (newline) ) ) (assert-equal '(my-append '(a b c) '(d e) '(f g h)) '(a b c d e f g h)) (assert-equal '(my-apply1 append '((a b c) (d e) (f g h))) '(a b c d e f g h)) (assert-equal '(my-apply + 1 2 3 '(4 5)) 15) (assert-equal '((compose1 (lambda (x) (* x x)) +) 3 4) 49) (assert-equal '(map1 sqrt '(1 2 3)) (list 1 (sqrt 2) (sqrt 3))) (assert-equal '(my-map + '(1 2 3) '(4 5 6)) '(5 7 9)) (assert-equal '(my-foldr / 1 '(1 2 3)) (/ 1 (/ 2 (/ 3 1)))) (assert-equal '(my-foldl / 2 '(1 2 3)) (/ 3 (/ 2 (/ 1 2)))) (assert-equal '(my-append22 '(a b c) '(d e)) '(a b c d e)) (assert-equal '(my-append2 '(a b) '(c) '(d e)) '(a b c d e)) (assert-equal '((swapargs cons) 'a 'b) '(b . a)) (assert-equal '(every1 even? '(2 4 6)) #t) (assert-equal '(every1 even? '(2 4 -3 6)) #f) (assert-equal '(some1 odd? '(2 4 6)) #f) (assert-equal '(some1 odd? '(2 4 -3 6)) #t) (assert-equal '(sum-numbers '(1 a b 5 c)) 6) (assert-equal '(some2 (lambda (x) (begin (display "hi") (number? x))) '(a b 1 c d)) #t) (assert-equal '(my-flatten '(1 ((2 3) () 4))) '(1 2 3 4)) (assert-equal '(L2 '(1 1 1)) (sqrt 3)) (assert-equal '(my-filter number? '(a 1 b 2)) '(1 2)) (assert-equal '(cartesian-product '(1 2 3) '(a b)) '((1 a) (1 b) (2 a) (2 b) (3 a) (3 b))) (assert-equal '(inner-join '((1 "Chuck") (2 "John") (3 "Britney")) '((2 "Lennon") (3 "Spears") (4 "Travolta"))) '(("John" "Lennon") ("Britney" "Spears"))) (assert-equal '(aggregate eqv? (lambda (lst) (cons (car lst) (length lst))) '(a a b c c b a)) '((a . 3) (b . 2) (c . 2))) (define (pred x y) (eqv? (car x) (car y))) (define (f lst) (list (caar lst) (/ (apply + (map cadr lst)) (length lst))) ) (assert-equal '(aggregate pred f '((a 3) (a 5) (b 1) (c 2) (c 1) (b 4) (a 1))) '((a 3) (b 5/2) (c 3/2)))