#lang plai-typed ;; HW 8 solution using PLAI Typed (define-type KCFAE [num (n : number)] [add (lhs : KCFAE) (rhs : KCFAE)] [sub (lhs : KCFAE) (rhs : KCFAE)] [neg (lhs : KCFAE)] [avg (lhs : KCFAE) (mhs : KCFAE) (rhs : KCFAE)] [id (name : symbol)] [fun (params : (listof symbol)) (body : KCFAE)] [app (fun-expr : KCFAE) (arg-exprs : (listof KCFAE))] [if0 (test : KCFAE) (then : KCFAE) (else : KCFAE)] [withcc (name : symbol) (body : KCFAE)] [trycatch (try : KCFAE) (catch : KCFAE)] [throw]) (define-type KCFAE-Value [numV (n : number)] [closureV (params : (listof symbol)) (body : KCFAE) (sc : DefrdSub)] [contV (proc : (KCFAE-Value -> 'a))]) (define-type DefrdSub [mtSub] [aSub (name : symbol) (value : KCFAE-Value) (rest : DefrdSub)]) (define-type KCFAE-Result [numR (n : number)] [functionR]) ;; ---------------------------------------- (define interp : (KCFAE DefrdSub (-> 'a) (KCFAE-Value -> 'a) -> 'a) (lambda (a-fae ds handler k) (type-case KCFAE a-fae [num (n) (k (numV n))] [add (l r) (interp l ds handler (lambda (v1) (interp r ds handler (lambda (v2) (k (num+ v1 v2))))))] [sub (l r) (interp l ds handler (lambda (v1) (interp r ds handler (lambda (v2) (k (num- v1 v2))))))] [neg (l) (interp l ds handler (lambda (v1) (k (num- (numV 0) v1))))] [avg (l m r) (interp l ds handler (lambda (v1) (interp m ds handler (lambda (v2) (interp r ds handler (lambda (v3) (k (numV (/ (+ (+ (numV-n v1) (numV-n v2)) (numV-n v3)) 3)))))))))] [id (name) (k (lookup name ds))] [fun (params body-expr) (k (closureV params body-expr ds))] [app (fun-expr arg-exprs) (interp fun-expr ds handler (lambda (fun-val) (interp-many arg-exprs ds handler (lambda (arg-vals) (type-case KCFAE-Value fun-val [closureV (params body ds) (interp body (add-subs params arg-vals ds) handler k)] [contV (k) (k (first arg-vals))] [else (error 'interp "not a function")])))))] [if0 (test-expr then-expr else-expr) (interp test-expr ds handler (lambda (v) (if (numzero? v) (interp then-expr ds handler k) (interp else-expr ds handler k))))] [withcc (id body-expr) (interp body-expr (aSub id (contV k) ds) handler k)] [trycatch (try-expr catch-expr) (interp try-expr ds (lambda () (interp catch-expr ds handler k)) k)] [throw () (handler)]))) (define interp-many : ((listof KCFAE) DefrdSub (-> 'a) ((listof KCFAE-Value) -> 'a) -> 'a) (lambda (exprs ds handler k) (cond [(empty? exprs) (k empty)] [else (interp (first exprs) ds handler (lambda (v) (interp-many (rest exprs) ds handler (lambda (vals) (k (cons v vals))))))]))) (define add-subs : ((listof symbol) (listof KCFAE-Value) DefrdSub -> DefrdSub) (lambda (syms vals ds) (cond [(empty? syms) ds] [else (add-subs (rest syms) (rest vals) (aSub (first syms) (first vals) ds))]))) (define (num-op [op : (number number -> number)]) : (KCFAE-Value KCFAE-Value -> KCFAE-Value) (lambda (x y) (numV (op (numV-n x) (numV-n y))))) (define num+ (num-op +)) (define num- (num-op -)) (define (numzero? x) (= 0 (numV-n x))) (define (lookup [name : symbol] [ds : DefrdSub]) : KCFAE-Value (type-case DefrdSub ds [mtSub () (error 'lookup "free variable")] [aSub (sub-name num rest-sc) (if (symbol=? sub-name name) num (lookup name rest-sc))])) (define (interp-expr [a-fae : KCFAE]) : KCFAE-Result (type-case KCFAE-Value (interp a-fae (mtSub) (lambda () (error 'interp "unhandled")) (lambda (x) x)) [numV (n) (numR n)] [closureV (param body ds) (functionR)] [contV (k) (functionR)])) ;; ---------------------------------------- (test (interp-expr (num 10)) (numR 10)) (test (interp-expr (add (num 10) (num 7))) (numR 17)) (test (interp-expr (sub (num 10) (num 7))) (numR 3)) (test (interp-expr (app (fun (cons 'x empty) (add (id 'x) (num 12))) (cons (add (num 1) (num 17)) empty))) (numR 30)) (test (interp-expr (app (fun (list 'x) (app (fun (list 'f) (add (app (id 'f) (list (num 1))) (app (fun (list 'x) (app (id 'f) (list (num 2)))) (list (num 3))))) (list (fun (list 'y) (add (id 'x) (id 'y)))))) (list (num 0)))) (numR 3)) (test (interp-expr (withcc 'k (app (id 'k) (list (num 10))))) (numR 10)) (test (interp-expr (withcc 'k (add (app (id 'k) (list (num 10))) (num 17)))) (numR 10)) (test (interp-expr (app (fun (list 'mk-list) (app (fun (list 'list) (if0 (app (id 'list) (list (num 0))) (app (id 'list) (list (num 1))) (app (num 0) (list (app (app (id 'list) (list (num 2))) (list (app (app (app (id 'mk-list) (list (sub (app (id 'list) (list (num 0))) (num 1)))) (list (add (app (id 'list) (list (num 1))) (num 2)))) (list (app (id 'list) (list (num 2))))))))))) (list (withcc 'k (app (app (app (id 'mk-list) (list (num 3))) (list (num 0))) (list (id 'k))))))) (list (fun (list 'a) (fun (list 'b) (fun (list 'c) (fun (list 'sel) (if0 (id 'sel) (id 'a) (if0 (sub (id 'sel) (num 1)) (id 'b) (id 'c)))))))))) (numR 6)) (test (interp-expr (withcc 'k (id 'k))) (functionR)) (test/exn (interp-expr (id 'x)) "free variable") (test/exn (interp-expr (throw)) "unhandled") ;; Check for eager evaluation: (test/exn (interp-expr (app (fun (list 'x) (num 0)) (list (app (num 1) (list (fun (list 'y) (id 'y))))))) "not a function") (test (interp-expr (neg (num 2))) (numR -2)) (test (interp-expr (avg (num 0) (num 6) (num 6))) (numR 4)) (test (interp-expr (withcc 'k (neg (app (id 'k) (list (num 3)))))) (numR 3)) (test (interp-expr (app (fun (list 'x 'y) (sub (id 'y) (id 'x))) (list (num 10) (num 12)))) (numR 2)) (test (interp-expr (fun empty (num 12))) (functionR)) (test (interp-expr (fun (list 'x) (fun empty (id 'x)))) (functionR)) (test (interp-expr (app (app (fun (list 'x) (fun empty (id 'x))) (list (num 13))) empty)) (numR 13)) (test (interp-expr (withcc 'esc (app (fun (list 'x 'y) (id 'x)) (list (num 1) (app (id 'esc) (list (num 3))))))) (numR 3)) (test (interp-expr (app (withcc 'esc (app (fun (list 'x 'y) (fun (list 'z) (add (id 'z) (id 'y)))) (list (num 1) (withcc 'k (app (id 'esc) (list (id 'k))))))) (list (num 10)))) (numR 20)) (test (interp-expr (trycatch (num 7) (num 8))) (numR 7)) (test (interp-expr (trycatch (throw) (num 8))) (numR 8)) (test (interp-expr (trycatch (add (num 1) (throw)) (num 8))) (numR 8)) (test (interp-expr (app (fun (list 'f) (trycatch (app (id 'f) empty) (num 8))) (list (fun empty (throw))))) (numR 8)) (test (interp-expr (trycatch (trycatch (throw) (num 8)) (num 9))) (numR 8)) (test (interp-expr (trycatch (trycatch (throw) (throw)) (num 9))) (numR 9)) (test (interp-expr (trycatch (trycatch (num 7) (throw)) (num 9))) (numR 7)) (test (interp-expr (app (withcc 'esc (trycatch (app (withcc 'k (app (id 'esc) (list (id 'k)))) empty) (fun (list 'x) (num 8)))) (list (fun empty (throw))))) (numR 8))