;; Solution to midterm 2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Problem 1 (define file->chars (lambda (filename) (with-input-from-file filename (letrec ((loop (lambda () (if (eof-object? (peek-char)) '() (cons (read-char) (loop)))))) loop)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Problem 2 (define letter? (lambda (c) (or (and (char>=? c #\a) (char<=? c #\z)) (and (char>=? c #\A) (char<=? c #\Z))))) (define make-special-token (lambda (c) (case c [(#\.) 'dot] [(#\() 'open-paren] [(#\)) 'close-paren] [(#\[) 'open-brak] [(#\]) 'close-brak]))) (define make-keyword-token (lambda () 'lambda)) (define make-var-token (lambda (chars) (letrec ((loop (lambda (chars acc) (if (and (not (null? chars)) (letter? (car chars))) (loop (cdr chars) (cons (car chars) acc)) (cons (cons 'VARIABLE (string->symbol (list->string (reverse acc)))) (chars->tokens chars)))))) (loop chars '())))) (define chars->tokens (lambda (chars) (if (null? chars) '() (case (car chars) [(#\( #\) #\. #\[ #\]) (cons (make-special-token (car chars)) (chars->tokens (cdr chars)))] [(#\space) (chars->tokens (cdr chars))] [(#\L) (cons (make-keyword-token) (chars->tokens (cdr chars)))] [else (make-var-token chars)])))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Problem 3 (define parse (lambda (toks) (let* ((r (parse-exp toks)) (tree (car r)) (rest (cdr r))) (if (null? rest) tree (error 'parse "Bad"))))) (define parse-exp (lambda (toks) (let* ((tok (car toks)) (toks (cdr toks))) (case tok [(open-brak) (let ((lam (car toks)) (id (cadr toks)) (dot (caddr toks)) (toks (cdddr toks))) (if (and (eq? lam 'lambda) (eq? (car id) 'VARIABLE) (eq? dot 'dot)) (let* ((r (parse-exp toks)) (body (car r)) (toks (cdr r))) (if (eq? (car toks) 'close-brak) (cons (make-lambda-exp (cdr id) body) (cdr toks)) (error 'parse "Bad"))) (error 'parse "Bad")))] [(open-paren) (let* ((r1 (parse-exp toks)) (fun (car r1)) (toks (cdr r1)) (r2 (parse-exp toks)) (arg (car r2)) (toks (cdr r2)) (close (car toks)) (toks (cdr toks))) (if (eq? close 'close-paren) (cons (make-application-exp fun arg) toks) (error 'parse "Bad")))] [else (cons (make-var-exp (cdr tok)) toks)])))) (define make-var-exp (lambda (id) id)) (define make-lambda-exp (lambda (id exp) `(lambda (,id) ,exp))) (define make-application-exp (lambda (e1 e2) `(,e1 ,e2))) (define var-exp? symbol?) (define lambda-exp? (lambda (obj) (and (pair? obj) (eq? (car obj) 'lambda)))) (define application-exp? (lambda (obj) (and (pair? obj) (= (length obj) 2)))) (define var-exp->name (lambda (obj) obj)) (define lambda-exp->id (lambda (obj) (caadr obj))) (define lambda-exp->body (lambda (obj) (caddr obj))) (define application-exp->function car) (define application-exp->argument cadr) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Problem 4 (define empty-env '()) (define lookup (lambda (env id) (if (null? env) (error 'lookup "Unbound variable ~s~n" id) (if (eq? (caar env) id) (cdar env) (lookup (cdr env) id))))) (define extend-environment (lambda (env p a) (cons (cons p a) env))) (define make-closure list) (define closure->parameter car) (define closure->body cadr) (define closure->env caddr) (define evaluate (lambda (code env) (cond [(var-exp? code) (lookup env (var-exp->name code))] [(lambda-exp? code) (make-closure (lambda-exp->id code) (lambda-exp->body code) env)] [(application-exp? code) (let ((closure (evaluate (application-exp->function code) env)) (argument (evaluate (application-exp->argument code) env))) (let ((parameter (closure->parameter closure)) (body (closure->body closure)) (env (closure->env closure))) (evaluate body (extend-environment env parameter argument))))]))) (define go (lambda (filename) (evaluate (parse (chars->tokens (file->chars filename))) empty-env))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Extra credit (define new-stack (lambda () (let ((contents '())) (lambda (msg) (case msg [(empty?) (null? contents)] [(push) (lambda (val) (set! contents (cons val contents)) (void))] [(pop) (if (null? contents) (error 'pop "Cannot pop from empty stack") (let ((top (car contents))) (set! contents (cdr contents)) top))]))))) (define empty-stack? (lambda (stack) (stack 'empty?))) (define push-stack (lambda (stack val) ((stack 'push) val) stack)) (define pop-stack (lambda (stack) (stack 'pop))) ;;; (define make-queue (lambda () (let ((stack1 (new-stack)) (stack2 (new-stack))) (lambda (msg) (case msg [(empty?) (and (empty-stack? stack1) (empty-stack? stack2))] [(enqueue) (lambda (val) (push-stack stack1 val))] [(dequeue) (if (empty-stack? stack2) (letrec ((loop (lambda () (if (empty-stack? stack1) (pop-stack stack2) (begin (push-stack stack2 (pop-stack stack1)) (loop)))))) (loop)) (pop-stack stack2))]))))) (define empty-queue? (lambda (queue) (queue 'empty?))) (define enqueue (lambda (queue val) ((queue 'enqueue) val) queue)) (define dequeue (lambda (queue) (queue 'dequeue)))