diff --git a/07-bae/main.rkt b/07-bae/main.rkt new file mode 100644 index 0000000..a48046f --- /dev/null +++ b/07-bae/main.rkt @@ -0,0 +1,336 @@ +#lang pl 04 + +; I added functions. + +#| CFG for the BAE language: + ::= + + | { + ... } + | { * ... } + | { - ... } + | { / ... } + | { = } + | { < } + | { <= } + | { with { } } + | { if } + | { if then else } -- Sugar. + | { and } -- Sugar. + | { or } -- Sugar. + | { not } -- Sugar. + | { lambda } + | { of } + | +|# + +;; BAE abstract syntax trees +(define-type BAE + [Num Number] + [Bool Boolean] + [Sum (Listof BAE)] + [Mul (Listof BAE)] + [Sub BAE (Listof BAE)] + [Div BAE (Listof BAE)] + [Eq BAE BAE] + [Lt BAE BAE] + [Lte BAE BAE] + [With Symbol BAE BAE] + [If BAE BAE BAE] + [Lambda Symbol BAE] + [Call BAE BAE] + [Id Symbol]) + +(define-type LambdaContents + [Par Symbol] + [Body BAE]) + +(define-type Primitive = (U Number Boolean (Listof LambdaContents))) + +(define reserved-names (list 'F 'T '+ '* '- '/ '= '< '<= 'with 'if 'then 'else 'lambda 'λ 'of)) + +(define pf (Bool #f)) +(define pt (Bool #t)) + +(: parse-sexpr : Sexpr -> BAE) +;; parses s-expressions into BAEs +(define (parse-sexpr sexpr) + ;; utility for parsing a list of expressions + (: parse-sexprs : (Listof Sexpr) -> (Listof BAE)) + (define (parse-sexprs sexprs) + (map parse-sexpr sexprs)) + (match sexpr + [(number: n) (Num n)] + ['T (Bool #t)] + ['F (Bool #f)] + [(list '+ args ...) (Sum (parse-sexprs args))] + [(list '* args ...) (Mul (parse-sexprs args))] + [(list '- fst args ...) (Sub (parse-sexpr fst) (parse-sexprs args))] + [(list '/ fst args ...) (Div (parse-sexpr fst) (parse-sexprs args))] + [(list '= l r) (Eq (parse-sexpr l) (parse-sexpr r))] + [(list '< l r) (Lt (parse-sexpr l) (parse-sexpr r))] + [(list '<= l r) (Lte (parse-sexpr l) (parse-sexpr r))] + [(cons 'with more) + (match sexpr + [(list 'with (list (symbol: name) named) body) + (With name (parse-sexpr named) (parse-sexpr body))] + [else (error 'parse-sexpr "bad `with' syntax in ~s" sexpr)])] + [(list 'if p b a) (If (parse-sexpr p) (parse-sexpr b) (parse-sexpr a))] + [(list 'if p 'then b 'else a) (If (parse-sexpr p) (parse-sexpr b) (parse-sexpr a))] + [(list 'and a b) (If (parse-sexpr a) (If (parse-sexpr b) pt pf) pf)] + [(list 'or a b) (If (parse-sexpr a) pt (If (parse-sexpr b) pt pf))] + [(list 'not a) (If (parse-sexpr a) pf pt)] + [(list 'lambda (symbol: arg) body) (Lambda arg (parse-sexpr body))] + [(list f 'of arg) (Call (parse-sexpr f) (parse-sexpr arg))] + [(symbol: name) (Id name)] + [else (error 'parse-sexpr "bad syntax in ~s" sexpr)])) + +(: parse : String -> BAE) +;; parses a string containing an BAE expression to an BAE AST +(define (parse str) + (parse-sexpr (string->sexpr str))) + +(: subst : BAE Symbol BAE -> BAE) +;; substitutes the second argument with the third argument in the +;; first argument, as per the rules of substitution; the resulting +;; expression contains no free instances of the second argument +(define (subst expr from to) + ;; convenient helper -- no need to specify `from' and `to' + (: subst* : BAE -> BAE) + (define (subst* x) + (subst x from to)) + ;; helper to substitute lists + (: substs* : (Listof BAE) -> (Listof BAE)) + (define (substs* exprs) + (map subst* exprs)) + (cases expr + [(Num n) expr] + [(Bool p) expr] + [(Sum args) (Sum (substs* args))] + [(Mul args) (Mul (substs* args))] + [(Sub fst args) (Sub (subst* fst) (substs* args))] + [(Div fst args) (Div (subst* fst) (substs* args))] + [(Eq l r) (Eq (subst* l) (subst* r))] + [(Lt l r) (Lt (subst* l) (subst* r))] + [(Lte l r) (Lte (subst* l) (subst* r))] + [(If p b a) (If (subst* p) (subst* b) (subst* a))] + [(With bound-id named-expr bound-body) + (With bound-id + (subst* named-expr) + (if (eq? bound-id from) + bound-body + (subst* bound-body)))] + [(Lambda arg body) + (Lambda arg (if (eq? arg from) body (subst* body)))] + [(Call f arg) (Call (subst* f) (subst* arg))] + [(Id name) (if (eq? name from) to expr)])) + +(: eval-number : BAE -> Number) +;; helper for `eval': verifies that the result is a number +(define (eval-number expr) + (let ([result (eval expr)]) + (if (number? result) + result + (error 'eval-number "need a number when evaluating ~s, but got ~s" expr result)))) + +(: eval-boolean : BAE -> Boolean) +;; helper for `eval': verifies that the result is a boolean +(define (eval-boolean expr) + (let ([result (eval expr)]) + (if (boolean? result) + result + (error 'eval-boolean "need a boolean when evaluating ~s, but got ~s" expr result)))) + +; This is pretty cursed, but I couldn't find a better way to have structured data. +(: rehydrate : (Listof LambdaContents) -> BAE) +; Recreates a lambda from list representation. +(define (rehydrate l) + (Lambda (cases (first l) [(Par s) s] [_ (error 'rehydrate "what")]) + (cases (second l) [(Body b) b] [_ (error 'rehydrate "what")]))) + +(: value->bae : Primitive -> BAE) +;; converts a value to an BAE value (so it can be used with `subst') +(define (value->bae val) + (cond + [(number? val) (Num val)] + [(boolean? val) (Bool val)] + [(list? val) (rehydrate val)])) + +(: eval-sum : (Listof BAE) -> Number) +; Evaluates a Sum expression. +(define (eval-sum args) + (define l (length args)) + (cond [(= l 0) 0] + [(= l 1) (eval-number (first args))] + [else (+ (eval-number (first args)) (eval-sum (rest args)))])) + +(: eval-mul : (Listof BAE) -> Number) +; Evaluates a Mul expression. +(define (eval-mul args) + (define l (length args)) + (cond [(= l 0) 1] + [(= l 1) (eval-number (first args))] + [else (* (eval-number (first args)) (eval-mul (rest args)))])) + +(: eval-sub : BAE (Listof BAE) -> Number) +; Evaluates a Sub expression. +(define (eval-sub fst args) + (define l (length args)) + (cond [(= l 0) (- (eval-number fst))] + [else (- (eval-number fst) (eval-sum args))])) ; Huh. + +(: eval-div : BAE (Listof BAE) -> Number) +; Evaluates a Div expression. +(define (eval-div fst args) + (define l (length args)) + (cond [(= l 0) (/ (eval-number fst))] + [else (/ (eval-number fst) (eval-mul args))])) ; Huh. + +(: eval-eq : BAE BAE -> Boolean) +; Evaluates an Eq expression. +(define (eval-eq a b) + (= (eval-number a) (eval-number b))) + +(: eval-lt : BAE BAE -> Boolean) +; Evaluates an Lt expression. +(define (eval-lt a b) + (< (eval-number a) (eval-number b))) + +(: eval-lte : BAE BAE -> Boolean) +; Evaluates an Lte expression. +(define (eval-lte a b) + (<= (eval-number a) (eval-number b))) + +(: eval-if : BAE BAE BAE -> Primitive) +; Evaluates an If expression. +(define (eval-if pred body alt) + (if (eval-boolean pred) (eval body) (eval alt))) + +(: eval-lambda : BAE Symbol BAE -> Primitive ) +; Evaluates a Lambda expression (in a Call expression). +(define (eval-lambda arg par body) + (if (member par reserved-names) + (error 'eval-lambda "Can't create parameter binding to reserved name '~s'." par) + (eval (subst body par (value->bae (eval arg)))))) + +(: eval-call : BAE BAE -> Primitive) +; Evaluates a Call expression. +(define (eval-call f arg) + (match f + [(list (symbol: par) body) (eval-lambda arg par body)] + [_ (cases f + [(Lambda par body) (eval-lambda arg par body)] + [_ (error 'eval-call "Expected lambda expression to call, instead got: ~s." f)])])) + +(: eval : BAE -> Primitive) +;; evaluates BAE expressions by reducing them to numbers +(define (eval expr) + (cases expr + [(Num n) n] + [(Bool p) p] + [(Sum args) (eval-sum args)] + [(Mul args) (eval-mul args)] + [(Sub fst args) (eval-sub fst args)] + [(Div fst args) (eval-div fst args)] + [(Eq l r) (eval-eq l r)] + [(Lt l r) (eval-lt l r)] + [(Lte l r) (eval-lte l r)] + [(If p b a) (eval-if p b a)] + [(With bound-id named-expr bound-body) + (if (member bound-id reserved-names) + (error 'eval "Can't create binding to reserved name '~s'." bound-id) + (eval (subst bound-body + bound-id + ;; see the above `value-bae' helper + (value->bae (eval named-expr)))))] + [(Lambda par body) (list (Par par) (Body body))] ; No lambda primitive, but this branch shouldn't happen anyway. Return dummy value for now. + [(Call f arg) (eval-call (value->bae (eval f)) arg)] + [(Id name) (error 'eval "free identifier: ~s" name)])) + +(: run : String -> Primitive) +;; evaluate an BAE program contained in a string +(define (run str) + (eval (parse str))) + +; Because we'ren't writing a lazy language, need to use the Z combinator to delay evaluation of f (otherwise it'd never terminate). +; Z = λf.(λx.(f λv.((x x) v)))(λx.(f λv.((x x) v))) +; factorial = (Y (λself.λn.if (<= n 1) 1 (* n (self (- n 1))))) + +(test (run " +{with + +{Z {lambda f { + {lambda x {f of {lambda v {{x of x} of v}}}} + of + {lambda x {f of {lambda v {{x of x} of v}}}} +}}} + +{with + +{factorial {Z of + {lambda self {lambda n + {if {<= n 1} 1 {* n {self of {- n 1}}}} + } +}}} + +{factorial of 5} + +}} +") => 120) + +(test (run "{{lambda f {f of 1}} of {lambda x {+ x 1}}}") => 2) +(test (run "{{lambda x {+ x 1}} of 2}") => 3) + +(test (run "{and T T}") => #t) +(test (run "{and F aaaaaaaaaa}") => #f) +(test (run "{or T aaaaaaaaaa}") => #T) +(test (run "{or F T}") => #T) +(test (run "{or T T}") => #T) +(test (run "{not T}") => #F) +(test (run "{not F}") => #T) +(test (run "{with {p1 {< 1 2}} {with {p2 {< 3 4}} {and p1 p2}}}") => #T) + +(test (run "{if T 1 2}") => 1) +(test (run "{if T then 1 else 2}") => 1) + +(test (run "{with {T 2} {+ T 1}}") =error> "Can't create binding to reserved name 'T'.") +(test (run "{with {+ 2} {+ + 1}}") =error> "Can't create binding to reserved name '+'.") + +(test (run "{< 1 2}") => #t) +(test (run "{< 2 2}") => #f) +(test (run "{< 2 1}") => #f) +(test (run "{= 1 2}") => #f) +(test (run "{= 2 2}") => #t) +(test (run "{<= 1 2}") => #t) +(test (run "{<= 2 2}") => #t) +(test (run "{<= 2 1}") => #f) + +(test (run "{+}") => 0) +(test (run "{+ 12}") => 12) +(test (run "{+ 1 2 3}") => 6) + +(test (run "{*}") => 1) +(test (run "{* 12}") => 12) +(test (run "{* 2 3 5}") => 30) + +(test (run "{-}") =error> "parse-sexpr: bad syntax in (-)") +(test (run "{- 1}") => -1) +(test (run "{- 3 2 1}") => 0) +(test (run "{- 1 2 3}") => -4) + +(test (run "{/}") =error> "parse-sexpr: bad syntax in (/)") +(test (run "{/ 2}") => 1/2) +(test (run "{/ 3 2 1}") => 3/2) +(test (run "{/ 1 2 3}") => 1/6) + +;; tests (for simple expressions) +(test (run "5") => 5) +(test (run "{+ 5 5}") => 10) +(test (run "{with {x {+ 5 5}} {+ x x}}") => 20) +(test (run "{with {x 5} {+ x x}}") => 10) +(test (run "{with {x {+ 5 5}} {with {y {- x 3}} {+ y y}}}") => 14) +(test (run "{with {x 5} {with {y {- x 3}} {+ y y}}}") => 4) +(test (run "{with {x 5} {+ x {with {x 3} 10}}}") => 15) +(test (run "{with {x 5} {+ x {with {x 3} x}}}") => 8) +(test (run "{with {x 5} {+ x {with {y 3} x}}}") => 10) +(test (run "{with {x 5} {with {y x} y}}") => 5) +(test (run "{with {x 5} {with {x x} x}}") => 5)