;; CS320 Spring 2006 Homework 1 Solution ;; ;; Distribution without permission is prohibited and is a violation of U.S. ;; Copyright Law. Submitting this solution as your own work whether in part ;; or as a whole also violates Academic Code of Conduct. (define (fold-right f init xs) (if (null? xs) init (f (car xs) (fold-right f init (cdr xs))))) (define (fold-left f init xs) (if (null? xs) init (fold-left f (f init (car xs)) (cdr xs)))) ;; Problem 1 (define (average-time xs) (let loop ((sum 0) (items 0) (xs xs)) (if (null? xs) (/ sum items) (let* ((pair (car xs)) (ys (cdr xs)) (data (cdr pair))) (loop (+ sum data) (+ items 1) ys)) ) ) ) ;; Problem 2 ;; forall? returns true if, given some predicate p, all elements of xs ;; applied to p returns true. (define (forall? p xs) (fold-left (lambda (res x) (and res (p x))) #t xs)) ;; we proceed by forming a list that consists solely of the names, ;; isolate the first name, and see if the rest of the names are ;; equal to it. (define (all-equal? xs) (if (null? xs) (error "applied on an empty list.") (let* ((vs (map cdr xs)) (v (car vs))) (forall? (lambda (u) (equal? u v)) (cdr vs))))) ;; this function counts the number of elements equal to x. (define (count-occurrences x xs) (fold-left (lambda (res y) (if (equal? x y) (+ res 1) res)) 0 xs)) ;; we proceed by verifying if all names occur exactly once. there ;; are more efficient ways to implement the all-different? function, ;; but negating the result of all-equal? doesn't work. (define (all-different? xs) (if (null? xs) (error "applied on an empty list.") (let ((vs (map cdr xs))) (forall? (lambda (v) (= (count-occurrences v vs) 1)) vs)))) ;; Problem 3 ;; given an ordering predicate leq?, mergesort returns xs in sorted ;; order using the algorithm mergesort. (define (mergesort leq? xs) (define (merge xs ys) (cond ((null? xs) ys) ((null? ys) xs) (else (if (leq? (car xs) (car ys)) (cons (car xs) (merge (cdr xs) ys)) (cons (car ys) (merge xs (cdr ys))))) ) ) (define (divide k xs) (let loop ((xs xs) (lefts '()) (rights '())) (if (null? xs) (k lefts rights) (loop (cdr xs) (cons (car xs) rights) lefts)))) (letrec ((conquor (lambda (xs ys) (if (or (null? xs) (null? (cdr xs))) (merge xs ys) (merge (divide conquor xs) (divide conquor ys)))))) (divide conquor xs)) ) ;; then we customize the mergesort function by passing an appropriate ;; predicate. (define (mergesort-by-time xs) (mergesort (lambda (p1 p2) (<= (cdr p1) (cdr p2))) xs)) (define (mergesort-by-name xs) (define (symbol<=? s1 s2) (string<=? (symbol->string s1) (symbol->string s2))) (mergesort (lambda (p1 p2) (symbol<=? (car p1) (car p2))) xs)) ;; Problem 4 (define (median-time xs) (let ((double-xs-sorted (mergesort-by-time (append xs xs)))) (let scan ((xs xs) (ys double-xs-sorted)) (if (null? xs) (cdr (car ys)) (scan (cdr xs) (cdr ys)))))) ;; Problem 5 (define (assign-medals xs) (define (medal-of-time t) (cond ((< t 10) 'gold) ((< t 11) 'silver) ((< t 12) 'bronze) ((< t 14) 'athletic) ((< t 18) 'good-effort) (else 'best-courage))) (map (lambda (p) (cons (car p) (medal-of-time (cdr p)))) xs) ) ;; Problem 6 ;; the procedure filter returns all elements in xs that satisfies ;; predicate p, as a list. (define (filter p xs) (fold-right (lambda (x res) (if (p x) (cons x res) res)) () xs)) (define (select-by-medal xs medal) (map car (filter (lambda (p) (eq? (cdr p) medal)) (assign-medals xs))))